Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Changes In Branch no-wideint Excluding Merge-Ins
This is equivalent to a diff from 49e104fa48 to b162d433dc
2018-02-06
| ||
20:07 | TIP 484: Merge 'int' and 'wideInt' Obj-type to a single 'int' check-in: 4f6d4a2b15 user: dgp tags: core-8-branch | |
2018-01-26
| ||
13:29 | Rename (internal) TclNewWideObj macro to TclNewIntObj. Change Tcl_SetIntObj/Tcl_SetLongObj to macro'... Closed-Leaf check-in: b162d433dc user: jan.nijtmans tags: no-wideint | |
12:32 | Merge core-8-branch. Also some minor performance improvement: Turn Tcl_NewLongObj/Tcl_NewIntObj/Tcl_... check-in: 85e9d69071 user: jan.nijtmans tags: no-wideint | |
2017-11-13
| ||
08:59 | merge tcl-9-cleanup (and also a minor bug-fix from core-8-branch). check-in: b03c4194f0 user: jan.nijtmans tags: trunk | |
2017-11-09
| ||
15:47 | Rebase branch to trunk. check-in: f714eca8f2 user: dgp tags: dgp-refactor | |
14:44 | merge trunk check-in: d27981d722 user: dgp tags: no-wideint | |
14:40 | merge trunk Closed-Leaf check-in: 844ae11ba0 user: dgp tags: tcl-9-cleanup | |
13:46 | merge trunk check-in: a10fc87c05 user: dgp tags: dgp-properbytearray | |
12:52 | merge trunk check-in: 54f289e311 user: jan.nijtmans tags: novem | |
12:51 | merge core-8-branch check-in: 49e104fa48 user: jan.nijtmans tags: trunk | |
12:50 | merge core-8-6-branch check-in: ef4cc04bc1 user: jan.nijtmans tags: core-8-branch | |
2017-11-08
| ||
09:38 | merge core-8-branch check-in: 3885b08997 user: jan.nijtmans tags: trunk | |
Changes to .fossil-settings/crlf-glob.
︙ | ︙ | |||
8 9 10 11 12 13 14 15 16 17 | libtommath/*.vcproj tools/tcl.hpj.in tools/tcl.wse.in win/buildall.vc.bat win/coffbase.txt win/makefile.vc win/rules.vc win/tcl.dsp win/tcl.dsw win/tcl.hpj.in | > > | 8 9 10 11 12 13 14 15 16 17 18 19 | libtommath/*.vcproj tools/tcl.hpj.in 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 |
Changes to .fossil-settings/crnl-glob.
︙ | ︙ | |||
8 9 10 11 12 13 14 15 16 17 | libtommath/*.vcproj tools/tcl.hpj.in tools/tcl.wse.in win/buildall.vc.bat win/coffbase.txt win/makefile.vc win/rules.vc win/tcl.dsp win/tcl.dsw win/tcl.hpj.in | > > | 8 9 10 11 12 13 14 15 16 17 18 19 | libtommath/*.vcproj tools/tcl.hpj.in 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 |
Changes to .fossil-settings/ignore-glob.
︙ | ︙ | |||
40 41 42 43 44 45 46 47 48 | unix/dltest.marker unix/tcl.pc unix/tclIndex unix/pkgs/* win/Debug* win/Release* win/pkgs/* win/tcl.hpj win/nmhlp-out.txt | > | 40 41 42 43 44 45 46 47 48 49 | unix/dltest.marker unix/tcl.pc unix/tclIndex unix/pkgs/* win/Debug* win/Release* win/pkgs/* win/coffbase.txt win/tcl.hpj win/nmhlp-out.txt |
Changes to .project.
1 2 | <?xml version="1.0" encoding="UTF-8"?> <projectDescription> | | | 1 2 3 4 5 6 7 8 9 10 | <?xml version="1.0" encoding="UTF-8"?> <projectDescription> <name>tcl8</name> <comment></comment> <projects> </projects> <buildSpec> </buildSpec> <natures> </natures> |
︙ | ︙ |
Changes to README.
1 | README: Tcl | | | 1 2 3 4 5 6 7 8 9 | README: Tcl 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 -------- 1. Introduction 2. Documentation |
︙ | ︙ |
Changes to changes.
︙ | ︙ | |||
8230 8231 8232 8233 8234 8235 8236 | 2013-05-06 (platform support) Cygwin64 (nijtmans) 2013-05-15 (enhancement) Improved [list {*}...] compile (fellows) 2013-05-16 (platform support) mingw-4.0 (nijtmans) | | | 8230 8231 8232 8233 8234 8235 8236 8237 8238 8239 8240 8241 8242 8243 8244 | 2013-05-06 (platform support) Cygwin64 (nijtmans) 2013-05-15 (enhancement) Improved [list {*}...] compile (fellows) 2013-05-16 (platform support) mingw-4.0 (nijtmans) 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) 2013-05-22 (bug fix)[3613609] [lsort -nocase] failed on non-ASCII (fellows) |
︙ | ︙ | |||
8653 8654 8655 8656 8657 8658 8659 | 2016-05-13 (bug)[3154ea] Mem corruption in assembler exceptions (tkob,kenny) 2016-05-13 (bug) registry package support any Unicode env (nijtmans) => registry 1.3.2 2016-05-21 (bug)[f7d4e] [namespace delete] performance (fellows) | | | 8653 8654 8655 8656 8657 8658 8659 8660 8661 8662 8663 8664 8665 8666 8667 | 2016-05-13 (bug)[3154ea] Mem corruption in assembler exceptions (tkob,kenny) 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 (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) 2016-06-21 (bug)[c383eb] crash in [glob -path a] (oehlmann,porter) |
︙ | ︙ | |||
8792 8793 8794 8795 8796 8797 8798 8799 8800 8801 8802 8803 8804 8805 | 2017-07-06 (bug)[adb198] Plug memleak in TclJoinPath (sebres,porter) 2017-07-17 (bug)[fb2208] Repeatable tclIndex generation (wiedemann,nijtmans) --- Released 8.6.7, August 9, 2017 --- http://core.tcl.tk/tcl/ for details 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) 2016-07-12 Make TCL_HASH_TYPE build-time configurable (nijtmans) | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 8792 8793 8794 8795 8796 8797 8798 8799 8800 8801 8802 8803 8804 8805 8806 8807 8808 8809 8810 8811 8812 8813 8814 8815 8816 8817 8818 8819 8820 8821 8822 8823 8824 8825 8826 8827 8828 8829 8830 8831 8832 8833 8834 8835 8836 8837 8838 8839 8840 8841 8842 8843 8844 | 2017-07-06 (bug)[adb198] Plug memleak in TclJoinPath (sebres,porter) 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) 2016-07-12 Make TCL_HASH_TYPE build-time configurable (nijtmans) |
︙ | ︙ | |||
8832 8833 8834 8835 8836 8837 8838 | 2017-06-22 (TIP 470) Tcl_GetDefineContextObject();[oo::define [self]] (fellows) => 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) | < | 8871 8872 8873 8874 8875 8876 8877 8878 8879 8880 8881 | 2017-06-22 (TIP 470) Tcl_GetDefineContextObject();[oo::define [self]] (fellows) => 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) 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.
|
| < < < < < < < < < < < < < < |
Changes to doc/Encoding.3.
︙ | ︙ | |||
256 257 258 259 260 261 262 | \fBTcl_ExternalToUtf\fR. .PP \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. | < < < < | 256 257 258 259 260 261 262 263 264 265 266 267 268 269 | \fBTcl_ExternalToUtf\fR. .PP \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. .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 \fIencoding\fR is deleted. The caller must not modify this string. .PP |
︙ | ︙ |
Changes to doc/GetInt.3.
︙ | ︙ | |||
60 61 62 63 64 65 66 67 | .QW \fB0d\fR then \fIsrc\fR is expected to be in decimal form; otherwise, 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 | > > > | | | 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 | .QW \fB0d\fR then \fIsrc\fR is expected to be in decimal form; otherwise, 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 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 ; a sequence of digits; the letter .QW \fBe\fR ; |
︙ | ︙ |
Changes to doc/Interp.3.
︙ | ︙ | |||
29 30 31 32 33 34 35 36 37 38 39 40 41 42 | structure. Callers of \fBTcl_CreateInterp\fR should use this pointer as an opaque token, suitable for nothing other than passing back to 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 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 result or error message, and the \fIfreeProc\fR field tells how to dispose of the storage for the string when it is not needed anymore. | > > > > > > > > > > > > > | 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 | structure. Callers of \fBTcl_CreateInterp\fR should use this pointer as an opaque token, suitable for nothing other than passing back to 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 result or error message, and the \fIfreeProc\fR field tells how to dispose of the storage for the string when it is not needed anymore. |
︙ | ︙ | |||
84 85 86 87 88 89 90 | As part of processing each command, \fBTcl_Eval\fR initializes \fIinterp->result\fR 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 | | | 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 | As part of processing each command, \fBTcl_Eval\fR initializes \fIinterp->result\fR 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 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 It is a general convention in Tcl-based applications that the result of an interpreter is normally in the initialized state described |
︙ | ︙ |
Changes to doc/Object.3.
︙ | ︙ | |||
253 254 255 256 257 258 259 | \fBincr x\fR .CE .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 | | | 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 | \fBincr x\fR .CE .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 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 then invalidates its string representation (by calling \fBTcl_InvalidateStringRep\fR) |
︙ | ︙ |
Changes to doc/SetResult.3.
︙ | ︙ | |||
193 194 195 196 197 198 199 200 201 202 203 204 205 206 | \fBTcl_FreeResult\fR performs part of the work of \fBTcl_ResetResult\fR. 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. .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 at a time when \fIinterp\fR holds a string result, they do whatever is necessary to dispose of the old string result | > > > > > > > > > > > > > | 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 | \fBTcl_FreeResult\fR performs part of the work of \fBTcl_ResetResult\fR. 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 at a time when \fIinterp\fR holds a string result, they do whatever is necessary to dispose of the old string result |
︙ | ︙ |
Changes to doc/ToUpper.3.
︙ | ︙ | |||
29 30 31 32 33 34 35 | \fBTcl_UtfToLower\fR(\fIstr\fR) .sp int \fBTcl_UtfToTitle\fR(\fIstr\fR) .SH ARGUMENTS .AS char *str in/out .AP int ch in | | | 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 | \fBTcl_UtfToLower\fR(\fIstr\fR) .sp int \fBTcl_UtfToTitle\fR(\fIstr\fR) .SH ARGUMENTS .AS char *str in/out .AP int ch in The Unicode character to be converted. .AP char *str in/out Pointer to UTF-8 string to be converted in place. .BE .SH DESCRIPTION .PP The first three routines convert the case of individual Unicode characters: |
︙ | ︙ |
Changes to doc/UniCharIsAlpha.3.
︙ | ︙ | |||
44 45 46 47 48 49 50 | \fBTcl_UniCharIsUpper\fR(\fIch\fR) .sp int \fBTcl_UniCharIsWordChar\fR(\fIch\fR) .SH ARGUMENTS .AS int ch .AP int ch in | | | < < < | 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 | \fBTcl_UniCharIsUpper\fR(\fIch\fR) .sp int \fBTcl_UniCharIsWordChar\fR(\fIch\fR) .SH ARGUMENTS .AS int ch .AP int ch in The Unicode character to be examined. .BE .SH DESCRIPTION .PP 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. .SH "CHARACTER CLASSES" .PP \fBTcl_UniCharIsAlnum\fR tests if the character is an alphanumeric Unicode character. .PP \fBTcl_UniCharIsAlpha\fR tests if the character is an alphabetic Unicode character. .PP |
︙ | ︙ |
Changes to doc/Utf.3.
︙ | ︙ | |||
73 74 75 76 77 78 79 | \fBTcl_UtfBackslash\fR(\fIsrc, readPtr, dst\fR) .SH ARGUMENTS .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 | | | 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 | \fBTcl_UtfBackslash\fR(\fIsrc, readPtr, dst\fR) .SH ARGUMENTS .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 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 Pointer to a UTF-8 string. .AP "const char" *ct in |
︙ | ︙ |
Changes to doc/expr.n.
︙ | ︙ | |||
46 47 48 49 50 51 52 | An expression consists of a combination of operands, operators, parentheses and commas, possibly with whitespace between any of these elements, which is 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 | | > > | 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 | An expression consists of a combination of operands, operators, parentheses and commas, possibly with whitespace between any of these elements, which is 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. 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. The strings \fBInf\fR and \fBNaN\fR, in any combination of case, are also recognized as floating point |
︙ | ︙ |
Changes to doc/format.n.
︙ | ︙ | |||
79 80 81 82 83 84 85 | number if the first character is not a sign. .TP 10 \fB0\fR Specifies that the number should be padded on the left with zeroes instead of spaces. .TP 10 \fB#\fR | | | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 | number if the first character is not a sign. .TP 10 \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 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. For \fBd\fR conversions, \fB0d\fR will be added to the beginning of the result unless it is zero. |
︙ | ︙ | |||
167 168 169 170 171 172 173 | Convert integer to unsigned hexadecimal string, using digits .QW 0123456789abcdef for \fBx\fR and .QW 0123456789ABCDEF for \fBX\fR). .TP 10 \fBb\fR | | | 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 | Convert integer to unsigned hexadecimal string, using digits .QW 0123456789abcdef for \fBx\fR and .QW 0123456789ABCDEF for \fBX\fR). .TP 10 \fBb\fR 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 No conversion; just insert string. .TP 10 |
︙ | ︙ |
Changes to doc/scan.n.
︙ | ︙ | |||
220 221 222 223 224 225 226 | hexadecimal conversions with substring sizes: .PP .CS set string "#08D03F" \fBscan\fR $string "#%2x%2x%2x" r g b .CE .PP | | > > | | 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 | hexadecimal conversions with substring sizes: .PP .CS set string "#08D03F" \fBscan\fR $string "#%2x%2x%2x" r g b .CE .PP 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" ;# *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} { error "invalid number of minutes" } |
︙ | ︙ |
Changes to generic/tcl.decls.
︙ | ︙ | |||
28 29 30 31 32 33 34 | # to preserve backwards compatibility. declare 0 { int Tcl_PkgProvideEx(Tcl_Interp *interp, const char *name, const char *version, const void *clientData) } declare 1 { | | | 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | # to preserve backwards compatibility. declare 0 { int Tcl_PkgProvideEx(Tcl_Interp *interp, const char *name, const char *version, const void *clientData) } declare 1 { 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, ...) } declare 3 { |
︙ | ︙ | |||
150 151 152 153 154 155 156 | } declare 35 { int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr) } declare 36 { int Tcl_GetIndexFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, | | | 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 | } declare 35 { int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr) } declare 36 { int Tcl_GetIndexFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, 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 { int Tcl_GetIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr) } |
︙ | ︙ | |||
281 282 283 284 285 286 287 | } declare 75 { int Tcl_AsyncReady(void) } declare 76 { void Tcl_BackgroundError(Tcl_Interp *interp) } | | | | | 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 | } declare 75 { int Tcl_AsyncReady(void) } declare 76 { void Tcl_BackgroundError(Tcl_Interp *interp) } 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) } declare 79 { void Tcl_CallWhenDeleted(Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, ClientData clientData) } declare 80 { void Tcl_CancelIdleCall(Tcl_IdleProc *idleProc, ClientData clientData) } declare 81 { int Tcl_Close(Tcl_Interp *interp, Tcl_Channel chan) } declare 82 { int Tcl_CommandComplete(const char *cmd) } declare 83 { char *Tcl_Concat(int argc, const char *const *argv) } declare 84 { int Tcl_ConvertElement(const char *src, char *dst, int flags) } declare 85 { int Tcl_ConvertCountedElement(const char *src, int length, char *dst, int flags) } declare 86 { int Tcl_CreateAlias(Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int argc, 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[]) } declare 88 { |
︙ | ︙ | |||
348 349 350 351 352 353 354 | } declare 93 { void Tcl_CreateExitHandler(Tcl_ExitProc *proc, ClientData clientData) } declare 94 { Tcl_Interp *Tcl_CreateInterp(void) } | | | 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 | } declare 93 { void Tcl_CreateExitHandler(Tcl_ExitProc *proc, ClientData clientData) } declare 94 { Tcl_Interp *Tcl_CreateInterp(void) } declare 95 {deprecated {}} { void Tcl_CreateMathFunc(Tcl_Interp *interp, const char *name, int numArgs, Tcl_ValueType *argTypes, Tcl_MathProc *proc, ClientData clientData) } declare 96 { Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp, const char *cmdName, |
︙ | ︙ | |||
457 458 459 460 461 462 463 | declare 125 { void Tcl_DStringStartSublist(Tcl_DString *dsPtr) } declare 126 { int Tcl_Eof(Tcl_Channel chan) } declare 127 { | | | < | 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 | declare 125 { void Tcl_DStringStartSublist(Tcl_DString *dsPtr) } declare 126 { int Tcl_Eof(Tcl_Channel chan) } declare 127 { const char *Tcl_ErrnoId(void) } declare 128 { const char *Tcl_ErrnoMsg(int err) } declare 129 { int Tcl_Eval(Tcl_Interp *interp, const char *script) } declare 130 { int Tcl_EvalFile(Tcl_Interp *interp, const char *fileName) } declare 131 { int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr) } declare 132 { |
︙ | ︙ | |||
525 526 527 528 529 530 531 | int Tcl_Flush(Tcl_Channel chan) } declare 147 { void Tcl_FreeResult(Tcl_Interp *interp) } declare 148 { int Tcl_GetAlias(Tcl_Interp *interp, const char *slaveCmd, | | | | | 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 | int Tcl_Flush(Tcl_Channel chan) } declare 147 { void Tcl_FreeResult(Tcl_Interp *interp) } declare 148 { int Tcl_GetAlias(Tcl_Interp *interp, const char *slaveCmd, 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, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv) } declare 150 { ClientData Tcl_GetAssocData(Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc **procPtr) } declare 151 { |
︙ | ︙ | |||
555 556 557 558 559 560 561 | declare 154 { ClientData Tcl_GetChannelInstanceData(Tcl_Channel chan) } declare 155 { int Tcl_GetChannelMode(Tcl_Channel chan) } declare 156 { | | | | | 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 | declare 154 { ClientData Tcl_GetChannelInstanceData(Tcl_Channel chan) } declare 155 { int Tcl_GetChannelMode(Tcl_Channel chan) } declare 156 { const char *Tcl_GetChannelName(Tcl_Channel chan) } declare 157 { int Tcl_GetChannelOption(Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, Tcl_DString *dsPtr) } declare 158 { CONST86 Tcl_ChannelType *Tcl_GetChannelType(Tcl_Channel chan) } declare 159 { int Tcl_GetCommandInfo(Tcl_Interp *interp, const char *cmdName, Tcl_CmdInfo *infoPtr) } declare 160 { const char *Tcl_GetCommandName(Tcl_Interp *interp, Tcl_Command command) } declare 161 { int Tcl_GetErrno(void) } declare 162 { const char *Tcl_GetHostName(void) } declare 163 { int Tcl_GetInterpPath(Tcl_Interp *askInterp, Tcl_Interp *slaveInterp) } declare 164 { Tcl_Interp *Tcl_GetMaster(Tcl_Interp *interp) } |
︙ | ︙ | |||
619 620 621 622 623 624 625 | declare 172 { Tcl_Interp *Tcl_GetSlave(Tcl_Interp *interp, const char *slaveName) } declare 173 { Tcl_Channel Tcl_GetStdChannel(int type) } declare 174 { | | | | | 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 | declare 172 { Tcl_Interp *Tcl_GetSlave(Tcl_Interp *interp, const char *slaveName) } declare 173 { Tcl_Channel Tcl_GetStdChannel(int type) } declare 174 { const char *Tcl_GetStringResult(Tcl_Interp *interp) } declare 175 { const char *Tcl_GetVar(Tcl_Interp *interp, const char *varName, int flags) } declare 176 { 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) } declare 178 { int Tcl_GlobalEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr) |
︙ | ︙ | |||
659 660 661 662 663 664 665 | int Tcl_InterpDeleted(Tcl_Interp *interp) } declare 185 { int Tcl_IsSafe(Tcl_Interp *interp) } # Obsolete, use Tcl_FSJoinPath declare 186 { | | | 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 | int Tcl_InterpDeleted(Tcl_Interp *interp) } declare 185 { int Tcl_IsSafe(Tcl_Interp *interp) } # Obsolete, use Tcl_FSJoinPath declare 186 { 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) } |
︙ | ︙ | |||
682 683 684 685 686 687 688 | declare 190 { int Tcl_MakeSafe(Tcl_Interp *interp) } declare 191 { Tcl_Channel Tcl_MakeTcpClientChannel(ClientData tcpSocket) } declare 192 { | | | | 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 | declare 190 { int Tcl_MakeSafe(Tcl_Interp *interp) } declare 191 { Tcl_Channel Tcl_MakeTcpClientChannel(ClientData tcpSocket) } declare 192 { char *Tcl_Merge(int argc, const char *const *argv) } declare 193 { Tcl_HashEntry *Tcl_NextHashEntry(Tcl_HashSearch *searchPtr) } declare 194 { void Tcl_NotifyChannel(Tcl_Channel channel, int mask) } declare 195 { Tcl_Obj *Tcl_ObjGetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags) } declare 196 { 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, 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) } declare 199 { |
︙ | ︙ | |||
726 727 728 729 730 731 732 | declare 202 { void Tcl_PrintDouble(Tcl_Interp *interp, double value, char *dst) } declare 203 { int Tcl_PutEnv(const char *assignment) } declare 204 { | | | 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 | declare 202 { void Tcl_PrintDouble(Tcl_Interp *interp, double value, char *dst) } declare 203 { int Tcl_PutEnv(const char *assignment) } declare 204 { const char *Tcl_PosixError(Tcl_Interp *interp) } declare 205 { void Tcl_QueueEvent(Tcl_Event *evPtr, Tcl_QueuePosition position) } declare 206 { int Tcl_Read(Tcl_Channel chan, char *bufPtr, int toRead) } |
︙ | ︙ | |||
762 763 764 765 766 767 768 | } declare 214 { int Tcl_RegExpMatch(Tcl_Interp *interp, const char *text, const char *pattern) } declare 215 { void Tcl_RegExpRange(Tcl_RegExp regexp, int index, | | < | | 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 | } declare 214 { int Tcl_RegExpMatch(Tcl_Interp *interp, const char *text, const char *pattern) } declare 215 { void Tcl_RegExpRange(Tcl_RegExp regexp, int index, const char **startPtr, const char **endPtr) } declare 216 { void Tcl_Release(ClientData clientData) } declare 217 { void Tcl_ResetResult(Tcl_Interp *interp) } declare 218 { int Tcl_ScanElement(const char *src, int *flagPtr) } declare 219 { int Tcl_ScanCountedElement(const char *src, int length, int *flagPtr) } declare 220 {deprecated {}} { int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode) } declare 221 { int Tcl_ServiceAll(void) } declare 222 { int Tcl_ServiceEvent(int flags) |
︙ | ︙ | |||
833 834 835 836 837 838 839 | declare 235 { void Tcl_SetObjResult(Tcl_Interp *interp, Tcl_Obj *resultObjPtr) } declare 236 { void Tcl_SetStdChannel(Tcl_Channel channel, int type) } declare 237 { | | | | | | | < | | 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 | declare 235 { void Tcl_SetObjResult(Tcl_Interp *interp, Tcl_Obj *resultObjPtr) } declare 236 { void Tcl_SetStdChannel(Tcl_Channel channel, int type) } declare 237 { const char *Tcl_SetVar(Tcl_Interp *interp, const char *varName, const char *newValue, int flags) } declare 238 { const char *Tcl_SetVar2(Tcl_Interp *interp, const char *part1, const char *part2, const char *newValue, int flags) } declare 239 { const char *Tcl_SignalId(int sig) } declare 240 { 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, const char ***argvPtr) } # Obsolete, use Tcl_FSSplitPath declare 243 { 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) } 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) } declare 248 { |
︙ | ︙ | |||
941 942 943 944 945 946 947 | } declare 265 { int Tcl_DumpActiveMemory(const char *fileName) } declare 266 { void Tcl_ValidateAllMemory(const char *file, int line) } | | | | | | | | | | | | 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 | } declare 265 { int Tcl_DumpActiveMemory(const char *fileName) } declare 266 { void Tcl_ValidateAllMemory(const char *file, int line) } declare 267 {deprecated {see TIP #422}} { void Tcl_AppendResultVA(Tcl_Interp *interp, va_list argList) } 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 { const char *Tcl_ParseVar(Tcl_Interp *interp, const char *start, const char **termPtr) } declare 271 { const char *Tcl_PkgPresent(Tcl_Interp *interp, const char *name, const char *version, int exact) } declare 272 { 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 { const char *Tcl_PkgRequire(Tcl_Interp *interp, const char *name, const char *version, int exact) } declare 275 {deprecated {see TIP #422}} { void Tcl_SetErrorCodeVA(Tcl_Interp *interp, va_list argList) } 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 {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) } declare 280 { void Tcl_InitMemory(Tcl_Interp *interp) |
︙ | ︙ | |||
1083 1084 1085 1086 1087 1088 1089 | declare 300 { Tcl_ThreadId Tcl_GetCurrentThread(void) } declare 301 { Tcl_Encoding Tcl_GetEncoding(Tcl_Interp *interp, const char *name) } declare 302 { | | | 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 | declare 300 { Tcl_ThreadId Tcl_GetCurrentThread(void) } declare 301 { Tcl_Encoding Tcl_GetEncoding(Tcl_Interp *interp, const char *name) } declare 302 { const char *Tcl_GetEncodingName(Tcl_Encoding encoding) } declare 303 { void Tcl_GetEncodingNames(Tcl_Interp *interp) } declare 304 { int Tcl_GetIndexFromObjStruct(Tcl_Interp *interp, Tcl_Obj *objPtr, const void *tablePtr, int offset, const char *msg, int flags, |
︙ | ︙ | |||
1159 1160 1161 1162 1163 1164 1165 | declare 323 { Tcl_UniChar Tcl_UniCharToUpper(int ch) } declare 324 { int Tcl_UniCharToUtf(int ch, char *buf) } declare 325 { | | | | | | | 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 | declare 323 { Tcl_UniChar Tcl_UniCharToUpper(int ch) } declare 324 { int Tcl_UniCharToUtf(int ch, char *buf) } declare 325 { 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 { const char *Tcl_UtfFindFirst(const char *src, int ch) } declare 329 { const char *Tcl_UtfFindLast(const char *src, int ch) } declare 330 { const char *Tcl_UtfNext(const char *src) } declare 331 { 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, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr) } |
︙ | ︙ | |||
1210 1211 1212 1213 1214 1215 1216 | } declare 339 { int Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr) } declare 340 { char *Tcl_GetString(Tcl_Obj *objPtr) } | | | | | 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 | } declare 339 { int Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr) } declare 340 { char *Tcl_GetString(Tcl_Obj *objPtr) } declare 341 {deprecated {Use Tcl_GetEncodingSearchPath}} { const char *Tcl_GetDefaultEncodingDir(void) } declare 342 {deprecated {Use Tcl_SetEncodingSearchPath}} { void Tcl_SetDefaultEncodingDir(const char *path) } declare 343 { void Tcl_AlertNotifier(ClientData clientData) } declare 344 { void Tcl_ServiceModeHook(int mode) |
︙ | ︙ | |||
1262 1263 1264 1265 1266 1267 1268 | Tcl_UniChar *Tcl_UtfToUniCharDString(const char *src, int length, Tcl_DString *dsPtr) } declare 356 { Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj, int flags) } | | | | | 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 | Tcl_UniChar *Tcl_UtfToUniCharDString(const char *src, int length, Tcl_DString *dsPtr) } declare 356 { Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj, int flags) } 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) } declare 359 { 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, const char **termPtr) } declare 361 { int Tcl_ParseCommand(Tcl_Interp *interp, const char *start, int numBytes, int nested, Tcl_Parse *parsePtr) } declare 362 { int Tcl_ParseExpr(Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr) } declare 363 { int Tcl_ParseQuotedString(Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr) } declare 364 { int Tcl_ParseVarName(Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append) } # These 4 functions are obsolete, use Tcl_FSGetCwd, Tcl_FSChdir, # Tcl_FSAccess and Tcl_FSStat |
︙ | ︙ | |||
1404 1405 1406 1407 1408 1409 1410 | declare 396 { Tcl_Channel Tcl_GetTopChannel(Tcl_Channel chan) } declare 397 { int Tcl_ChannelBuffered(Tcl_Channel chan) } declare 398 { | | | 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 | declare 396 { Tcl_Channel Tcl_GetTopChannel(Tcl_Channel chan) } declare 397 { int Tcl_ChannelBuffered(Tcl_Channel chan) } declare 398 { const char *Tcl_ChannelName(const Tcl_ChannelType *chanTypePtr) } declare 399 { Tcl_ChannelTypeVersion Tcl_ChannelVersion( const Tcl_ChannelType *chanTypePtr) } declare 400 { Tcl_DriverBlockModeProc *Tcl_ChannelBlockModeProc( |
︙ | ︙ | |||
1544 1545 1546 1547 1548 1549 1550 | # introduced in 8.4a3 declare 434 { Tcl_UniChar *Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr) } # TIP#15 (math function introspection) dkf | | | | 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 | # introduced in 8.4a3 declare 434 { Tcl_UniChar *Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr) } # TIP#15 (math function introspection) dkf declare 435 {deprecated {}} { int Tcl_GetMathFuncInfo(Tcl_Interp *interp, const char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, ClientData *clientDataPtr) } declare 436 {deprecated {}} { Tcl_Obj *Tcl_ListMathFuncs(Tcl_Interp *interp, const char *pattern) } # TIP#36 (better access to 'subst') dkf declare 437 { Tcl_Obj *Tcl_SubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags) } |
︙ | ︙ |
Changes to generic/tcl.h.
︙ | ︙ | |||
48 49 50 51 52 53 54 | * macosx/Tcl.xcode/default.pbxuser (not patchlevel) 1 LOC * macosx/Tcl-Common.xcconfig (not patchlevel) 1 LOC * win/README (not patchlevel) (sections 0 and 2) * unix/tcl.spec (1 LOC patch) * tools/tcl.hpj.in (not patchlevel, for windows installer) */ | | | | | | | 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 | * macosx/Tcl.xcode/default.pbxuser (not patchlevel) 1 LOC * macosx/Tcl-Common.xcconfig (not patchlevel) 1 LOC * 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 8 #define TCL_MINOR_VERSION 7 #define TCL_RELEASE_LEVEL TCL_ALPHA_RELEASE #define TCL_RELEASE_SERIAL 2 #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. * We use this method because there is no autoconf equivalent. */ |
︙ | ︙ | |||
133 134 135 136 137 138 139 | * written for older versions of Tcl where the macros permitted * support for the varargs.h system as well as stdarg.h . * * New code should just directly be written to use stdarg.h conventions. */ #include <stdarg.h> | | | 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 | * written for older versions of Tcl where the macros permitted * support for the varargs.h system as well as stdarg.h . * * New code should just directly be written to use stdarg.h conventions. */ #include <stdarg.h> #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) # define TCL_FORMAT_PRINTF(a,b) __attribute__ ((__format__ (__printf__, a, b))) # define TCL_NORETURN __attribute__ ((noreturn)) |
︙ | ︙ | |||
250 251 252 253 254 255 256 | * The following _ANSI_ARGS_ macro is to support old extensions * written for older versions of Tcl where it permitted support * for compilers written in the pre-prototype era of C. * * New code should use prototypes. */ | | < < < < < < < < < < < < < < < < < < < | | | | | | 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 | * The following _ANSI_ARGS_ macro is to support old extensions * written for older versions of Tcl where it permitted support * for compilers written in the pre-prototype era of C. * * New code should use prototypes. */ #if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 # undef _ANSI_ARGS_ # define _ANSI_ARGS_(x) x /* * Definitions that allow this header file to be used either with or without * ANSI C features. */ #ifndef INLINE # define INLINE #endif #ifndef CONST # define CONST const #endif #define CONST84 const #define CONST84_RETURN const #endif /* !TCL_NO_DEPRECATED */ #ifndef CONST86 # define CONST86 const #endif /* * Make sure EXTERN isn't defined elsewhere. */ #ifdef EXTERN |
︙ | ︙ | |||
314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 | /* *---------------------------------------------------------------------------- * The following code is copied from winnt.h. If we don't replicate it here, * then <windows.h> can't be included after tcl.h, since tcl.h also defines * VOID. This block is skipped under Cygwin and Mingw. */ #if defined(_WIN32) && !defined(HAVE_WINNT_IGNORE_VOID) #ifndef VOID #define VOID void typedef char CHAR; typedef short SHORT; typedef long LONG; #endif #endif /* _WIN32 && !HAVE_WINNT_IGNORE_VOID */ /* * 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__ | > < | < < < > < | < < < | 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 | /* *---------------------------------------------------------------------------- * The following code is copied from winnt.h. If we don't replicate it here, * then <windows.h> 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; typedef long LONG; #endif #endif /* _WIN32 && !HAVE_WINNT_IGNORE_VOID */ /* * 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__ # define VOID void #endif #endif /* !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 */ /* * Miscellaneous declarations. */ #ifndef _CLIENTDATA typedef void *ClientData; # define _CLIENTDATA #endif /* * Darwin specific configure overrides (to support fat compiles, where * configure runs only once for multiple architectures): */ |
︙ | ︙ | |||
488 489 490 491 492 493 494 | * "real" definition in tclInt.h. * * 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(). */ | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 | * "real" definition in tclInt.h. * * 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 #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; typedef struct Tcl_Condition_ *Tcl_Condition; typedef struct Tcl_Dict_ *Tcl_Dict; |
︙ | ︙ | |||
637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 | #define TCL_OK 0 #define TCL_ERROR 1 #define TCL_RETURN 2 #define TCL_BREAK 3 #define TCL_CONTINUE 4 /* *---------------------------------------------------------------------------- * Flags to control what substitutions are performed by Tcl_SubstObj(): */ #define TCL_SUBST_COMMANDS 001 #define TCL_SUBST_VARIABLES 002 #define TCL_SUBST_BACKSLASHES 004 #define TCL_SUBST_ALL 007 /* * Argument descriptors for math function callbacks in expressions: */ typedef enum { TCL_INT, TCL_DOUBLE, TCL_EITHER, TCL_WIDE_INT } Tcl_ValueType; typedef struct Tcl_Value { Tcl_ValueType type; /* Indicates intValue or doubleValue is valid, * or both. */ long intValue; /* Integer value. */ double doubleValue; /* Double-precision floating value. */ Tcl_WideInt wideValue; /* Wide (min. 64-bit) integer value. */ } Tcl_Value; /* * Forward declaration of Tcl_Obj to prevent an error when the forward * reference to Tcl_Obj is encountered in the function types declared below. */ struct Tcl_Obj; /* *---------------------------------------------------------------------------- * Function types defined by Tcl: */ typedef int (Tcl_AppInitProc) (Tcl_Interp *interp); typedef int (Tcl_AsyncProc) (ClientData clientData, Tcl_Interp *interp, 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, | > > > > > > > > > | | | 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 | #define TCL_OK 0 #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(): */ #define TCL_SUBST_COMMANDS 001 #define TCL_SUBST_VARIABLES 002 #define TCL_SUBST_BACKSLASHES 004 #define TCL_SUBST_ALL 007 /* * 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 { Tcl_ValueType type; /* Indicates intValue or doubleValue is valid, * 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. */ struct Tcl_Obj; /* *---------------------------------------------------------------------------- * Function types defined by Tcl: */ typedef int (Tcl_AppInitProc) (Tcl_Interp *interp); typedef int (Tcl_AsyncProc) (ClientData clientData, Tcl_Interp *interp, 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, const char *argv[]); typedef void (Tcl_CmdTraceProc) (ClientData clientData, Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *proc, 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, struct Tcl_Obj *dupPtr); typedef int (Tcl_EncodingConvertProc) (ClientData clientData, const char *src, |
︙ | ︙ | |||
722 723 724 725 726 727 728 | typedef void (Tcl_PanicProc) (const char *format, ...); typedef void (Tcl_TcpAcceptProc) (ClientData callbackData, Tcl_Channel chan, 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, | | | 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 | typedef void (Tcl_PanicProc) (const char *format, ...); typedef void (Tcl_TcpAcceptProc) (ClientData callbackData, Tcl_Channel chan, 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, 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); typedef void (Tcl_AlertNotifierProc) (ClientData clientData); typedef void (Tcl_ServiceModeHookProc) (int mode); |
︙ | ︙ | |||
821 822 823 824 825 826 827 | void Tcl_IncrRefCount(Tcl_Obj *objPtr); void Tcl_DecrRefCount(Tcl_Obj *objPtr); int Tcl_IsShared(Tcl_Obj *objPtr); /* *---------------------------------------------------------------------------- | | > | > > > > > > > > | | 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 | void Tcl_IncrRefCount(Tcl_Obj *objPtr); void Tcl_DecrRefCount(Tcl_Obj *objPtr); int Tcl_IsShared(Tcl_Obj *objPtr); /* *---------------------------------------------------------------------------- * 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 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 * tclInt.h). */ |
︙ | ︙ | |||
950 951 952 953 954 955 956 | char staticSpace[TCL_DSTRING_STATIC_SIZE]; /* Space to use in common case where string is * small. */ } Tcl_DString; #define Tcl_DStringLength(dsPtr) ((dsPtr)->length) #define Tcl_DStringValue(dsPtr) ((dsPtr)->string) | | | 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 | char staticSpace[TCL_DSTRING_STATIC_SIZE]; /* Space to use in common case where string is * small. */ } Tcl_DString; #define Tcl_DStringLength(dsPtr) ((dsPtr)->length) #define Tcl_DStringValue(dsPtr) ((dsPtr)->string) #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 * specified in the "tcl_precision" variable, and the number of bytes of * buffer space required by Tcl_PrintDouble. |
︙ | ︙ | |||
1078 1079 1080 1081 1082 1083 1084 | /* * The TCL_PARSE_PART1 flag is deprecated and has no effect. The part1 is now * 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) */ | | | 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 | /* * The TCL_PARSE_PART1 flag is deprecated and has no effect. The part1 is now * 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) */ #if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 # define TCL_PARSE_PART1 0x400 #endif /* !TCL_NO_DEPRECATED */ /* * Types for linked variables: */ |
︙ | ︙ | |||
1431 1432 1433 1434 1435 1436 1437 | typedef int (Tcl_DriverCloseProc) (ClientData instanceData, Tcl_Interp *interp); 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, | | | | 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 | typedef int (Tcl_DriverCloseProc) (ClientData instanceData, Tcl_Interp *interp); 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, 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, 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); typedef int (Tcl_DriverHandlerProc) (ClientData instanceData, int interestMask); |
︙ | ︙ | |||
1931 1932 1933 1934 1935 1936 1937 | * is described by a TCL_TOKEN_SUB_EXPR token * followed by the TCL_TOKEN_OPERATOR token for * 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 | | | 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 | * is described by a TCL_TOKEN_SUB_EXPR token * followed by the TCL_TOKEN_OPERATOR token for * 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 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 * that it marks a word that began with the * literal character prefix "{*}". This word is |
︙ | ︙ | |||
2510 2511 2512 2513 2514 2515 2516 | Tcl_DbNewLongObj((val)!=0, __FILE__, __LINE__) # undef Tcl_NewByteArrayObj # define Tcl_NewByteArrayObj(bytes, len) \ Tcl_DbNewByteArrayObj(bytes, len, __FILE__, __LINE__) # undef Tcl_NewDoubleObj # define Tcl_NewDoubleObj(val) \ Tcl_DbNewDoubleObj(val, __FILE__, __LINE__) | < < < < < < | 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 | Tcl_DbNewLongObj((val)!=0, __FILE__, __LINE__) # undef Tcl_NewByteArrayObj # 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_NewListObj # define Tcl_NewListObj(objc, objv) \ Tcl_DbNewListObj(objc, objv, __FILE__, __LINE__) # undef Tcl_NewObj # define Tcl_NewObj() \ Tcl_DbNewObj(__FILE__, __LINE__) # undef Tcl_NewStringObj # define Tcl_NewStringObj(bytes, len) \ Tcl_DbNewStringObj(bytes, len, __FILE__, __LINE__) # undef Tcl_NewWideIntObj |
︙ | ︙ | |||
2581 2582 2583 2584 2585 2586 2587 | #endif /* TCL_THREADS */ /* *---------------------------------------------------------------------------- * Deprecated Tcl functions: */ | | | | 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 | #endif /* TCL_THREADS */ /* *---------------------------------------------------------------------------- * Deprecated Tcl functions: */ #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 compatibility. */ # define Tcl_Ckalloc Tcl_Alloc # define Tcl_Ckfree Tcl_Free # define Tcl_Ckrealloc Tcl_Realloc # define Tcl_Return Tcl_SetResult # define Tcl_TildeSubst Tcl_TranslateFileName |
︙ | ︙ |
Changes to generic/tclAssembly.c.
︙ | ︙ | |||
4262 4263 4264 4265 4266 4267 4268 | Tcl_AddErrorInfo(interp, "\n in assembly code between lines "); lineNo = Tcl_NewIntObj(bbPtr->startLine); Tcl_IncrRefCount(lineNo); Tcl_AppendObjToErrorInfo(interp, lineNo); Tcl_AddErrorInfo(interp, " and "); if (bbPtr->successor1 != NULL) { | | | 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 | Tcl_AddErrorInfo(interp, "\n in assembly code between lines "); lineNo = Tcl_NewIntObj(bbPtr->startLine); Tcl_IncrRefCount(lineNo); Tcl_AppendObjToErrorInfo(interp, lineNo); Tcl_AddErrorInfo(interp, " and "); if (bbPtr->successor1 != NULL) { TclSetIntObj(lineNo, bbPtr->successor1->startLine); Tcl_AppendObjToErrorInfo(interp, lineNo); } else { Tcl_AddErrorInfo(interp, "end of assembly code"); } Tcl_DecrRefCount(lineNo); } |
︙ | ︙ |
Changes to generic/tclBasic.c.
︙ | ︙ | |||
114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 | static Tcl_ObjCmdProc ExprBoolFunc; static Tcl_ObjCmdProc ExprCeilFunc; static Tcl_ObjCmdProc ExprDoubleFunc; static Tcl_ObjCmdProc ExprEntierFunc; static Tcl_ObjCmdProc ExprFloorFunc; static Tcl_ObjCmdProc ExprIntFunc; static Tcl_ObjCmdProc ExprIsqrtFunc; static Tcl_ObjCmdProc ExprRandFunc; static Tcl_ObjCmdProc ExprRoundFunc; static Tcl_ObjCmdProc ExprSqrtFunc; static Tcl_ObjCmdProc ExprSrandFunc; static Tcl_ObjCmdProc ExprUnaryFunc; static Tcl_ObjCmdProc ExprWideFunc; static void MathFuncWrongNumArgs(Tcl_Interp *interp, int expected, int actual, Tcl_Obj *const *objv); static Tcl_NRPostProc NRCoroutineCallerCallback; static Tcl_NRPostProc NRCoroutineExitCallback; static Tcl_NRPostProc NRCommand; static Tcl_ObjCmdProc OldMathFuncProc; static void OldMathFuncDeleteProc(ClientData clientData); 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, int objc, Tcl_Obj *const objv[], int flags); static inline Command * TEOV_LookupCmdFromObj(Tcl_Interp *interp, | > > > > | 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 | static Tcl_ObjCmdProc ExprBoolFunc; static Tcl_ObjCmdProc ExprCeilFunc; 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; static Tcl_ObjCmdProc ExprWideFunc; static void MathFuncWrongNumArgs(Tcl_Interp *interp, int expected, 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, int objc, Tcl_Obj *const objv[], int flags); static inline Command * TEOV_LookupCmdFromObj(Tcl_Interp *interp, |
︙ | ︙ | |||
199 200 201 202 203 204 205 | /* * Commands in the generic core. */ {"append", Tcl_AppendObjCmd, TclCompileAppendCmd, NULL, CMD_IS_SAFE}, {"apply", Tcl_ApplyObjCmd, NULL, TclNRApplyObjCmd, CMD_IS_SAFE}, {"break", Tcl_BreakObjCmd, TclCompileBreakCmd, NULL, CMD_IS_SAFE}, | | | 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 | /* * Commands in the generic core. */ {"append", Tcl_AppendObjCmd, TclCompileAppendCmd, NULL, CMD_IS_SAFE}, {"apply", Tcl_ApplyObjCmd, NULL, TclNRApplyObjCmd, CMD_IS_SAFE}, {"break", Tcl_BreakObjCmd, TclCompileBreakCmd, NULL, CMD_IS_SAFE}, #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}, {"coroutine", NULL, NULL, TclNRCoroutineObjCmd, CMD_IS_SAFE}, {"error", Tcl_ErrorObjCmd, TclCompileErrorCmd, NULL, CMD_IS_SAFE}, |
︙ | ︙ | |||
317 318 319 320 321 322 323 324 325 326 327 328 329 330 | { "floor", ExprFloorFunc, NULL }, { "fmod", ExprBinaryFunc, (ClientData) fmod }, { "hypot", ExprBinaryFunc, (ClientData) hypot }, { "int", ExprIntFunc, NULL }, { "isqrt", ExprIsqrtFunc, NULL }, { "log", ExprUnaryFunc, (ClientData) log }, { "log10", ExprUnaryFunc, (ClientData) log10 }, { "pow", ExprBinaryFunc, (ClientData) pow }, { "rand", ExprRandFunc, NULL }, { "round", ExprRoundFunc, NULL }, { "sin", ExprUnaryFunc, (ClientData) sin }, { "sinh", ExprUnaryFunc, (ClientData) sinh }, { "sqrt", ExprSqrtFunc, NULL }, { "srand", ExprSrandFunc, NULL }, | > > | 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 | { "floor", ExprFloorFunc, NULL }, { "fmod", ExprBinaryFunc, (ClientData) fmod }, { "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 }, { "sqrt", ExprSqrtFunc, NULL }, { "srand", ExprSrandFunc, NULL }, |
︙ | ︙ | |||
506 507 508 509 510 511 512 | * (whose name is ""; an alias is "::"). This also initializes the Tcl * object type table and other object management code. */ iPtr = ckalloc(sizeof(Interp)); interp = (Tcl_Interp *) iPtr; | > | > | < > | < | 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 | * (whose name is ""; an alias is "::"). This also initializes the Tcl * object type table and other object management code. */ iPtr = ckalloc(sizeof(Interp)); interp = (Tcl_Interp *) iPtr; #ifdef TCL_NO_DEPRECATED iPtr->result = &tclEmptyString; #else iPtr->result = iPtr->resultSpace; #endif iPtr->freeProc = NULL; iPtr->errorLine = 0; iPtr->objResultPtr = Tcl_NewObj(); Tcl_IncrRefCount(iPtr->objResultPtr); iPtr->handle = TclHandleCreate(iPtr); iPtr->globalNsPtr = NULL; iPtr->hiddenCmdTablePtr = NULL; iPtr->interpInfo = NULL; |
︙ | ︙ | |||
568 569 570 571 572 573 574 575 576 577 578 579 580 581 | TclNewLiteralStringObj(iPtr->ecVar, "::errorCode"); Tcl_IncrRefCount(iPtr->ecVar); iPtr->returnLevel = 1; iPtr->returnCode = TCL_OK; iPtr->rootFramePtr = NULL; /* Initialise as soon as :: is available */ iPtr->lookupNsPtr = NULL; Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS); iPtr->packageUnknown = NULL; /* TIP #268 */ #if (TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE) if (getenv("TCL_PKG_PREFER_LATEST") == NULL) { | > > > > > > | 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 | TclNewLiteralStringObj(iPtr->ecVar, "::errorCode"); Tcl_IncrRefCount(iPtr->ecVar); 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 */ #if (TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE) if (getenv("TCL_PKG_PREFER_LATEST") == NULL) { |
︙ | ︙ | |||
597 598 599 600 601 602 603 604 605 606 607 608 609 610 | iPtr->activeCmdTracePtr = NULL; iPtr->activeInterpTracePtr = NULL; iPtr->assocData = NULL; iPtr->execEnvPtr = NULL; /* Set after namespaces initialized. */ iPtr->emptyObjPtr = Tcl_NewObj(); /* Another empty object. */ Tcl_IncrRefCount(iPtr->emptyObjPtr); iPtr->threadId = Tcl_GetCurrentThread(); /* TIP #378 */ #ifdef TCL_INTERP_DEBUG_FRAME iPtr->flags |= INTERP_DEBUG_FRAME; #else if (getenv("TCL_INTERP_DEBUG_FRAME") != NULL) { | > > > | 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 | iPtr->activeCmdTracePtr = NULL; iPtr->activeInterpTracePtr = NULL; 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; #else if (getenv("TCL_INTERP_DEBUG_FRAME") != NULL) { |
︙ | ︙ | |||
706 707 708 709 710 711 712 713 714 715 716 717 718 719 | statsPtr->numLiteralsCreated = 0; statsPtr->totalLitStringBytes = 0.0; statsPtr->currentLitStringBytes = 0.0; memset(statsPtr->literalCount, 0, sizeof(statsPtr->literalCount)); #endif /* TCL_COMPILE_STATS */ /* * Initialize the ensemble error message rewriting support. */ TclResetRewriteEnsemble(interp, 1); /* | > > > > > > | 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 | statsPtr->numLiteralsCreated = 0; 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); /* |
︙ | ︙ | |||
930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 | /* * 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); Tcl_TraceVar2(interp, "tcl_precision", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, TclPrecTraceProc, NULL); TclpSetVariables(interp); #ifdef TCL_THREADS /* * The existence of the "threaded" element of the tcl_platform array * indicates that this particular Tcl shell has been compiled with threads * turned on. Using "info exists tcl_platform(threaded)" a Tcl script can | > > | 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 | /* * 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 * indicates that this particular Tcl shell has been compiled with threads * turned on. Using "info exists tcl_platform(threaded)" a Tcl script can |
︙ | ︙ | |||
1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 | /* * Free up the result *after* deleting variables, since variable deletion * could have transferred ownership of the result string to Tcl. */ Tcl_FreeResult(interp); Tcl_DecrRefCount(iPtr->objResultPtr); iPtr->objResultPtr = NULL; Tcl_DecrRefCount(iPtr->ecVar); if (iPtr->errorCode) { Tcl_DecrRefCount(iPtr->errorCode); iPtr->errorCode = NULL; } | > | 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 | /* * 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); iPtr->errorCode = NULL; } |
︙ | ︙ | |||
1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 | Tcl_DecrRefCount(iPtr->upLiteral); Tcl_DecrRefCount(iPtr->callLiteral); Tcl_DecrRefCount(iPtr->innerLiteral); Tcl_DecrRefCount(iPtr->innerContext); if (iPtr->returnOpts) { Tcl_DecrRefCount(iPtr->returnOpts); } TclFreePackageInfo(iPtr); while (iPtr->tracePtr != NULL) { Tcl_DeleteTrace((Tcl_Interp *) iPtr, (Tcl_Trace) iPtr->tracePtr); } if (iPtr->execEnvPtr != NULL) { TclDeleteExecEnv(iPtr->execEnvPtr); } | > > > > > > | 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 | Tcl_DecrRefCount(iPtr->upLiteral); Tcl_DecrRefCount(iPtr->callLiteral); 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) { TclDeleteExecEnv(iPtr->execEnvPtr); } |
︙ | ︙ | |||
2071 2072 2073 2074 2075 2076 2077 | } else { nsPtr = iPtr->globalNsPtr; tail = cmdName; } hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew); | | | | 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 | } else { nsPtr = iPtr->globalNsPtr; tail = cmdName; } hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &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); /* * Be careful to preserve * any existing import links so we can restore them down below. That |
︙ | ︙ | |||
2218 2219 2220 2221 2222 2223 2224 | * qualifiers, the new command is put in the * specified namespace; otherwise it is put in * the global namespace. */ Tcl_ObjCmdProc *proc, /* Object-based function to associate with * name. */ ClientData clientData, /* Arbitrary value to pass to object * function. */ | | > < < < < < > | > > > > > > > > > > > > > | | > > > | > > > > > > > > > > > > > > > > > > > > > > > > < < < < < < < < < < < < < < < < < < < < | | | > | 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 | * qualifiers, the new command is put in the * specified namespace; otherwise it is put in * 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 /* If not NULL, gives a function to call when * this command is deleted. */ ) { Interp *iPtr = (Interp *) interp; Namespace *nsPtr; const char *tail; 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) { 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); /* * [***] This is wrong. See Tcl Bug a16752c252. * However, this buggy behavior is kept under particular |
︙ | ︙ | |||
2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 | * intact. */ cmdPtr->refCount++; if (cmdPtr->importRefPtr) { cmdPtr->flags |= CMD_REDEF_IN_PROGRESS; } Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); if (cmdPtr->flags & CMD_REDEF_IN_PROGRESS) { oldRefPtr = cmdPtr->importRefPtr; cmdPtr->importRefPtr = NULL; } TclCleanupCommandMacro(cmdPtr); deleted = 1; } | > > > > > > < | 2357 2358 2359 2360 2361 2362 2363 2364 2365 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 | * intact. */ 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). */ |
︙ | ︙ | |||
2340 2341 2342 2343 2344 2345 2346 | * being registered with the namespace's command table. During BC * compilation, the so-resolved command turns into a CmdName literal. * Without invalidating a possible CmdName literal here explicitly, * such literals keep being reused while pointing to overhauled * commands. */ | | | 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 | * being registered with the namespace's command table. During BC * compilation, the so-resolved command turns into a CmdName literal. * Without invalidating a possible CmdName literal here explicitly, * such literals keep being reused while pointing to overhauled * commands. */ 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. */ |
︙ | ︙ | |||
2455 2456 2457 2458 2459 2460 2461 | * "Wrapper" Tcl_CmdProc used to call an existing object-based * Tcl_ObjCmdProc if no string-based function exists for a command. A * 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: | | | 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 | * "Wrapper" Tcl_CmdProc used to call an existing object-based * Tcl_ObjCmdProc if no string-based function exists for a command. A * 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 string result value. * * Side effects: * Besides those side effects of the called Tcl_ObjCmdProc, * TclInvokeObjectCommand allocates and frees storage. * *---------------------------------------------------------------------- */ |
︙ | ︙ | |||
2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 | if (cmdPtr->objProc != NULL) { result = cmdPtr->objProc(cmdPtr->objClientData, interp, argc, objv); } else { result = Tcl_NRCallObjProc(interp, cmdPtr->nreProc, cmdPtr->objClientData, argc, objv); } /* * Decrement the ref counts for the argument objects created above, then * free the objv array if malloc'ed storage was used. */ for (i = 0; i < argc; i++) { objPtr = objv[i]; | > > > > > > > | 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 | if (cmdPtr->objProc != NULL) { result = cmdPtr->objProc(cmdPtr->objClientData, interp, argc, objv); } 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. */ for (i = 0; i < argc; i++) { objPtr = objv[i]; |
︙ | ︙ | |||
2563 2564 2565 2566 2567 2568 2569 | Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't %s \"%s\": command doesn't exist", ((newName == NULL)||(*newName == '\0'))? "delete":"rename", oldName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", oldName, NULL); return TCL_ERROR; } | < < < < | < > > > > > | 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 | Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't %s \"%s\": command doesn't exist", ((newName == NULL)||(*newName == '\0'))? "delete":"rename", oldName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", oldName, NULL); return TCL_ERROR; } /* * 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); 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. */ TclGetNamespaceForQualName(interp, newName, NULL, |
︙ | ︙ | |||
3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 | cmdPtr->flags |= CMD_IS_DELETED; /* * Call trace functions for the command being deleted. Then delete its * traces. */ if (cmdPtr->tracePtr != NULL) { CommandTrace *tracePtr; CallCommandTraces(iPtr,cmdPtr,NULL,NULL,TCL_TRACE_DELETE); /* * Now delete these traces. | > > | 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 | cmdPtr->flags |= CMD_IS_DELETED; /* * 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); /* * Now delete these traces. |
︙ | ︙ | |||
3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 | /* * 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. */ TclInvalidateNsCmdLookup(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 * command-specific (i.e., inline) bytecodes for the now-deleted command. * This field is checked in Tcl_EvalObj and ObjInterpProc, and code whose | > | 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 | /* * 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. */ 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 * command-specific (i.e., inline) bytecodes for the now-deleted command. * This field is checked in Tcl_EvalObj and ObjInterpProc, and code whose |
︙ | ︙ | |||
3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 | * an instruction specific to the replaced function. In addition, * redefioning a non-builtin function will force existing code to be * invalidated if the number of arguments has changed. * *---------------------------------------------------------------------- */ void Tcl_CreateMathFunc( Tcl_Interp *interp, /* Interpreter in which function is to be * available. */ const char *name, /* Name of function (e.g. "sin"). */ int numArgs, /* Nnumber of arguments required by * function. */ | > | 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 | * an instruction specific to the replaced function. In addition, * redefioning a non-builtin function will force existing code to be * 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"). */ int numArgs, /* Nnumber of arguments required by * function. */ |
︙ | ︙ | |||
3504 3505 3506 3507 3508 3509 3510 | * Whatever the math function does. * *---------------------------------------------------------------------- */ static int OldMathFuncProc( | | | 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 | * Whatever the math function does. * *---------------------------------------------------------------------- */ static int OldMathFuncProc( 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 */ { Tcl_Obj *valuePtr; OldMathFuncData *dataPtr = clientData; |
︙ | ︙ | |||
3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 | /* * We have a non-numeric argument. */ Tcl_SetObjResult(interp, Tcl_NewStringObj( "argument to math function didn't have numeric value", -1)); ckfree(args); return TCL_ERROR; } /* * Copy the object's numeric value to the argument record, converting * it if necessary. | > | 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 | /* * We have a non-numeric argument. */ Tcl_SetObjResult(interp, Tcl_NewStringObj( "argument to math function didn't have numeric value", -1)); TclCheckBadOctal(interp, TclGetString(valuePtr)); ckfree(args); return TCL_ERROR; } /* * Copy the object's numeric value to the argument record, converting * it if necessary. |
︙ | ︙ | |||
3616 3617 3618 3619 3620 3621 3622 | } /* * Return the result of the call. */ if (funcResult.type == TCL_INT) { | | | 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 | } /* * Return the result of the call. */ if (funcResult.type == TCL_INT) { TclNewIntObj(valuePtr, funcResult.intValue); } else if (funcResult.type == TCL_WIDE_INT) { valuePtr = Tcl_NewWideIntObj(funcResult.wideValue); } else { return CheckDoubleResult(interp, funcResult.doubleValue); } Tcl_SetObjResult(interp, valuePtr); return TCL_OK; |
︙ | ︙ | |||
3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 | result = Tcl_NewObj(); } Tcl_DecrRefCount(script); Tcl_RestoreInterpState(interp, state); return result; } /* *---------------------------------------------------------------------- * * TclInterpReady -- * * Check if an interpreter is ready to eval commands or scripts, i.e., if * it was not deleted and if the nesting level is not too high. * * Results: * The return value is TCL_OK if it the interpreter is ready, TCL_ERROR * otherwise. * * Side effects: | > | | | | 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 | result = Tcl_NewObj(); } Tcl_DecrRefCount(script); Tcl_RestoreInterpState(interp, state); return result; } #endif /* !defined(TCL_NO_DEPRECATED) */ /* *---------------------------------------------------------------------- * * TclInterpReady -- * * Check if an interpreter is ready to eval commands or scripts, i.e., if * it was not deleted and if the nesting level is not too high. * * Results: * The return value is TCL_OK if it the interpreter is ready, TCL_ERROR * otherwise. * * Side effects: * The interpreters object and string results are cleared. * *---------------------------------------------------------------------- */ int TclInterpReady( Tcl_Interp *interp) { register Interp *iPtr = (Interp *) interp; /* * Reset both the interpreter's string and object results and clear out * any previous error information. */ Tcl_ResetResult(interp); /* * If the interpreter has been deleted, return an error. */ |
︙ | ︙ | |||
4391 4392 4393 4394 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 | TclNRRunCallbacks( Tcl_Interp *interp, int result, struct NRE_callback *rootPtr) /* All callbacks down to rootPtr not inclusive * are to be run. */ { NRE_callback *callbackPtr; Tcl_NRPostProc *procPtr; while (TOP_CB(interp) != rootPtr) { callbackPtr = TOP_CB(interp); procPtr = callbackPtr->procPtr; TOP_CB(interp) = callbackPtr->nextPtr; result = procPtr(callbackPtr->data, interp, result); TCLNR_FREE(interp, callbackPtr); | > > > > > > > > > > > > > > > | 4458 4459 4460 4461 4462 4463 4464 4465 4466 4467 4468 4469 4470 4471 4472 4473 4474 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 | TclNRRunCallbacks( Tcl_Interp *interp, 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; result = procPtr(callbackPtr->data, interp, result); TCLNR_FREE(interp, callbackPtr); |
︙ | ︙ | |||
4527 4528 4529 4530 4531 4532 4533 | Interp *iPtr = (Interp *) interp; int allowExceptions = (PTR2INT(data[0]) & TCL_ALLOW_EXCEPTIONS); if (result != TCL_OK) { if (result == TCL_RETURN) { result = TclUpdateReturnInfo(iPtr); } | | | 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 4620 4621 4622 4623 | Interp *iPtr = (Interp *) interp; int allowExceptions = (PTR2INT(data[0]) & TCL_ALLOW_EXCEPTIONS); if (result != TCL_OK) { if (result == TCL_RETURN) { result = TclUpdateReturnInfo(iPtr); } if ((result != TCL_OK) && (result != TCL_ERROR) && !allowExceptions) { ProcessUnexpectedResult(interp, result); result = TCL_ERROR; } } /* * We are returning to level 0, so should process TclResetCancellation. As |
︙ | ︙ | |||
4708 4709 4710 4711 4712 4713 4714 | Command **cmdPtrPtr, Tcl_Obj *commandPtr, int objc, Tcl_Obj *const objv[]) { Interp *iPtr = (Interp *) interp; Command *cmdPtr = *cmdPtrPtr; | | | 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 | Command **cmdPtrPtr, Tcl_Obj *commandPtr, int objc, Tcl_Obj *const objv[]) { Interp *iPtr = (Interp *) interp; Command *cmdPtr = *cmdPtrPtr; unsigned int newEpoch, cmdEpoch = cmdPtr->cmdEpoch; int length, traceCode = TCL_OK; const char *command = TclGetStringFromObj(commandPtr, &length); /* * Call trace functions. * Execute any command or execution traces. Note that we bump up the * command's reference count for the duration of the calling of the |
︙ | ︙ | |||
4851 4852 4853 4854 4855 4856 4857 4858 4859 4860 4861 4862 4863 4864 | int count) /* Number of tokens to consider at tokenPtr. * Must be at least 1. */ { return TclSubstTokens(interp, tokenPtr, count, /* numLeftPtr */ NULL, 1, NULL, NULL); } /* *---------------------------------------------------------------------- * * Tcl_EvalTokens -- * * Given an array of tokens parsed from a Tcl command (e.g., the tokens * that make up a word or the index for an array variable) this function | > | 4933 4934 4935 4936 4937 4938 4939 4940 4941 4942 4943 4944 4945 4946 4947 | int count) /* Number of tokens to consider at tokenPtr. * Must be at least 1. */ { return TclSubstTokens(interp, tokenPtr, count, /* numLeftPtr */ NULL, 1, NULL, NULL); } #if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 /* *---------------------------------------------------------------------- * * Tcl_EvalTokens -- * * Given an array of tokens parsed from a Tcl command (e.g., the tokens * that make up a word or the index for an array variable) this function |
︙ | ︙ | |||
4898 4899 4900 4901 4902 4903 4904 4905 4906 4907 4908 4909 4910 4911 | return NULL; } resPtr = Tcl_GetObjResult(interp); Tcl_IncrRefCount(resPtr); Tcl_ResetResult(interp); return resPtr; } /* *---------------------------------------------------------------------- * * Tcl_EvalEx, TclEvalEx -- * * This function evaluates a Tcl script without using the compiler or | > | 4981 4982 4983 4984 4985 4986 4987 4988 4989 4990 4991 4992 4993 4994 4995 | return NULL; } resPtr = Tcl_GetObjResult(interp); Tcl_IncrRefCount(resPtr); Tcl_ResetResult(interp); return resPtr; } #endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- * * Tcl_EvalEx, TclEvalEx -- * * This function evaluates a Tcl script without using the compiler or |
︙ | ︙ | |||
5861 5862 5863 5864 5865 5866 5867 | #undef Tcl_Eval int 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. */ { | | > > > > > > > > > | 5945 5946 5947 5948 5949 5950 5951 5952 5953 5954 5955 5956 5957 5958 5959 5960 5961 5962 5963 5964 5965 5966 5967 5968 | #undef Tcl_Eval int 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. */ { 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; } /* *---------------------------------------------------------------------- * * Tcl_EvalObj, Tcl_GlobalEvalObj -- * |
︙ | ︙ | |||
6284 6285 6286 6287 6288 6289 6290 6291 6292 6293 6294 6295 6296 6297 | *ptr = 0; } else { exprPtr = Tcl_NewStringObj(exprstring, -1); Tcl_IncrRefCount(exprPtr); result = Tcl_ExprLongObj(interp, exprPtr, ptr); Tcl_DecrRefCount(exprPtr); } return result; } int Tcl_ExprDouble( Tcl_Interp *interp, /* Context in which to evaluate the | > > > | 6377 6378 6379 6380 6381 6382 6383 6384 6385 6386 6387 6388 6389 6390 6391 6392 6393 | *ptr = 0; } 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 Tcl_ExprDouble( Tcl_Interp *interp, /* Context in which to evaluate the |
︙ | ︙ | |||
6310 6311 6312 6313 6314 6315 6316 6317 6318 6319 6320 6321 6322 6323 | *ptr = 0.0; } else { exprPtr = Tcl_NewStringObj(exprstring, -1); Tcl_IncrRefCount(exprPtr); result = Tcl_ExprDoubleObj(interp, exprPtr, ptr); Tcl_DecrRefCount(exprPtr); /* Discard the expression object. */ } return result; } int Tcl_ExprBoolean( Tcl_Interp *interp, /* Context in which to evaluate the | > > > | 6406 6407 6408 6409 6410 6411 6412 6413 6414 6415 6416 6417 6418 6419 6420 6421 6422 | *ptr = 0.0; } else { 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 Tcl_ExprBoolean( Tcl_Interp *interp, /* Context in which to evaluate the |
︙ | ︙ | |||
6335 6336 6337 6338 6339 6340 6341 6342 6343 6344 6345 6346 6347 6348 | } else { int result; Tcl_Obj *exprPtr = Tcl_NewStringObj(exprstring, -1); Tcl_IncrRefCount(exprPtr); result = Tcl_ExprBooleanObj(interp, exprPtr, ptr); Tcl_DecrRefCount(exprPtr); return result; } } /* *-------------------------------------------------------------- * | > > > > > > > > | 6434 6435 6436 6437 6438 6439 6440 6441 6442 6443 6444 6445 6446 6447 6448 6449 6450 6451 6452 6453 6454 6455 | } else { int result; 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; } } /* *-------------------------------------------------------------- * |
︙ | ︙ | |||
6393 6394 6395 6396 6397 6398 6399 | Tcl_DecrRefCount(resultPtr); if (Tcl_InitBignumFromDouble(interp, d, &big) != TCL_OK) { return TCL_ERROR; } resultPtr = Tcl_NewBignumObj(&big); /* FALLTHROUGH */ } | < | 6500 6501 6502 6503 6504 6505 6506 6507 6508 6509 6510 6511 6512 6513 | Tcl_DecrRefCount(resultPtr); if (Tcl_InitBignumFromDouble(interp, d, &big) != TCL_OK) { return TCL_ERROR; } resultPtr = Tcl_NewBignumObj(&big); /* FALLTHROUGH */ } case TCL_NUMBER_WIDE: case TCL_NUMBER_BIG: result = TclGetLongFromObj(interp, resultPtr, ptr); break; case TCL_NUMBER_NAN: Tcl_GetDoubleFromObj(interp, resultPtr, &d); |
︙ | ︙ | |||
6649 6650 6651 6652 6653 6654 6655 6656 6657 6658 6659 6660 6661 6662 | code = Tcl_ExprObj(interp, exprObj, &resultPtr); Tcl_DecrRefCount(exprObj); if (code == TCL_OK) { Tcl_SetObjResult(interp, resultPtr); Tcl_DecrRefCount(resultPtr); } } return code; } /* *---------------------------------------------------------------------- * * Tcl_AppendObjToErrorInfo -- | > > > > > > | 6755 6756 6757 6758 6759 6760 6761 6762 6763 6764 6765 6766 6767 6768 6769 6770 6771 6772 6773 6774 | code = Tcl_ExprObj(interp, exprObj, &resultPtr); Tcl_DecrRefCount(exprObj); 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; } /* *---------------------------------------------------------------------- * * Tcl_AppendObjToErrorInfo -- |
︙ | ︙ | |||
6755 6756 6757 6758 6759 6760 6761 | /* * If we are just starting to log an error, errorInfo is initialized from * the error message in the interpreter's result. */ iPtr->flags |= ERR_LEGACY_COPY; if (iPtr->errorInfo == NULL) { | > > > > > > > > > > > | > | 6867 6868 6869 6870 6871 6872 6873 6874 6875 6876 6877 6878 6879 6880 6881 6882 6883 6884 6885 6886 6887 6888 6889 6890 6891 6892 6893 | /* * If we are just starting to log an error, errorInfo is initialized from * the error message in the interpreter's result. */ iPtr->flags |= ERR_LEGACY_COPY; if (iPtr->errorInfo == NULL) { 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); } } /* |
︙ | ︙ | |||
6833 6834 6835 6836 6837 6838 6839 | * Tcl_VarEval -- * * 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 | | | 6957 6958 6959 6960 6961 6962 6963 6964 6965 6966 6967 6968 6969 6970 6971 | * Tcl_VarEval -- * * 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 interp->result. * * Side effects: * Depends on what was done by the command. * *---------------------------------------------------------------------- */ /* ARGSUSED */ |
︙ | ︙ | |||
7351 7352 7353 7354 7355 7356 7357 | return TCL_ERROR; } if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { return TCL_ERROR; } | | | | | | | | | 7475 7476 7477 7478 7479 7480 7481 7482 7483 7484 7485 7486 7487 7488 7489 7490 7491 7492 7493 7494 7495 7496 7497 7498 7499 7500 7501 7502 7503 7504 7505 7506 7507 7508 7509 7510 | return TCL_ERROR; } if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { return TCL_ERROR; } if (type == TCL_NUMBER_WIDE) { Tcl_WideInt l = *((const Tcl_WideInt *) ptr); if (l > (Tcl_WideInt)0) { goto unChanged; } 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)); return TCL_OK; } string++; } } goto unChanged; } else if (l == LLONG_MIN) { TclInitBignumFromWideInt(&big, l); goto tooLarge; } Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-l)); return TCL_OK; } if (type == TCL_NUMBER_DOUBLE) { double d = *((const double *) ptr); static const double poszero = 0.0; |
︙ | ︙ | |||
7396 7397 7398 7399 7400 7401 7402 | } else if (d > -0.0) { goto unChanged; } Tcl_SetObjResult(interp, Tcl_NewDoubleObj(-d)); return TCL_OK; } | < < < < < < < < < < < < < < < < | 7520 7521 7522 7523 7524 7525 7526 7527 7528 7529 7530 7531 7532 7533 | } else if (d > -0.0) { goto unChanged; } Tcl_SetObjResult(interp, Tcl_NewDoubleObj(-d)); return TCL_OK; } 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); Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big)); } else { |
︙ | ︙ | |||
7607 7608 7609 7610 7611 7612 7613 7614 7615 7616 7617 7618 7619 7620 | Tcl_IncrRefCount(objPtr); TclGetWideIntFromObj(NULL, objPtr, &wResult); Tcl_DecrRefCount(objPtr); } Tcl_SetObjResult(interp, Tcl_NewWideIntObj(wResult)); return TCL_OK; } static int ExprRandFunc( ClientData clientData, /* Ignored. */ Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count. */ | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 7715 7716 7717 7718 7719 7720 7721 7722 7723 7724 7725 7726 7727 7728 7729 7730 7731 7732 7733 7734 7735 7736 7737 7738 7739 7740 7741 7742 7743 7744 7745 7746 7747 7748 7749 7750 7751 7752 7753 7754 7755 7756 7757 7758 7759 7760 7761 7762 7763 7764 7765 7766 7767 7768 7769 7770 7771 7772 7773 7774 7775 7776 7777 7778 7779 7780 7781 7782 7783 7784 7785 7786 7787 7788 7789 7790 7791 7792 7793 | Tcl_IncrRefCount(objPtr); TclGetWideIntFromObj(NULL, objPtr, &wResult); 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 * function. */ int objc, /* Actual parameter count. */ |
︙ | ︙ | |||
7631 7632 7633 7634 7635 7636 7637 | return TCL_ERROR; } if (!(iPtr->flags & RAND_SEED_INITIALIZED)) { iPtr->flags |= RAND_SEED_INITIALIZED; /* | | | 7804 7805 7806 7807 7808 7809 7810 7811 7812 7813 7814 7815 7816 7817 7818 | return TCL_ERROR; } if (!(iPtr->flags & RAND_SEED_INITIALIZED)) { iPtr->flags |= RAND_SEED_INITIALIZED; /* * 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); /* * Make sure 1 <= randSeed <= (2^31) - 2. See below. |
︙ | ︙ | |||
8093 8094 8095 8096 8097 8098 8099 8100 8101 8102 8103 8104 8105 8106 | Tcl_CmdDeleteProc *deleteProc) /* If not NULL, gives a function to call when * this command is deleted. */ { Command *cmdPtr = (Command *) Tcl_CreateObjCommand(interp,cmdName,proc,clientData,deleteProc); cmdPtr->nreProc = nreProc; return (Tcl_Command) cmdPtr; } /**************************************************************************** * Stuff for the public api ****************************************************************************/ | > > > > > > > > > > > > > > > > | 8266 8267 8268 8269 8270 8271 8272 8273 8274 8275 8276 8277 8278 8279 8280 8281 8282 8283 8284 8285 8286 8287 8288 8289 8290 8291 8292 8293 8294 8295 | Tcl_CmdDeleteProc *deleteProc) /* If not NULL, gives a function to call when * 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; } /**************************************************************************** * Stuff for the public api ****************************************************************************/ |
︙ | ︙ | |||
8881 8882 8883 8884 8885 8886 8887 | ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Command *cmdPtr; CoroutineData *corPtr; | | | | < < < < < | | | | | | < < < < < < < < < < < < < < < | | < > | 9070 9071 9072 9073 9074 9075 9076 9077 9078 9079 9080 9081 9082 9083 9084 9085 9086 9087 9088 9089 9090 9091 9092 9093 9094 9095 9096 9097 9098 9099 9100 9101 9102 9103 9104 9105 9106 9107 9108 9109 9110 9111 9112 9113 9114 9115 9116 9117 9118 9119 9120 9121 9122 | ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Command *cmdPtr; CoroutineData *corPtr; 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; } 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", procName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "NAMESPACE", NULL); return TCL_ERROR; } if (simpleName == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create procedure \"%s\": bad procedure name", procName)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", procName, NULL); return TCL_ERROR; } /* * We ARE creating the coroutine command: allocate the corresponding * struct and create the corresponding command. */ corPtr = ckalloc(sizeof(CoroutineData)); cmdPtr = (Command *) TclNRCreateCommandInNs(interp, simpleName, (Tcl_Namespace *)nsPtr, /*objProc*/ NULL, TclNRInterpCoroutine, corPtr, DeleteCoroutine); corPtr->cmdPtr = cmdPtr; cmdPtr->refCount++; /* * #280. * Provide the new coroutine with its own copy of the lineLABCPtr |
︙ | ︙ |
Changes to generic/tclCmdAH.c.
︙ | ︙ | |||
160 161 162 163 164 165 166 | * A standard Tcl object result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | | | 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 | * A standard Tcl object result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ #if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 /* ARGSUSED */ int Tcl_CaseObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ |
︙ | ︙ |
Changes to generic/tclCmdIL.c.
︙ | ︙ | |||
2941 2942 2943 2944 2945 2946 2947 | int i, match, index, result, listc, length, elemLen, bisect; int dataType, isIncreasing, lower, upper, offset; Tcl_WideInt patWide, objWide; int allMatches, inlineReturn, negatedMatch, returnSubindices, noCase; double patDouble, objDouble; SortInfo sortInfo; Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr; | | | 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 | int i, match, index, result, listc, length, elemLen, bisect; int dataType, isIncreasing, lower, upper, offset; 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 = TclUtfCmp; Tcl_RegExp regexp = NULL; static const char *const options[] = { "-all", "-ascii", "-bisect", "-decreasing", "-dictionary", "-exact", "-glob", "-increasing", "-index", "-inline", "-integer", "-nocase", "-not", "-real", "-regexp", "-sorted", "-start", "-subindices", NULL |
︙ | ︙ | |||
4259 4260 4261 4262 4263 4264 4265 | /* Values to be compared. */ SortInfo *infoPtr) /* Information passed from the top-level * "lsort" command. */ { int order = 0; if (infoPtr->sortMode == SORTMODE_ASCII) { | | | 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 | /* Values to be compared. */ SortInfo *infoPtr) /* Information passed from the top-level * "lsort" command. */ { int order = 0; if (infoPtr->sortMode == SORTMODE_ASCII) { 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) { order = DictionaryCompare(elemPtr1->collationKey.strValuePtr, elemPtr2->collationKey.strValuePtr); |
︙ | ︙ |
Changes to generic/tclCmdMZ.c.
︙ | ︙ | |||
305 306 307 308 309 310 311 | * start of the string unless the previous character is a newline. */ if (offset == 0) { eflags = 0; } else if (offset > stringLength) { eflags = TCL_REG_NOTBOL; | | | 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 | * start of the string unless the previous character is a newline. */ if (offset == 0) { eflags = 0; } else if (offset > stringLength) { eflags = TCL_REG_NOTBOL; } else if (Tcl_GetUniChar(objPtr, offset-1) == '\n') { eflags = 0; } else { eflags = TCL_REG_NOTBOL; } match = Tcl_RegExpExecObj(interp, regExpr, objPtr, offset, numMatchesSaved, eflags); |
︙ | ︙ | |||
1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 | * is a *major* win when splitting on a long string (especially in the * megabyte range!) - DKF */ Tcl_InitHashTable(&charReuseTable, TCL_ONE_WORD_KEYS); for ( ; stringPtr < end; stringPtr += len) { len = TclUtfToUniChar(stringPtr, &ch); /* * Assume Tcl_UniChar is an integral type... */ | > > > > > > > > > | | 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 | * is a *major* win when splitting on a long string (especially in the * megabyte range!) - DKF */ 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(fullchar), &isNew); if (isNew) { TclNewStringObj(objPtr, stringPtr, len); /* * Don't need to fiddle with refcount... */ |
︙ | ︙ | |||
1592 1593 1594 1595 1596 1597 1598 | case STR_IS_DIGIT: chcomp = Tcl_UniCharIsDigit; break; case STR_IS_DOUBLE: { /* TODO */ if ((objPtr->typePtr == &tclDoubleType) || (objPtr->typePtr == &tclIntType) || | < < < | 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 | case STR_IS_DIGIT: chcomp = Tcl_UniCharIsDigit; break; case STR_IS_DOUBLE: { /* TODO */ if ((objPtr->typePtr == &tclDoubleType) || (objPtr->typePtr == &tclIntType) || (objPtr->typePtr == &tclBignumType)) { break; } string1 = TclGetStringFromObj(objPtr, &length1); if (length1 == 0) { if (strict) { result = 0; |
︙ | ︙ | |||
1629 1630 1631 1632 1633 1634 1635 | case STR_IS_INT: if (TCL_OK == TclGetIntFromObj(NULL, objPtr, &i)) { break; } goto failedIntParse; case STR_IS_ENTIER: if ((objPtr->typePtr == &tclIntType) || | < < < | 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 | case STR_IS_INT: if (TCL_OK == TclGetIntFromObj(NULL, objPtr, &i)) { break; } goto failedIntParse; case STR_IS_ENTIER: if ((objPtr->typePtr == &tclIntType) || (objPtr->typePtr == &tclBignumType)) { break; } string1 = TclGetStringFromObj(objPtr, &length1); if (length1 == 0) { if (strict) { result = 0; |
︙ | ︙ | |||
1810 1811 1812 1813 1814 1815 1816 1817 | if (strict) { result = 0; } goto str_is_done; } end = string1 + length1; for (; string1 < end; string1 += length2, failat++) { length2 = TclUtfToUniChar(string1, &ch); | > > > > > > > > | | 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 | if (strict) { result = 0; } goto str_is_done; } end = string1 + length1; for (; string1 < end; string1 += length2, failat++) { int fullchar; length2 = TclUtfToUniChar(string1, &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; } } } /* |
︙ | ︙ | |||
2872 2873 2874 2875 2876 2877 2878 | * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ | < | 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 | * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ static int StringBytesCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { |
︙ | ︙ | |||
3526 3527 3528 3529 3530 3531 3532 | "--", NULL }; enum options { OPT_EXACT, OPT_GLOB, OPT_INDEXV, OPT_MATCHV, OPT_NOCASE, OPT_REGEXP, OPT_LAST }; typedef int (*strCmpFn_t)(const char *, const char *); | | | 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 | "--", NULL }; 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 = TclUtfCmp; mode = OPT_EXACT; foundmode = 0; indexVarObj = NULL; matchVarObj = NULL; numMatchesSaved = 0; noCase = 0; |
︙ | ︙ | |||
4289 4290 4291 4292 4293 4294 4295 | commonHandler: if (Tcl_ListObjLength(interp, objv[i+2], &dummy) != TCL_OK) { Tcl_DecrRefCount(handlersObj); return TCL_ERROR; } info[0] = objv[i]; /* type */ | | | 4299 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 | commonHandler: if (Tcl_ListObjLength(interp, objv[i+2], &dummy) != TCL_OK) { Tcl_DecrRefCount(handlersObj); return TCL_ERROR; } info[0] = objv[i]; /* type */ 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 */ bodyShared = !strcmp(TclGetString(objv[i+3]), "-"); |
︙ | ︙ |
Changes to generic/tclCompile.h.
︙ | ︙ | |||
421 422 423 424 425 426 427 | * ByteCode was compiled. Used to invalidate * code when, e.g., commands with compile * 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. */ | | | | 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 | * ByteCode was compiled. Used to invalidate * code when, e.g., commands with compile * 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. */ 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. */ 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 * TCL_BYTECODE_ masks defined above */ const char *source; /* The source string from which this ByteCode |
︙ | ︙ |
Changes to generic/tclDecls.h.
︙ | ︙ | |||
49 50 51 52 53 54 55 | */ /* 0 */ EXTERN int Tcl_PkgProvideEx(Tcl_Interp *interp, const char *name, const char *version, const void *clientData); /* 1 */ | | | 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 | */ /* 0 */ EXTERN int Tcl_PkgProvideEx(Tcl_Interp *interp, const char *name, const char *version, const void *clientData); /* 1 */ 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 */ EXTERN char * Tcl_Alloc(unsigned int size); /* 4 */ |
︙ | ︙ | |||
155 156 157 158 159 160 161 | EXTERN int Tcl_GetDouble(Tcl_Interp *interp, const char *src, double *doublePtr); /* 35 */ EXTERN int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr); /* 36 */ EXTERN int Tcl_GetIndexFromObj(Tcl_Interp *interp, | | < | 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 | EXTERN int Tcl_GetDouble(Tcl_Interp *interp, const char *src, double *doublePtr); /* 35 */ EXTERN int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr); /* 36 */ EXTERN int Tcl_GetIndexFromObj(Tcl_Interp *interp, 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 */ EXTERN int Tcl_GetIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr); |
︙ | ︙ | |||
259 260 261 262 263 264 265 | /* 74 */ EXTERN void Tcl_AsyncMark(Tcl_AsyncHandler async); /* 75 */ EXTERN int Tcl_AsyncReady(void); /* 76 */ EXTERN void Tcl_BackgroundError(Tcl_Interp *interp); /* 77 */ | > | | | | 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 | /* 74 */ EXTERN void Tcl_AsyncMark(Tcl_AsyncHandler async); /* 75 */ EXTERN int Tcl_AsyncReady(void); /* 76 */ EXTERN void Tcl_BackgroundError(Tcl_Interp *interp); /* 77 */ 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 */ EXTERN void Tcl_CallWhenDeleted(Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, ClientData clientData); /* 80 */ EXTERN void Tcl_CancelIdleCall(Tcl_IdleProc *idleProc, ClientData clientData); /* 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, const char *const *argv); /* 84 */ EXTERN int Tcl_ConvertElement(const char *src, char *dst, int flags); /* 85 */ EXTERN int Tcl_ConvertCountedElement(const char *src, 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, 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[]); /* 88 */ EXTERN Tcl_Channel Tcl_CreateChannel(const Tcl_ChannelType *typePtr, |
︙ | ︙ | |||
318 319 320 321 322 323 324 | ClientData clientData); /* 93 */ EXTERN void Tcl_CreateExitHandler(Tcl_ExitProc *proc, ClientData clientData); /* 94 */ EXTERN Tcl_Interp * Tcl_CreateInterp(void); /* 95 */ | > | | 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 | ClientData clientData); /* 93 */ EXTERN void Tcl_CreateExitHandler(Tcl_ExitProc *proc, ClientData clientData); /* 94 */ EXTERN Tcl_Interp * Tcl_CreateInterp(void); /* 95 */ 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, const char *cmdName, Tcl_ObjCmdProc *proc, ClientData clientData, |
︙ | ︙ | |||
408 409 410 411 412 413 414 | /* 124 */ EXTERN void Tcl_DStringSetLength(Tcl_DString *dsPtr, int length); /* 125 */ EXTERN void Tcl_DStringStartSublist(Tcl_DString *dsPtr); /* 126 */ EXTERN int Tcl_Eof(Tcl_Channel chan); /* 127 */ | | | | 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 | /* 124 */ EXTERN void Tcl_DStringSetLength(Tcl_DString *dsPtr, int length); /* 125 */ EXTERN void Tcl_DStringStartSublist(Tcl_DString *dsPtr); /* 126 */ EXTERN int Tcl_Eof(Tcl_Channel chan); /* 127 */ EXTERN const char * Tcl_ErrnoId(void); /* 128 */ 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); /* 131 */ EXTERN int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr); |
︙ | ︙ | |||
465 466 467 468 469 470 471 | EXTERN int Tcl_Flush(Tcl_Channel chan); /* 147 */ EXTERN void Tcl_FreeResult(Tcl_Interp *interp); /* 148 */ EXTERN int Tcl_GetAlias(Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, | | | | | | | | 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 | EXTERN int Tcl_Flush(Tcl_Channel chan); /* 147 */ EXTERN void Tcl_FreeResult(Tcl_Interp *interp); /* 148 */ EXTERN int Tcl_GetAlias(Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *argcPtr, const char ***argvPtr); /* 149 */ EXTERN int Tcl_GetAliasObj(Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 150 */ EXTERN ClientData Tcl_GetAssocData(Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc **procPtr); /* 151 */ EXTERN Tcl_Channel Tcl_GetChannel(Tcl_Interp *interp, const char *chanName, int *modePtr); /* 152 */ EXTERN int Tcl_GetChannelBufferSize(Tcl_Channel chan); /* 153 */ EXTERN int Tcl_GetChannelHandle(Tcl_Channel chan, int direction, ClientData *handlePtr); /* 154 */ EXTERN ClientData Tcl_GetChannelInstanceData(Tcl_Channel chan); /* 155 */ EXTERN int Tcl_GetChannelMode(Tcl_Channel chan); /* 156 */ 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 */ 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 const char * Tcl_GetCommandName(Tcl_Interp *interp, Tcl_Command command); /* 161 */ EXTERN int Tcl_GetErrno(void); /* 162 */ 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); /* 165 */ EXTERN const char * Tcl_GetNameOfExecutable(void); |
︙ | ︙ | |||
542 543 544 545 546 547 548 | EXTERN int Tcl_GetServiceMode(void); /* 172 */ EXTERN Tcl_Interp * Tcl_GetSlave(Tcl_Interp *interp, const char *slaveName); /* 173 */ EXTERN Tcl_Channel Tcl_GetStdChannel(int type); /* 174 */ | | | | | | < | 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 | EXTERN int Tcl_GetServiceMode(void); /* 172 */ EXTERN Tcl_Interp * Tcl_GetSlave(Tcl_Interp *interp, const char *slaveName); /* 173 */ EXTERN Tcl_Channel Tcl_GetStdChannel(int type); /* 174 */ EXTERN const char * Tcl_GetStringResult(Tcl_Interp *interp); /* 175 */ EXTERN const char * Tcl_GetVar(Tcl_Interp *interp, const char *varName, int flags); /* 176 */ EXTERN const char * Tcl_GetVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 177 */ EXTERN int Tcl_GlobalEval(Tcl_Interp *interp, const char *command); /* 178 */ EXTERN int Tcl_GlobalEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr); /* 179 */ |
︙ | ︙ | |||
574 575 576 577 578 579 580 | /* 183 */ EXTERN int Tcl_InputBuffered(Tcl_Channel chan); /* 184 */ EXTERN int Tcl_InterpDeleted(Tcl_Interp *interp); /* 185 */ EXTERN int Tcl_IsSafe(Tcl_Interp *interp); /* 186 */ | | | | | 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 | /* 183 */ EXTERN int Tcl_InputBuffered(Tcl_Channel chan); /* 184 */ EXTERN int Tcl_InterpDeleted(Tcl_Interp *interp); /* 185 */ EXTERN int Tcl_IsSafe(Tcl_Interp *interp); /* 186 */ 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 */ /* 189 */ EXTERN Tcl_Channel Tcl_MakeFileChannel(ClientData handle, int mode); /* 190 */ EXTERN int Tcl_MakeSafe(Tcl_Interp *interp); /* 191 */ EXTERN Tcl_Channel Tcl_MakeTcpClientChannel(ClientData tcpSocket); /* 192 */ 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 */ EXTERN Tcl_Obj * Tcl_ObjGetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 196 */ 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, const char **argv, int flags); /* 198 */ EXTERN Tcl_Channel Tcl_OpenFileChannel(Tcl_Interp *interp, const char *fileName, const char *modeString, int permissions); /* 199 */ EXTERN Tcl_Channel Tcl_OpenTcpClient(Tcl_Interp *interp, int port, const char *address, const char *myaddr, |
︙ | ︙ | |||
623 624 625 626 627 628 629 | EXTERN void Tcl_Preserve(ClientData data); /* 202 */ EXTERN void Tcl_PrintDouble(Tcl_Interp *interp, double value, char *dst); /* 203 */ EXTERN int Tcl_PutEnv(const char *assignment); /* 204 */ | | | 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 | EXTERN void Tcl_Preserve(ClientData data); /* 202 */ EXTERN void Tcl_PrintDouble(Tcl_Interp *interp, double value, char *dst); /* 203 */ EXTERN int Tcl_PutEnv(const char *assignment); /* 204 */ 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); /* 207 */ EXTERN void Tcl_ReapDetachedProcs(void); |
︙ | ︙ | |||
653 654 655 656 657 658 659 | EXTERN int Tcl_RegExpExec(Tcl_Interp *interp, Tcl_RegExp regexp, const char *text, const char *start); /* 214 */ EXTERN int Tcl_RegExpMatch(Tcl_Interp *interp, const char *text, const char *pattern); /* 215 */ EXTERN void Tcl_RegExpRange(Tcl_RegExp regexp, int index, | | < > | | 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 | EXTERN int Tcl_RegExpExec(Tcl_Interp *interp, Tcl_RegExp regexp, const char *text, const char *start); /* 214 */ EXTERN int Tcl_RegExpMatch(Tcl_Interp *interp, const char *text, const char *pattern); /* 215 */ EXTERN void Tcl_RegExpRange(Tcl_RegExp regexp, int index, const char **startPtr, const char **endPtr); /* 216 */ EXTERN void Tcl_Release(ClientData clientData); /* 217 */ EXTERN void Tcl_ResetResult(Tcl_Interp *interp); /* 218 */ EXTERN int Tcl_ScanElement(const char *src, int *flagPtr); /* 219 */ EXTERN int Tcl_ScanCountedElement(const char *src, int length, int *flagPtr); /* 220 */ 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 */ EXTERN void Tcl_SetAssocData(Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc *proc, |
︙ | ︙ | |||
709 710 711 712 713 714 715 | Tcl_Obj *errorObjPtr); /* 235 */ EXTERN void Tcl_SetObjResult(Tcl_Interp *interp, Tcl_Obj *resultObjPtr); /* 236 */ EXTERN void Tcl_SetStdChannel(Tcl_Channel channel, int type); /* 237 */ | | | < | | | | | | | > | | 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 | Tcl_Obj *errorObjPtr); /* 235 */ EXTERN void Tcl_SetObjResult(Tcl_Interp *interp, Tcl_Obj *resultObjPtr); /* 236 */ EXTERN void Tcl_SetStdChannel(Tcl_Channel channel, int type); /* 237 */ EXTERN const char * Tcl_SetVar(Tcl_Interp *interp, const char *varName, const char *newValue, int flags); /* 238 */ EXTERN const char * Tcl_SetVar2(Tcl_Interp *interp, const char *part1, const char *part2, const char *newValue, int flags); /* 239 */ EXTERN const char * Tcl_SignalId(int sig); /* 240 */ 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, const char ***argvPtr); /* 243 */ EXTERN void Tcl_SplitPath(const char *path, int *argcPtr, 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 */ 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 */ EXTERN int Tcl_TraceVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags, |
︙ | ︙ | |||
808 809 810 811 812 813 814 | EXTERN void Tcl_WrongNumArgs(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], const char *message); /* 265 */ EXTERN int Tcl_DumpActiveMemory(const char *fileName); /* 266 */ EXTERN void Tcl_ValidateAllMemory(const char *file, int line); /* 267 */ | > | > | | | | | < | | | < > | > | > | | 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 | EXTERN void Tcl_WrongNumArgs(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], const char *message); /* 265 */ EXTERN int Tcl_DumpActiveMemory(const char *fileName); /* 266 */ EXTERN void Tcl_ValidateAllMemory(const char *file, int line); /* 267 */ TCL_DEPRECATED("see TIP #422") void Tcl_AppendResultVA(Tcl_Interp *interp, va_list argList); /* 268 */ TCL_DEPRECATED("see TIP #422") void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, va_list argList); /* 269 */ EXTERN char * Tcl_HashStats(Tcl_HashTable *tablePtr); /* 270 */ EXTERN const char * Tcl_ParseVar(Tcl_Interp *interp, const char *start, const char **termPtr); /* 271 */ EXTERN const char * Tcl_PkgPresent(Tcl_Interp *interp, const char *name, const char *version, int exact); /* 272 */ 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 const char * Tcl_PkgRequire(Tcl_Interp *interp, const char *name, const char *version, int exact); /* 275 */ TCL_DEPRECATED("see TIP #422") void Tcl_SetErrorCodeVA(Tcl_Interp *interp, va_list argList); /* 276 */ 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 */ 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); /* 281 */ EXTERN Tcl_Channel Tcl_StackChannel(Tcl_Interp *interp, |
︙ | ︙ | |||
906 907 908 909 910 911 912 | /* 299 */ EXTERN void Tcl_FreeEncoding(Tcl_Encoding encoding); /* 300 */ EXTERN Tcl_ThreadId Tcl_GetCurrentThread(void); /* 301 */ EXTERN Tcl_Encoding Tcl_GetEncoding(Tcl_Interp *interp, const char *name); /* 302 */ | | | 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 | /* 299 */ EXTERN void Tcl_FreeEncoding(Tcl_Encoding encoding); /* 300 */ EXTERN Tcl_ThreadId Tcl_GetCurrentThread(void); /* 301 */ EXTERN Tcl_Encoding Tcl_GetEncoding(Tcl_Interp *interp, const char *name); /* 302 */ 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, int offset, const char *msg, int flags, int *indexPtr); |
︙ | ︙ | |||
965 966 967 968 969 970 971 | /* 322 */ EXTERN Tcl_UniChar Tcl_UniCharToTitle(int ch); /* 323 */ EXTERN Tcl_UniChar Tcl_UniCharToUpper(int ch); /* 324 */ EXTERN int Tcl_UniCharToUtf(int ch, char *buf); /* 325 */ | | | | | | | 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 | /* 322 */ EXTERN Tcl_UniChar Tcl_UniCharToTitle(int ch); /* 323 */ EXTERN Tcl_UniChar Tcl_UniCharToUpper(int ch); /* 324 */ EXTERN int Tcl_UniCharToUtf(int ch, char *buf); /* 325 */ 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 const char * Tcl_UtfFindFirst(const char *src, int ch); /* 329 */ EXTERN const char * Tcl_UtfFindLast(const char *src, int ch); /* 330 */ EXTERN const char * Tcl_UtfNext(const char *src); /* 331 */ 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, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); |
︙ | ︙ | |||
1006 1007 1008 1009 1010 1011 1012 | EXTERN int Tcl_WriteChars(Tcl_Channel chan, const char *src, int srcLen); /* 339 */ EXTERN int Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr); /* 340 */ EXTERN char * Tcl_GetString(Tcl_Obj *objPtr); /* 341 */ | > | > | | 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 | EXTERN int Tcl_WriteChars(Tcl_Channel chan, const char *src, int srcLen); /* 339 */ EXTERN int Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr); /* 340 */ EXTERN char * Tcl_GetString(Tcl_Obj *objPtr); /* 341 */ TCL_DEPRECATED("Use Tcl_GetEncodingSearchPath") const char * Tcl_GetDefaultEncodingDir(void); /* 342 */ 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 */ EXTERN int Tcl_UniCharIsAlnum(int ch); /* 346 */ |
︙ | ︙ | |||
1043 1044 1045 1046 1047 1048 1049 | /* 355 */ EXTERN Tcl_UniChar * Tcl_UtfToUniCharDString(const char *src, int length, Tcl_DString *dsPtr); /* 356 */ EXTERN Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj, int flags); /* 357 */ | > | | | | 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 | /* 355 */ EXTERN Tcl_UniChar * Tcl_UtfToUniCharDString(const char *src, int length, Tcl_DString *dsPtr); /* 356 */ EXTERN Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj, int flags); /* 357 */ 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, const char *script, const char *command, int length); /* 360 */ EXTERN int Tcl_ParseBraces(Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr); /* 361 */ EXTERN int Tcl_ParseCommand(Tcl_Interp *interp, const char *start, int numBytes, int nested, Tcl_Parse *parsePtr); /* 362 */ EXTERN int Tcl_ParseExpr(Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr); /* 363 */ EXTERN int Tcl_ParseQuotedString(Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr); /* 364 */ EXTERN int Tcl_ParseVarName(Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append); /* 365 */ EXTERN char * Tcl_GetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 366 */ |
︙ | ︙ | |||
1157 1158 1159 1160 1161 1162 1163 | EXTERN int Tcl_WriteRaw(Tcl_Channel chan, const char *src, int srcLen); /* 396 */ EXTERN Tcl_Channel Tcl_GetTopChannel(Tcl_Channel chan); /* 397 */ EXTERN int Tcl_ChannelBuffered(Tcl_Channel chan); /* 398 */ | < | | 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 | EXTERN int Tcl_WriteRaw(Tcl_Channel chan, const char *src, int srcLen); /* 396 */ EXTERN Tcl_Channel Tcl_GetTopChannel(Tcl_Channel chan); /* 397 */ EXTERN int Tcl_ChannelBuffered(Tcl_Channel chan); /* 398 */ 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( const Tcl_ChannelType *chanTypePtr); /* 401 */ |
︙ | ︙ | |||
1264 1265 1266 1267 1268 1269 1270 | EXTERN int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, int length); /* 433 */ EXTERN Tcl_ThreadId Tcl_GetChannelThread(Tcl_Channel channel); /* 434 */ EXTERN Tcl_UniChar * Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr); /* 435 */ | > | > | | 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 | EXTERN int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, int length); /* 433 */ EXTERN Tcl_ThreadId Tcl_GetChannelThread(Tcl_Channel channel); /* 434 */ EXTERN Tcl_UniChar * Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr); /* 435 */ TCL_DEPRECATED("") int Tcl_GetMathFuncInfo(Tcl_Interp *interp, const char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, ClientData *clientDataPtr); /* 436 */ 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 */ EXTERN int Tcl_DetachChannel(Tcl_Interp *interp, Tcl_Channel channel); |
︙ | ︙ | |||
1839 1840 1841 1842 1843 1844 1845 | } TclStubHooks; typedef struct TclStubs { int magic; const TclStubHooks *hooks; int (*tcl_PkgProvideEx) (Tcl_Interp *interp, const char *name, const char *version, const void *clientData); /* 0 */ | | | 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 | } TclStubHooks; typedef struct TclStubs { int magic; const TclStubHooks *hooks; int (*tcl_PkgProvideEx) (Tcl_Interp *interp, const char *name, const char *version, const void *clientData); /* 0 */ 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 */ void (*tcl_DbCkfree) (char *ptr, const char *file, int line); /* 7 */ char * (*tcl_DbCkrealloc) (char *ptr, unsigned int size, const char *file, int line); /* 8 */ |
︙ | ︙ | |||
1890 1891 1892 1893 1894 1895 1896 | Tcl_Obj * (*tcl_DuplicateObj) (Tcl_Obj *objPtr); /* 29 */ void (*tclFreeObj) (Tcl_Obj *objPtr); /* 30 */ 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 */ | | | 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 | Tcl_Obj * (*tcl_DuplicateObj) (Tcl_Obj *objPtr); /* 29 */ void (*tclFreeObj) (Tcl_Obj *objPtr); /* 30 */ 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, 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 */ void (*tcl_InvalidateStringRep) (Tcl_Obj *objPtr); /* 42 */ int (*tcl_ListObjAppendList) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *elemListPtr); /* 43 */ |
︙ | ︙ | |||
1931 1932 1933 1934 1935 1936 1937 | void (*tcl_AppendResult) (Tcl_Interp *interp, ...); /* 70 */ Tcl_AsyncHandler (*tcl_AsyncCreate) (Tcl_AsyncProc *proc, ClientData clientData); /* 71 */ 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 */ | | | | | | 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 | void (*tcl_AppendResult) (Tcl_Interp *interp, ...); /* 70 */ Tcl_AsyncHandler (*tcl_AsyncCreate) (Tcl_AsyncProc *proc, ClientData clientData); /* 71 */ 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 */ 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, 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, 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 */ 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 */ void (*tcl_DeleteChannelHandler) (Tcl_Channel chan, Tcl_ChannelProc *proc, ClientData clientData); /* 101 */ void (*tcl_DeleteCloseHandler) (Tcl_Channel chan, Tcl_CloseProc *proc, ClientData clientData); /* 102 */ |
︙ | ︙ | |||
1981 1982 1983 1984 1985 1986 1987 | void (*tcl_DStringFree) (Tcl_DString *dsPtr); /* 120 */ void (*tcl_DStringGetResult) (Tcl_Interp *interp, Tcl_DString *dsPtr); /* 121 */ 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 */ | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 1988 1989 1990 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 2025 2026 2027 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 | void (*tcl_DStringFree) (Tcl_DString *dsPtr); /* 120 */ void (*tcl_DStringGetResult) (Tcl_Interp *interp, Tcl_DString *dsPtr); /* 121 */ 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 */ 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 */ int (*tcl_ExposeCommand) (Tcl_Interp *interp, const char *hiddenCmdToken, const char *cmdName); /* 134 */ int (*tcl_ExprBoolean) (Tcl_Interp *interp, const char *expr, int *ptr); /* 135 */ int (*tcl_ExprBooleanObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *ptr); /* 136 */ int (*tcl_ExprDouble) (Tcl_Interp *interp, const char *expr, double *ptr); /* 137 */ int (*tcl_ExprDoubleObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, double *ptr); /* 138 */ int (*tcl_ExprLong) (Tcl_Interp *interp, const char *expr, long *ptr); /* 139 */ int (*tcl_ExprLongObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, long *ptr); /* 140 */ int (*tcl_ExprObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj **resultPtrPtr); /* 141 */ int (*tcl_ExprString) (Tcl_Interp *interp, const char *expr); /* 142 */ 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, 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 */ 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 */ const char * (*tcl_GetCommandName) (Tcl_Interp *interp, Tcl_Command command); /* 160 */ int (*tcl_GetErrno) (void); /* 161 */ 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 */ int (*tcl_GetOpenFile) (Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, ClientData *filePtr); /* 167 */ #endif /* UNIX */ #if defined(_WIN32) /* WIN */ void (*reserved167)(void); #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ int (*tcl_GetOpenFile) (Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, ClientData *filePtr); /* 167 */ #endif /* MACOSX */ Tcl_PathType (*tcl_GetPathType) (const char *path); /* 168 */ 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 */ 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, 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, 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, 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 */ 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 */ 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, 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 */ 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 */ int (*tcl_SetCommandInfo) (Tcl_Interp *interp, const char *cmdName, const Tcl_CmdInfo *infoPtr); /* 226 */ void (*tcl_SetErrno) (int err); /* 227 */ void (*tcl_SetErrorCode) (Tcl_Interp *interp, ...); /* 228 */ void (*tcl_SetMaxBlockTime) (const Tcl_Time *timePtr); /* 229 */ void (*tcl_SetPanicProc) (TCL_NORETURN1 Tcl_PanicProc *panicProc); /* 230 */ int (*tcl_SetRecursionLimit) (Tcl_Interp *interp, int depth); /* 231 */ 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 */ 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, const char ***argvPtr); /* 242 */ void (*tcl_SplitPath) (const char *path, int *argcPtr, const char ***argvPtr); /* 243 */ void (*tcl_StaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 244 */ int (*tcl_StringMatch) (const char *str, const char *pattern); /* 245 */ TCL_DEPRECATED_API("") int (*tcl_TellOld) (Tcl_Channel chan); /* 246 */ 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 */ int (*tcl_UnregisterChannel) (Tcl_Interp *interp, Tcl_Channel chan); /* 252 */ int (*tcl_UnsetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 253 */ int (*tcl_UnsetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 254 */ void (*tcl_UntraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 255 */ void (*tcl_UntraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 256 */ void (*tcl_UpdateLinkedVar) (Tcl_Interp *interp, const char *varName); /* 257 */ int (*tcl_UpVar) (Tcl_Interp *interp, const char *frameName, const char *varName, const char *localName, int flags); /* 258 */ int (*tcl_UpVar2) (Tcl_Interp *interp, const char *frameName, const char *part1, const char *part2, const char *localName, int flags); /* 259 */ int (*tcl_VarEval) (Tcl_Interp *interp, ...); /* 260 */ ClientData (*tcl_VarTraceInfo) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData); /* 261 */ 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 */ 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 */ 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 */ 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_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 */ void (*tcl_SetMainLoop) (Tcl_MainLoopProc *proc); /* 284 */ void (*reserved285)(void); |
︙ | ︙ | |||
2164 2165 2166 2167 2168 2169 2170 | int (*tcl_ExternalToUtf) (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); /* 295 */ char * (*tcl_ExternalToUtfDString) (Tcl_Encoding encoding, const char *src, int srcLen, Tcl_DString *dsPtr); /* 296 */ 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 */ | | | 2171 2172 2173 2174 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 | int (*tcl_ExternalToUtf) (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); /* 295 */ char * (*tcl_ExternalToUtfDString) (Tcl_Encoding encoding, const char *src, int srcLen, Tcl_DString *dsPtr); /* 296 */ 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 */ 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 */ void (*tcl_MutexLock) (Tcl_Mutex *mutexPtr); /* 308 */ void (*tcl_MutexUnlock) (Tcl_Mutex *mutexPtr); /* 309 */ |
︙ | ︙ | |||
2187 2188 2189 2190 2191 2192 2193 | void (*tcl_ThreadAlert) (Tcl_ThreadId threadId); /* 318 */ void (*tcl_ThreadQueueEvent) (Tcl_ThreadId threadId, Tcl_Event *evPtr, Tcl_QueuePosition position); /* 319 */ 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 */ | | | | | | | | | | | | 2194 2195 2196 2197 2198 2199 2200 2201 2202 2203 2204 2205 2206 2207 2208 2209 2210 2211 2212 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 2228 2229 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 2246 | void (*tcl_ThreadAlert) (Tcl_ThreadId threadId); /* 318 */ void (*tcl_ThreadQueueEvent) (Tcl_ThreadId threadId, Tcl_Event *evPtr, Tcl_QueuePosition position); /* 319 */ 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 */ 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 */ 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 */ 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 */ int (*tcl_UniCharIsLower) (int ch); /* 348 */ int (*tcl_UniCharIsSpace) (int ch); /* 349 */ int (*tcl_UniCharIsUpper) (int ch); /* 350 */ int (*tcl_UniCharIsWordChar) (int ch); /* 351 */ 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_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, 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, 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 */ int (*tcl_UtfNcmp) (const char *s1, const char *s2, unsigned long n); /* 369 */ int (*tcl_UtfNcasecmp) (const char *s1, const char *s2, unsigned long n); /* 370 */ |
︙ | ︙ | |||
2260 2261 2262 2263 2264 2265 2266 | void (*tcl_ConditionFinalize) (Tcl_Condition *condPtr); /* 391 */ void (*tcl_MutexFinalize) (Tcl_Mutex *mutex); /* 392 */ 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 */ | | | 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 | void (*tcl_ConditionFinalize) (Tcl_Condition *condPtr); /* 391 */ void (*tcl_MutexFinalize) (Tcl_Mutex *mutex); /* 392 */ 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 */ 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 */ Tcl_DriverOutputProc * (*tcl_ChannelOutputProc) (const Tcl_ChannelType *chanTypePtr); /* 404 */ Tcl_DriverSeekProc * (*tcl_ChannelSeekProc) (const Tcl_ChannelType *chanTypePtr); /* 405 */ |
︙ | ︙ | |||
2297 2298 2299 2300 2301 2302 2303 | char * (*tcl_AttemptAlloc) (unsigned int size); /* 428 */ char * (*tcl_AttemptDbCkalloc) (unsigned int size, const char *file, int line); /* 429 */ 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 */ | | | | 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 | char * (*tcl_AttemptAlloc) (unsigned int size); /* 428 */ char * (*tcl_AttemptDbCkalloc) (unsigned int size, const char *file, int line); /* 429 */ 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 */ 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 */ int (*tcl_FSCreateDirectory) (Tcl_Obj *pathPtr); /* 442 */ int (*tcl_FSDeleteFile) (Tcl_Obj *pathPtr); /* 443 */ |
︙ | ︙ | |||
3884 3885 3886 3887 3888 3889 3890 | Tcl_EvalEx(interp, objPtr, -1, 0) #undef Tcl_GlobalEval #define Tcl_GlobalEval(interp, objPtr) \ Tcl_EvalEx(interp, objPtr, -1, TCL_EVAL_GLOBAL) #undef Tcl_SaveResult #define Tcl_SaveResult(interp, statePtr) \ do { \ | | | | | | | 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 | Tcl_EvalEx(interp, objPtr, -1, 0) #undef Tcl_GlobalEval #define Tcl_GlobalEval(interp, objPtr) \ Tcl_EvalEx(interp, objPtr, -1, TCL_EVAL_GLOBAL) #undef Tcl_SaveResult #define Tcl_SaveResult(interp, statePtr) \ do { \ (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)->objResultPtr); \ Tcl_DecrRefCount((statePtr)->objResultPtr); \ } while(0) #undef Tcl_DiscardResult #define Tcl_DiscardResult(statePtr) \ Tcl_DecrRefCount((statePtr)->objResultPtr) #undef Tcl_SetResult #define Tcl_SetResult(interp, result, freeProc) \ do { \ char *__result = result; \ Tcl_FreeProc *__freeProc = freeProc; \ Tcl_SetObjResult(interp, Tcl_NewStringObj(__result, -1)); \ if (__result != NULL && __freeProc != NULL && __freeProc != TCL_VOLATILE) { \ |
︙ | ︙ | |||
3923 3924 3925 3926 3927 3928 3929 | /* 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 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. */ | < < < < < < | 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 3941 3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 | /* 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 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_GetLongFromObj # undef Tcl_ExprLong # undef Tcl_ExprLongObj # undef Tcl_UniCharNcmp # undef Tcl_UtfNcmp # undef Tcl_UtfNcasecmp # undef Tcl_UniCharNcasecmp # define Tcl_GetLongFromObj ((int(*)(Tcl_Interp*,Tcl_Obj*,long*))Tcl_GetWideIntFromObj) # 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; return result; } |
︙ | ︙ | |||
3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 | # define Tcl_UtfNcasecmp(s1,s2,n) \ ((int(*)(const char*,const char*,unsigned int))tclStubsPtr->tcl_UtfNcasecmp)(s1,s2,(unsigned int)(n)) # 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 /* * Deprecated Tcl procedures: */ #undef Tcl_EvalObj #define Tcl_EvalObj(interp, objPtr) \ Tcl_EvalObjEx(interp, objPtr, 0) #undef Tcl_GlobalEvalObj #define Tcl_GlobalEvalObj(interp, objPtr) \ Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL) #endif /* _TCLDECLS */ | > > > > > > > > > > > | 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 | # define Tcl_UtfNcasecmp(s1,s2,n) \ ((int(*)(const char*,const char*,unsigned int))tclStubsPtr->tcl_UtfNcasecmp)(s1,s2,(unsigned int)(n)) # 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 #define Tcl_EvalObj(interp, objPtr) \ Tcl_EvalObjEx(interp, objPtr, 0) #undef Tcl_GlobalEvalObj #define Tcl_GlobalEvalObj(interp, objPtr) \ Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL) #endif /* _TCLDECLS */ |
Changes to generic/tclDictObj.c.
︙ | ︙ | |||
483 484 485 486 487 488 489 | *---------------------------------------------------------------------- */ static void UpdateStringOfDict( Tcl_Obj *dictPtr) { | | | < | 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 | *---------------------------------------------------------------------- */ static void UpdateStringOfDict( Tcl_Obj *dictPtr) { #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; /* * This field is the most useful one in the whole hash structure, and it * is not exposed by any API function... */ int numElems = dict->table.numEntries * 2; |
︙ | ︙ | |||
513 514 515 516 517 518 519 | /* * Pass 1: estimate space, gather flags. */ if (numElems <= LOCAL_SIZE) { flagPtr = localFlags; | < < | | 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 | /* * Pass 1: estimate space, gather flags. */ if (numElems <= LOCAL_SIZE) { flagPtr = localFlags; } else { flagPtr = ckalloc(numElems); } for (i=0,cPtr=dict->entryChainHead; i<numElems; i+=2,cPtr=cPtr->nextPtr) { /* * Assume that cPtr is never NULL since we know the number of array * elements already. */ |
︙ | ︙ |
Changes to generic/tclDisassemble.c.
︙ | ︙ | |||
250 251 252 253 254 255 256 | unsigned char *codeDeltaNext, *codeLengthNext; unsigned char *srcDeltaNext, *srcLengthNext; int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i, line; Interp *iPtr = (Interp *) *codePtr->interpHandle; Tcl_Obj *bufferObj, *fileObj; TclNewObj(bufferObj); | | | 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 | unsigned char *codeDeltaNext, *codeLengthNext; unsigned char *srcDeltaNext, *srcLengthNext; int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i, line; Interp *iPtr = (Interp *) *codePtr->interpHandle; Tcl_Obj *bufferObj, *fileObj; TclNewObj(bufferObj); if (!codePtr->refCount) { return bufferObj; /* Already freed. */ } codeStart = codePtr->codeStart; codeLimit = codeStart + codePtr->numCodeBytes; numCmds = codePtr->numCommands; |
︙ | ︙ | |||
308 309 310 311 312 313 314 | */ if (codePtr->procPtr != NULL) { Proc *procPtr = codePtr->procPtr; int numCompiledLocals = procPtr->numCompiledLocals; Tcl_AppendPrintfToObj(bufferObj, | | | 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 | */ if (codePtr->procPtr != NULL) { Proc *procPtr = codePtr->procPtr; int numCompiledLocals = procPtr->numCompiledLocals; Tcl_AppendPrintfToObj(bufferObj, " Proc %p, refCt %u, args %d, compiled locals %d\n", procPtr, procPtr->refCount, procPtr->numArgs, numCompiledLocals); if (numCompiledLocals > 0) { CompiledLocal *localPtr = procPtr->firstLocalPtr; for (i = 0; i < numCompiledLocals; i++) { Tcl_AppendPrintfToObj(bufferObj, |
︙ | ︙ | |||
793 794 795 796 797 798 799 | Tcl_Obj * TclNewInstNameObj( unsigned char inst) { Tcl_Obj *objPtr = Tcl_NewObj(); objPtr->typePtr = &tclInstNameType; | | | | | 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 | Tcl_Obj * TclNewInstNameObj( unsigned char inst) { Tcl_Obj *objPtr = Tcl_NewObj(); objPtr->typePtr = &tclInstNameType; objPtr->internalRep.wideValue = (long) inst; objPtr->bytes = NULL; return objPtr; } /* *---------------------------------------------------------------------- * * UpdateStringOfInstName -- * * Update the string representation for an instruction name object. * *---------------------------------------------------------------------- */ static void UpdateStringOfInstName( Tcl_Obj *objPtr) { 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.wideValue].name; } len = strlen(s); objPtr->bytes = ckalloc(len + 1); memcpy(objPtr->bytes, s, len + 1); objPtr->length = len; } |
︙ | ︙ |
Changes to generic/tclEncoding.c.
︙ | ︙ | |||
14 15 16 17 18 19 20 | typedef size_t (LengthProc)(const char *src); /* * The following data structure represents an encoding, which describes how to * convert between various character sets and UTF-8. */ | | | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 | typedef size_t (LengthProc)(const char *src); /* * The following data structure represents an encoding, which describes how to * convert between various character sets and UTF-8. */ 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. */ Tcl_EncodingConvertProc *toUtfProc; /* Function to convert from external encoding |
︙ | ︙ | |||
53 54 55 56 57 58 59 | /* * The following structure is the clientData for a dynamically-loaded, * table-driven encoding created by LoadTableEncoding(). It maps between * Unicode and a single-byte, double-byte, or multibyte (1 or 2 bytes only) * encoding. */ | | | 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 | /* * The following structure is the clientData for a dynamically-loaded, * 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 { 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 * corresponding entry in this array is 1, * otherwise it is 0. */ |
︙ | ︙ | |||
87 88 89 90 91 92 93 | * escape-driven encoding that is itself comprised of other simpler encodings. * An example is "iso-2022-jp", which uses escape sequences to switch between * 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. */ | | | | 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 | * escape-driven encoding that is itself comprised of other simpler encodings. * An example is "iso-2022-jp", which uses escape sequences to switch between * 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 { 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 { 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 * in conversion. */ unsigned finalLen; /* Length of following string. */ |
︙ | ︙ | |||
689 690 691 692 693 694 695 696 697 698 699 700 701 702 | * * Side effects: * None. * *------------------------------------------------------------------------- */ const char * Tcl_GetDefaultEncodingDir(void) { int numDirs; Tcl_Obj *first, *searchPath = Tcl_GetEncodingSearchPath(); Tcl_ListObjLength(NULL, searchPath, &numDirs); | > | 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 | * * Side effects: * None. * *------------------------------------------------------------------------- */ #if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 const char * Tcl_GetDefaultEncodingDir(void) { int numDirs; Tcl_Obj *first, *searchPath = Tcl_GetEncodingSearchPath(); Tcl_ListObjLength(NULL, searchPath, &numDirs); |
︙ | ︙ | |||
732 733 734 735 736 737 738 739 740 741 742 743 744 745 | Tcl_Obj *searchPath = Tcl_GetEncodingSearchPath(); Tcl_Obj *directory = Tcl_NewStringObj(path, -1); searchPath = Tcl_DuplicateObj(searchPath); Tcl_ListObjReplace(NULL, searchPath, 0, 0, 1, &directory); Tcl_SetEncodingSearchPath(searchPath); } /* *------------------------------------------------------------------------- * * Tcl_GetEncoding -- * * Given the name of a encoding, find the corresponding Tcl_Encoding | > | 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 | Tcl_Obj *searchPath = Tcl_GetEncodingSearchPath(); Tcl_Obj *directory = Tcl_NewStringObj(path, -1); searchPath = Tcl_DuplicateObj(searchPath); Tcl_ListObjReplace(NULL, searchPath, 0, 0, 1, &directory); Tcl_SetEncodingSearchPath(searchPath); } #endif /* *------------------------------------------------------------------------- * * Tcl_GetEncoding -- * * Given the name of a encoding, find the corresponding Tcl_Encoding |
︙ | ︙ | |||
3605 3606 3607 3608 3609 3610 3611 | * *------------------------------------------------------------------------- */ static void InitializeEncodingSearchPath( char **valuePtr, | | | 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 | * *------------------------------------------------------------------------- */ static void InitializeEncodingSearchPath( char **valuePtr, unsigned int *lengthPtr, Tcl_Encoding *encodingPtr) { const char *bytes; int i, numDirs; Tcl_Obj *libPathObj, *encodingObj, *searchPathObj; TclNewLiteralStringObj(encodingObj, "encoding"); |
︙ | ︙ |
Changes to generic/tclEnsemble.c.
︙ | ︙ | |||
88 89 90 91 92 93 94 | /* * The internal rep for caching ensemble subcommand lookups and * spell corrections. */ typedef struct { | | | 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 | /* * The internal rep for caching ensemble subcommand lookups and * spell corrections. */ typedef struct { 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. */ Tcl_HashEntry *hPtr; /* Direct link to entry in the subcommand * hash table. */ |
︙ | ︙ | |||
142 143 144 145 146 147 148 | TclNamespaceEnsembleCmd( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Tcl_Namespace *namespacePtr; | | > > | 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 | TclNamespaceEnsembleCmd( ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Tcl_Namespace *namespacePtr; 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( "tried to manipulate ensemble of deleted namespace", -1)); |
︙ | ︙ | |||
191 192 193 194 195 196 197 | if (objc & 1) { Tcl_WrongNumArgs(interp, 2, objv, "?option value ...?"); return TCL_ERROR; } objv += 2; objc -= 2; | < < < < < < | > > | 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 | if (objc & 1) { Tcl_WrongNumArgs(interp, 2, objv, "?option value ...?"); return TCL_ERROR; } objv += 2; objc -= 2; 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 * memory leaks. */ for (; objc>1 ; objc-=2,objv+=2) { if (Tcl_GetIndexFromObj(interp, objv[0], ensembleCreateOptions, "option", 0, &index) != TCL_OK) { if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); } 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); } return TCL_ERROR; |
︙ | ︙ | |||
333 334 335 336 337 338 339 340 341 342 343 344 345 346 | return TCL_ERROR; } unknownObj = (len > 0 ? objv[1] : NULL); continue; } } /* * 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.) */ | > > > > | > | | 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 | return TCL_ERROR; } 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 = 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); /* * Tricky! Must ensure that the result is not shared (command delete |
︙ | ︙ | |||
632 633 634 635 636 637 638 | } return TCL_OK; } /* *---------------------------------------------------------------------- * | | | < < | < < < | > | > > > | > | > | | < | < < | | < < < < | < | > | < | | < < < | < < > | > | | > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > | > > > > > > > > > > | 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 | } return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCreateEnsembleInNs -- * * Like Tcl_CreateEnsemble, but additionally accepts as an argument the * name of the namespace to create the command in. * *---------------------------------------------------------------------- */ Tcl_Command TclCreateEnsembleInNs( Tcl_Interp *interp, const char *name, /* Simple name of command to create (no */ /* namespace components). */ Tcl_Namespace /* Name of namespace to create the command in. */ *nameNsPtr, Tcl_Namespace *ensembleNsPtr, /* Name of the namespace for the ensemble. */ int flags ) { Namespace *nsPtr = (Namespace *) ensembleNsPtr; EnsembleConfig *ensemblePtr; Tcl_Command token; ensemblePtr = ckalloc(sizeof(EnsembleConfig)); token = TclNRCreateCommandInNs(interp, name, (Tcl_Namespace *) nameNsPtr, NsEnsembleImplementationCmd, NsEnsembleImplementationCmdNR, ensemblePtr, DeleteEnsembleConfig); if (token == NULL) { ckfree(ensemblePtr); return NULL; } ensemblePtr->nsPtr = nsPtr; ensemblePtr->epoch = 0; Tcl_InitHashTable(&ensemblePtr->subcommandTable, TCL_STRING_KEYS); ensemblePtr->subcommandArrayPtr = NULL; ensemblePtr->subcmdList = NULL; ensemblePtr->subcommandDict = NULL; ensemblePtr->flags = flags; ensemblePtr->numParameters = 0; ensemblePtr->parameterList = NULL; ensemblePtr->unknownHandler = NULL; ensemblePtr->token = token; ensemblePtr->next = (EnsembleConfig *) nsPtr->ensembles; nsPtr->ensembles = (Tcl_Ensemble *) ensemblePtr; /* * Trigger an eventual recomputation of the ensemble command set. Note * that this is slightly tricky, as it means that we are not actually * counting the number of namespace export actions, but it is the simplest * way to go! */ nsPtr->exportLookupEpoch++; if (flags & ENSEMBLE_COMPILE) { ((Command *) ensemblePtr->token)->compileProc = TclCompileEnsemble; } 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 -- * * Set the subcommand list for a particular ensemble. |
︙ | ︙ | |||
1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 | /* * Hand off to the target command. */ TclSkipTailcall(interp); Tcl_ListObjGetElements(NULL, copyPtr, ©Objc, ©Objv); return TclNREvalObjv(interp, copyObjc, copyObjv, TCL_EVAL_INVOKE, NULL); } unknownOrAmbiguousSubcommand: /* * Have not been able to match the subcommand asked for with a real * subcommand that we export. See whether a handler has been registered | > | 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 | /* * 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: /* * Have not been able to match the subcommand asked for with a real * subcommand that we export. See whether a handler has been registered |
︙ | ︙ | |||
2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 | * None. * * Side effects: * Memory is (eventually) deallocated. * *---------------------------------------------------------------------- */ static void DeleteEnsembleConfig( ClientData clientData) { EnsembleConfig *ensemblePtr = clientData; Namespace *nsPtr = ensemblePtr->nsPtr; | > > > > > > > > > > > > > > > > > > > > < < | 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 | * None. * * 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; /* * Unlink from the ensemble chain if it has not been marked as having been * done already. */ if (ensemblePtr->next != ensemblePtr) { |
︙ | ︙ | |||
2435 2436 2437 2438 2439 2440 2441 | ensemblePtr->flags |= ENSEMBLE_DEAD; /* * Kill the pointer-containing fields. */ | < | < < < < < < < < < | 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 | ensemblePtr->flags |= ENSEMBLE_DEAD; /* * Kill the pointer-containing fields. */ ClearTable(ensemblePtr); if (ensemblePtr->subcmdList != NULL) { Tcl_DecrRefCount(ensemblePtr->subcmdList); } if (ensemblePtr->parameterList != NULL) { Tcl_DecrRefCount(ensemblePtr->parameterList); } if (ensemblePtr->subcommandDict != NULL) { |
︙ | ︙ | |||
2501 2502 2503 2504 2505 2506 2507 2508 | { Tcl_HashSearch search; /* Used for scanning the set of commands in * the namespace that backs up this * ensemble. */ int i, j, isNew; Tcl_HashTable *hash = &ensemblePtr->subcommandTable; Tcl_HashEntry *hPtr; | > > > > | > > > > > | > > > | > > > > > | | > | | | < | < | | | | > > > > > > > | < < < < < | < < | > < < | | < | < < < < < | | | < | < | < | < | | | | | | | > | | | | | < < < < < < | | | | > | | | | | | | | | | | | | | | | | | | 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 | { Tcl_HashSearch search; /* Used for scanning the set of commands in * the namespace that backs up this * ensemble. */ int i, j, isNew; Tcl_HashTable *hash = &ensemblePtr->subcommandTable; Tcl_HashEntry *hPtr; 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 * not matter here.) We must find out what commands are actually * exported by filtering each command in the namespace against each of |
︙ | ︙ | |||
2630 2631 2632 2633 2634 2635 2636 | * substituted part of the command (as a list) as their * content! */ if (isNew) { Tcl_Obj *cmdObj, *cmdPrefixObj; | < < < < | | 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 | * substituted part of the command (as a list) as their * content! */ if (isNew) { Tcl_Obj *cmdObj, *cmdPrefixObj; cmdObj = Tcl_NewStringObj(nsCmdName, -1); cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); Tcl_SetHashValue(hPtr, cmdPrefixObj); Tcl_IncrRefCount(cmdPrefixObj); } break; } } |
︙ | ︙ |
Changes to generic/tclEvent.c.
︙ | ︙ | |||
1053 1054 1055 1056 1057 1058 1059 | TclpInitPlatform(); /* Creates signal handler(s) */ TclInitDoubleConversion(); /* Initializes constants for * converting to/from double. */ TclInitObjSubsystem(); /* Register obj types, create * mutexes. */ TclInitIOSubsystem(); /* Inits a tsd key (noop). */ TclInitEncodingSubsystem(); /* Process wide encoding init. */ | < | 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 | TclpInitPlatform(); /* Creates signal handler(s) */ TclInitDoubleConversion(); /* Initializes constants for * converting to/from double. */ TclInitObjSubsystem(); /* Register obj types, create * mutexes. */ TclInitIOSubsystem(); /* Inits a tsd key (noop). */ TclInitEncodingSubsystem(); /* Process wide encoding init. */ TclInitNamespaceSubsystem();/* Register ns obj type (mutexed). */ subsystemsInitialized = 1; } TclpInitUnlock(); } TclInitNotifier(); } |
︙ | ︙ |
Changes to generic/tclExecute.c.
︙ | ︙ | |||
321 322 323 324 325 326 327 | NEXT_INST_F(((condition)? TclGetInt1AtPtr(pc+1) : 2), (cleanup), 0); \ case INST_JUMP_FALSE4: \ 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) { \ | | | | | | 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 | NEXT_INST_F(((condition)? TclGetInt1AtPtr(pc+1) : 2), (cleanup), 0); \ case INST_JUMP_FALSE4: \ 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) { \ TclNewIntObj(objResultPtr, -1); \ } else { \ objResultPtr = TCONST((condition) > 0); \ } \ NEXT_INST_F(0, (cleanup), 1); \ } \ } while (0) #define JUMP_PEEPHOLE_V(condition, pcAdjustment, cleanup) \ do { \ pc += (pcAdjustment); \ switch (*pc) { \ case INST_JUMP_FALSE1: \ NEXT_INST_V(((condition)? 2 : TclGetInt1AtPtr(pc+1)), (cleanup), 0); \ case INST_JUMP_TRUE1: \ NEXT_INST_V(((condition)? TclGetInt1AtPtr(pc+1) : 2), (cleanup), 0); \ case INST_JUMP_FALSE4: \ 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) { \ TclNewIntObj(objResultPtr, -1); \ } else { \ objResultPtr = TCONST((condition) > 0); \ } \ NEXT_INST_V(0, (cleanup), 1); \ } \ } while (0) #else /* TCL_COMPILE_DEBUG */ #define JUMP_PEEPHOLE_F(condition, pcAdjustment, cleanup) \ do{ \ if ((condition) < 0) { \ 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) { \ TclNewIntObj(objResultPtr, -1); \ } else { \ objResultPtr = TCONST((condition) > 0); \ } \ NEXT_INST_V((pcAdjustment), (cleanup), 1); \ } while (0) #endif |
︙ | ︙ | |||
494 495 496 497 498 499 500 | * Macro used in this file to save a function call for common uses of * TclGetNumberFromObj(). The ANSI C "prototype" is: * * MODULE_SCOPE int GetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, * ClientData *ptrPtr, int *tPtr); */ | < < < < < < < < < < < < < < < < < < < < < | > | | 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 | * Macro used in this file to save a function call for common uses of * TclGetNumberFromObj(). The ANSI C "prototype" is: * * MODULE_SCOPE int GetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, * ClientData *ptrPtr, int *tPtr); */ #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)) \ ? (*(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))) /* * Macro used in this file to save a function call for common uses of * Tcl_GetBooleanFromObj(). The ANSI C "prototype" is: * * MODULE_SCOPE int TclGetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, * int *boolPtr); */ #define TclGetBooleanFromObj(interp, objPtr, boolPtr) \ (((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 * comparing sign bits; the rest of the word is irrelevant. The ANSI C * "prototype" (where inttype_t is any integer type) is: |
︙ | ︙ | |||
572 573 574 575 576 577 578 | #define IsErroringNaNType(type) 0 #endif /* * Auxiliary tables used to compute powers of small integers. */ | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 552 553 554 555 556 557 558 559 560 561 562 563 564 565 | #define IsErroringNaNType(type) 0 #endif /* * Auxiliary tables used to compute powers of small integers. */ /* * Maximum base that, when raised to powers 2, 3, ..., 16, fits in a * Tcl_WideInt. */ static const Tcl_WideInt MaxBase64[] = { (Tcl_WideInt)46340*65536+62259, /* 3037000499 == isqrt(2**63-1) */ |
︙ | ︙ | |||
709 710 711 712 713 714 715 | (Tcl_WideInt)100000*100000*100000*10*10*10, (Tcl_WideInt)161051*161051*161051*11*11, (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); | < | 655 656 657 658 659 660 661 662 663 664 665 666 667 668 | (Tcl_WideInt)100000*100000*100000*10*10*10, (Tcl_WideInt)161051*161051*161051*11*11, (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); /* * Markers for ExecuteExtendedBinaryMathOp. */ #define DIVIDED_BY_ZERO ((Tcl_Obj *) -1) #define EXPONENT_OF_ZERO ((Tcl_Obj *) -2) |
︙ | ︙ | |||
740 741 742 743 744 745 746 | const unsigned char *pc, int stackTop, int checkStack); #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); | < < | 685 686 687 688 689 690 691 692 693 694 695 696 697 698 | const unsigned char *pc, int stackTop, int checkStack); #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); 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); static void FreeExprCodeInternalRep(Tcl_Obj *objPtr); static ExceptionRange * GetExceptRangeForPc(const unsigned char *pc, |
︙ | ︙ | |||
904 905 906 907 908 909 910 | * [sizeof(Tcl_Obj*)] */ { ExecEnv *eePtr = ckalloc(sizeof(ExecEnv)); ExecStack *esPtr = ckalloc(sizeof(ExecStack) + (size_t) (size-1) * sizeof(Tcl_Obj *)); eePtr->execStackPtr = esPtr; | | | | 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 | * [sizeof(Tcl_Obj*)] */ { ExecEnv *eePtr = ckalloc(sizeof(ExecEnv)); ExecStack *esPtr = ckalloc(sizeof(ExecStack) + (size_t) (size-1) * sizeof(Tcl_Obj *)); eePtr->execStackPtr = esPtr; TclNewIntObj(eePtr->constants[0], 0); Tcl_IncrRefCount(eePtr->constants[0]); TclNewIntObj(eePtr->constants[1], 1); Tcl_IncrRefCount(eePtr->constants[1]); eePtr->interp = interp; eePtr->callbackPtr = NULL; eePtr->corPtr = NULL; eePtr->rewind = 0; esPtr->prevPtr = NULL; |
︙ | ︙ | |||
1873 1874 1875 1876 1877 1878 1879 | */ TclGetIntFromObj(interp, incrPtr, &type1); Tcl_AddErrorInfo(interp, "\n (reading increment)"); return TCL_ERROR; } | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < | 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 | */ TclGetIntFromObj(interp, incrPtr, &type1); Tcl_AddErrorInfo(interp, "\n (reading increment)"); return TCL_ERROR; } if ((type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN)) { /* * Produce error message (reparse?!) */ return TclGetIntFromObj(interp, valuePtr, &type1); } if ((type2 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_NAN)) { /* * Produce error message (reparse?!) */ TclGetIntFromObj(interp, incrPtr, &type1); Tcl_AddErrorInfo(interp, "\n (reading increment)"); return TCL_ERROR; } if ((type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) { Tcl_WideInt w1, w2, sum; TclGetWideIntFromObj(NULL, valuePtr, &w1); TclGetWideIntFromObj(NULL, incrPtr, &w2); sum = w1 + w2; /* * Check for overflow. */ if (!Overflowing(w1, w2, sum)) { TclSetIntObj(valuePtr, sum); return TCL_OK; } } Tcl_TakeBignumFromObj(interp, valuePtr, &value); Tcl_GetBignumFromObj(interp, incrPtr, &incr); mp_add(&value, &incr, &value); mp_clear(&incr); Tcl_SetBignumObj(valuePtr, &value); return TCL_OK; |
︙ | ︙ | |||
3622 3623 3624 3625 3626 3627 3628 | * common execution code. */ /*TODO: Consider more untangling here; merge with LOAD and STORE ? */ { Tcl_Obj *incrPtr; | < < | 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 | * common execution code. */ /*TODO: Consider more untangling here; merge with LOAD and STORE ? */ { Tcl_Obj *incrPtr; Tcl_WideInt w; long increment; case INST_INCR_SCALAR1: case INST_INCR_ARRAY1: case INST_INCR_ARRAY_STK: case INST_INCR_SCALAR_STK: case INST_INCR_STK: |
︙ | ︙ | |||
3723 3724 3725 3726 3727 3728 3729 | if (TclIsVarDirectModifyable(varPtr)) { ClientData ptr; int type; objPtr = varPtr->value.objPtr; if (GetNumberFromObj(NULL, objPtr, &ptr, &type) == TCL_OK) { | | | | | | < | < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 3653 3654 3655 3656 3657 3658 3659 3660 3661 3662 3663 3664 3665 3666 3667 3668 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 3690 3691 3692 3693 3694 3695 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 | if (TclIsVarDirectModifyable(varPtr)) { ClientData ptr; int type; objPtr = varPtr->value.objPtr; if (GetNumberFromObj(NULL, objPtr, &ptr, &type) == TCL_OK) { 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. */ if (!Overflowing(augend, increment, sum)) { TRACE(("%u %ld => ", opnd, increment)); if (Tcl_IsShared(objPtr)) { objPtr->refCount--; /* We know it's shared. */ TclNewIntObj(objResultPtr, sum); Tcl_IncrRefCount(objResultPtr); varPtr->value.objPtr = objResultPtr; } else { objResultPtr = objPtr; TclSetIntObj(objPtr, sum); } goto doneIncr; } w = (Tcl_WideInt)augend; TRACE(("%u %ld => ", opnd, increment)); if (Tcl_IsShared(objPtr)) { objPtr->refCount--; /* We know it's shared. */ objResultPtr = Tcl_NewWideIntObj(w+increment); Tcl_IncrRefCount(objResultPtr); varPtr->value.objPtr = objResultPtr; } else { objResultPtr = objPtr; /* * We know the sum value is outside the long range; * use macro form that doesn't range test again. */ 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; } TclNewIntObj(incrPtr, increment); if (TclIncrObj(interp, objResultPtr, incrPtr) != TCL_OK) { Tcl_DecrRefCount(incrPtr); TRACE_ERROR(interp); goto gotError; } Tcl_DecrRefCount(incrPtr); goto doneIncr; } /* * All other cases, flow through to generic handling. */ TclNewIntObj(incrPtr, increment); Tcl_IncrRefCount(incrPtr); doIncrScalar: varPtr = LOCAL(opnd); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } |
︙ | ︙ | |||
4522 4523 4524 4525 4526 4527 4528 | Tcl_GetCommandFullName(interp, (Tcl_Command) corPtr->cmdPtr, objResultPtr); } TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); } case INST_INFO_LEVEL_NUM: | | | 4395 4396 4397 4398 4399 4400 4401 4402 4403 4404 4405 4406 4407 4408 4409 | Tcl_GetCommandFullName(interp, (Tcl_Command) corPtr->cmdPtr, objResultPtr); } TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); } case INST_INFO_LEVEL_NUM: 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; register CallFrame *rootFramePtr = iPtr->rootFramePtr; |
︙ | ︙ | |||
4891 4892 4893 4894 4895 4896 4897 | case INST_LIST_LENGTH: TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS))); if (TclListObjLength(interp, OBJ_AT_TOS, &length) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } | | | 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 | case INST_LIST_LENGTH: TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS))); if (TclListObjLength(interp, OBJ_AT_TOS, &length) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } 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; valuePtr = OBJ_UNDER_TOS; TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr))); |
︙ | ︙ | |||
5362 5363 5364 5365 5366 5367 5368 | TRACE(("\"%.20s\" \"%.20s\" => %d\n", O2S(valuePtr), O2S(value2Ptr), (match < 0 ? -1 : match > 0 ? 1 : 0))); JUMP_PEEPHOLE_F(match, 1, 2); case INST_STR_LEN: valuePtr = OBJ_AT_TOS; length = Tcl_GetCharLength(valuePtr); | | | 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 | TRACE(("\"%.20s\" \"%.20s\" => %d\n", O2S(valuePtr), O2S(value2Ptr), (match < 0 ? -1 : match > 0 ? 1 : 0))); JUMP_PEEPHOLE_F(match, 1, 2); case INST_STR_LEN: valuePtr = OBJ_AT_TOS; length = Tcl_GetCharLength(valuePtr); TclNewIntObj(objResultPtr, length); TRACE(("\"%.20s\" => %d\n", O2S(valuePtr), length)); NEXT_INST_F(1, 1, 1); case INST_STR_UPPER: valuePtr = OBJ_AT_TOS; TRACE(("\"%.20s\" => ", O2S(valuePtr))); if (Tcl_IsShared(valuePtr)) { |
︙ | ︙ | |||
5717 5718 5719 5720 5721 5722 5723 | NEXT_INST_V(1, 3, 1); 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)); | | | | 5590 5591 5592 5593 5594 5595 5596 5597 5598 5599 5600 5601 5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 | NEXT_INST_V(1, 3, 1); 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)); 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)); TclNewIntObj(objResultPtr, match); NEXT_INST_F(1, 2, 1); case INST_STR_CLASS: opnd = TclGetInt1AtPtr(pc+1); valuePtr = OBJ_AT_TOS; TRACE(("%s \"%.30s\" => ", tclStringClassTable[opnd].name, O2S(valuePtr))); |
︙ | ︙ | |||
5898 5899 5900 5901 5902 5903 5904 | * ----------------------------------------------------------------- * Start of numeric operator instructions. */ { ClientData ptr1, ptr2; int type1, type2; | | | | < < < < < < < < > < | | 5771 5772 5773 5774 5775 5776 5777 5778 5779 5780 5781 5782 5783 5784 5785 5786 5787 5788 5789 5790 5791 5792 5793 5794 5795 5796 5797 5798 5799 5800 5801 5802 5803 5804 5805 5806 5807 5808 | * ----------------------------------------------------------------- * Start of numeric operator instructions. */ { ClientData ptr1, ptr2; int type1, type2; 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_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_LONG; } } 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; } } TclNewIntObj(objResultPtr, type1); TRACE(("\"%.20s\" => %d\n", O2S(OBJ_AT_TOS), type1)); NEXT_INST_F(1, 1, 1); case INST_EQ: case INST_NEQ: case INST_LT: case INST_GT: |
︙ | ︙ | |||
5964 5965 5966 5967 5968 5969 5970 | iResult = (*pc == INST_NEQ); goto foundResult; } if (valuePtr == value2Ptr) { compare = MP_EQ; goto convertComparison; } | | | | | | 5829 5830 5831 5832 5833 5834 5835 5836 5837 5838 5839 5840 5841 5842 5843 5844 5845 5846 | iResult = (*pc == INST_NEQ); goto foundResult; } if (valuePtr == value2Ptr) { compare = MP_EQ; goto convertComparison; } 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); } /* * Turn comparison outcome into appropriate result for opcode. */ |
︙ | ︙ | |||
6043 6044 6045 6046 6047 6048 6049 | goto gotError; } /* * Check for common, simple case. */ | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < < < < < < < < | 5908 5909 5910 5911 5912 5913 5914 5915 5916 5917 5918 5919 5920 5921 5922 5923 5924 5925 5926 5927 5928 5929 5930 5931 5932 5933 5934 5935 5936 5937 5938 5939 5940 5941 5942 5943 5944 5945 5946 5947 5948 5949 5950 5951 5952 5953 5954 5955 5956 5957 5958 5959 5960 5961 5962 5963 5964 5965 5966 5967 5968 5969 5970 5971 5972 5973 5974 5975 5976 5977 5978 5979 5980 5981 5982 5983 5984 5985 5986 5987 5988 5989 5990 5991 5992 5993 5994 5995 5996 5997 5998 5999 6000 6001 6002 6003 6004 6005 6006 6007 6008 6009 6010 6011 6012 6013 6014 6015 6016 6017 6018 6019 6020 6021 6022 6023 6024 6025 6026 6027 6028 6029 6030 6031 6032 6033 6034 6035 6036 6037 6038 6039 6040 6041 6042 6043 6044 6045 6046 6047 6048 6049 6050 6051 6052 6053 6054 6055 6056 6057 6058 6059 6060 6061 6062 6063 6064 6065 6066 6067 6068 6069 6070 6071 6072 6073 6074 6075 6076 6077 6078 6079 | goto gotError; } /* * Check for common, simple case. */ 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 (w2 == 0) { TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr), O2S(value2Ptr))); goto divideByZero; } 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 (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 { wResult = w1 / w2; /* * Force Tcl's integer division rules. * TODO: examine for logic simplification */ if ((wResult < 0 || (wResult == 0 && ((w1 < 0 && w2 > 0) || (w1 > 0 && w2 < 0)))) && (wResult * w2 != w1)) { wResult -= 1; } wResult = w1 - w2*wResult; goto wideResultOfArithmetic; } case INST_RSHIFT: 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", "domain error: argument not in valid range", NULL); CACHE_STACK_INFO(); #endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ goto gotError; } 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 (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 (w1 > 0L) { objResultPtr = TCONST(0); } else { TclNewIntObj(objResultPtr, -1); } TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } /* * Handle shifts within the native long range. */ wResult = w1 >> ((int) w2); goto wideResultOfArithmetic; } case INST_LSHIFT: 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", "domain error: argument not in valid range", NULL); CACHE_STACK_INFO(); #endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ goto gotError; } 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 (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. */ Tcl_SetObjResult(interp, Tcl_NewStringObj( "integer value too large to represent", -1)); #ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR DECACHE_STACK_INFO(); Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", "integer value too large to represent", NULL); CACHE_STACK_INFO(); #endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ goto gotError; } else { int shift = (int) w2; /* * Handle shifts within the native long range. */ if ((size_t) shift < CHAR_BIT*sizeof(long) && (w1 != 0) && !((w1>0 ? w1 : ~w1) & -(1L<<(CHAR_BIT*sizeof(long) - 1 - shift)))) { wResult = w1 << shift; goto wideResultOfArithmetic; } } /* * Too large; need to use the broken-out function. */ TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); break; case INST_BITAND: wResult = w1 & w2; goto wideResultOfArithmetic; case INST_BITOR: wResult = w1 | w2; goto wideResultOfArithmetic; case INST_BITXOR: wResult = w1 ^ w2; goto wideResultOfArithmetic; } } /* * DO NOT MERGE THIS WITH THE EQUIVALENT SECTION LATER! That would * encourage the compiler to inline ExecuteExtendedBinaryMathOp, which * is highly undesirable due to the overall impact on size. |
︙ | ︙ | |||
6292 6293 6294 6295 6296 6297 6298 | #endif /* * Handle (long,long) arithmetic as best we can without going out to * an external function. */ | | < < | | < < < < < < < < | | | | | | | | | | | | | | | | | 6148 6149 6150 6151 6152 6153 6154 6155 6156 6157 6158 6159 6160 6161 6162 6163 6164 6165 6166 6167 6168 6169 6170 6171 6172 6173 6174 6175 6176 6177 6178 6179 6180 6181 6182 6183 6184 6185 6186 6187 6188 6189 6190 6191 6192 6193 6194 6195 6196 6197 6198 6199 6200 6201 6202 6203 6204 6205 6206 6207 6208 6209 6210 6211 6212 6213 6214 6215 6216 6217 6218 6219 6220 6221 6222 6223 6224 6225 6226 6227 6228 6229 6230 6231 6232 6233 6234 6235 6236 6237 6238 | #endif /* * Handle (long,long) arithmetic as best we can without going out to * an external function. */ if ((type1 == TCL_NUMBER_WIDE) && (type2 == TCL_NUMBER_WIDE)) { w1 = *((const Tcl_WideInt *)ptr1); w2 = *((const Tcl_WideInt *)ptr2); switch (*pc) { case INST_ADD: wResult = w1 + w2; /* * Check for overflow. */ if (Overflowing(w1, w2, wResult)) { goto overflow; } goto wideResultOfArithmetic; case INST_SUB: wResult = w1 - w2; /* * 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 * so it does the job. Note that the only "bad" case (w2==0) * is irrelevant for this macro, as in that case w1 and * wResult have the same sign and there is no overflow anyway. */ if (Overflowing(w1, ~w2, wResult)) { goto overflow; } 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); } TclSetIntObj(valuePtr, wResult); TRACE(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 1, 0); case INST_DIV: if (w2 == 0) { TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr), O2S(value2Ptr))); goto divideByZero; } else if ((w1 == LLONG_MIN) && (w2 == -1)) { /* * Can't represent (-LLONG_MIN) as a long. */ goto overflow; } wResult = w1 / w2; /* * Force Tcl's integer division rules. * TODO: examine for logic simplification */ if (((wResult < 0) || ((wResult == 0) && ((w1 < 0 && w2 > 0) || (w1 > 0 && w2 < 0)))) && ((wResult * w2) != w1)) { wResult -= 1; } goto wideResultOfArithmetic; case INST_MULT: if (((sizeof(long) >= 2*sizeof(int)) && (w1 <= INT_MAX) && (w1 >= INT_MIN) && (w2 <= INT_MAX) && (w2 >= INT_MIN)) || ((sizeof(long) >= 2*sizeof(short)) && (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. */ } |
︙ | ︙ | |||
6445 6446 6447 6448 6449 6450 6451 | TRACE_APPEND(("ERROR: illegal type %s\n", (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); CACHE_STACK_INFO(); goto gotError; } | | | | | | 6291 6292 6293 6294 6295 6296 6297 6298 6299 6300 6301 6302 6303 6304 6305 6306 6307 6308 6309 6310 6311 6312 | TRACE_APPEND(("ERROR: illegal type %s\n", (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); DECACHE_STACK_INFO(); IllegalExprOperandType(interp, pc, valuePtr); CACHE_STACK_INFO(); goto gotError; } if (type1 == TCL_NUMBER_WIDE) { w1 = *((const Tcl_WideInt *) ptr1); if (Tcl_IsShared(valuePtr)) { TclNewIntObj(objResultPtr, ~w1); TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } TclSetIntObj(valuePtr, ~w1); TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } objResultPtr = ExecuteExtendedUnaryMathOp(*pc, valuePtr); if (objResultPtr != NULL) { TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); |
︙ | ︙ | |||
6482 6483 6484 6485 6486 6487 6488 | goto gotError; } switch (type1) { case TCL_NUMBER_NAN: /* -NaN => NaN */ TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); | | | | | | | 6328 6329 6330 6331 6332 6333 6334 6335 6336 6337 6338 6339 6340 6341 6342 6343 6344 6345 6346 6347 6348 6349 6350 | goto gotError; } switch (type1) { case TCL_NUMBER_NAN: /* -NaN => NaN */ TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); case TCL_NUMBER_WIDE: w1 = *((const Tcl_WideInt *) ptr1); if (w1 != LLONG_MIN) { if (Tcl_IsShared(valuePtr)) { TclNewIntObj(objResultPtr, -w1); TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } TclSetIntObj(valuePtr, -w1); TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } /* FALLTHROUGH */ } objResultPtr = ExecuteExtendedUnaryMathOp(*pc, valuePtr); if (objResultPtr != NULL) { |
︙ | ︙ | |||
6651 6652 6653 6654 6655 6656 6657 | opnd = TclGetUInt4AtPtr(pc+1); infoPtr = codePtr->auxDataArrayPtr[opnd].clientData; iterTmpIndex = infoPtr->loopCtTemp; iterVarPtr = LOCAL(iterTmpIndex); oldValuePtr = iterVarPtr->value.objPtr; if (oldValuePtr == NULL) { | | | | 6497 6498 6499 6500 6501 6502 6503 6504 6505 6506 6507 6508 6509 6510 6511 6512 6513 6514 | opnd = TclGetUInt4AtPtr(pc+1); infoPtr = codePtr->auxDataArrayPtr[opnd].clientData; iterTmpIndex = infoPtr->loopCtTemp; iterVarPtr = LOCAL(iterTmpIndex); oldValuePtr = iterVarPtr->value.objPtr; if (oldValuePtr == NULL) { TclNewIntObj(iterVarPtr->value.objPtr, -1); Tcl_IncrRefCount(iterVarPtr->value.objPtr); } else { TclSetIntObj(oldValuePtr, -1); } TRACE(("%u => loop iter count temp %d\n", opnd, iterTmpIndex)); #ifndef TCL_COMPILE_DEBUG /* * Remark that the compiler ALWAYS sets INST_FOREACH_STEP4 immediately * after INST_FOREACH_START4 - let us just fall through instead of |
︙ | ︙ | |||
6688 6689 6690 6691 6692 6693 6694 | /* * Increment the temp holding the loop iteration number. */ iterVarPtr = LOCAL(infoPtr->loopCtTemp); valuePtr = iterVarPtr->value.objPtr; | | | | 6534 6535 6536 6537 6538 6539 6540 6541 6542 6543 6544 6545 6546 6547 6548 6549 | /* * Increment the temp holding the loop iteration number. */ iterVarPtr = LOCAL(infoPtr->loopCtTemp); valuePtr = iterVarPtr->value.objPtr; iterNum = valuePtr->internalRep.wideValue + 1; TclSetIntObj(valuePtr, iterNum); /* * Check whether all value lists are exhausted and we should stop the * loop. */ continueLoop = 0; |
︙ | ︙ | |||
7022 7023 7024 7025 7026 7027 7028 | TclNewObj(objPtr); Tcl_IncrRefCount(objPtr); iPtr->objResultPtr = objPtr; NEXT_INST_F(1, 0, -1); case INST_PUSH_RETURN_CODE: | | | 6868 6869 6870 6871 6872 6873 6874 6875 6876 6877 6878 6879 6880 6881 6882 | TclNewObj(objPtr); Tcl_IncrRefCount(objPtr); iPtr->objResultPtr = objPtr; NEXT_INST_F(1, 0, -1); case INST_PUSH_RETURN_CODE: TclNewIntObj(objResultPtr, result); TRACE(("=> %u\n", result)); NEXT_INST_F(1, 0, 1); case INST_PUSH_RETURN_OPTIONS: DECACHE_STACK_INFO(); objResultPtr = Tcl_GetReturnOptions(interp, result); CACHE_STACK_INFO(); |
︙ | ︙ | |||
7688 7689 7690 7691 7692 7693 7694 | case 3: /* seconds */ Tcl_GetTime(&now); wval = (Tcl_WideInt) now.sec; break; default: Tcl_Panic("clockRead instruction with unknown clock#"); } | < | 7534 7535 7536 7537 7538 7539 7540 7541 7542 7543 7544 7545 7546 7547 | case 3: /* seconds */ Tcl_GetTime(&now); wval = (Tcl_WideInt) now.sec; break; default: Tcl_Panic("clockRead instruction with unknown clock#"); } objResultPtr = Tcl_NewWideIntObj(wval); TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(2, 0, 1); } default: Tcl_Panic("TclNRExecuteByteCode: unrecognized opCode %u", *pc); |
︙ | ︙ | |||
8120 8121 8122 8123 8124 8125 8126 | ExecuteExtendedBinaryMathOp( Tcl_Interp *interp, /* Where to report errors. */ 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. */ { | < < < < < < < < | | 7965 7966 7967 7968 7969 7970 7971 7972 7973 7974 7975 7976 7977 7978 7979 7980 7981 7982 7983 | ExecuteExtendedBinaryMathOp( Tcl_Interp *interp, /* Where to report errors. */ 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 WIDE_RESULT(w) \ if (Tcl_IsShared(valuePtr)) { \ return Tcl_NewWideIntObj(w); \ } else { \ TclSetIntObj(valuePtr, w); \ return NULL; \ } #define BIG_RESULT(b) \ if (Tcl_IsShared(valuePtr)) { \ return Tcl_NewBignumObj(b); \ } else { \ Tcl_SetBignumObj(valuePtr, b); \ |
︙ | ︙ | |||
8154 8155 8156 8157 8158 8159 8160 | Tcl_SetDoubleObj(valuePtr, (d)); \ return NULL; \ } int type1, type2; ClientData ptr1, ptr2; double d1, d2, dResult; | < | | | | | < | 7991 7992 7993 7994 7995 7996 7997 7998 7999 8000 8001 8002 8003 8004 8005 8006 8007 8008 8009 8010 8011 8012 8013 8014 8015 8016 8017 8018 8019 8020 8021 8022 8023 8024 8025 8026 8027 8028 8029 8030 8031 | Tcl_SetDoubleObj(valuePtr, (d)); \ return NULL; \ } int type1, type2; ClientData ptr1, ptr2; double d1, d2, dResult; Tcl_WideInt w1, w2, wResult; mp_int big1, big2, bigResult, bigRemainder; Tcl_Obj *objResultPtr; int invalid, numPos, zero; long shift; (void) GetNumberFromObj(NULL, valuePtr, &ptr1, &type1); (void) GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2); switch (opcode) { case INST_MOD: /* TODO: Attempts to re-use unshared operands on stack */ w2 = 0; /* silence gcc warning */ if (type2 == TCL_NUMBER_WIDE) { w2 = *((const Tcl_WideInt *)ptr2); if (w2 == 0) { return DIVIDED_BY_ZERO; } if ((w2 == 1) || (w2 == -1)) { /* * Div. by |1| always yields remainder of 0. */ return constants[0]; } } if (type1 == TCL_NUMBER_WIDE) { w1 = *((const Tcl_WideInt *)ptr1); if (type2 != TCL_NUMBER_BIG) { Tcl_WideInt wQuotient, wRemainder; Tcl_GetWideIntFromObj(NULL, value2Ptr, &w2); wQuotient = w1 / w2; |
︙ | ︙ | |||
8227 8228 8229 8230 8231 8232 8233 | /* * Arguments are same sign; remainder is first operand. */ mp_clear(&big2); return NULL; } | < | 8062 8063 8064 8065 8066 8067 8068 8069 8070 8071 8072 8073 8074 8075 | /* * Arguments are same sign; remainder is first operand. */ mp_clear(&big2); return NULL; } Tcl_GetBignumFromObj(NULL, valuePtr, &big1); Tcl_GetBignumFromObj(NULL, value2Ptr, &big2); mp_init(&bigResult); mp_init(&bigRemainder); mp_div(&big1, &big2, &bigResult, &bigRemainder); if (!mp_iszero(&bigRemainder) && (bigRemainder.sign != big2.sign)) { /* |
︙ | ︙ | |||
8254 8255 8256 8257 8258 8259 8260 | case INST_LSHIFT: case INST_RSHIFT: { /* * Reject negative shift argument. */ switch (type2) { | < < < < < | | | | | | < < < < < | | < | < | 8088 8089 8090 8091 8092 8093 8094 8095 8096 8097 8098 8099 8100 8101 8102 8103 8104 8105 8106 8107 8108 8109 8110 8111 8112 8113 8114 8115 8116 8117 8118 8119 8120 8121 8122 8123 8124 8125 8126 8127 8128 8129 8130 8131 8132 8133 8134 8135 8136 8137 8138 8139 8140 8141 8142 8143 8144 8145 8146 8147 8148 8149 8150 8151 8152 8153 8154 8155 8156 8157 8158 8159 8160 8161 8162 8163 8164 8165 8166 8167 8168 8169 8170 8171 8172 8173 8174 8175 8176 8177 8178 8179 8180 8181 8182 8183 8184 8185 8186 8187 8188 8189 8190 8191 8192 8193 8194 8195 8196 8197 8198 8199 8200 8201 8202 8203 8204 8205 8206 8207 8208 8209 8210 8211 8212 8213 | case INST_LSHIFT: case INST_RSHIFT: { /* * Reject negative shift argument. */ switch (type2) { case TCL_NUMBER_WIDE: invalid = (*((const Tcl_WideInt *)ptr2) < (Tcl_WideInt)0); break; case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); invalid = (mp_cmp_d(&big2, 0) == MP_LT); mp_clear(&big2); break; default: /* Unused, here to silence compiler warning */ invalid = 0; } if (invalid) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "negative shift argument", -1)); return GENERAL_ARITHMETIC_ERROR; } /* * Zero shifted any number of bits is still zero. */ if ((type1==TCL_NUMBER_WIDE) && (*((const Tcl_WideInt *)ptr1) == (Tcl_WideInt)0)) { return constants[0]; } if (opcode == INST_LSHIFT) { /* * Large left shifts create integer overflow. * * 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_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. */ Tcl_SetObjResult(interp, Tcl_NewStringObj( "integer value too large to represent", -1)); return GENERAL_ARITHMETIC_ERROR; } shift = (int)(*((const Tcl_WideInt *)ptr2)); /* * Handle shifts within the native wide range. */ if ((type1 != TCL_NUMBER_BIG) && ((size_t)shift < CHAR_BIT*sizeof(Tcl_WideInt))) { TclGetWideIntFromObj(NULL, valuePtr, &w1); if (!((w1>0 ? w1 : ~w1) & -(((Tcl_WideInt)1) << (CHAR_BIT*sizeof(Tcl_WideInt) - 1 - shift)))) { WIDE_RESULT(w1 << shift); } } } else { /* * Quickly force large right shifts to 0 or -1. */ 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_WIDE: zero = (*(const Tcl_WideInt *)ptr1 > (Tcl_WideInt)0); break; case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); zero = (mp_cmp_d(&big1, 0) == MP_GT); mp_clear(&big1); break; default: /* Unused, here to silence compiler warning. */ zero = 0; } if (zero) { return constants[0]; } WIDE_RESULT(-1); } shift = (int)(*(const Tcl_WideInt *)ptr2); /* * Handle shifts within the native wide range. */ if (type1 == TCL_NUMBER_WIDE) { w1 = *(const Tcl_WideInt *)ptr1; if ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideInt)) { if (w1 >= (Tcl_WideInt)0) { return constants[0]; } WIDE_RESULT(-1); } WIDE_RESULT(w1 >> shift); } } Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); mp_init(&bigResult); if (opcode == INST_LSHIFT) { mp_mul_2d(&big1, shift, &bigResult); |
︙ | ︙ | |||
8545 8546 8547 8548 8549 8550 8551 | } mp_clear(&big1); mp_clear(&big2); BIG_RESULT(&bigResult); } | < < | | | | | | | | | | | | < < < < < < | | | | | | | | | | | | < < < < | | < | < < < < | | < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < | | | | | | 8367 8368 8369 8370 8371 8372 8373 8374 8375 8376 8377 8378 8379 8380 8381 8382 8383 8384 8385 8386 8387 8388 8389 8390 8391 8392 8393 8394 8395 8396 8397 8398 8399 8400 8401 8402 8403 8404 8405 8406 8407 8408 8409 8410 8411 8412 8413 8414 8415 8416 8417 8418 8419 8420 8421 8422 8423 8424 8425 8426 8427 8428 8429 8430 8431 8432 8433 8434 8435 8436 8437 8438 8439 8440 8441 8442 8443 8444 8445 8446 8447 8448 8449 8450 8451 8452 8453 8454 8455 8456 8457 8458 8459 8460 8461 8462 8463 8464 8465 8466 8467 8468 8469 8470 8471 8472 8473 8474 8475 8476 8477 8478 8479 8480 8481 8482 8483 8484 8485 8486 8487 8488 8489 8490 8491 8492 8493 8494 8495 8496 8497 8498 8499 8500 8501 8502 8503 8504 8505 8506 8507 8508 8509 8510 8511 8512 8513 8514 8515 8516 8517 8518 8519 8520 8521 8522 8523 8524 8525 8526 8527 8528 8529 8530 8531 8532 8533 8534 8535 8536 8537 8538 8539 8540 8541 8542 8543 8544 8545 8546 8547 8548 8549 8550 8551 8552 8553 8554 8555 8556 8557 8558 8559 8560 8561 8562 8563 8564 8565 8566 8567 8568 8569 8570 8571 8572 8573 8574 8575 8576 8577 8578 8579 | } mp_clear(&big1); mp_clear(&big2); BIG_RESULT(&bigResult); } if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) { TclGetWideIntFromObj(NULL, valuePtr, &w1); TclGetWideIntFromObj(NULL, value2Ptr, &w2); switch (opcode) { case INST_BITAND: wResult = w1 & w2; break; case INST_BITOR: wResult = w1 | w2; break; case INST_BITXOR: wResult = w1 ^ w2; break; default: /* Unused, here to silence compiler warning. */ wResult = 0; } WIDE_RESULT(wResult); } w1 = *((const Tcl_WideInt *)ptr1); w2 = *((const Tcl_WideInt *)ptr2); switch (opcode) { case INST_BITAND: wResult = w1 & w2; break; case INST_BITOR: wResult = w1 | w2; break; case INST_BITXOR: wResult = w1 ^ w2; break; default: /* Unused, here to silence compiler warning. */ wResult = 0; } WIDE_RESULT(wResult); case INST_EXPON: { int oddExponent = 0, negativeExponent = 0; unsigned short base; if ((type1 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_DOUBLE)) { Tcl_GetDoubleFromObj(NULL, valuePtr, &d1); Tcl_GetDoubleFromObj(NULL, value2Ptr, &d2); if (d1==0.0 && d2<0.0) { return EXPONENT_OF_ZERO; } dResult = pow(d1, d2); goto doubleResult; } 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 (w2 == 1) { /* * Anything to the first power is itself */ return NULL; } } switch (type2) { case TCL_NUMBER_WIDE: w2 = *((const Tcl_WideInt *)ptr2); negativeExponent = (w2 < 0); oddExponent = (int) (w2 & (Tcl_WideInt)1); break; 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_WIDE) { w1 = *((const Tcl_WideInt *)ptr1); } if (negativeExponent) { 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) { WIDE_RESULT(-1); } /* fallthrough */ case 1: /* * 1 to any power is 1. */ return constants[1]; } } /* * Integers with magnitude greater than 1 raise to a negative * power yield the answer zero (see TIP 123). */ return constants[0]; } if (type1 == TCL_NUMBER_WIDE) { switch (w1) { case 0: /* * Zero to a positive power is zero. */ return constants[0]; case 1: /* * 1 to any power is 1. */ return constants[1]; case -1: if (!oddExponent) { return constants[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_WIDE type must hold a value larger than we * accept. */ if (type2 != TCL_NUMBER_WIDE) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "exponent too large", -1)); return GENERAL_ARITHMETIC_ERROR; } if (type1 == TCL_NUMBER_WIDE) { if (w1 == 2) { /* * Reduce small powers of 2 to shifts. */ if ((Tcl_WideUInt) w2 < (Tcl_WideUInt) CHAR_BIT*sizeof(Tcl_WideInt) - 1) { WIDE_RESULT(((Tcl_WideInt) 1) << (int)w2); } goto overflowExpon; } if (w1 == -2) { int signum = oddExponent ? -1 : 1; /* * Reduce small powers of 2 to shifts. */ if ((Tcl_WideUInt)w2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1){ WIDE_RESULT(signum * (((Tcl_WideInt) 1) << (int) w2)); } goto overflowExpon; } } if (type1 == TCL_NUMBER_WIDE) { w1 = *((const Tcl_WideInt *) ptr1); } else { goto overflowExpon; } 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 (w2) { case 2: break; case 3: wResult *= w1; /* b**3 */ break; case 4: wResult *= wResult; /* b**4 */ break; case 5: wResult *= wResult; /* b**4 */ wResult *= w1; /* b**5 */ |
︙ | ︙ | |||
8911 8912 8913 8914 8915 8916 8917 | /* * 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 | | | | | < | 8642 8643 8644 8645 8646 8647 8648 8649 8650 8651 8652 8653 8654 8655 8656 8657 8658 8659 8660 8661 8662 8663 8664 8665 8666 8667 8668 8669 8670 8671 8672 8673 8674 8675 8676 8677 8678 8679 8680 8681 8682 | /* * 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 && w2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) { base = Exp64Index[w1 - 3] + (unsigned short) (w2 - 2 - MaxBase64Size); if (base < Exp64Index[w1 - 2]) { /* * 64-bit number raised to intermediate power, done by * table lookup. */ WIDE_RESULT(Exp64Value[base]); } } if (-w1 - 3 >= 0 && -w1 - 2 < (long)Exp64IndexSize && w2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) { base = Exp64Index[-w1 - 3] + (unsigned short) (w2 - 2 - MaxBase64Size); if (base < Exp64Index[-w1 - 2]) { /* * 64-bit number raised to intermediate power, done by * table lookup. */ wResult = oddExponent ? -Exp64Value[base] : Exp64Value[base]; WIDE_RESULT(wResult); } } overflowExpon: Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); if (big2.used > 1) { mp_clear(&big2); Tcl_SetObjResult(interp, Tcl_NewStringObj( "exponent too large", -1)); |
︙ | ︙ | |||
9018 9019 9020 9021 9022 9023 9024 | if ((type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) { TclGetWideIntFromObj(NULL, valuePtr, &w1); TclGetWideIntFromObj(NULL, value2Ptr, &w2); switch (opcode) { case INST_ADD: wResult = w1 + w2; | < < < < | < | 8748 8749 8750 8751 8752 8753 8754 8755 8756 8757 8758 8759 8760 8761 8762 8763 8764 8765 8766 8767 8768 8769 8770 8771 8772 8773 8774 8775 8776 8777 8778 8779 8780 8781 8782 8783 8784 8785 8786 8787 8788 8789 8790 8791 8792 8793 8794 8795 8796 | if ((type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) { TclGetWideIntFromObj(NULL, valuePtr, &w1); TclGetWideIntFromObj(NULL, value2Ptr, &w2); switch (opcode) { case INST_ADD: wResult = w1 + w2; if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) { /* * Check for overflow. */ if (Overflowing(w1, w2, wResult)) { goto overflowBasic; } } break; case INST_SUB: wResult = w1 - w2; if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) { /* * 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 so it does the job. Note that * the only "bad" case (w2==0) is irrelevant for this * macro, as in that case w1 and wResult have the same * sign and there is no overflow anyway. */ if (Overflowing(w1, ~w2, wResult)) { goto overflowBasic; } } break; case INST_MULT: if ((w1 < INT_MIN) || (w1 > INT_MAX) || (w2 < INT_MIN) || (w2 > INT_MAX)) { goto overflowBasic; } wResult = w1 * w2; break; case INST_DIV: if (w2 == 0) { |
︙ | ︙ | |||
9160 9161 9162 9163 9164 9165 9166 | mp_int big; Tcl_Obj *objResultPtr; (void) GetNumberFromObj(NULL, valuePtr, &ptr, &type); switch (opcode) { case INST_BITNOT: | < < < < < < < < < < < < | 8885 8886 8887 8888 8889 8890 8891 8892 8893 8894 8895 8896 8897 8898 8899 8900 8901 8902 8903 8904 8905 8906 8907 8908 8909 8910 8911 8912 8913 8914 8915 8916 8917 8918 8919 8920 8921 8922 8923 8924 8925 8926 8927 8928 | mp_int big; Tcl_Obj *objResultPtr; (void) GetNumberFromObj(NULL, valuePtr, &ptr, &type); switch (opcode) { case INST_BITNOT: if (type == TCL_NUMBER_WIDE) { w = *((const Tcl_WideInt *) ptr); WIDE_RESULT(~w); } 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_WIDE: w = *((const Tcl_WideInt *) ptr); if (w != LLONG_MIN) { WIDE_RESULT(-w); } TclInitBignumFromWideInt(&big, w); break; default: Tcl_TakeBignumFromObj(NULL, valuePtr, &big); } mp_neg(&big, &big); BIG_RESULT(&big); } Tcl_Panic("unexpected opcode"); return NULL; } #undef WIDE_RESULT #undef BIG_RESULT #undef DOUBLE_RESULT /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
9233 9234 9235 9236 9237 9238 9239 | Tcl_Obj *valuePtr, Tcl_Obj *value2Ptr) { int type1 = TCL_NUMBER_NAN, type2 = TCL_NUMBER_NAN, compare; ClientData ptr1, ptr2; mp_int big1, big2; double d1, d2, tmp; | < < < | | < < < < < < | < > | | | 8946 8947 8948 8949 8950 8951 8952 8953 8954 8955 8956 8957 8958 8959 8960 8961 8962 8963 8964 8965 8966 8967 8968 8969 8970 8971 8972 8973 8974 8975 8976 8977 8978 8979 8980 8981 8982 8983 | Tcl_Obj *valuePtr, Tcl_Obj *value2Ptr) { int type1 = TCL_NUMBER_NAN, type2 = TCL_NUMBER_NAN, compare; ClientData ptr1, ptr2; mp_int big1, big2; double d1, d2, tmp; Tcl_WideInt w1, w2; (void) GetNumberFromObj(NULL, valuePtr, &ptr1, &type1); (void) GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2); switch (type1) { 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_DOUBLE: d2 = *((const double *)ptr2); 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(Tcl_WideInt) || w1 == (Tcl_WideInt) d1 || modf(d2, &tmp) != 0.0) { goto doubleCompare; } /* * Otherwise, to make comparision based on full precision, need to * convert the double to a suitably sized integer. |
︙ | ︙ | |||
9288 9289 9290 9291 9292 9293 9294 | if (d2 < (double)LONG_MIN) { return MP_GT; } if (d2 > (double)LONG_MAX) { return MP_LT; } | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 8992 8993 8994 8995 8996 8997 8998 8999 9000 9001 9002 9003 9004 9005 9006 9007 9008 9009 9010 9011 9012 9013 9014 9015 9016 9017 9018 9019 9020 9021 9022 9023 9024 9025 9026 9027 9028 9029 9030 9031 9032 9033 9034 9035 9036 9037 9038 9039 9040 | if (d2 < (double)LONG_MIN) { return MP_GT; } if (d2 > (double)LONG_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) { compare = MP_GT; } else { compare = MP_LT; } mp_clear(&big2); return compare; } 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_WIDE: w2 = *((const Tcl_WideInt *)ptr2); d2 = (double) w2; if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt) || w2 == (Tcl_WideInt) d2 || modf(d1, &tmp) != 0.0) { goto doubleCompare; } if (d1 < (double)LLONG_MIN) { return MP_LT; } if (d1 > (double)LLONG_MAX) { return MP_GT; } w1 = (Tcl_WideInt) d1; goto wideCompare; case TCL_NUMBER_BIG: if (TclIsInfinite(d1)) { return (d1 > 0.0) ? MP_GT : MP_LT; } Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); if ((d1 < (double)LONG_MAX) && (d1 > (double)LONG_MIN)) { if (mp_cmp_d(&big2, 0) == MP_LT) { |
︙ | ︙ | |||
9406 9407 9408 9409 9410 9411 9412 | Tcl_InitBignumFromDouble(NULL, d1, &big1); goto bigCompare; } case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); switch (type2) { | < < < | 9054 9055 9056 9057 9058 9059 9060 9061 9062 9063 9064 9065 9066 9067 9068 | Tcl_InitBignumFromDouble(NULL, d1, &big1); goto bigCompare; } case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); switch (type2) { case TCL_NUMBER_WIDE: compare = mp_cmp_d(&big1, 0); mp_clear(&big1); return compare; case TCL_NUMBER_DOUBLE: d2 = *((const double *)ptr2); if (TclIsInfinite(d2)) { compare = (d2 > 0.0) ? MP_LT : MP_GT; |
︙ | ︙ | |||
9474 9475 9476 9477 9478 9479 9480 | PrintByteCodeInfo( register ByteCode *codePtr) /* The bytecode whose summary is printed to * stdout. */ { Proc *procPtr = codePtr->procPtr; Interp *iPtr = (Interp *) *codePtr->interpHandle; | | | | | 9119 9120 9121 9122 9123 9124 9125 9126 9127 9128 9129 9130 9131 9132 9133 9134 9135 | PrintByteCodeInfo( register ByteCode *codePtr) /* The bytecode whose summary is printed to * stdout. */ { Proc *procPtr = codePtr->procPtr; Interp *iPtr = (Interp *) *codePtr->interpHandle; 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", codePtr->numCommands, codePtr->numSrcBytes, codePtr->numCodeBytes, codePtr->numLitObjects, |
︙ | ︙ | |||
9622 9623 9624 9625 9626 9627 9628 | if (opcode == INST_EXPON) { operator = "**"; } else if (opcode <= INST_LNOT) { operator = operatorStrings[opcode - INST_LOR]; } if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) { | > > > > > > > > | > | < | 9267 9268 9269 9270 9271 9272 9273 9274 9275 9276 9277 9278 9279 9280 9281 9282 9283 9284 9285 9286 9287 9288 9289 9290 9291 9292 9293 9294 9295 9296 9297 9298 9299 9300 9301 | if (opcode == INST_EXPON) { operator = "**"; } else if (opcode <= INST_LNOT) { operator = operatorStrings[opcode - INST_LOR]; } if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) { 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 { /* TODO: No caller needs this. Eliminate? */ description = "(big) integer"; } Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't use %s as operand of \"%s\"", description, operator)); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", description, NULL); } /* *---------------------------------------------------------------------- * * TclGetSrcInfoForPc, GetSrcInfoForPc, TclGetSourceFromFrame -- |
︙ | ︙ |
Changes to generic/tclGet.c.
︙ | ︙ | |||
138 139 140 141 142 143 144 | obj.typePtr = NULL; code = TclSetBooleanFromAny(interp, &obj); if (obj.refCount > 1) { Tcl_Panic("invalid sharing of Tcl_Obj on C stack"); } if (code == TCL_OK) { | | | 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 | obj.typePtr = NULL; 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.wideValue; } return code; } /* * Local Variables: * mode: c |
︙ | ︙ |
Changes to generic/tclHistory.c.
︙ | ︙ | |||
69 70 71 72 73 74 75 76 77 78 79 80 81 82 | * Call Tcl_RecordAndEvalObj to do the actual work. */ cmdPtr = Tcl_NewStringObj(cmd, -1); Tcl_IncrRefCount(cmdPtr); result = Tcl_RecordAndEvalObj(interp, cmdPtr, flags); /* * Discard the Tcl object created to hold the command. */ Tcl_DecrRefCount(cmdPtr); } else { /* | > > > > > > > | 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 | * Call Tcl_RecordAndEvalObj to do the actual work. */ 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); } else { /* |
︙ | ︙ |
Changes to generic/tclIO.c.
︙ | ︙ | |||
9028 9029 9030 9031 9032 9033 9034 9035 9036 9037 9038 9039 9040 9041 9042 9043 9044 9045 9046 9047 9048 9049 9050 9051 9052 | * Side effects: * May schedule a background copy operation that causes both channels to * be marked busy. * *---------------------------------------------------------------------- */ int TclCopyChannelOld( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Channel inChan, /* Channel to read from. */ Tcl_Channel outChan, /* Channel to write to. */ int toRead, /* Amount of data to copy, or -1 for all. */ Tcl_Obj *cmdPtr) /* Pointer to script to execute or NULL. */ { return TclCopyChannel(interp, inChan, outChan, (Tcl_WideInt) toRead, cmdPtr); } int TclCopyChannel( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Channel inChan, /* Channel to read from. */ Tcl_Channel outChan, /* Channel to write to. */ Tcl_WideInt toRead, /* Amount of data to copy, or -1 for all. */ | > > | 9028 9029 9030 9031 9032 9033 9034 9035 9036 9037 9038 9039 9040 9041 9042 9043 9044 9045 9046 9047 9048 9049 9050 9051 9052 9053 9054 | * Side effects: * May schedule a background copy operation that causes both channels to * 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. */ int toRead, /* Amount of data to copy, or -1 for all. */ 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. */ Tcl_Channel outChan, /* Channel to write to. */ Tcl_WideInt toRead, /* Amount of data to copy, or -1 for all. */ |
︙ | ︙ |
Changes to generic/tclIOCmd.c.
︙ | ︙ | |||
133 134 135 136 137 138 139 | case 4: /* [puts -nonewline $chan $x] or * [puts $chan $x nonewline] */ newline = 0; if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) { chanObjPtr = objv[2]; string = objv[3]; break; | | | 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 | case 4: /* [puts -nonewline $chan $x] or * [puts $chan $x nonewline] */ newline = 0; if (strcmp(TclGetString(objv[1]), "-nonewline") == 0) { chanObjPtr = objv[2]; string = objv[3]; break; #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, * maybe even earlier. */ |
︙ | ︙ | |||
435 436 437 438 439 440 441 | * Compute how many bytes to read. */ toRead = -1; if (i < objc) { if ((TclGetIntFromObj(interp, objv[i], &toRead) != TCL_OK) || (toRead < 0)) { | | | | 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 | * Compute how many bytes to read. */ toRead = -1; if (i < objc) { if ((TclGetIntFromObj(interp, objv[i], &toRead) != TCL_OK) || (toRead < 0)) { #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. */ if (strcmp(TclGetString(objv[i]), "nonewline") != 0) { #endif 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 !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 } newline = 1; #endif } } resultPtr = Tcl_NewObj(); |
︙ | ︙ |
Changes to generic/tclIORTrans.c.
︙ | ︙ | |||
83 84 85 86 87 88 89 | }; /* * 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. */ | | | 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 | }; /* * 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 { 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; #define ResultLength(r) ((r)->used) |
︙ | ︙ | |||
249 250 251 252 253 254 255 | * command handler thread (CT), and the thread managing the channel (MT), * executed in CT. Tcl_Obj's are not allowed to cross thread boundaries. So we * 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. */ | | | 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 | * command handler thread (CT), and the thread managing the channel (MT), * executed in CT. Tcl_Obj's are not allowed to cross thread boundaries. So we * 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 { 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; /* |
︙ | ︙ | |||
294 295 296 297 298 299 300 | typedef struct ForwardingResult ForwardingResult; /* * General event structure, with reference to operation specific data. */ | | | 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 | typedef struct ForwardingResult ForwardingResult; /* * General event structure, with reference to operation specific data. */ 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 * ForwardParam pointer. */ } ForwardingEvent; |
︙ | ︙ |
Changes to generic/tclIOUtil.c.
︙ | ︙ | |||
241 242 243 244 245 246 247 | * a file system by way of making a temporary copy of the file on the native * filesystem. We need to store both the actual unloadProc/clientData * 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. */ | | | 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 | * a file system by way of making a temporary copy of the file on the native * filesystem. We need to store both the actual unloadProc/clientData * 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 { Tcl_LoadHandle loadHandle; Tcl_FSUnloadFileProc *unloadProcPtr; Tcl_Obj *divertedFile; const Tcl_Filesystem *divertedFilesystem; ClientData divertedFileNativeRep; } FsDivertLoad; |
︙ | ︙ | |||
408 409 410 411 412 413 414 | } Tcl_DStringInit(cwdPtr); TclDStringAppendObj(cwdPtr, cwd); Tcl_DecrRefCount(cwd); return Tcl_DStringValue(cwdPtr); } | < | 408 409 410 411 412 413 414 415 416 417 418 419 420 421 | } Tcl_DStringInit(cwdPtr); TclDStringAppendObj(cwdPtr, cwd); Tcl_DecrRefCount(cwd); return Tcl_DStringValue(cwdPtr); } 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. */ { int ret; |
︙ | ︙ | |||
827 828 829 830 831 832 833 | void TclResetFilesystem(void) { filesystemList = &nativeFilesystemRecord; if (++theFilesystemEpoch == 0) { ++theFilesystemEpoch; } | < < < < < < < < < | 826 827 828 829 830 831 832 833 834 835 836 837 838 839 | void TclResetFilesystem(void) { filesystemList = &nativeFilesystemRecord; if (++theFilesystemEpoch == 0) { ++theFilesystemEpoch; } } /* *---------------------------------------------------------------------- * * Tcl_FSRegister -- * |
︙ | ︙ |
Changes to generic/tclIndexObj.c.
︙ | ︙ | |||
872 873 874 875 876 877 878 | Tcl_Obj *const objv[], /* Initial argument objects, which should be * included in the error message. */ const char *message) /* Error message to print after the leading * objects in objv. The message may be * NULL. */ { Tcl_Obj *objPtr; | | > | 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 | Tcl_Obj *const objv[], /* Initial argument objects, which should be * included in the error message. */ 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; char flags; Interp *iPtr = (Interp *) interp; const char *elementStr; /* * [incr Tcl] does something fairly horrific when generating error * messages for its ensembles; it passes the whole set of ensemble * arguments as a list in the first argument. This means that this code |
︙ | ︙ |
Changes to generic/tclInt.decls.
︙ | ︙ | |||
46 47 48 49 50 51 52 | } declare 6 { void TclCleanupCommand(Command *cmdPtr) } declare 7 { int TclCopyAndCollapse(int count, const char *src, char *dst) } | | | 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 | } declare 6 { void TclCleanupCommand(Command *cmdPtr) } declare 7 { int TclCopyAndCollapse(int count, const char *src, char *dst) } 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. declare 9 { |
︙ | ︙ | |||
69 70 71 72 73 74 75 | } declare 11 { void TclDeleteCompiledLocalVars(Interp *iPtr, CallFrame *framePtr) } declare 12 { void TclDeleteVars(Interp *iPtr, TclVarHashTable *tablePtr) } | | | | 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 | } declare 11 { void TclDeleteCompiledLocalVars(Interp *iPtr, CallFrame *framePtr) } declare 12 { void TclDeleteVars(Interp *iPtr, TclVarHashTable *tablePtr) } # Removed in 8.5: #declare 13 { # int TclDoGlob(Tcl_Interp *interp, char *separators, # Tcl_DString *headPtr, char *tail, Tcl_GlobTypeData *types) #} declare 14 { int TclDumpMemoryInfo(ClientData clientData, int flags) } # Removed in 8.1: # declare 15 { # void TclExpandParseValue(ParseValue *pvPtr, int needed) # } declare 16 { void TclExprFloatError(Tcl_Interp *interp, double value) } # 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) #} #declare 19 { |
︙ | ︙ | |||
110 111 112 113 114 115 116 | int *sizePtr, int *bracePtr) } 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 { | | | | 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 | int *sizePtr, int *bracePtr) } 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, Tcl_WideInt n) } declare 25 { void TclFreePackageInfo(Interp *iPtr) } # Removed in 8.1: # declare 26 { # char *TclGetCwd(Tcl_Interp *interp) # } # Removed in 8.5: #declare 27 { # int TclGetDate(char *p, unsigned long now, long zone, # unsigned long *timePtr) #} declare 28 { Tcl_Channel TclpGetDefaultStdChannel(int type) } |
︙ | ︙ | |||
143 144 145 146 147 148 149 | declare 31 { const char *TclGetExtension(const char *name) } declare 32 { int TclGetFrame(Tcl_Interp *interp, const char *str, CallFrame **framePtrPtr) } | | | | 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 | declare 31 { const char *TclGetExtension(const char *name) } declare 32 { int TclGetFrame(Tcl_Interp *interp, const char *str, CallFrame **framePtrPtr) } # Removed in 8.5: #declare 33 { # TclCmdProcType TclGetInterpProc(void) #} declare 34 { int TclGetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr, int endValue, int *indexPtr) } # Removed in 8.4b2: #declare 35 { # Tcl_Obj *TclGetIndexedScalar(Tcl_Interp *interp, int localIndex, # int flags) #} # 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) } declare 38 { |
︙ | ︙ | |||
181 182 183 184 185 186 187 | } declare 41 { Tcl_Command TclGetOriginalCommand(Tcl_Command command) } declare 42 { CONST86 char *TclpGetUserHome(const char *name, Tcl_DString *bufferPtr) } | | | | 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 | } declare 41 { Tcl_Command TclGetOriginalCommand(Tcl_Command command) } declare 42 { CONST86 char *TclpGetUserHome(const char *name, Tcl_DString *bufferPtr) } # Removed in 8.5a2: #declare 43 { # int TclGlobalInvoke(Tcl_Interp *interp, int argc, const char **argv, # int flags) #} declare 44 { int TclGuessPackageName(const char *fileName, Tcl_DString *bufPtr) } declare 45 { int TclHideUnsafeCommands(Tcl_Interp *interp) |
︙ | ︙ | |||
216 217 218 219 220 221 222 | declare 50 { void TclInitCompiledLocals(Tcl_Interp *interp, CallFrame *framePtr, Namespace *nsPtr) } declare 51 { int TclInterpInit(Tcl_Interp *interp) } | | | | | 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 | declare 50 { void TclInitCompiledLocals(Tcl_Interp *interp, CallFrame *framePtr, Namespace *nsPtr) } declare 51 { int TclInterpInit(Tcl_Interp *interp) } # Removed in 8.5a2: #declare 52 { # int TclInvoke(Tcl_Interp *interp, int argc, const char **argv, # int flags) #} declare 53 { int TclInvokeObjectCommand(ClientData clientData, Tcl_Interp *interp, int argc, const char **argv) } declare 54 { int TclInvokeStringCommand(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) } declare 55 { Proc *TclIsProc(Command *cmdPtr) |
︙ | ︙ | |||
269 270 271 272 273 274 275 | int TclObjInterpProc(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) } declare 64 { int TclObjInvoke(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags) } | | | 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 | int TclObjInterpProc(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) } declare 64 { int TclObjInvoke(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags) } # Removed in 8.5a2: #declare 65 { # int TclObjInvokeGlobal(Tcl_Interp *interp, int objc, # Tcl_Obj *const objv[], int flags) #} #declare 66 { # int TclOpenFileChannelDeleteProc(TclOpenFileChannelProc_ *proc) #} |
︙ | ︙ | |||
309 310 311 312 313 314 315 | } declare 75 { unsigned long TclpGetClicks(void) } declare 76 { unsigned long TclpGetSeconds(void) } | < < | | 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 | } declare 75 { unsigned long TclpGetClicks(void) } declare 76 { unsigned long TclpGetSeconds(void) } declare 77 {deprecated {}} { void TclpGetTime(Tcl_Time *time) } # Removed in 8.6: #declare 78 { # int TclpGetTimeZone(unsigned long time) #} # Replaced by Tcl_FSListVolumes in 8.4: |
︙ | ︙ | |||
353 354 355 356 357 358 359 | # declare 86 { # int TclParseQuotes(Tcl_Interp *interp, char *str, int termChar, # int flags, char **termPtr, ParseValue *pvPtr) # } # declare 87 { # void TclPlatformInit(Tcl_Interp *interp) # } | | | 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 | # declare 86 { # int TclParseQuotes(Tcl_Interp *interp, char *str, int termChar, # int flags, char **termPtr, ParseValue *pvPtr) # } # declare 87 { # void TclPlatformInit(Tcl_Interp *interp) # } 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, Tcl_Command cmd) } |
︙ | ︙ | |||
376 377 378 379 380 381 382 | int TclProcCompileProc(Tcl_Interp *interp, Proc *procPtr, Tcl_Obj *bodyPtr, Namespace *nsPtr, const char *description, const char *procName) } declare 93 { void TclProcDeleteProc(ClientData clientData) } | | | 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 | int TclProcCompileProc(Tcl_Interp *interp, Proc *procPtr, Tcl_Obj *bodyPtr, Namespace *nsPtr, const char *description, const char *procName) } declare 93 { void TclProcDeleteProc(ClientData clientData) } # 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: #declare 95 { # int TclpStat(const char *path, Tcl_StatBuf *buf) |
︙ | ︙ | |||
415 416 417 418 419 420 421 | declare 102 { void TclSetupEnv(Tcl_Interp *interp) } declare 103 { int TclSockGetPort(Tcl_Interp *interp, const char *str, const char *proto, int *portPtr) } | | | 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 | declare 102 { void TclSetupEnv(Tcl_Interp *interp) } declare 103 { int TclSockGetPort(Tcl_Interp *interp, const char *str, const char *proto, int *portPtr) } 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) #} #declare 106 { |
︙ | ︙ | |||
451 452 453 454 455 456 457 | declare 111 { void Tcl_AddInterpResolvers(Tcl_Interp *interp, const char *name, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc) } declare 112 { | | | | | | | | | | | | | | | | | 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 | declare 111 { void Tcl_AddInterpResolvers(Tcl_Interp *interp, const char *name, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc) } declare 112 { int TclAppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr) } declare 113 { Tcl_Namespace *TclCreateNamespace(Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc) } declare 114 { void TclDeleteNamespace(Tcl_Namespace *nsPtr) } declare 115 { int TclExport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst) } declare 116 { Tcl_Command TclFindCommand(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags) } declare 117 { 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) } declare 119 { int Tcl_GetNamespaceResolvers(Tcl_Namespace *namespacePtr, Tcl_ResolverInfo *resInfo) } declare 120 { Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags) } declare 121 { int TclForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern) } declare 122 { Tcl_Command TclGetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr) } declare 123 { void TclGetCommandFullName(Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr) } declare 124 { Tcl_Namespace *TclGetCurrentNamespace_(Tcl_Interp *interp) } declare 125 { Tcl_Namespace *TclGetGlobalNamespace_(Tcl_Interp *interp) } declare 126 { void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr) } declare 127 { int TclImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int allowOverwrite) } declare 128 { void Tcl_PopCallFrame(Tcl_Interp *interp) } declare 129 { int Tcl_PushCallFrame(Tcl_Interp *interp, Tcl_CallFrame *framePtr, Tcl_Namespace *nsPtr, int isProcCallFrame) } declare 130 { int Tcl_RemoveInterpResolvers(Tcl_Interp *interp, const char *name) } declare 131 { void Tcl_SetNamespaceResolvers(Tcl_Namespace *namespacePtr, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc) } declare 132 { int TclpHasSockets(Tcl_Interp *interp) } 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, # const struct tm *t, int useGMT) #} #declare 135 { # int TclpCheckStackSpace(void) #} # Added in 8.1: #declare 137 { # int TclpChdir(const char *dirName) #} declare 138 { 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) #} #declare 140 { # int TclLooksLikeInt(const char *bytes, int length) #} # This is used by TclX, but should otherwise be considered private declare 141 { const char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr) } declare 142 { int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr, CompileHookProc *hookProc, ClientData clientData) } declare 143 { int TclAddLiteralObj(struct CompileEnv *envPtr, Tcl_Obj *objPtr, |
︙ | ︙ | |||
621 622 623 624 625 626 627 | declare 156 { void TclRegError(Tcl_Interp *interp, const char *msg, int status) } declare 157 { Var *TclVarTraceExists(Tcl_Interp *interp, const char *varName) } | < | < | | 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 | declare 156 { void TclRegError(Tcl_Interp *interp, const char *msg, int status) } declare 157 { Var *TclVarTraceExists(Tcl_Interp *interp, const char *varName) } declare 158 {deprecated {use public Tcl_SetStartupScript()}} { void TclSetStartupScriptFileName(const char *filename) } 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, # GlobTypeData *types) #} |
︙ | ︙ | |||
672 673 674 675 676 677 678 | # New function due to TIP #33 declare 166 { int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj *valuePtr) } | < < | < | | 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 | # New function due to TIP #33 declare 166 { int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj *valuePtr) } declare 167 {deprecated {use public Tcl_SetStartupScript()}} { void TclSetStartupScriptPath(Tcl_Obj *pathPtr) } 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) } declare 170 { |
︙ | ︙ | |||
726 727 728 729 730 731 732 | declare 176 { void TclCleanupVar(Var *varPtr, Var *arrayPtr) } declare 177 { void TclVarErrMsg(Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason) } | < | | < < | | | 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 | declare 176 { void TclCleanupVar(Var *varPtr, Var *arrayPtr) } declare 177 { void TclVarErrMsg(Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason) } declare 178 { void TclSetStartupScript(Tcl_Obj *pathPtr, const char *encodingName) } declare 179 { Tcl_Obj *TclGetStartupScript(const char **encodingNamePtr) } # REMOVED # Allocate lists without copying arrays # declare 180 { # Tcl_Obj *TclNewListObjDirect(int objc, Tcl_Obj **objv) # } #declare 181 { # Tcl_Obj *TclDbNewListObjDirect(int objc, Tcl_Obj **objv, # const char *file, int line) #} declare 182 {deprecated {}} { struct tm *TclpLocaltime(const time_t *clock) } declare 183 {deprecated {}} { struct tm *TclpGmtime(const time_t *clock) } # For the new "Thread Storage" subsystem. ### REMOVED on grounds it should never have been exposed. All these ### functions are now either static in tclThreadStorage.c or |
︙ | ︙ | |||
933 934 935 936 937 938 939 | declare 234 { Var *TclVarHashCreateVar(TclVarHashTable *tablePtr, const char *key, int *newPtr) } declare 235 { void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr) } | < < < | | 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 | declare 234 { Var *TclVarHashCreateVar(TclVarHashTable *tablePtr, const char *key, int *newPtr) } declare 235 { void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr) } declare 236 {deprecated {use Tcl_BackgroundException}} { void TclBackgroundException(Tcl_Interp *interp, int code) } # TIP #285: Script cancellation support. declare 237 { int TclResetCancellation(Tcl_Interp *interp, int force) } |
︙ | ︙ | |||
1086 1087 1088 1089 1090 1091 1092 | declare 9 win { int TclWinGetPlatformId(void) } # new for 8.4.20+/8.5.12+ Cygwin only declare 10 win { Tcl_DirEntry *TclpReaddir(DIR *dir) } | | | 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 | declare 9 win { int TclWinGetPlatformId(void) } # 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): #declare 10 win { # int TclWinSynchSpawn(void *args, int type, void **trans, Tcl_Pid *pidPtr) #} # Pipe channel functions declare 11 win { |
︙ | ︙ | |||
1136 1137 1138 1139 1140 1141 1142 | } declare 19 win { TclFile TclpOpenFile(const char *fname, int mode) } declare 20 win { void TclWinAddProcess(HANDLE hProcess, DWORD id) } | < | 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 | } declare 19 win { TclFile TclpOpenFile(const char *fname, int mode) } declare 20 win { void TclWinAddProcess(HANDLE hProcess, DWORD id) } declare 21 win { char *TclpInetNtoa(struct in_addr addr) } # removed permanently for 8.4 #declare 21 win { # void TclpAsyncMark(Tcl_AsyncHandler async) #} |
︙ | ︙ |
Changes to generic/tclInt.h.
︙ | ︙ | |||
156 157 158 159 160 161 162 | typedef struct Tcl_ResolvedVarInfo { Tcl_ResolveRuntimeVarProc *fetchProc; Tcl_ResolveVarDeleteProc *deleteProc; } Tcl_ResolvedVarInfo; typedef int (Tcl_ResolveCompiledVarProc)(Tcl_Interp *interp, | | | | | 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 | typedef struct Tcl_ResolvedVarInfo { Tcl_ResolveRuntimeVarProc *fetchProc; Tcl_ResolveVarDeleteProc *deleteProc; } Tcl_ResolvedVarInfo; typedef int (Tcl_ResolveCompiledVarProc)(Tcl_Interp *interp, const char *name, int length, Tcl_Namespace *context, Tcl_ResolvedVarInfo **rPtr); 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, const char *name, Tcl_Namespace *context, int flags, Tcl_Command *rPtr); typedef struct Tcl_ResolverInfo { Tcl_ResolveCmdProc *cmdResProc; /* Procedure handling command name * resolution. */ Tcl_ResolveVarProc *varResProc; |
︙ | ︙ | |||
261 262 263 264 265 266 267 | * strings; values have type (Namespace *). */ #else Tcl_HashTable *childTablePtr; /* Contains any child namespaces. Indexed by * strings; values have type (Namespace *). If * NULL, there are no children. */ #endif | | | | 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 | * strings; values have type (Namespace *). */ #else Tcl_HashTable *childTablePtr; /* Contains any child namespaces. Indexed by * strings; values have type (Namespace *). If * NULL, there are no children. */ #endif 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. */ 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 *). * Commands imported by Tcl_Import have * Command structures that point (via an |
︙ | ︙ | |||
295 296 297 298 299 300 301 | * commands; however, no namespace qualifiers * are allowed. NULL if no export patterns are * registered. */ int numExportPatterns; /* Number of export patterns currently * registered using "namespace export". */ int maxExportPatterns; /* Mumber of export patterns for which space * is currently allocated. */ | | | | 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 | * commands; however, no namespace qualifiers * are allowed. NULL if no export patterns are * registered. */ int numExportPatterns; /* Number of export patterns currently * registered using "namespace export". */ int maxExportPatterns; /* Mumber of export patterns for which space * is currently allocated. */ 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. */ 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 * recompiled under the new rules.*/ Tcl_ResolveCmdProc *cmdResProc; |
︙ | ︙ | |||
327 328 329 330 331 332 333 | Tcl_ResolveCompiledVarProc *compiledVarResProc; /* If non-null, this procedure overrides the * usual variable resolution mechanism in Tcl. * This procedure is invoked within * LookupCompiledLocal to resolve variable * references within the namespace at compile * time. */ | | | 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 | Tcl_ResolveCompiledVarProc *compiledVarResProc; /* If non-null, this procedure overrides the * usual variable resolution mechanism in Tcl. * This procedure is invoked within * LookupCompiledLocal to resolve variable * references within the namespace at compile * time. */ 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 * of the ensembles that are implemented on * top of this namespace. */ |
︙ | ︙ | |||
422 423 424 425 426 427 428 | * commands that are actually exported by the namespace, and an epoch counter * that, combined with the exportLookupEpoch field of the namespace structure, * defines whether the table contains valid data or will need to be recomputed * next time the ensemble command is called. */ typedef struct EnsembleConfig { | | | | 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 | * commands that are actually exported by the namespace, and an epoch counter * that, combined with the exportLookupEpoch field of the namespace structure, * 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 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.) */ 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. */ Tcl_HashTable subcommandTable; /* Hash table of ensemble subcommand names, |
︙ | ︙ | |||
541 542 543 544 545 546 547 | ClientData clientData; /* Argument to pass to proc. */ int flags; /* What events the trace procedure is * 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. */ | | | 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 | ClientData clientData; /* Argument to pass to proc. */ int flags; /* What events the trace procedure is * 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. */ 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; /* * When a command trace is active (i.e. its associated procedure is executing) |
︙ | ︙ | |||
614 615 616 617 618 619 620 | * "upvar", this field points to the * referenced variable's Var struct. */ } value; } Var; typedef struct VarInHash { Var var; | | | 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 | * "upvar", this field points to the * referenced variable's Var struct. */ } value; } Var; typedef struct VarInHash { Var var; 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 * record can't be deleted until refCount * becomes 0. */ |
︙ | ︙ | |||
946 947 948 949 950 951 952 | * collection of Tcl commands plus information about arguments and other local * variables recognized at compile time. */ typedef struct Proc { struct Interp *iPtr; /* Interpreter for which this command is * defined. */ | | | 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 | * collection of Tcl commands plus information about arguments and other local * variables recognized at compile time. */ typedef struct Proc { struct Interp *iPtr; /* Interpreter for which this command is * defined. */ 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 * procedure. This is used to get the * namespace in which to execute the |
︙ | ︙ | |||
1063 1064 1065 1066 1067 1068 1069 | /* * 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 { | | | 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 | /* * 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 { unsigned int refCount; int numVars; Tcl_Obj *varName0; } LocalCache; #define localName(framePtr, i) \ ((&((framePtr)->localCachePtr->varName0))[(i)]) |
︙ | ︙ | |||
1225 1226 1227 1228 1229 1230 1231 | * TclArgumentBCEnter(). These will be removed * by TclArgumentBCRelease. */ } CmdFrame; typedef struct CFWord { CmdFrame *framePtr; /* CmdFrame to access. */ int word; /* Index of the word in the command. */ | | | 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 | * TclArgumentBCEnter(). These will be removed * by TclArgumentBCRelease. */ } CmdFrame; typedef struct CFWord { CmdFrame *framePtr; /* CmdFrame to access. */ int word; /* Index of the word in the command. */ unsigned int refCount; /* Number of times the word is on the * stack. */ } CFWord; typedef struct CFWordBC { CmdFrame *framePtr; /* CmdFrame to access. */ int pc; /* Instruction pointer of a command in * ExtCmdLoc.loc[.] */ |
︙ | ︙ | |||
1488 1489 1490 1491 1492 1493 1494 | typedef struct LiteralEntry { 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. */ | | | | | 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 | typedef struct LiteralEntry { 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. */ 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, (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; typedef struct LiteralTable { LiteralEntry **buckets; /* Pointer to bucket array. Each element * points to first entry in bucket's hash * chain, or NULL. */ LiteralEntry *staticBuckets[TCL_SMALL_HASH_TABLE]; /* Bucket array used for small tables to avoid * mallocs and frees. */ int numBuckets; /* Total number of buckets allocated at * **buckets. */ int numEntries; /* Total number of entries present in * table. */ int rebuildSize; /* Enlarge table when numEntries gets to be * this large. */ 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 * interpreter's operation in that interpreter. */ |
︙ | ︙ | |||
1630 1631 1632 1633 1634 1635 1636 | * from its Tcl_Command handle. NULL means * that the hash table entry has been removed * already (this can happen if deleteProc * causes the command to be deleted or * recreated). */ Namespace *nsPtr; /* Points to the namespace containing this * command. */ | | | | 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 | * from its Tcl_Command handle. NULL means * that the hash table entry has been removed * already (this can happen if deleteProc * causes the command to be deleted or * recreated). */ Namespace *nsPtr; /* Points to the namespace containing this * command. */ 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. */ 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. */ ClientData objClientData; /* Arbitrary value passed to object proc. */ Tcl_CmdProc *proc; /* String-based command procedure. */ |
︙ | ︙ | |||
1769 1770 1771 1772 1773 1774 1775 | * variable storage. Primary responsibility for this data structure is in * tclBasic.c, but almost every Tcl source file uses something in here. *---------------------------------------------------------------- */ typedef struct Interp { /* | | | | < > | | | | > > > > > | > > | > > > > > > | | | | < | < | < | | 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 | * variable storage. Primary responsibility for this data structure is in * tclBasic.c, but almost every Tcl source file uses something in here. *---------------------------------------------------------------- */ typedef struct Interp { /* * 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. */ 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. 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. */ Tcl_HashTable *hiddenCmdTablePtr; /* Hash table used by tclBasic.c to keep track * of hidden commands on a per-interp * basis. */ ClientData interpInfo; /* Information used by tclInterp.c to keep * track of master/slave interps on a * per-interp basis. */ union { 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 overridden by extensions. */ } extra; /* * Information related to procedures and variables. See tclProc.c and * tclVar.c for usage. */ |
︙ | ︙ | |||
1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 | * or NULL if no active traces. */ int returnCode; /* [return -code] parameter. */ 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 about packages. Used only in tclPkg.c. */ Tcl_HashTable packageTable; /* Describes all of the packages loaded in or * available to this interpreter. Keys are * package names, values are (Package *) | > > > > > > > > > > > > > > > > > > > | 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 1885 | * or NULL if no active traces. */ int returnCode; /* [return -code] parameter. */ 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 * available to this interpreter. Keys are * package names, values are (Package *) |
︙ | ︙ | |||
1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 | int cmdCount; /* Total number of times a command procedure * 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. */ 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. */ unsigned int compileEpoch; /* Holds the current "compilation epoch" for * this interpreter. This is incremented to | > | 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 | int cmdCount; /* Total number of times a command procedure * 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. */ unsigned int compileEpoch; /* Holds the current "compilation epoch" for * this interpreter. This is incremented to |
︙ | ︙ | |||
1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 | struct ExecEnv *execEnvPtr; /* Execution environment for Tcl bytecode * execution. Contains a pointer to the Tcl * 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. */ 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. */ ActiveCommandTrace *activeCmdTracePtr; /* First in list of active command traces for | > > > > > > > > | 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 | struct ExecEnv *execEnvPtr; /* Execution environment for Tcl bytecode * execution. Contains a pointer to the Tcl * 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. */ ActiveCommandTrace *activeCmdTracePtr; /* First in list of active command traces for |
︙ | ︙ | |||
2211 2212 2213 2214 2215 2216 2217 | * instructions. This is set 1, for example, when command * traces are requested. * 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, | | | 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 | * instructions. This is set 1, for example, when command * traces are requested. * 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 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 * invoked. * INTERP_ALTERNATE_WRONG_ARGS: Used for listing second and subsequent forms |
︙ | ︙ | |||
2344 2345 2346 2347 2348 2349 2350 | * struct is grown (reallocated and copied) as necessary to hold all the * list's element pointers. The struct might contain more slots than currently * used to hold all element pointers. This is done to make append operations * faster. */ typedef struct List { | | | | 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 | * struct is grown (reallocated and copied) as necessary to hold all the * list's element pointers. The struct might contain more slots than currently * used to hold all element pointers. This is done to make append operations * faster. */ typedef struct List { 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 * accommodate all elements. */ } List; #define LIST_MAX \ (1 + (int)(((size_t)UINT_MAX - sizeof(List))/sizeof(Tcl_Obj *))) #define LIST_SIZE(numElems) \ (unsigned)(sizeof(List) + (((numElems) - 1) * sizeof(Tcl_Obj *))) |
︙ | ︙ | |||
2411 2412 2413 2414 2415 2416 2417 2418 2419 | /* * Macros providing a faster path to integers: Tcl_GetLongFromObj, * Tcl_GetIntFromObj and TclGetIntForIndex. * * WARNING: these macros eval their args more than once. */ #define TclGetLongFromObj(interp, objPtr, longPtr) \ (((objPtr)->typePtr == &tclIntType) \ | > | | < | | | < < | | | | > | | | | | | < < < < < < < | < < < < | | | 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 | /* * Macros providing a faster path to integers: Tcl_GetLongFromObj, * Tcl_GetIntFromObj and TclGetIntForIndex. * * WARNING: these macros eval their args more than once. */ #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); */ #define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \ (((objPtr)->typePtr == &tclIntType) \ ? (*(wideIntPtr) = (Tcl_WideInt) \ ((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 * updates will be needed. * * 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 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-existent dictionaries on the path. */ #define DICT_PATH_READ 0 #define DICT_PATH_UPDATE 1 #define DICT_PATH_EXISTS 2 #define DICT_PATH_CREATE 5 |
︙ | ︙ | |||
2586 2587 2588 2589 2590 2591 2592 | /* *---------------------------------------------------------------- * Data structures for process-global values. *---------------------------------------------------------------- */ | | | | | 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 | /* *---------------------------------------------------------------- * Data structures for process-global values. *---------------------------------------------------------------- */ 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 * the value, and the master is kept as a counted string, with epoch and mutex * control. Each ProcessGlobalValue struct should be a static variable in some * file. */ typedef struct ProcessGlobalValue { unsigned int epoch; /* Epoch counter to detect changes in the * master value. */ 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 * copy when a "get" request comes in before * any "set" request has been received. */ |
︙ | ︙ | |||
2688 2689 2690 2691 2692 2693 2694 | MODULE_SCOPE const Tcl_ObjType tclEndOffsetType; MODULE_SCOPE const Tcl_ObjType tclIntType; MODULE_SCOPE const Tcl_ObjType tclListType; MODULE_SCOPE const Tcl_ObjType tclDictType; MODULE_SCOPE const Tcl_ObjType tclProcBodyType; MODULE_SCOPE const Tcl_ObjType tclStringType; MODULE_SCOPE const Tcl_ObjType tclEnsembleCmdType; | < < < | 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 | MODULE_SCOPE const Tcl_ObjType tclEndOffsetType; MODULE_SCOPE const Tcl_ObjType tclIntType; MODULE_SCOPE const Tcl_ObjType tclListType; MODULE_SCOPE const Tcl_ObjType tclDictType; MODULE_SCOPE const Tcl_ObjType tclProcBodyType; MODULE_SCOPE const Tcl_ObjType tclStringType; MODULE_SCOPE const Tcl_ObjType tclEnsembleCmdType; MODULE_SCOPE const Tcl_ObjType tclRegexpType; MODULE_SCOPE Tcl_ObjType tclCmdNameType; /* * Variables denoting the hash key types defined in the core. */ |
︙ | ︙ | |||
2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 | MODULE_SCOPE double TclBignumToDouble(const mp_int *bignum); MODULE_SCOPE int TclByteArrayMatch(const unsigned char *string, 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 TclChanCaughtErrorBypass(Tcl_Interp *interp, Tcl_Channel chan); MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd; MODULE_SCOPE Tcl_NRPostProc TclClearRootEnsemble; 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 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); | > > > > > > > > > > > > > > > > > | | 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 | MODULE_SCOPE double TclBignumToDouble(const mp_int *bignum); MODULE_SCOPE int TclByteArrayMatch(const unsigned char *string, 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 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; MODULE_SCOPE Tcl_ObjCmdProc TclFileDeleteCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileLinkCmd; |
︙ | ︙ | |||
2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 | MODULE_SCOPE char * TclDStringAppendObj(Tcl_DString *dsPtr, Tcl_Obj *objPtr); 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 void TclFinalizeAllocSubsystem(void); MODULE_SCOPE void TclFinalizeAsync(void); MODULE_SCOPE void TclFinalizeDoubleConversion(void); MODULE_SCOPE void TclFinalizeEncodingSubsystem(void); MODULE_SCOPE void TclFinalizeEnvironment(void); MODULE_SCOPE void TclFinalizeEvaluation(void); MODULE_SCOPE void TclFinalizeExecution(void); | > > | 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 | MODULE_SCOPE char * TclDStringAppendObj(Tcl_DString *dsPtr, Tcl_Obj *objPtr); 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); MODULE_SCOPE void TclFinalizeEvaluation(void); MODULE_SCOPE void TclFinalizeExecution(void); |
︙ | ︙ | |||
2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 | MODULE_SCOPE void TclFinalizeThreadAllocThread(void); MODULE_SCOPE void TclFinalizeThreadData(int quick); 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 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); MODULE_SCOPE int TclGetChannelFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Channel *chanPtr, | > > > > > > > > > | 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 | MODULE_SCOPE void TclFinalizeThreadAllocThread(void); MODULE_SCOPE void TclFinalizeThreadData(int quick); 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); MODULE_SCOPE int TclGetChannelFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Channel *chanPtr, |
︙ | ︙ | |||
3055 3056 3057 3058 3059 3060 3061 | const char *host, int port, int willBind, const char **errorMsgPtr); 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, | | | 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 | const char *host, int port, int willBind, const char **errorMsgPtr); 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, 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); MODULE_SCOPE void TclpMasterUnlock(void); MODULE_SCOPE int TclpMatchFiles(Tcl_Interp *interp, char *separators, |
︙ | ︙ | |||
3089 3090 3091 3092 3093 3094 3095 | Tcl_Obj *resultingNameObj); MODULE_SCOPE void TclPkgFileSeen(Tcl_Interp *interp, const char *fileName); 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); | < | | 3140 3141 3142 3143 3144 3145 3146 3147 3148 3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 3163 3164 3165 3166 3167 | Tcl_Obj *resultingNameObj); MODULE_SCOPE void TclPkgFileSeen(Tcl_Interp *interp, const char *fileName); 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 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); MODULE_SCOPE void TclRememberCondition(Tcl_Condition *mutex); MODULE_SCOPE void TclRememberJoinableThread(Tcl_ThreadId id); MODULE_SCOPE void TclRememberMutex(Tcl_Mutex *mutex); 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, 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); MODULE_SCOPE void TclSetCmdNameObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Command *cmdPtr); |
︙ | ︙ | |||
3149 3150 3151 3152 3153 3154 3155 3156 3157 3158 3159 3160 3161 3162 | MODULE_SCOPE int TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, int count, int *tokensLeftPtr, int line, 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 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, Tcl_LoadHandle *loadHandle, Tcl_FSUnloadFileProc **unloadProcPtr, int flags); | > | 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 | MODULE_SCOPE int TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, int count, int *tokensLeftPtr, int line, 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, Tcl_LoadHandle *loadHandle, Tcl_FSUnloadFileProc **unloadProcPtr, int flags); |
︙ | ︙ | |||
3198 3199 3200 3201 3202 3203 3204 | Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); 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[]); | | | 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 | Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); 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[]); #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, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); |
︙ | ︙ | |||
4376 4377 4378 4379 4380 4381 4382 | * the result of Tcl_UtfToUniChar. The ANSI C "prototype" for this macro is: * * MODULE_SCOPE int TclUtfToUniChar(const char *string, Tcl_UniChar *ch); *---------------------------------------------------------------- */ #define TclUtfToUniChar(str, chPtr) \ | | | 4427 4428 4429 4430 4431 4432 4433 4434 4435 4436 4437 4438 4439 4440 4441 | * the result of Tcl_UtfToUniChar. The ANSI C "prototype" for this macro is: * * MODULE_SCOPE int TclUtfToUniChar(const char *string, Tcl_UniChar *ch); *---------------------------------------------------------------- */ #define TclUtfToUniChar(str, chPtr) \ ((((unsigned char) *(str)) < 0x80) ? \ ((*(chPtr) = (unsigned char) *(str)), 1) \ : Tcl_UtfToUniChar(str, chPtr)) /* *---------------------------------------------------------------- * Macro counterpart of the Tcl_NumUtfChars() function. To be used in speed- * -sensitive points where it pays to avoid a function call in the common case |
︙ | ︙ | |||
4501 4502 4503 4504 4505 4506 4507 | /* *---------------------------------------------------------------- * 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: * | < | | | < < < < < < < < < < < | | | | 4552 4553 4554 4555 4556 4557 4558 4559 4560 4561 4562 4563 4564 4565 4566 4567 4568 4569 4570 4571 4572 4573 4574 4575 4576 4577 4578 4579 4580 4581 4582 4583 4584 4585 4586 4587 4588 4589 4590 4591 4592 4593 4594 4595 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 | /* *---------------------------------------------------------------- * 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 TclSetIntObj(Tcl_Obj *objPtr, Tcl_WideInt w); * MODULE_SCOPE void TclSetDoubleObj(Tcl_Obj *objPtr, double d); *---------------------------------------------------------------- */ #define TclSetIntObj(objPtr, i) \ do { \ TclInvalidateStringRep(objPtr); \ TclFreeIntRep(objPtr); \ (objPtr)->internalRep.wideValue = (Tcl_WideInt)(i); \ (objPtr)->typePtr = &tclIntType; \ } while (0) #define TclSetDoubleObj(objPtr, d) \ do { \ TclInvalidateStringRep(objPtr); \ TclFreeIntRep(objPtr); \ (objPtr)->internalRep.doubleValue = (double)(d); \ (objPtr)->typePtr = &tclDoubleType; \ } while (0) /* *---------------------------------------------------------------- * 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 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 TclNewIntObj(objPtr, i) \ do { \ TclIncrObjsAllocated(); \ TclAllocObjStorage(objPtr); \ (objPtr)->refCount = 0; \ (objPtr)->bytes = NULL; \ (objPtr)->internalRep.wideValue = (Tcl_WideInt)(i); \ (objPtr)->typePtr = &tclIntType; \ TCL_DTRACE_OBJ_CREATE(objPtr); \ } while (0) #define TclNewDoubleObj(objPtr, d) \ do { \ TclIncrObjsAllocated(); \ |
︙ | ︙ | |||
4582 4583 4584 4585 4586 4587 4588 | (objPtr)->refCount = 0; \ TclInitStringRep((objPtr), (s), (len)); \ (objPtr)->typePtr = NULL; \ TCL_DTRACE_OBJ_CREATE(objPtr); \ } while (0) #else /* TCL_MEM_DEBUG */ | | | | 4621 4622 4623 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 | (objPtr)->refCount = 0; \ TclInitStringRep((objPtr), (s), (len)); \ (objPtr)->typePtr = NULL; \ TCL_DTRACE_OBJ_CREATE(objPtr); \ } while (0) #else /* TCL_MEM_DEBUG */ #define TclNewIntObj(objPtr, w) \ (objPtr) = Tcl_NewWideIntObj(w) #define TclNewDoubleObj(objPtr, d) \ (objPtr) = Tcl_NewDoubleObj(d) #define TclNewStringObj(objPtr, s, len) \ (objPtr) = Tcl_NewStringObj((s), (len)) #endif /* TCL_MEM_DEBUG */ |
︙ | ︙ |
Changes to generic/tclIntDecls.h.
︙ | ︙ | |||
24 25 26 27 28 29 30 | # ifdef USE_TCL_STUBS # define TCL_STORAGE_CLASS # else # define TCL_STORAGE_CLASS DLLIMPORT # endif #endif | | > | | | | | | | | | | | | < | | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 | # ifdef USE_TCL_STUBS # define TCL_STORAGE_CLASS # else # define TCL_STORAGE_CLASS DLLIMPORT # endif #endif #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. */ |
︙ | ︙ | |||
71 72 73 74 75 76 77 | Tcl_Pid *pidPtr, Tcl_Channel errorChan); /* 6 */ EXTERN void TclCleanupCommand(Command *cmdPtr); /* 7 */ EXTERN int TclCopyAndCollapse(int count, const char *src, char *dst); /* 8 */ | > | | 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 | Tcl_Pid *pidPtr, Tcl_Channel errorChan); /* 6 */ EXTERN void TclCleanupCommand(Command *cmdPtr); /* 7 */ EXTERN int TclCopyAndCollapse(int count, const char *src, char *dst); /* 8 */ 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, TclFile *inPipePtr, TclFile *outPipePtr, TclFile *errFilePtr); |
︙ | ︙ | |||
109 110 111 112 113 114 115 | const char *listStr, int listLength, const char **elementPtr, const char **nextPtr, int *sizePtr, int *bracePtr); /* 23 */ EXTERN Proc * TclFindProc(Interp *iPtr, const char *procName); /* 24 */ | | | 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 | const char *listStr, int listLength, const char **elementPtr, const char **nextPtr, int *sizePtr, int *bracePtr); /* 23 */ EXTERN Proc * TclFindProc(Interp *iPtr, const char *procName); /* 24 */ EXTERN int TclFormatInt(char *buffer, Tcl_WideInt n); /* 25 */ EXTERN void TclFreePackageInfo(Interp *iPtr); /* Slot 26 is reserved */ /* Slot 27 is reserved */ /* 28 */ EXTERN Tcl_Channel TclpGetDefaultStdChannel(int type); /* Slot 29 is reserved */ |
︙ | ︙ | |||
169 170 171 172 173 174 175 | CallFrame *framePtr, Namespace *nsPtr); /* 51 */ EXTERN int TclInterpInit(Tcl_Interp *interp); /* Slot 52 is reserved */ /* 53 */ EXTERN int TclInvokeObjectCommand(ClientData clientData, Tcl_Interp *interp, int argc, | | | 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 | CallFrame *framePtr, Namespace *nsPtr); /* 51 */ EXTERN int TclInterpInit(Tcl_Interp *interp); /* Slot 52 is reserved */ /* 53 */ EXTERN int TclInvokeObjectCommand(ClientData clientData, Tcl_Interp *interp, int argc, const char **argv); /* 54 */ EXTERN int TclInvokeStringCommand(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 55 */ EXTERN Proc * TclIsProc(Command *cmdPtr); /* Slot 56 is reserved */ |
︙ | ︙ | |||
214 215 216 217 218 219 220 | /* 74 */ EXTERN void TclpFree(char *ptr); /* 75 */ EXTERN unsigned long TclpGetClicks(void); /* 76 */ EXTERN unsigned long TclpGetSeconds(void); /* 77 */ | > | > | | 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 | /* 74 */ EXTERN void TclpFree(char *ptr); /* 75 */ EXTERN unsigned long TclpGetClicks(void); /* 76 */ EXTERN unsigned long TclpGetSeconds(void); /* 77 */ 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); /* Slot 82 is reserved */ /* Slot 83 is reserved */ /* Slot 84 is reserved */ /* Slot 85 is reserved */ /* Slot 86 is reserved */ /* Slot 87 is reserved */ /* 88 */ 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); /* Slot 90 is reserved */ /* 91 */ |
︙ | ︙ | |||
263 264 265 266 267 268 269 | EXTERN CONST86 char * TclSetPreInitScript(const char *string); /* 102 */ EXTERN void TclSetupEnv(Tcl_Interp *interp); /* 103 */ EXTERN int TclSockGetPort(Tcl_Interp *interp, const char *str, const char *proto, int *portPtr); /* 104 */ | > | | | | | | | | | | | | | > | < | < | | 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 | EXTERN CONST86 char * TclSetPreInitScript(const char *string); /* 102 */ EXTERN void TclSetupEnv(Tcl_Interp *interp); /* 103 */ EXTERN int TclSockGetPort(Tcl_Interp *interp, const char *str, const char *proto, int *portPtr); /* 104 */ 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); /* 109 */ EXTERN int TclUpdateReturnInfo(Interp *iPtr); /* 110 */ EXTERN int TclSockMinimumBuffers(void *sock, int size); /* 111 */ EXTERN void Tcl_AddInterpResolvers(Tcl_Interp *interp, const char *name, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 112 */ EXTERN int TclAppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 113 */ EXTERN Tcl_Namespace * TclCreateNamespace(Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 114 */ EXTERN void TclDeleteNamespace(Tcl_Namespace *nsPtr); /* 115 */ EXTERN int TclExport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst); /* 116 */ EXTERN Tcl_Command TclFindCommand(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 117 */ 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); /* 119 */ EXTERN int Tcl_GetNamespaceResolvers( Tcl_Namespace *namespacePtr, Tcl_ResolverInfo *resInfo); /* 120 */ EXTERN Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 121 */ EXTERN int TclForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern); /* 122 */ EXTERN Tcl_Command TclGetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr); /* 123 */ EXTERN void TclGetCommandFullName(Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 124 */ EXTERN Tcl_Namespace * TclGetCurrentNamespace_(Tcl_Interp *interp); /* 125 */ EXTERN Tcl_Namespace * TclGetGlobalNamespace_(Tcl_Interp *interp); /* 126 */ EXTERN void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr); /* 127 */ 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, Tcl_CallFrame *framePtr, Tcl_Namespace *nsPtr, int isProcCallFrame); /* 130 */ EXTERN int Tcl_RemoveInterpResolvers(Tcl_Interp *interp, const char *name); /* 131 */ EXTERN void Tcl_SetNamespaceResolvers( Tcl_Namespace *namespacePtr, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 132 */ EXTERN int TclpHasSockets(Tcl_Interp *interp); /* 133 */ 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 const char * TclGetEnv(const char *name, Tcl_DString *valuePtr); /* Slot 139 is reserved */ /* Slot 140 is reserved */ /* 141 */ 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 */ EXTERN int TclAddLiteralObj(struct CompileEnv *envPtr, Tcl_Obj *objPtr, LiteralEntry **litPtrPtr); |
︙ | ︙ | |||
397 398 399 400 401 402 403 | /* 156 */ EXTERN void TclRegError(Tcl_Interp *interp, const char *msg, int status); /* 157 */ EXTERN Var * TclVarTraceExists(Tcl_Interp *interp, const char *varName); /* 158 */ | > | > | > | > | | 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 | /* 156 */ EXTERN void TclRegError(Tcl_Interp *interp, const char *msg, int status); /* 157 */ EXTERN Var * TclVarTraceExists(Tcl_Interp *interp, const char *varName); /* 158 */ TCL_DEPRECATED("use public Tcl_SetStartupScript()") void TclSetStartupScriptFileName(const char *filename); /* 159 */ 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 */ EXTERN void TclChannelEventScriptInvoker(ClientData clientData, int flags); /* 163 */ EXTERN const void * TclGetInstructionTable(void); /* 164 */ EXTERN void TclExpandCodeArray(void *envPtr); /* 165 */ EXTERN void TclpSetInitialEncodings(void); /* 166 */ EXTERN int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj *valuePtr); /* 167 */ TCL_DEPRECATED("use public Tcl_SetStartupScript()") void TclSetStartupScriptPath(Tcl_Obj *pathPtr); /* 168 */ 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, const char *command, int numChars, Command *cmdPtr, int result, int traceFlags, |
︙ | ︙ | |||
453 454 455 456 457 458 459 | /* 176 */ EXTERN void TclCleanupVar(Var *varPtr, Var *arrayPtr); /* 177 */ EXTERN void TclVarErrMsg(Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason); /* 178 */ | | | > | > | | 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 | /* 176 */ EXTERN void TclCleanupVar(Var *varPtr, Var *arrayPtr); /* 177 */ EXTERN void TclVarErrMsg(Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason); /* 178 */ EXTERN void TclSetStartupScript(Tcl_Obj *pathPtr, const char *encodingName); /* 179 */ EXTERN Tcl_Obj * TclGetStartupScript(const char **encodingNamePtr); /* Slot 180 is reserved */ /* Slot 181 is reserved */ /* 182 */ TCL_DEPRECATED("") struct tm * TclpLocaltime(const time_t *clock); /* 183 */ 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 */ /* Slot 189 is reserved */ /* Slot 190 is reserved */ |
︙ | ︙ | |||
566 567 568 569 570 571 572 | /* 234 */ EXTERN Var * TclVarHashCreateVar(TclVarHashTable *tablePtr, const char *key, int *newPtr); /* 235 */ EXTERN void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr); /* 236 */ | > | | 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 | /* 234 */ EXTERN Var * TclVarHashCreateVar(TclVarHashTable *tablePtr, const char *key, int *newPtr); /* 235 */ EXTERN void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr); /* 236 */ 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, Tcl_Obj *const objv[]); /* 239 */ |
︙ | ︙ | |||
648 649 650 651 652 653 654 | void (*reserved1)(void); void (*reserved2)(void); 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 */ | | | | 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 | void (*reserved1)(void); void (*reserved2)(void); 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 */ 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); int (*tclDumpMemoryInfo) (ClientData clientData, int flags); /* 14 */ void (*reserved15)(void); void (*tclExprFloatError) (Tcl_Interp *interp, double value); /* 16 */ void (*reserved17)(void); void (*reserved18)(void); 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, Tcl_WideInt n); /* 24 */ void (*tclFreePackageInfo) (Interp *iPtr); /* 25 */ void (*reserved26)(void); void (*reserved27)(void); Tcl_Channel (*tclpGetDefaultStdChannel) (int type); /* 28 */ void (*reserved29)(void); void (*reserved30)(void); const char * (*tclGetExtension) (const char *name); /* 31 */ |
︙ | ︙ | |||
693 694 695 696 697 698 699 | int (*tclInExit) (void); /* 46 */ void (*reserved47)(void); 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); | | | 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 | int (*tclInExit) (void); /* 46 */ void (*reserved47)(void); 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, 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 */ void (*reserved59)(void); int (*tclNeedSpace) (const char *start, const char *end); /* 60 */ |
︙ | ︙ | |||
717 718 719 720 721 722 723 | void (*reserved70)(void); void (*reserved71)(void); void (*reserved72)(void); void (*reserved73)(void); void (*tclpFree) (char *ptr); /* 74 */ unsigned long (*tclpGetClicks) (void); /* 75 */ unsigned long (*tclpGetSeconds) (void); /* 76 */ | | | | | | | | | | | | | | | | | | | | | | | | | | | | 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 | void (*reserved70)(void); void (*reserved71)(void); void (*reserved72)(void); void (*reserved73)(void); void (*tclpFree) (char *ptr); /* 74 */ unsigned long (*tclpGetClicks) (void); /* 75 */ unsigned long (*tclpGetSeconds) (void); /* 76 */ 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); void (*reserved83)(void); void (*reserved84)(void); void (*reserved85)(void); void (*reserved86)(void); void (*reserved87)(void); 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 */ void (*reserved94)(void); void (*reserved95)(void); int (*tclRenameCommand) (Tcl_Interp *interp, const char *oldName, const char *newName); /* 96 */ void (*tclResetShadowedCmdRefs) (Tcl_Interp *interp, Command *newCmdPtr); /* 97 */ int (*tclServiceIdle) (void); /* 98 */ 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 */ 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 (*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 (*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 (*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 */ 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); const char * (*tclGetEnv) (const char *name, Tcl_DString *valuePtr); /* 138 */ void (*reserved139)(void); void (*reserved140)(void); 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 */ void (*tclHandleFree) (TclHandle handle); /* 147 */ TclHandle (*tclHandlePreserve) (TclHandle handle); /* 148 */ void (*tclHandleRelease) (TclHandle handle); /* 149 */ int (*tclRegAbout) (Tcl_Interp *interp, Tcl_RegExp re); /* 150 */ void (*tclRegExpRangeUniChar) (Tcl_RegExp re, int index, int *startPtr, int *endPtr); /* 151 */ void (*tclSetLibraryPath) (Tcl_Obj *pathPtr); /* 152 */ 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 */ 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 */ 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 (*tclSetStartupScript) (Tcl_Obj *pathPtr, const char *encodingName); /* 178 */ Tcl_Obj * (*tclGetStartupScript) (const char **encodingNamePtr); /* 179 */ void (*reserved180)(void); void (*reserved181)(void); 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); void (*reserved189)(void); void (*reserved190)(void); |
︙ | ︙ | |||
876 877 878 879 880 881 882 | int (*tclPtrMakeUpvar) (Tcl_Interp *interp, Var *otherP1Ptr, const char *myName, int myFlags, int index); /* 229 */ Var * (*tclObjLookupVar) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, const char *part2, int flags, const char *msg, const int createPart1, const int createPart2, Var **arrayPtrPtr); /* 230 */ 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 */ | | | 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 | int (*tclPtrMakeUpvar) (Tcl_Interp *interp, Var *otherP1Ptr, const char *myName, int myFlags, int index); /* 229 */ Var * (*tclObjLookupVar) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, const char *part2, int flags, const char *msg, const int createPart1, const int createPart2, Var **arrayPtrPtr); /* 230 */ 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 */ 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 */ int (*tclNREvalObjv) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags, Command *cmdPtr); /* 242 */ void (*tclDbDumpActiveObjects) (FILE *outFile); /* 243 */ |
︙ | ︙ | |||
1084 1085 1086 1087 1088 1089 1090 | (tclIntStubsPtr->tclTeardownNamespace) /* 108 */ #define TclUpdateReturnInfo \ (tclIntStubsPtr->tclUpdateReturnInfo) /* 109 */ #define TclSockMinimumBuffers \ (tclIntStubsPtr->tclSockMinimumBuffers) /* 110 */ #define Tcl_AddInterpResolvers \ (tclIntStubsPtr->tcl_AddInterpResolvers) /* 111 */ | | | | | | | | | | | | | | | | | | | | | | | | | | 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 | (tclIntStubsPtr->tclTeardownNamespace) /* 108 */ #define TclUpdateReturnInfo \ (tclIntStubsPtr->tclUpdateReturnInfo) /* 109 */ #define TclSockMinimumBuffers \ (tclIntStubsPtr->tclSockMinimumBuffers) /* 110 */ #define Tcl_AddInterpResolvers \ (tclIntStubsPtr->tcl_AddInterpResolvers) /* 111 */ #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 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 TclImport \ (tclIntStubsPtr->tclImport) /* 127 */ #define Tcl_PopCallFrame \ (tclIntStubsPtr->tcl_PopCallFrame) /* 128 */ #define Tcl_PushCallFrame \ (tclIntStubsPtr->tcl_PushCallFrame) /* 129 */ #define Tcl_RemoveInterpResolvers \ (tclIntStubsPtr->tcl_RemoveInterpResolvers) /* 130 */ #define Tcl_SetNamespaceResolvers \ |
︙ | ︙ | |||
1206 1207 1208 1209 1210 1211 1212 | /* Slot 174 is reserved */ #define TclCallVarTraces \ (tclIntStubsPtr->tclCallVarTraces) /* 175 */ #define TclCleanupVar \ (tclIntStubsPtr->tclCleanupVar) /* 176 */ #define TclVarErrMsg \ (tclIntStubsPtr->tclVarErrMsg) /* 177 */ | | | | | | 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 | /* Slot 174 is reserved */ #define TclCallVarTraces \ (tclIntStubsPtr->tclCallVarTraces) /* 175 */ #define TclCleanupVar \ (tclIntStubsPtr->tclCleanupVar) /* 176 */ #define TclVarErrMsg \ (tclIntStubsPtr->tclVarErrMsg) /* 177 */ #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 \ (tclIntStubsPtr->tclpGmtime) /* 183 */ /* Slot 184 is reserved */ |
︙ | ︙ | |||
1346 1347 1348 1349 1350 1351 1352 | #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT | > | | | | | < < | < < | < < | < < | < < < < < | < < | < < | < < | | < | < < < < < | < < | | | | | < < < < | 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 | #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT #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 #endif /* _TCLINTDECLS */ |
Changes to generic/tclIntPlatDecls.h.
︙ | ︙ | |||
551 552 553 554 555 556 557 | #define TclpInetNtoa inet_ntoa #if defined(_WIN32) # undef TclWinNToHS # undef TclWinGetServByName # undef TclWinGetSockOpt # undef TclWinSetSockOpt | > > > > | | | | > > > > | 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 | #define TclpInetNtoa inet_ntoa #if defined(_WIN32) # undef TclWinNToHS # undef TclWinGetServByName # undef TclWinGetSockOpt # undef TclWinSetSockOpt # 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 #endif /* _TCLINTPLATDECLS */ |
Changes to generic/tclInterp.c.
︙ | ︙ | |||
3204 3205 3206 3207 3208 3209 3210 | * master; the overall implementations are safe, but they're normally * defined by init.tcl which is not sourced by safe interpreters. * Assume these functions all work. [Bug 2895741] */ (void) Tcl_EvalEx(interp, "namespace eval ::tcl {namespace eval mathfunc {}}", -1, 0); | < < < < | 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 | * master; the overall implementations are safe, but they're normally * defined by init.tcl which is not sourced by safe interpreters. * Assume these functions all work. [Bug 2895741] */ (void) Tcl_EvalEx(interp, "namespace eval ::tcl {namespace eval mathfunc {}}", -1, 0); } iPtr->flags |= SAFE_INTERP; /* * Unsetting variables : (which should not have been set in the first * place, but...) |
︙ | ︙ |
Changes to generic/tclLink.c.
︙ | ︙ | |||
650 651 652 653 654 655 656 | static int SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static Tcl_ObjType invalidRealType = { "invalidReal", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ NULL, /* updateStringProc */ | | | 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 | static int SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static Tcl_ObjType invalidRealType = { "invalidReal", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ NULL, /* updateStringProc */ NULL /* setFromAnyProc */ }; static int SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr) { const char *str; const char *endPtr; |
︙ | ︙ |
Changes to generic/tclListObj.c.
︙ | ︙ | |||
51 52 53 54 55 56 57 | #endif /* *---------------------------------------------------------------------- * * NewListIntRep -- * | | | | | | < | | | | < | | | 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 | #endif /* *---------------------------------------------------------------------- * * NewListIntRep -- * * 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. * * 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 * NewListIntRep( int objc, |
︙ | ︙ | |||
130 131 132 133 134 135 136 | } return listRepPtr; } /* *---------------------------------------------------------------------- * | | > > > > > > > | > | > > > > | 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 | } return listRepPtr; } /* *---------------------------------------------------------------------- * * AttemptNewList -- * * 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( Tcl_Interp *interp, int objc, |
︙ | ︙ | |||
165 166 167 168 169 170 171 | } /* *---------------------------------------------------------------------- * * Tcl_NewListObj -- * | > | < > > < > > > | | | | | < | | | 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 | } /* *---------------------------------------------------------------------- * * Tcl_NewListObj -- * * 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 #undef Tcl_NewListObj |
︙ | ︙ | |||
229 230 231 232 233 234 235 | return listPtr; } #endif /* if TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * | | | > > > | | | | | | > > > > > > > > > > > | 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 | return listPtr; } #endif /* if TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * * 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 Tcl_Obj * |
︙ | ︙ | |||
297 298 299 300 301 302 303 | #endif /* TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * * Tcl_SetListObj -- * | | > > > | > > > > > > > > | 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 | #endif /* TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * * Tcl_SetListObj -- * * 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 Tcl_SetListObj( Tcl_Obj *objPtr, /* Object whose internal rep to init. */ |
︙ | ︙ | |||
342 343 344 345 346 347 348 | } /* *---------------------------------------------------------------------- * * TclListObjCopy -- * | | | | | | | | | < | | < | 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 | } /* *---------------------------------------------------------------------- * * TclListObjCopy -- * * 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 * TclListObjCopy( Tcl_Interp *interp, /* Used to report errors if not NULL. */ |
︙ | ︙ | |||
385 386 387 388 389 390 391 | } /* *---------------------------------------------------------------------- * * Tcl_ListObjGetElements -- * | | | < < | > | | > > > | | | | | | < < < < < | < > | | 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 | } /* *---------------------------------------------------------------------- * * Tcl_ListObjGetElements -- * * 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 Tcl_ListObjGetElements( Tcl_Interp *interp, /* Used to report errors if not NULL. */ |
︙ | ︙ | |||
449 450 451 452 453 454 455 | } /* *---------------------------------------------------------------------- * * Tcl_ListObjAppendList -- * | | > | < | < < < | < < | | < | | | | | < | 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 | } /* *---------------------------------------------------------------------- * * Tcl_ListObjAppendList -- * * 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 Tcl_ListObjAppendList( Tcl_Interp *interp, /* Used to report errors if not NULL. */ |
︙ | ︙ | |||
508 509 510 511 512 513 514 | } /* *---------------------------------------------------------------------- * * Tcl_ListObjAppendElement -- * | | > > > | < | < | < < < | | | | < < | > | | | | 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 | } /* *---------------------------------------------------------------------- * * Tcl_ListObjAppendElement -- * * 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 Tcl_ListObjAppendElement( Tcl_Interp *interp, /* Used to report errors if not NULL. */ |
︙ | ︙ | |||
679 680 681 682 683 684 685 | } /* *---------------------------------------------------------------------- * * Tcl_ListObjIndex -- * | | | | | > | < | | | | | < | < < | | < | | 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 | } /* *---------------------------------------------------------------------- * * Tcl_ListObjIndex -- * * 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 Tcl_ListObjIndex( Tcl_Interp *interp, /* Used to report errors if not NULL. */ |
︙ | ︙ | |||
741 742 743 744 745 746 747 | } /* *---------------------------------------------------------------------- * * Tcl_ListObjLength -- * | | > > | < | < | > > | < < | | < | 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 | } /* *---------------------------------------------------------------------- * * Tcl_ListObjLength -- * * 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 Tcl_ListObjLength( Tcl_Interp *interp, /* Used to report errors if not NULL. */ |
︙ | ︙ | |||
790 791 792 793 794 795 796 | } /* *---------------------------------------------------------------------- * * Tcl_ListObjReplace -- * | | > > > | | | < > | | < < < | | | > > > | < | | | < < | < | < > | | | 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 | } /* *---------------------------------------------------------------------- * * Tcl_ListObjReplace -- * * 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 Tcl_ListObjReplace( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ |
︙ | ︙ | |||
1077 1078 1079 1080 1081 1082 1083 | } /* *---------------------------------------------------------------------- * * TclLindexList -- * | | | | | | | | < < | > > > > > | 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 | } /* *---------------------------------------------------------------------- * * TclLindexList -- * * 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 * TclLindexList( Tcl_Interp *interp, /* Tcl interpreter. */ |
︙ | ︙ | |||
1161 1162 1163 1164 1165 1166 1167 | Tcl_DecrRefCount(indexListCopy); return listPtr; } /* *---------------------------------------------------------------------- * | | | | | > > > < < > | > > > > | | < | 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 | Tcl_DecrRefCount(indexListCopy); return listPtr; } /* *---------------------------------------------------------------------- * * 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 * TclLindexFlat( Tcl_Interp *interp, /* Tcl interpreter. */ |
︙ | ︙ | |||
1250 1251 1252 1253 1254 1255 1256 | } /* *---------------------------------------------------------------------- * * TclLsetList -- * | | | > > | | > < > | > > > > | 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 | } /* *---------------------------------------------------------------------- * * TclLsetList -- * * Core of the 'lset' command when objc == 4. Objv[2] may be either a * scalar index or a list of indices. * * 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. * * Side effects: * None. * * 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 * TclLsetList( Tcl_Interp *interp, /* Tcl interpreter. */ |
︙ | ︙ | |||
1321 1322 1323 1324 1325 1326 1327 | /* *---------------------------------------------------------------------- * * TclLsetFlat -- * * Core engine of the 'lset' command. * | | | > | < > | > | | < < | < < | | | | | < < < | < | | > | | > > | | | | 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 | /* *---------------------------------------------------------------------- * * TclLsetFlat -- * * Core engine of the 'lset' command. * * 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 * values of 'ptr2' are immaterial; on exit, the 'ptr2' field of any * Tcl_Obj that has been modified is set to NULL. * *---------------------------------------------------------------------- */ Tcl_Obj * |
︙ | ︙ | |||
1568 1569 1570 1571 1572 1573 1574 | } /* *---------------------------------------------------------------------- * * TclListObjSetElement -- * | | < < < | < | < < < < < | | < < < < | | | | | < | | < > | | > > | 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 | } /* *---------------------------------------------------------------------- * * TclListObjSetElement -- * * 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 object. * *---------------------------------------------------------------------- */ int TclListObjSetElement( Tcl_Interp *interp, /* Tcl interpreter; used for error reporting |
︙ | ︙ | |||
1717 1718 1719 1720 1721 1722 1723 | } /* *---------------------------------------------------------------------- * * FreeListInternalRep -- * | | | | > > | | | | 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 | } /* *---------------------------------------------------------------------- * * FreeListInternalRep -- * * 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 FreeListInternalRep( Tcl_Obj *listPtr) /* List object with internal rep to free. */ |
︙ | ︙ | |||
1753 1754 1755 1756 1757 1758 1759 | } /* *---------------------------------------------------------------------- * * DupListInternalRep -- * | | | > > | | | < | < | < > | < | < | | 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 | } /* *---------------------------------------------------------------------- * * DupListInternalRep -- * * Initialize the internal representation of a list Tcl_Obj to share the * internal representation of an existing list object. * * Results: * None. * * Side effects: * The reference count of the List internal rep is incremented. * *---------------------------------------------------------------------- */ static void DupListInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { List *listRepPtr = ListRepPtr(srcPtr); ListSetIntRep(copyPtr, listRepPtr); } /* *---------------------------------------------------------------------- * * SetListFromAny -- * * 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 SetListFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ |
︙ | ︙ | |||
1916 1917 1918 1919 1920 1921 1922 | } /* *---------------------------------------------------------------------- * * UpdateStringOfList -- * | | < | | | > | > | | > | | | 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 | } /* *---------------------------------------------------------------------- * * UpdateStringOfList -- * * 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 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; Tcl_Obj **elemPtrs; |
︙ | ︙ | |||
1972 1973 1974 1975 1976 1977 1978 | if (numElems <= LOCAL_SIZE) { flagPtr = localFlags; } else { /* * We know numElems <= LIST_MAX, so this is safe. */ | | | 1991 1992 1993 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 | if (numElems <= LOCAL_SIZE) { flagPtr = localFlags; } else { /* * We know numElems <= LIST_MAX, so this is safe. */ 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); bytesNeeded += TclScanElement(elem, length, flagPtr+i); if (bytesNeeded < 0) { |
︙ | ︙ |
Changes to generic/tclLiteral.c.
︙ | ︙ | |||
182 183 184 185 186 187 188 | int *newPtr, Namespace *nsPtr, int flags, LiteralEntry **globalPtrPtr) { LiteralTable *globalTablePtr = &iPtr->literalTable; LiteralEntry *globalPtr; | | | 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 | int *newPtr, Namespace *nsPtr, int flags, LiteralEntry **globalPtrPtr) { LiteralTable *globalTablePtr = &iPtr->literalTable; LiteralEntry *globalPtr; unsigned int globalHash; Tcl_Obj *objPtr; /* * Is it in the interpreter's global literal table? */ if (hash == (unsigned) -1) { |
︙ | ︙ | |||
389 390 391 392 393 394 395 | { CompileEnv *envPtr = ePtr; Interp *iPtr = envPtr->iPtr; LiteralTable *localTablePtr = &envPtr->localLitTable; LiteralEntry *globalPtr, *localPtr; Tcl_Obj *objPtr; unsigned hash; | > | | 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 | { CompileEnv *envPtr = ePtr; Interp *iPtr = envPtr->iPtr; LiteralTable *localTablePtr = &envPtr->localLitTable; LiteralEntry *globalPtr, *localPtr; Tcl_Obj *objPtr; unsigned hash; unsigned int localHash; int objIndex, new; Namespace *nsPtr; if (length < 0) { length = (bytes ? strlen(bytes) : 0); } hash = HashString(bytes, length); |
︙ | ︙ | |||
533 534 535 536 537 538 539 | register CompileEnv *envPtr,/* Points to CompileEnv whose literal array * contains the entry being hidden. */ int index) /* The index of the entry in the literal * array. */ { LiteralEntry **nextPtrPtr, *entryPtr, *lPtr; LiteralTable *localTablePtr = &envPtr->localLitTable; | | > | | 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 | register CompileEnv *envPtr,/* Points to CompileEnv whose literal array * contains the entry being hidden. */ int index) /* The index of the entry in the literal * array. */ { LiteralEntry **nextPtrPtr, *entryPtr, *lPtr; LiteralTable *localTablePtr = &envPtr->localLitTable; unsigned int localHash; int length; const char *bytes; Tcl_Obj *newObjPtr; lPtr = &envPtr->literalArrayPtr[index]; /* * To avoid unwanted sharing we need to copy the object and remove it from * the local and global literal tables. It still has a slot in the literal * array so it can be referred to by byte codes, but it will not be * matched by literal searches. */ newObjPtr = Tcl_DuplicateObj(lPtr->objPtr); Tcl_IncrRefCount(newObjPtr); TclReleaseLiteral(interp, lPtr->objPtr); lPtr->objPtr = newObjPtr; bytes = TclGetStringFromObj(newObjPtr, &length); localHash = HashString(bytes, length) & localTablePtr->mask; nextPtrPtr = &localTablePtr->buckets[localHash]; for (entryPtr=*nextPtrPtr ; entryPtr!=NULL ; entryPtr=*nextPtrPtr) { if (entryPtr == lPtr) { *nextPtrPtr = lPtr->nextPtr; lPtr->nextPtr = NULL; localTablePtr->numEntries--; |
︙ | ︙ | |||
608 609 610 611 612 613 614 | } objIndex = envPtr->literalArrayNext; envPtr->literalArrayNext++; lPtr = &envPtr->literalArrayPtr[objIndex]; lPtr->objPtr = objPtr; Tcl_IncrRefCount(objPtr); | | | 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 | } objIndex = envPtr->literalArrayNext; envPtr->literalArrayNext++; lPtr = &envPtr->literalArrayPtr[objIndex]; lPtr->objPtr = objPtr; Tcl_IncrRefCount(objPtr); lPtr->refCount = (size_t)-1; /* i.e., unused */ lPtr->nextPtr = NULL; if (litPtrPtr) { *litPtrPtr = lPtr; } return objIndex; |
︙ | ︙ | |||
805 806 807 808 809 810 811 | * previously created by a call to * TclRegisterLiteral. */ { Interp *iPtr = (Interp *) interp; LiteralTable *globalTablePtr; register LiteralEntry *entryPtr, *prevPtr; const char *bytes; | | > < < | | 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 | * previously created by a call to * TclRegisterLiteral. */ { Interp *iPtr = (Interp *) interp; LiteralTable *globalTablePtr; register LiteralEntry *entryPtr, *prevPtr; const char *bytes; int length; unsigned int index; if (iPtr == NULL) { goto done; } globalTablePtr = &iPtr->literalTable; bytes = TclGetStringFromObj(objPtr, &length); index = (HashString(bytes, length) & globalTablePtr->mask); /* * Check to see if the object is in the global literal table and remove * this reference. The object may not be in the table if it is a hidden * local literal. */ for (prevPtr=NULL, entryPtr=globalTablePtr->buckets[index]; entryPtr!=NULL ; prevPtr=entryPtr, entryPtr=entryPtr->nextPtr) { if (entryPtr->objPtr == objPtr) { /* * 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-- <= 1) { if (prevPtr == NULL) { globalTablePtr->buckets[index] = entryPtr->nextPtr; } else { prevPtr->nextPtr = entryPtr->nextPtr; } ckfree(entryPtr); globalTablePtr->numEntries--; |
︙ | ︙ | |||
950 951 952 953 954 955 956 | /* Local or global table to enlarge. */ { LiteralEntry **oldBuckets; register LiteralEntry **oldChainPtr, **newChainPtr; register LiteralEntry *entryPtr; LiteralEntry **bucketPtr; const char *bytes; | | | | 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 | /* Local or global table to enlarge. */ { LiteralEntry **oldBuckets; register LiteralEntry **oldChainPtr, **newChainPtr; register LiteralEntry *entryPtr; LiteralEntry **bucketPtr; const char *bytes; unsigned int oldSize, index; int count, length; oldSize = tablePtr->numBuckets; oldBuckets = tablePtr->buckets; /* * Allocate and initialize the new bucket array, and set up hashing * constants for new array size. |
︙ | ︙ |
Changes to generic/tclLoad.c.
︙ | ︙ | |||
466 467 468 469 470 471 472 | /* * Test for whether the initialization failed. If so, transfer the error * from the target interpreter to the originating one. */ if (code != TCL_OK) { | < < < < < < < < < < < | 466 467 468 469 470 471 472 473 474 475 476 477 478 479 | /* * Test for whether the initialization failed. If so, transfer the error * from the target interpreter to the originating one. */ if (code != TCL_OK) { Tcl_TransferResult(target, code, interp); goto done; } /* * Record the fact that the package has been loaded in the target * interpreter. |
︙ | ︙ |
Changes to generic/tclMain.c.
︙ | ︙ | |||
262 263 264 265 266 267 268 | } else { /* * Test for the existence of the rc file before trying to read it. */ c = Tcl_OpenFileChannel(NULL, fullName, "r", 0); if (c != NULL) { | < < < | < | 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 | } else { /* * Test for the existence of the rc file before trying to read it. */ c = Tcl_OpenFileChannel(NULL, fullName, "r", 0); if (c != NULL) { Tcl_Close(NULL, c); 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_DStringFree(&temp); } } #endif /* !TCL_ASCII_MAIN */ |
︙ | ︙ |
Changes to generic/tclNamesp.c.
︙ | ︙ | |||
28 29 30 31 32 33 34 | /* * Thread-local storage used to avoid having a global lock on data that is not * limited to a single interpreter. */ typedef struct { | | | 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | /* * Thread-local storage used to avoid having a global lock on data that is not * limited to a single interpreter. */ typedef struct { 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, * but does not need to be global because * object internal reps are always per-thread |
︙ | ︙ | |||
398 399 400 401 402 403 404 | if (framePtr->varTablePtr != NULL) { TclDeleteVars(iPtr, framePtr->varTablePtr); ckfree(framePtr->varTablePtr); framePtr->varTablePtr = NULL; } if (framePtr->numCompiledLocals > 0) { TclDeleteCompiledLocalVars(iPtr, framePtr); | | | 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 | if (framePtr->varTablePtr != NULL) { TclDeleteVars(iPtr, framePtr->varTablePtr); ckfree(framePtr->varTablePtr); framePtr->varTablePtr = NULL; } if (framePtr->numCompiledLocals > 0) { TclDeleteCompiledLocalVars(iPtr, framePtr); if (framePtr->localCachePtr->refCount-- <= 1) { TclFreeLocalCache(interp, framePtr->localCachePtr); } framePtr->localCachePtr = NULL; } /* * Decrement the namespace's count of active call frames. If the namespace |
︙ | ︙ | |||
911 912 913 914 915 916 917 918 919 920 921 922 923 924 | Interp *iPtr = (Interp *) nsPtr->interp; Namespace *globalNsPtr = (Namespace *) TclGetGlobalNamespace((Tcl_Interp *) iPtr); Tcl_HashEntry *entryPtr; Tcl_HashSearch search; Command *cmdPtr; /* * 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] * * Note that setting this field requires access to the internal definition | > > > > > | 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 | Interp *iPtr = (Interp *) nsPtr->interp; Namespace *globalNsPtr = (Namespace *) 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] * * Note that setting this field requires access to the internal definition |
︙ | ︙ | |||
1043 1044 1045 1046 1047 1048 1049 | if (nsPtr->childTablePtr != NULL) { Tcl_DeleteHashTable(nsPtr->childTablePtr); ckfree(nsPtr->childTablePtr); } #endif Tcl_DeleteHashTable(&nsPtr->cmdTable); | < < < < < < < < | < > | 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 | if (nsPtr->childTablePtr != NULL) { Tcl_DeleteHashTable(nsPtr->childTablePtr); ckfree(nsPtr->childTablePtr); } #endif Tcl_DeleteHashTable(&nsPtr->cmdTable); nsPtr ->flags |= NS_DEAD; } else { /* * Restore the ::errorInfo and ::errorCode traces. */ EstablishErrorInfoTraces(NULL, nsPtr->interp, NULL, NULL, 0); EstablishErrorCodeTraces(NULL, nsPtr->interp, NULL, NULL, 0); /* * We didn't really kill it, so remove the KILLED marks, so it can * get killed later, avoiding mem leaks. */ nsPtr->flags &= ~(NS_DYING|NS_KILLED); } } TclNsDecrRefCount(nsPtr); } /* *---------------------------------------------------------------------- * * TclTeardownNamespace -- * |
︙ | ︙ | |||
2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 | Tcl_DStringFree(&buffer); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_FindNamespace -- * * Searches for a namespace. * * Results: * Returns a pointer to the namespace if it is found. Otherwise, returns * NULL and leaves an error message in the interpreter's result object if | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 2430 2431 2432 2433 2434 2435 2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 | Tcl_DStringFree(&buffer); return TCL_OK; } /* *---------------------------------------------------------------------- * * 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: * Returns a pointer to the namespace if it is found. Otherwise, returns * NULL and leaves an error message in the interpreter's result object if |
︙ | ︙ | |||
2634 2635 2636 2637 2638 2639 2640 | } } } } else { Namespace *nsPtr[2]; register int search; | | | 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 | } } } } else { Namespace *nsPtr[2]; register int search; 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 * context and from the global namespace. */ |
︙ | ︙ |
Changes to generic/tclOO.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 | /* * tclOO.c -- * * This file contains the object-system core (NB: not Tcl_Obj, but ::oo) * * Copyright (c) 2005-2012 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #ifdef HAVE_CONFIG_H #include "config.h" | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | /* * 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. */ #ifdef HAVE_CONFIG_H #include "config.h" |
︙ | ︙ | |||
54 55 56 57 58 59 60 | /* * 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, | | < < > > > > > > < | 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 | /* * 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, 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); static void DeletedDefineNamespace(ClientData clientData); 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 int PublicObjectCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static int PublicNRObjectCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); |
︙ | ︙ | |||
224 225 226 227 228 229 230 | * * The ocPtr parameter (only in these macros) is assumed to work fine with * 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. */ | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 | * * The ocPtr parameter (only in these macros) is assumed to work fine with * 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) ((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 -- * * Called to initialise the OO system within an interpreter. |
︙ | ︙ | |||
371 372 373 374 375 376 377 | objdefCmds[i].objProc, INT2PTR(objdefCmds[i].flag), NULL); Tcl_DStringFree(&buffer); } Tcl_CallWhenDeleted(interp, KillFoundation, NULL); /* | | < < < < | < < < < < < < < < < < < < < | 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 | objdefCmds[i].objProc, INT2PTR(objdefCmds[i].flag), NULL); Tcl_DStringFree(&buffer); } Tcl_CallWhenDeleted(interp, KillFoundation, NULL); /* * Create the special objects at the core of the object system. */ InitClassSystemRoots(interp, fPtr); /* * Basic method declarations for the core classes. */ for (i=0 ; objMethods[i].name ; i++) { TclOONewBasicMethod(interp, fPtr->objectCls, &objMethods[i]); |
︙ | ︙ | |||
459 460 461 462 463 464 465 466 467 468 469 470 471 472 | */ if (TclOODefineSlots(fPtr) != TCL_OK) { return TCL_ERROR; } return Tcl_EvalEx(interp, slotScript, -1, 0); } /* * ---------------------------------------------------------------------- * * DeletedDefineNamespace, DeletedObjdefNamespace, DeletedHelpersNamespace -- * * Simple helpers used to clear fields of the foundation when they no | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 | */ 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 -- * * Simple helpers used to clear fields of the foundation when they no |
︙ | ︙ | |||
518 519 520 521 522 523 524 | ClientData clientData, /* Pointer to the OO system foundation * structure. */ Tcl_Interp *interp) /* The interpreter containing the OO system * foundation. */ { Foundation *fPtr = GetFoundation(interp); | < < | > > > | > > | | < | < | 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 | ClientData clientData, /* Pointer to the OO system foundation * structure. */ Tcl_Interp *interp) /* The interpreter containing the OO system * foundation. */ { Foundation *fPtr = GetFoundation(interp); TclDecrRefCount(fPtr->unknownMethodNameObj); TclDecrRefCount(fPtr->constructorName); TclDecrRefCount(fPtr->destructorName); TclDecrRefCount(fPtr->clonedName); TclDecrRefCount(fPtr->defineName); ckfree(fPtr); } /* * ---------------------------------------------------------------------- * * 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 * 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 * AllocObject( Tcl_Interp *interp, /* Interpreter within which to create the * 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. */ { Foundation *fPtr = GetFoundation(interp); Object *oPtr; Command *cmdPtr; CommandTrace *tracePtr; int creationEpoch; oPtr = ckalloc(sizeof(Object)); memset(oPtr, 0, sizeof(Object)); /* * Every object has a namespace; make one. Note that this also normally * computes the creation epoch value for the object, a sequence number * that is unique to the object (and which allows us to manage method * caching without comparing pointers). * * When creating a namespace, we first check to see if the caller * specified the name for the namespace. If not, we generate namespace * names using the epoch until such time as a new namespace is actually * created. */ if (nsNameStr != NULL) { oPtr->namespacePtr = Tcl_CreateNamespace(interp, nsNameStr, oPtr, NULL); if (oPtr->namespacePtr != NULL) { creationEpoch = ++fPtr->tsdPtr->nsCount; goto configNamespace; } Tcl_ResetResult(interp); } while (1) { char objName[10 + TCL_INTEGER_SPACE]; sprintf(objName, "::oo::Obj%d", ++fPtr->tsdPtr->nsCount); oPtr->namespacePtr = Tcl_CreateNamespace(interp, objName, oPtr, NULL); if (oPtr->namespacePtr != NULL) { creationEpoch = fPtr->tsdPtr->nsCount; break; } /* * Could not make that namespace, so we make another. But first we |
︙ | ︙ | |||
630 631 632 633 634 635 636 | /* * 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] */ | | < > > > > > > > | | | | | < < < | | < < < < < < < > > < < < < | < < < < < < < < < < < | < < < | 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 | /* * 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 = ObjectNamespaceDeleted; /* * Fill in the rest of the non-zero/NULL parts of the structure. */ oPtr->fPtr = fPtr; oPtr->creationEpoch = creationEpoch; /* * 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) { 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. */ cmdPtr = (Command *) oPtr->command; cmdPtr->nreProc = PublicNRObjectCmd; cmdPtr->tracePtr = tracePtr = ckalloc(sizeof(CommandTrace)); tracePtr->traceProc = ObjectRenamedTrace; tracePtr->clientData = oPtr; tracePtr->flags = TCL_TRACE_RENAME|TCL_TRACE_DELETE; tracePtr->nextPtr = NULL; tracePtr->refCount = 1; oPtr->myCommand = TclNRCreateCommandInNs(interp, "my", oPtr->namespacePtr, PrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted); return oPtr; } /* * ---------------------------------------------------------------------- * * SquelchCachedName -- |
︙ | ︙ | |||
751 752 753 754 755 756 757 | oPtr->myCommand = NULL; } /* * ---------------------------------------------------------------------- * | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | < < < < < < | < < < < < < < < < < < < < < < < < < < < < | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | > < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 | oPtr->myCommand = NULL; } /* * ---------------------------------------------------------------------- * * 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 * object data structures. * * ---------------------------------------------------------------------- */ static void ObjectRenamedTrace( ClientData clientData, /* The object being deleted. */ Tcl_Interp *interp, /* The interpreter containing the object. */ 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; /* * If this is a rename and not a delete of the object, we just flush the * cache of the object name. */ if (flags & TCL_TRACE_RENAME) { SquelchCachedName(oPtr); return; } /* * The namespace is only deleted if it hasn't already been deleted. [Bug * 2950259]. */ if (!Deleted(oPtr)) { Tcl_DeleteNamespace(oPtr->namespacePtr); } 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, *tmpClsPtr; Method *mPtr; Foundation *fPtr = oPtr->fPtr; Tcl_Obj *variableObj; /* * Sanity check! */ if (!Deleted(oPtr)) { if (IsRootClass(oPtr)) { Tcl_Panic("deleting class structure for non-deleted %s", "::oo::class"); } else if (IsRootObject(oPtr)) { Tcl_Panic("deleting class structure for non-deleted %s", "::oo::object"); } else { Tcl_Panic("deleting class structure for non-deleted %s", "general object"); } } /* * Squelch method implementation chain caches. */ if (clsPtr->constructorChainPtr) { TclOODeleteChain(clsPtr->constructorChainPtr); clsPtr->constructorChainPtr = NULL; |
︙ | ︙ | |||
1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 | FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) { metadataTypePtr->deleteProc(value); } Tcl_DeleteHashTable(clsPtr->metadataPtr); ckfree(clsPtr->metadataPtr); clsPtr->metadataPtr = NULL; } } /* * ---------------------------------------------------------------------- * * ObjectNamespaceDeleted -- * | > > > > > > > > > > > > > > > > > > > > > > > > > | 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 | FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) { metadataTypePtr->deleteProc(value); } 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); } } /* * ---------------------------------------------------------------------- * * ObjectNamespaceDeleted -- * |
︙ | ︙ | |||
1171 1172 1173 1174 1175 1176 1177 1178 | static void ObjectNamespaceDeleted( ClientData clientData) /* Pointer to the class whose namespace is * being deleted. */ { Object *oPtr = clientData; FOREACH_HASH_DECLS; | > | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | < | | > | < < | < | > > > > > > > > | | | < < | < | 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 | static void ObjectNamespaceDeleted( ClientData clientData) /* Pointer to the class whose namespace is * being deleted. */ { Object *oPtr = clientData; Foundation *fPtr = oPtr->fPtr; FOREACH_HASH_DECLS; Class *mixinPtr; Method *mPtr; Tcl_Obj *filterObj, *variableObj; 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 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 (((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. */ /* * TODO: Should this be protected with a * !IsRoot() condition? */ TclOORemoveFromInstances(oPtr, oPtr->selfCls); FOREACH(mixinPtr, oPtr->mixins) { i -= TclOORemoveFromInstances(oPtr, mixinPtr); } if (i) { ckfree(oPtr->mixins.list); } FOREACH(filterObj, oPtr->filters) { TclDecrRefCount(filterObj); |
︙ | ︙ | |||
1259 1260 1261 1262 1263 1264 1265 | } Tcl_DeleteHashTable(oPtr->metadataPtr); ckfree(oPtr->metadataPtr); oPtr->metadataPtr = NULL; } /* | | < | < | < | < < < < < < < < | < < < < < < < | < | | | < < < < < < < < < < < < < < < | < < | > | < < | < < | < < | | | < < | > > > > | > > > > > > > > > > > > > > | > > > | > > > > > > > | > > > > | | | < < < < | | < < < < | | < > | | | < > < > < < < > | | | | > > > > | > > | < < < < < < < < < < | 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 | } Tcl_DeleteHashTable(oPtr->metadataPtr); ckfree(oPtr->metadataPtr); oPtr->metadataPtr = NULL; } /* * 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 (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. */ 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; } /* * ---------------------------------------------------------------------- * * TclOORemoveFromInstances -- * * Utility function to remove an object from the list of instances within * a class. * * ---------------------------------------------------------------------- */ int TclOORemoveFromInstances( Object *oPtr, /* The instance to remove. */ Class *clsPtr) /* The class (possibly) containing the * reference to the instance. */ { int i, res = 0; Object *instPtr; if (Deleted(clsPtr->thisPtr)) { return res; } FOREACH(instPtr, clsPtr->instances) { if (oPtr == instPtr) { RemoveItem(Object, clsPtr->instances, i); TclOODecrRefCount(oPtr); res++; break; } } return res; } /* * ---------------------------------------------------------------------- * * TclOOAddToInstances -- * * Utility function to add an object to the list of instances within a * class. * * ---------------------------------------------------------------------- */ void TclOOAddToInstances( 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 (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 { 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. Returns the number of removals performed. * * ---------------------------------------------------------------------- */ int TclOORemoveFromSubclasses( Class *subPtr, /* The subclass to remove. */ Class *superPtr) /* The superclass to possibly remove the * subclass reference from. */ { int i, res = 0; Class *subclsPtr; if (Deleted(superPtr->thisPtr)) { return res; } FOREACH(subclsPtr, superPtr->subclasses) { if (subPtr == subclsPtr) { RemoveItem(Class, superPtr->subclasses, i); TclOODecrRefCount(subPtr->thisPtr); res++; } } return res; } /* * ---------------------------------------------------------------------- * * TclOOAddToSubclasses -- * |
︙ | ︙ | |||
1471 1472 1473 1474 1475 1476 1477 | { if (Deleted(superPtr->thisPtr)) { return; } if (superPtr->subclasses.num >= superPtr->subclasses.size) { superPtr->subclasses.size += ALLOC_CHUNK; if (superPtr->subclasses.size == ALLOC_CHUNK) { | | > | | | > > > > | > > > | < < < < < < < < < < | 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 | { if (Deleted(superPtr->thisPtr)) { 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); } else { superPtr->subclasses.list = ckrealloc(superPtr->subclasses.list, sizeof(Class *) * superPtr->subclasses.size); } } superPtr->subclasses.list[superPtr->subclasses.num++] = subPtr; AddRef(subPtr->thisPtr); } /* * ---------------------------------------------------------------------- * * TclOORemoveFromMixinSubs -- * * Utility function to remove a class from the list of mixinSubs within * another class. * * ---------------------------------------------------------------------- */ int TclOORemoveFromMixinSubs( Class *subPtr, /* The subclass to remove. */ Class *superPtr) /* The superclass to possibly remove the * subclass reference from. */ { int i, res = 0; Class *subclsPtr; if (Deleted(superPtr->thisPtr)) { return res; } FOREACH(subclsPtr, superPtr->mixinSubs) { if (subPtr == subclsPtr) { RemoveItem(Class, superPtr->mixinSubs, i); TclOODecrRefCount(subPtr->thisPtr); res++; break; } } return res; } /* * ---------------------------------------------------------------------- * * TclOOAddToMixinSubs -- * |
︙ | ︙ | |||
1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 | superPtr->mixinSubs.list = ckalloc(sizeof(Class *) * ALLOC_CHUNK); } else { superPtr->mixinSubs.list = ckrealloc(superPtr->mixinSubs.list, sizeof(Class *) * superPtr->mixinSubs.size); } } superPtr->mixinSubs.list[superPtr->mixinSubs.num++] = subPtr; } /* * ---------------------------------------------------------------------- * * AllocClass -- * | > | | | | | < < < < < < < < < < < < < < < < < < < | > > > > > > > > > > > > > > < < > | > < < < | < < < < < < | < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | < < < < < | | < < < | > | < > < < < < < < < < < < < < < < | 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 | superPtr->mixinSubs.list = ckalloc(sizeof(Class *) * ALLOC_CHUNK); } else { 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 add class to its * class's instance list. * * ---------------------------------------------------------------------- */ static inline void InitClassPath( Tcl_Interp *interp, Class *clsPtr) { Foundation *fPtr = GetFoundation(interp); if (fPtr->helpersNs != NULL) { Tcl_Namespace *path[2]; path[0] = fPtr->helpersNs; path[1] = fPtr->ooNs; 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; /* * Configure the namespace path for the class's object. */ 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. */ clsPtr->thisPtr->classPtr = clsPtr; /* * That's the complicated bit. Now fill in the rest of the non-zero/NULL * fields. */ Tcl_InitObjHashTable(&clsPtr->classMethods); return clsPtr; } /* * ---------------------------------------------------------------------- * * Tcl_NewObjectInstance -- * * 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 * the code to pick its own unique name. */ const char *nsNameStr, /* Name of namespace to create inside object, * or NULL to ask the code to pick its own * unique name. */ int objc, /* Number of arguments. Negative value means * do not call constructor. */ Tcl_Obj *const *objv, /* Argument list. */ int skip) /* Number of arguments to _not_ pass to the * constructor. */ { register Class *classPtr = (Class *) cls; Object *oPtr; ClientData clientData[4]; oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr); if (oPtr == NULL) { return NULL; } /* * 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); if (contextPtr != NULL) { int isRoot, result; Tcl_InterpState state; state = Tcl_SaveInterpState(interp, TCL_OK); contextPtr->callPtr->flags |= CONSTRUCTOR; contextPtr->skip = skip; /* * Adjust the ensemble tracking record if necessary. [Bug 3514761] */ isRoot = TclInitRewriteEnsemble(interp, skip, skip, objv); result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr, objc, objv); if (isRoot) { TclResetRewriteEnsemble(interp, 1); } clientData[0] = contextPtr; clientData[1] = oPtr; clientData[2] = state; clientData[3] = &oPtr; result = FinalizeAlloc(clientData, interp, result); if (result != TCL_OK) { return NULL; } } } return (Tcl_Object) oPtr; } int |
︙ | ︙ | |||
1785 1786 1787 1788 1789 1790 1791 | Tcl_Obj *const *objv, /* Argument list. */ int skip, /* Number of arguments to _not_ pass to the * constructor. */ Tcl_Object *objectPtr) /* Place to write the object reference upon * successful allocation. */ { register Class *classPtr = (Class *) cls; | < < < < < | < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | < < | > > > > > | > > > > > | 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 | Tcl_Obj *const *objv, /* Argument list. */ int skip, /* Number of arguments to _not_ pass to the * constructor. */ Tcl_Object *objectPtr) /* Place to write the object reference upon * successful allocation. */ { register Class *classPtr = (Class *) cls; CallContext *contextPtr; Tcl_InterpState state; Object *oPtr; oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr); if (oPtr == NULL) { return TCL_ERROR; } /* * Run constructors, except when objc < 0 (a special flag case used for * object cloning only). If there aren't any constructors, we do nothing. */ if (objc < 0) { *objectPtr = (Tcl_Object) oPtr; return TCL_OK; } contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL); if (contextPtr == NULL) { *objectPtr = (Tcl_Object) oPtr; return TCL_OK; } state = Tcl_SaveInterpState(interp, TCL_OK); contextPtr->callPtr->flags |= CONSTRUCTOR; contextPtr->skip = skip; /* * Adjust the ensemble tracking record if necessary. [Bug 3514761] */ if (TclInitRewriteEnsemble(interp, skip, skip, objv)) { TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL); } /* * Fire off the constructors non-recursively. */ 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, int result) { CallContext *contextPtr = data[0]; Object *oPtr = data[1]; Tcl_InterpState state = data[2]; Tcl_Object *objectPtr = data[3]; /* * Ensure an error if the object was deleted in the constructor. Don't * want to lose errors by accident. [Bug 2903011] */ 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; } 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); } /* * This decrements the refcount of oPtr. */ TclOODeleteContext(contextPtr); return TCL_ERROR; } Tcl_RestoreInterpState(interp, state); *objectPtr = (Tcl_Object) oPtr; /* * This decrements the refcount of oPtr. */ TclOODeleteContext(contextPtr); return TCL_OK; } /* * ---------------------------------------------------------------------- * * Tcl_CopyObjectInstance -- |
︙ | ︙ | |||
2019 2020 2021 2022 2023 2024 2025 | * kept object-local. The duplicate is never deleted at this point, nor is * it the root of the object system or in the midst of processing a filter * call. */ o2Ptr->flags = oPtr->flags & ~( OBJECT_DELETED | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING); | < | 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 | * kept object-local. The duplicate is never deleted at this point, nor is * it the root of the object system or in the midst of processing a filter * call. */ o2Ptr->flags = oPtr->flags & ~( OBJECT_DELETED | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING); /* * Copy the object's metadata. */ if (oPtr->metadataPtr != NULL) { Tcl_ObjectMetadataType *metadataTypePtr; ClientData value, duplicate; |
︙ | ︙ | |||
3031 3032 3033 3034 3035 3036 3037 | return (Tcl_Class) ((Object *)object)->classPtr; } int Tcl_ObjectDeleted( Tcl_Object object) { | | | 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 | return (Tcl_Class) ((Object *)object)->classPtr; } int Tcl_ObjectDeleted( Tcl_Object object) { return ((Object *)object)->command == NULL; } Tcl_Object Tcl_GetClassAsObject( Tcl_Class clazz) { return (Tcl_Object) ((Class *)clazz)->thisPtr; |
︙ | ︙ |
Changes to generic/tclOOBasic.c.
︙ | ︙ | |||
1202 1203 1204 1205 1206 1207 1208 | * [oo::define] command. */ if (objc == 2) { o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, NULL, NULL); } else { const char *name, *namespaceName; | < < < < < < < < < < < < | 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 | * [oo::define] command. */ if (objc == 2) { o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, NULL, NULL); } else { const char *name, *namespaceName; name = TclGetString(objv[2]); if (name[0] == '\0') { name = NULL; } /* * Choose a unique namespace name if the user didn't supply one. */ namespaceName = NULL; |
︙ | ︙ | |||
1239 1240 1241 1242 1243 1244 1245 | Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s refers to an existing namespace", namespaceName)); return TCL_ERROR; } } o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, name, namespaceName); | < | 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 | Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%s refers to an existing namespace", namespaceName)); return TCL_ERROR; } } o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, name, namespaceName); } if (o2Ptr == NULL) { return TCL_ERROR; } /* |
︙ | ︙ |
Changes to generic/tclOOCall.c.
︙ | ︙ | |||
106 107 108 109 110 111 112 | CallContext *contextPtr) { register Object *oPtr = contextPtr->oPtr; TclOODeleteChain(contextPtr->callPtr); if (oPtr != NULL) { TclStackFree(oPtr->fPtr->interp, contextPtr); | > > > > > | | 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 | CallContext *contextPtr) { register Object *oPtr = contextPtr->oPtr; TclOODeleteChain(contextPtr->callPtr); if (oPtr != NULL) { TclStackFree(oPtr->fPtr->interp, contextPtr); /* * Corresponding AddRef() in TclOO.c/TclOOObjectCmdCore */ TclOODecrRefCount(oPtr); } } /* * ---------------------------------------------------------------------- * * TclOODeleteChainCache -- |
︙ | ︙ | |||
896 897 898 899 900 901 902 903 904 905 906 907 908 909 | callPtr->chain = callPtr->staticChain; } /* * ---------------------------------------------------------------------- * * 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 * - Still across the same object strucutre (same local epoch), and * - No public/private/filter magic leakage (same flags, modulo the fact | > | 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 | callPtr->chain = callPtr->staticChain; } /* * ---------------------------------------------------------------------- * * 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 * - Still across the same object strucutre (same local epoch), and * - No public/private/filter magic leakage (same flags, modulo the fact |
︙ | ︙ | |||
1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 | oPtr->selfCls->destructorChainPtr = callPtr; callPtr->refCount++; } returnContext: contextPtr = TclStackAlloc(oPtr->fPtr->interp, sizeof(CallContext)); contextPtr->oPtr = oPtr; AddRef(oPtr); contextPtr->callPtr = callPtr; contextPtr->skip = 2; contextPtr->index = 0; return contextPtr; } | > > > > > | 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 | oPtr->selfCls->destructorChainPtr = callPtr; callPtr->refCount++; } 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; } |
︙ | ︙ |
Changes to generic/tclOODefineCmds.c.
︙ | ︙ | |||
119 120 121 122 123 124 125 126 127 128 129 130 131 132 | {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}} }; /* * ---------------------------------------------------------------------- * * 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. * * ---------------------------------------------------------------------- | > | 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 | {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}} }; /* * ---------------------------------------------------------------------- * * 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. * * ---------------------------------------------------------------------- |
︙ | ︙ | |||
163 164 165 166 167 168 169 170 171 172 173 174 175 176 | TclOOGetFoundation(interp)->epoch++; } /* * ---------------------------------------------------------------------- * * RecomputeClassCacheFlag -- * Determine whether the object is prototypical of its class, and hence * able to use the class's method chain cache. * * ---------------------------------------------------------------------- */ static inline void | > | 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 | TclOOGetFoundation(interp)->epoch++; } /* * ---------------------------------------------------------------------- * * RecomputeClassCacheFlag -- * * Determine whether the object is prototypical of its class, and hence * able to use the class's method chain cache. * * ---------------------------------------------------------------------- */ static inline void |
︙ | ︙ | |||
185 186 187 188 189 190 191 192 193 194 195 196 197 198 | } } /* * ---------------------------------------------------------------------- * * TclOOObjectSetFilters -- * Install a list of filter method names into an object. * * ---------------------------------------------------------------------- */ void TclOOObjectSetFilters( | > | 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 | } } /* * ---------------------------------------------------------------------- * * TclOOObjectSetFilters -- * * Install a list of filter method names into an object. * * ---------------------------------------------------------------------- */ void TclOOObjectSetFilters( |
︙ | ︙ | |||
243 244 245 246 247 248 249 250 251 252 253 254 255 256 | oPtr->epoch++; /* Only this object can be affected. */ } /* * ---------------------------------------------------------------------- * * TclOOClassSetFilters -- * Install a list of filter method names into a class. * * ---------------------------------------------------------------------- */ void TclOOClassSetFilters( | > | 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 | oPtr->epoch++; /* Only this object can be affected. */ } /* * ---------------------------------------------------------------------- * * TclOOClassSetFilters -- * * Install a list of filter method names into a class. * * ---------------------------------------------------------------------- */ void TclOOClassSetFilters( |
︙ | ︙ | |||
305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 | BumpGlobalEpoch(interp, classPtr); } /* * ---------------------------------------------------------------------- * * TclOOObjectSetMixins -- * Install a list of mixin classes into an object. * * ---------------------------------------------------------------------- */ void TclOOObjectSetMixins( Object *oPtr, int numMixins, Class *const *mixins) { Class *mixinPtr; int i; if (numMixins == 0) { if (oPtr->mixins.num != 0) { FOREACH(mixinPtr, oPtr->mixins) { | > < | < | 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 | BumpGlobalEpoch(interp, classPtr); } /* * ---------------------------------------------------------------------- * * TclOOObjectSetMixins -- * * Install a list of mixin classes into an object. * * ---------------------------------------------------------------------- */ void TclOOObjectSetMixins( Object *oPtr, int numMixins, Class *const *mixins) { Class *mixinPtr; int i; if (numMixins == 0) { if (oPtr->mixins.num != 0) { FOREACH(mixinPtr, oPtr->mixins) { TclOORemoveFromInstances(oPtr, mixinPtr); } ckfree(oPtr->mixins.list); oPtr->mixins.num = 0; } RecomputeClassCacheFlag(oPtr); } else { if (oPtr->mixins.num != 0) { |
︙ | ︙ | |||
348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 | oPtr->flags &= ~USE_CLASS_CACHE; } oPtr->mixins.num = numMixins; memcpy(oPtr->mixins.list, mixins, sizeof(Class *) * numMixins); FOREACH(mixinPtr, oPtr->mixins) { if (mixinPtr != oPtr->selfCls) { TclOOAddToInstances(oPtr, mixinPtr); } } } oPtr->epoch++; } /* * ---------------------------------------------------------------------- * * TclOOClassSetMixins -- * Install a list of mixin classes into a class. * * ---------------------------------------------------------------------- */ void TclOOClassSetMixins( | > > > > > > > > | 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 | oPtr->flags &= ~USE_CLASS_CACHE; } 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++; } /* * ---------------------------------------------------------------------- * * TclOOClassSetMixins -- * * Install a list of mixin classes into a class. * * ---------------------------------------------------------------------- */ void TclOOClassSetMixins( |
︙ | ︙ | |||
395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 | } else { classPtr->mixins.list = ckalloc(sizeof(Class *) * numMixins); } classPtr->mixins.num = numMixins; memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins); FOREACH(mixinPtr, classPtr->mixins) { TclOOAddToMixinSubs(classPtr, mixinPtr); } } BumpGlobalEpoch(interp, classPtr); } /* * ---------------------------------------------------------------------- * * RenameDeleteMethod -- * Core of the code to rename and delete methods. * * ---------------------------------------------------------------------- */ static int RenameDeleteMethod( | > > > > > > > > | 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 | } else { classPtr->mixins.list = ckalloc(sizeof(Class *) * numMixins); } 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. * * ---------------------------------------------------------------------- */ static int RenameDeleteMethod( |
︙ | ︙ | |||
493 494 495 496 497 498 499 500 501 502 503 504 505 506 | return TCL_OK; } /* * ---------------------------------------------------------------------- * * 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. * * ---------------------------------------------------------------------- */ | > | 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 | return TCL_OK; } /* * ---------------------------------------------------------------------- * * 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. * * ---------------------------------------------------------------------- */ |
︙ | ︙ | |||
571 572 573 574 575 576 577 578 579 580 581 582 583 584 | return TCL_ERROR; } /* * ---------------------------------------------------------------------- * * FindCommand -- * Specialized version of Tcl_FindCommand that handles command prefixes * and disallows namespace magic. * * ---------------------------------------------------------------------- */ static Tcl_Command | > | 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 | return TCL_ERROR; } /* * ---------------------------------------------------------------------- * * FindCommand -- * * Specialized version of Tcl_FindCommand that handles command prefixes * and disallows namespace magic. * * ---------------------------------------------------------------------- */ static Tcl_Command |
︙ | ︙ | |||
631 632 633 634 635 636 637 638 639 640 641 642 643 644 | return cmd; } /* * ---------------------------------------------------------------------- * * 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. * * ---------------------------------------------------------------------- */ | > | 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 | return cmd; } /* * ---------------------------------------------------------------------- * * 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. * * ---------------------------------------------------------------------- */ |
︙ | ︙ | |||
656 657 658 659 660 661 662 | Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot process definitions; support namespace deleted", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } | > | > > | 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 | Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot process definitions; support namespace deleted", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } /* * 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; framePtr->objv = objv; /* Reference counts do not need to be * incremented here. */ return TCL_OK; } /* * ---------------------------------------------------------------------- * * TclOOGetDefineCmdContext -- * * Extracts the magic token from the current stack frame, or returns NULL * (and leaves an error message) otherwise. * * ---------------------------------------------------------------------- */ Tcl_Object |
︙ | ︙ | |||
707 708 709 710 711 712 713 714 715 716 717 718 719 720 | return object; } /* * ---------------------------------------------------------------------- * * 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. * * ---------------------------------------------------------------------- */ | > | 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 | return object; } /* * ---------------------------------------------------------------------- * * 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. * * ---------------------------------------------------------------------- */ |
︙ | ︙ | |||
749 750 751 752 753 754 755 756 757 758 759 760 761 762 | return oPtr->classPtr; } /* * ---------------------------------------------------------------------- * * GenerateErrorInfo -- * Factored out code to generate part of the error trace messages. * * ---------------------------------------------------------------------- */ static inline void GenerateErrorInfo( | > | 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 | return oPtr->classPtr; } /* * ---------------------------------------------------------------------- * * GenerateErrorInfo -- * * Factored out code to generate part of the error trace messages. * * ---------------------------------------------------------------------- */ static inline void GenerateErrorInfo( |
︙ | ︙ | |||
787 788 789 790 791 792 793 794 795 796 797 798 799 800 | (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); } /* * ---------------------------------------------------------------------- * * 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. * * ---------------------------------------------------------------------- */ | > | 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 | (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); } /* * ---------------------------------------------------------------------- * * 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. * * ---------------------------------------------------------------------- */ |
︙ | ︙ | |||
850 851 852 853 854 855 856 857 858 859 860 861 862 863 | return result; } /* * ---------------------------------------------------------------------- * * 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. * * ---------------------------------------------------------------------- | > | 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 | return result; } /* * ---------------------------------------------------------------------- * * 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. * * ---------------------------------------------------------------------- |
︙ | ︙ | |||
910 911 912 913 914 915 916 | if (result == TCL_ERROR) { GenerateErrorInfo(interp, oPtr, objNameObj, "class"); } TclDecrRefCount(objNameObj); } else { result = MagicDefinitionInvoke(interp, fPtr->defineNs, 2, objc, objv); } | | > | 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 | if (result == TCL_ERROR) { GenerateErrorInfo(interp, oPtr, objNameObj, "class"); } TclDecrRefCount(objNameObj); } else { result = MagicDefinitionInvoke(interp, fPtr->defineNs, 2, objc, objv); } TclOODecrRefCount(oPtr); /* * Restore the previous "current" namespace. */ TclPopStackFrame(interp); return result; } /* * ---------------------------------------------------------------------- * * 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. * * ---------------------------------------------------------------------- |
︙ | ︙ | |||
977 978 979 980 981 982 983 | if (result == TCL_ERROR) { GenerateErrorInfo(interp, oPtr, objNameObj, "object"); } TclDecrRefCount(objNameObj); } else { result = MagicDefinitionInvoke(interp, fPtr->objdefNs, 2, objc, objv); } | | > | 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 | if (result == TCL_ERROR) { GenerateErrorInfo(interp, oPtr, objNameObj, "object"); } TclDecrRefCount(objNameObj); } else { result = MagicDefinitionInvoke(interp, fPtr->objdefNs, 2, objc, objv); } TclOODecrRefCount(oPtr); /* * Restore the previous "current" namespace. */ TclPopStackFrame(interp); return result; } /* * ---------------------------------------------------------------------- * * 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. * * ---------------------------------------------------------------------- |
︙ | ︙ | |||
1044 1045 1046 1047 1048 1049 1050 | if (result == TCL_ERROR) { GenerateErrorInfo(interp, oPtr, objNameObj, "class object"); } TclDecrRefCount(objNameObj); } else { result = MagicDefinitionInvoke(interp, fPtr->objdefNs, 1, objc, objv); } | | > | 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 | if (result == TCL_ERROR) { GenerateErrorInfo(interp, oPtr, objNameObj, "class object"); } TclDecrRefCount(objNameObj); } else { result = MagicDefinitionInvoke(interp, fPtr->objdefNs, 1, objc, objv); } TclOODecrRefCount(oPtr); /* * Restore the previous "current" namespace. */ TclPopStackFrame(interp); return result; } /* * ---------------------------------------------------------------------- * * TclOODefineObjSelfObjCmd -- * * Implementation of the "self" subcommand of the "oo::objdefine" * command. * * ---------------------------------------------------------------------- */ int |
︙ | ︙ | |||
1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 | return TCL_OK; } /* * ---------------------------------------------------------------------- * * TclOODefineClassObjCmd -- * Implementation of the "class" subcommand of the "oo::objdefine" * command. * * ---------------------------------------------------------------------- */ int | > | 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 | return TCL_OK; } /* * ---------------------------------------------------------------------- * * TclOODefineClassObjCmd -- * * Implementation of the "class" subcommand of the "oo::objdefine" * command. * * ---------------------------------------------------------------------- */ int |
︙ | ︙ | |||
1164 1165 1166 1167 1168 1169 1170 1171 | /* * Set the object's class. */ if (oPtr->selfCls != clsPtr) { TclOORemoveFromInstances(oPtr, oPtr->selfCls); oPtr->selfCls = clsPtr; | > > > > > < < < | > > | 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 | /* * 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 (oPtr->classPtr != NULL) { BumpGlobalEpoch(interp, oPtr->classPtr); } else { oPtr->epoch++; } } return TCL_OK; } /* * ---------------------------------------------------------------------- * * TclOODefineConstructorObjCmd -- * * Implementation of the "constructor" subcommand of the "oo::define" * command. * * ---------------------------------------------------------------------- */ int |
︙ | ︙ | |||
1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 | return TCL_OK; } /* * ---------------------------------------------------------------------- * * TclOODefineDeleteMethodObjCmd -- * Implementation of the "deletemethod" subcommand of the "oo::define" * and "oo::objdefine" commands. * * ---------------------------------------------------------------------- */ int | > | 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 | return TCL_OK; } /* * ---------------------------------------------------------------------- * * TclOODefineDeleteMethodObjCmd -- * * Implementation of the "deletemethod" subcommand of the "oo::define" * and "oo::objdefine" commands. * * ---------------------------------------------------------------------- */ int |
︙ | ︙ | |||
1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 | return TCL_OK; } /* * ---------------------------------------------------------------------- * * TclOODefineDestructorObjCmd -- * Implementation of the "destructor" subcommand of the "oo::define" * command. * * ---------------------------------------------------------------------- */ int | > | 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 | return TCL_OK; } /* * ---------------------------------------------------------------------- * * TclOODefineDestructorObjCmd -- * * Implementation of the "destructor" subcommand of the "oo::define" * command. * * ---------------------------------------------------------------------- */ int |
︙ | ︙ | |||
1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 | return TCL_OK; } /* * ---------------------------------------------------------------------- * * TclOODefineExportObjCmd -- * Implementation of the "export" subcommand of the "oo::define" and * "oo::objdefine" commands. * * ---------------------------------------------------------------------- */ int | > | 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 | return TCL_OK; } /* * ---------------------------------------------------------------------- * * TclOODefineExportObjCmd -- * * Implementation of the "export" subcommand of the "oo::define" and * "oo::objdefine" commands. * * ---------------------------------------------------------------------- */ int |
︙ | ︙ | |||
1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 | return TCL_OK; } /* * ---------------------------------------------------------------------- * * TclOODefineForwardObjCmd -- * Implementation of the "forward" subcommand of the "oo::define" and * "oo::objdefine" commands. * * ---------------------------------------------------------------------- */ int | > | 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 | return TCL_OK; } /* * ---------------------------------------------------------------------- * * TclOODefineForwardObjCmd -- * * Implementation of the "forward" subcommand of the "oo::define" and * "oo::objdefine" commands. * * ---------------------------------------------------------------------- */ int |
︙ | ︙ | |||
1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 | return TCL_OK; } /* * ---------------------------------------------------------------------- * * TclOODefineMethodObjCmd -- * Implementation of the "method" subcommand of the "oo::define" and * "oo::objdefine" commands. * * ---------------------------------------------------------------------- */ int | > | 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 | return TCL_OK; } /* * ---------------------------------------------------------------------- * * TclOODefineMethodObjCmd -- * * Implementation of the "method" subcommand of the "oo::define" and * "oo::objdefine" commands. * * ---------------------------------------------------------------------- */ int |
︙ | ︙ | |||
1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 | return TCL_OK; } /* * ---------------------------------------------------------------------- * * TclOODefineMixinObjCmd -- * Implementation of the "mixin" subcommand of the "oo::define" and * "oo::objdefine" commands. * * ---------------------------------------------------------------------- */ int | > | 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 | return TCL_OK; } /* * ---------------------------------------------------------------------- * * TclOODefineMixinObjCmd -- * * Implementation of the "mixin" subcommand of the "oo::define" and * "oo::objdefine" commands. * * ---------------------------------------------------------------------- */ int |
︙ | ︙ | |||
1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 | if (!isInstanceMixin && TclOOIsReachable(oPtr->classPtr, clsPtr)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "may not mix a class into itself", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL); goto freeAndError; } mixins[i-1] = clsPtr; } if (isInstanceMixin) { TclOOObjectSetMixins(oPtr, objc-1, mixins); } else { TclOOClassSetMixins(interp, oPtr->classPtr, objc-1, mixins); } TclStackFree(interp, mixins); return TCL_OK; freeAndError: TclStackFree(interp, mixins); return TCL_ERROR; } /* * ---------------------------------------------------------------------- * * TclOODefineRenameMethodObjCmd -- * Implementation of the "renamemethod" subcommand of the "oo::define" * and "oo::objdefine" commands. * * ---------------------------------------------------------------------- */ int | > > > > > > > > > > > | 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 | if (!isInstanceMixin && TclOOIsReachable(oPtr->classPtr, clsPtr)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "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 { TclOOClassSetMixins(interp, oPtr->classPtr, objc-1, mixins); } 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. * * ---------------------------------------------------------------------- */ int |
︙ | ︙ | |||
1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 | return TCL_OK; } /* * ---------------------------------------------------------------------- * * TclOODefineUnexportObjCmd -- * Implementation of the "unexport" subcommand of the "oo::define" and * "oo::objdefine" commands. * * ---------------------------------------------------------------------- */ int | > | 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 | return TCL_OK; } /* * ---------------------------------------------------------------------- * * TclOODefineUnexportObjCmd -- * * Implementation of the "unexport" subcommand of the "oo::define" and * "oo::objdefine" commands. * * ---------------------------------------------------------------------- */ int |
︙ | ︙ | |||
1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 | return TCL_OK; } /* * ---------------------------------------------------------------------- * * Tcl_ClassSetConstructor, Tcl_ClassSetDestructor -- * How to install a constructor or destructor into a class; API to call * from C. * * ---------------------------------------------------------------------- */ void | > | 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 | return TCL_OK; } /* * ---------------------------------------------------------------------- * * Tcl_ClassSetConstructor, Tcl_ClassSetDestructor -- * * How to install a constructor or destructor into a class; API to call * from C. * * ---------------------------------------------------------------------- */ void |
︙ | ︙ | |||
1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 | } } /* * ---------------------------------------------------------------------- * * TclOODefineSlots -- * Create the "::oo::Slot" class and its standard instances. Class * definition is empty at the stage (added by scripting). * * ---------------------------------------------------------------------- */ int | > | 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 | } } /* * ---------------------------------------------------------------------- * * TclOODefineSlots -- * * Create the "::oo::Slot" class and its standard instances. Class * definition is empty at the stage (added by scripting). * * ---------------------------------------------------------------------- */ int |
︙ | ︙ | |||
1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 | return TCL_OK; } /* * ---------------------------------------------------------------------- * * ClassFilterGet, ClassFilterSet -- * Implementation of the "filter" slot accessors of the "oo::define" * command. * * ---------------------------------------------------------------------- */ static int | > | 1948 1949 1950 1951 1952 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 | return TCL_OK; } /* * ---------------------------------------------------------------------- * * ClassFilterGet, ClassFilterSet -- * * Implementation of the "filter" slot accessors of the "oo::define" * command. * * ---------------------------------------------------------------------- */ static int |
︙ | ︙ | |||
1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 | return TCL_OK; } /* * ---------------------------------------------------------------------- * * ClassMixinGet, ClassMixinSet -- * Implementation of the "mixin" slot accessors of the "oo::define" * command. * * ---------------------------------------------------------------------- */ static int | > | 2028 2029 2030 2031 2032 2033 2034 2035 2036 2037 2038 2039 2040 2041 2042 | return TCL_OK; } /* * ---------------------------------------------------------------------- * * ClassMixinGet, ClassMixinSet -- * * Implementation of the "mixin" slot accessors of the "oo::define" * command. * * ---------------------------------------------------------------------- */ static int |
︙ | ︙ | |||
2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 | mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc); for (i=0 ; i<mixinc ; i++) { mixins[i] = GetClassInOuterContext(interp, mixinv[i], "may only mix in classes"); if (mixins[i] == NULL) { goto freeAndError; } if (TclOOIsReachable(oPtr->classPtr, 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; } } TclOOClassSetMixins(interp, oPtr->classPtr, mixinc, mixins); TclStackFree(interp, mixins); return TCL_OK; freeAndError: TclStackFree(interp, mixins); return TCL_ERROR; } /* * ---------------------------------------------------------------------- * * ClassSuperGet, ClassSuperSet -- * Implementation of the "superclass" slot accessors of the "oo::define" * command. * * ---------------------------------------------------------------------- */ static int | > > > > > > > > > > > > | 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 | mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc); for (i=0 ; i<mixinc ; i++) { mixins[i] = GetClassInOuterContext(interp, mixinv[i], "may only mix in classes"); if (mixins[i] == NULL) { i--; goto freeAndError; } if (TclOOIsReachable(oPtr->classPtr, 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. * * ---------------------------------------------------------------------- */ static int |
︙ | ︙ | |||
2168 2169 2170 2171 2172 2173 2174 | * * Note that zero classes is special, as it is equivalent to just the * class of objects. [Bug 9d61624b3d] */ if (superc == 0) { superclasses = ckrealloc(superclasses, sizeof(Class *)); | > > > | > | < > > > | > > > > > > > > > > > > > > > > > > > | 2239 2240 2241 2242 2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 2257 2258 2259 2260 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 | * * Note that zero classes is special, as it is equivalent to just the * class of objects. [Bug 9d61624b3d] */ if (superc == 0) { superclasses = ckrealloc(superclasses, sizeof(Class *)); if (TclOOIsReachable(oPtr->fPtr->classCls, oPtr->classPtr)) { superclasses[0] = oPtr->fPtr->classCls; } else { superclasses[0] = oPtr->fPtr->objectCls; } superc = 1; /* * Corresponding TclOODecrRefCount is near the end of this function. */ AddRef(superclasses[0]->thisPtr); } else { for (i=0 ; i<superc ; i++) { superclasses[i] = GetClassInOuterContext(interp, superv[i], "only a class can be a superclass"); if (superclasses[i] == NULL) { i--; goto failedAfterAlloc; } for (j=0 ; j<i ; j++) { if (superclasses[j] == superclasses[i]) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "class should only be a direct superclass once", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS",NULL); goto failedAfterAlloc; } } if (TclOOIsReachable(oPtr->classPtr, 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 * involves splicing the class out of the superclasses' subclass list that * it used to be a member of and splicing it into the new superclasses' * subclass list. */ if (oPtr->classPtr->superclasses.num != 0) { FOREACH(superPtr, oPtr->classPtr->superclasses) { TclOORemoveFromSubclasses(oPtr->classPtr, superPtr); } ckfree(oPtr->classPtr->superclasses.list); } 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; } /* * ---------------------------------------------------------------------- * * ClassVarsGet, ClassVarsSet -- * * Implementation of the "variable" slot accessors of the "oo::define" * command. * * ---------------------------------------------------------------------- */ static int |
︙ | ︙ | |||
2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 | return TCL_OK; } /* * ---------------------------------------------------------------------- * * ObjectFilterGet, ObjectFilterSet -- * Implementation of the "filter" slot accessors of the "oo::objdefine" * command. * * ---------------------------------------------------------------------- */ static int | > | 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 | return TCL_OK; } /* * ---------------------------------------------------------------------- * * ObjectFilterGet, ObjectFilterSet -- * * Implementation of the "filter" slot accessors of the "oo::objdefine" * command. * * ---------------------------------------------------------------------- */ static int |
︙ | ︙ | |||
2436 2437 2438 2439 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 | return TCL_OK; } /* * ---------------------------------------------------------------------- * * ObjectMixinGet, ObjectMixinSet -- * Implementation of the "mixin" slot accessors of the "oo::objdefine" * command. * * ---------------------------------------------------------------------- */ static int | > | 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 | return TCL_OK; } /* * ---------------------------------------------------------------------- * * ObjectMixinGet, ObjectMixinSet -- * * Implementation of the "mixin" slot accessors of the "oo::objdefine" * command. * * ---------------------------------------------------------------------- */ static int |
︙ | ︙ | |||
2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 | mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc); for (i=0 ; i<mixinc ; i++) { mixins[i] = GetClassInOuterContext(interp, mixinv[i], "may only mix in classes"); if (mixins[i] == NULL) { TclStackFree(interp, mixins); return TCL_ERROR; } } TclOOObjectSetMixins(oPtr, mixinc, mixins); TclStackFree(interp, mixins); return TCL_OK; } /* * ---------------------------------------------------------------------- * * ObjectVarsGet, ObjectVarsSet -- * Implementation of the "variable" slot accessors of the "oo::objdefine" * command. * * ---------------------------------------------------------------------- */ static int | > > > > > > > > > > > | 2605 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 2641 2642 2643 | mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc); for (i=0 ; i<mixinc ; i++) { mixins[i] = GetClassInOuterContext(interp, mixinv[i], "may only mix in classes"); if (mixins[i] == NULL) { while (i-- > 0) { TclOODecrRefCount(mixins[i]->thisPtr); } TclStackFree(interp, mixins); return TCL_ERROR; } /* * Corresponding TclOODecrRefCount() is in TclOOObjectSetMixins() or * just above if this function fails. */ AddRef(mixins[i]->thisPtr); } TclOOObjectSetMixins(oPtr, mixinc, mixins); TclStackFree(interp, mixins); return TCL_OK; } /* * ---------------------------------------------------------------------- * * ObjectVarsGet, ObjectVarsSet -- * * Implementation of the "variable" slot accessors of the "oo::objdefine" * command. * * ---------------------------------------------------------------------- */ static int |
︙ | ︙ |
Changes to generic/tclOOInt.h.
︙ | ︙ | |||
189 190 191 192 193 194 195 | LIST_STATIC(Tcl_Obj *) variables; } Object; #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. */ | | | | > | 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 | LIST_STATIC(Tcl_Obj *) variables; } Object; #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 /* 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* * processed on the object, preventing nasty * recursive filtering problems. */ |
︙ | ︙ | |||
218 219 220 221 222 223 224 | * And the definition of a class. Note that every class also has an associated * object, through which it is manipulated. */ typedef struct Class { Object *thisPtr; /* Reference to the object associated with * this class. */ | < < < < | 219 220 221 222 223 224 225 226 227 228 229 230 231 232 | * And the definition of a class. Note that every class also has an associated * object, through which it is manipulated. */ typedef struct Class { Object *thisPtr; /* Reference to the object associated with * this class. */ int flags; /* Assorted flags. */ LIST_STATIC(struct Class *) superclasses; /* List of superclasses, used for generation * of method call chains. */ LIST_DYNAMIC(struct Class *) subclasses; /* List of subclasses, used to ensure deletion * of dependent entities happens properly when |
︙ | ︙ | |||
491 492 493 494 495 496 497 498 499 500 501 502 503 504 | MODULE_SCOPE void TclOOAddToMixinSubs(Class *subPtr, Class *mixinPtr); MODULE_SCOPE void TclOOAddToSubclasses(Class *subPtr, Class *superPtr); 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 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); MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr, Tcl_Obj *methodNameObj, int flags, | > > > > > | 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 | MODULE_SCOPE void TclOOAddToMixinSubs(Class *subPtr, Class *mixinPtr); MODULE_SCOPE void TclOOAddToSubclasses(Class *subPtr, Class *superPtr); 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); MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr, Tcl_Obj *methodNameObj, int flags, |
︙ | ︙ | |||
520 521 522 523 524 525 526 | Tcl_Obj *const objv[]); MODULE_SCOPE int TclNRObjectContextInvokeNext(Tcl_Interp *interp, 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); | | | | > > > > > > | < < < < < > > | | 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 | Tcl_Obj *const objv[]); MODULE_SCOPE int TclNRObjectContextInvokeNext(Tcl_Interp *interp, 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 int TclOORemoveFromInstances(Object *oPtr, Class *clsPtr); MODULE_SCOPE int TclOORemoveFromMixinSubs(Class *subPtr, Class *mixinPtr); 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); MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr); /* * 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. * REQUIRES DECLARATION: int i; */ #define FOREACH(var,ary) \ 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 * only iterates over values. */ |
︙ | ︙ | |||
582 583 584 585 586 587 588 | do { \ register unsigned len = sizeof(type) * ((target).num=(source).num);\ if (len != 0) { \ memcpy(((target).list=(type*)ckalloc(len)), (source).list, len); \ } else { \ (target).list = NULL; \ } \ | < < < < < < < < < < < | 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 | do { \ register unsigned len = sizeof(type) * ((target).num=(source).num);\ if (len != 0) { \ memcpy(((target).list=(type*)ckalloc(len)), (source).list, len); \ } else { \ (target).list = NULL; \ } \ } while(0) #endif /* TCL_OO_INTERNAL_H */ /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
Changes to generic/tclObj.c.
︙ | ︙ | |||
206 207 208 209 210 211 212 | */ 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); | | | < | 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 | */ 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); #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, int copy, mp_int *bignumValue); |
︙ | ︙ | |||
238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 | /* * The structures below defines the Tcl object types defined in this file by * means of functions that can be invoked by generic object code. See also * tclStringObj.c, tclListObj.c, tclByteCode.c for other type manager * implementations. */ static const Tcl_ObjType oldBooleanType = { "boolean", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ NULL, /* updateStringProc */ TclSetBooleanFromAny /* setFromAnyProc */ }; const Tcl_ObjType tclBooleanType = { "booleanString", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ NULL, /* updateStringProc */ TclSetBooleanFromAny /* setFromAnyProc */ }; const Tcl_ObjType tclDoubleType = { "double", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ UpdateStringOfDouble, /* updateStringProc */ SetDoubleFromAny /* setFromAnyProc */ }; const Tcl_ObjType tclIntType = { "int", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ UpdateStringOfInt, /* updateStringProc */ SetIntFromAny /* setFromAnyProc */ }; | > > > > > > | | | | | | 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 | /* * The structures below defines the Tcl object types defined in this file by * 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 */ TclSetBooleanFromAny /* setFromAnyProc */ }; const Tcl_ObjType tclDoubleType = { "double", /* name */ NULL, /* freeIntRepProc */ 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 */ }; #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 */ UpdateStringOfOldInt, /* updateStringProc */ SetIntFromAny /* setFromAnyProc */ }; #endif const Tcl_ObjType tclBignumType = { "bignum", /* name */ FreeBignum, /* freeIntRepProc */ DupBignum, /* dupIntRepProc */ UpdateStringOfBignum, /* updateStringProc */ |
︙ | ︙ | |||
340 341 342 343 344 345 346 | typedef struct ResolvedCmdName { 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.*/ | | | | | 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 | typedef struct ResolvedCmdName { 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.*/ 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). */ 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. */ 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. */ size_t refCount; /* Reference count: 1 for each cmdName object * that has a pointer to this ResolvedCmdName |
︙ | ︙ | |||
392 393 394 395 396 397 398 | typeTableInitialized = 1; Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS); Tcl_MutexUnlock(&tableMutex); Tcl_RegisterObjType(&tclByteArrayType); Tcl_RegisterObjType(&tclDoubleType); Tcl_RegisterObjType(&tclEndOffsetType); | < > | | | > > | 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 | typeTableInitialized = 1; Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS); Tcl_MutexUnlock(&tableMutex); Tcl_RegisterObjType(&tclByteArrayType); Tcl_RegisterObjType(&tclDoubleType); Tcl_RegisterObjType(&tclEndOffsetType); 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); #endif #ifdef TCL_COMPILE_STATS Tcl_MutexLock(&tclObjMutex); tclObjsAlloced = 0; tclObjsFreed = 0; { |
︙ | ︙ | |||
1758 1759 1760 1761 1762 1763 1764 | Tcl_Obj * Tcl_NewBooleanObj( register int boolValue) /* Boolean used to initialize new object. */ { register Tcl_Obj *objPtr; | | | 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 | Tcl_Obj * Tcl_NewBooleanObj( register int boolValue) /* Boolean used to initialize new object. */ { register Tcl_Obj *objPtr; TclNewIntObj(objPtr, boolValue!=0); return objPtr; } #endif /* TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
1806 1807 1808 1809 1810 1811 1812 | * debugging. */ { register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); objPtr->bytes = NULL; | | | 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 | * debugging. */ { register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); objPtr->bytes = NULL; objPtr->internalRep.wideValue = (boolValue != 0); objPtr->typePtr = &tclIntType; return objPtr; } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * |
︙ | ︙ | |||
1853 1854 1855 1856 1857 1858 1859 | register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ register int boolValue) /* Boolean used to set object's value. */ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetBooleanObj"); } | | | 1860 1861 1862 1863 1864 1865 1866 1867 1868 1869 1870 1871 1872 1873 1874 | register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ register int boolValue) /* Boolean used to set object's value. */ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetBooleanObj"); } TclSetIntObj(objPtr, boolValue!=0); } #endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- * * Tcl_GetBooleanFromObj -- |
︙ | ︙ | |||
1884 1885 1886 1887 1888 1889 1890 | Tcl_GetBooleanFromObj( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ register Tcl_Obj *objPtr, /* The object from which to get boolean. */ register int *boolPtr) /* Place to store resulting boolean. */ { do { if (objPtr->typePtr == &tclIntType) { | | | 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 | Tcl_GetBooleanFromObj( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ 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.wideValue != 0); return TCL_OK; } if (objPtr->typePtr == &tclBooleanType) { *boolPtr = (int) objPtr->internalRep.longValue; return TCL_OK; } if (objPtr->typePtr == &tclDoubleType) { |
︙ | ︙ | |||
1912 1913 1914 1915 1916 1917 1918 | *boolPtr = (d != 0.0); return TCL_OK; } if (objPtr->typePtr == &tclBignumType) { *boolPtr = 1; return TCL_OK; } | < < < < < < | 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 | *boolPtr = (d != 0.0); return TCL_OK; } if (objPtr->typePtr == &tclBignumType) { *boolPtr = 1; return TCL_OK; } } while ((ParseBoolean(objPtr) == TCL_OK) || (TCL_OK == TclParseNumber(interp, objPtr, "boolean value", NULL,-1,NULL,0))); return TCL_ERROR; } /* *---------------------------------------------------------------------- |
︙ | ︙ | |||
1956 1957 1958 1959 1960 1961 1962 | * For some "pure" numeric Tcl_ObjTypes (no string rep), we can determine * whether a boolean conversion is possible without generating the string * rep. */ if (objPtr->bytes == NULL) { if (objPtr->typePtr == &tclIntType) { | | < < < < < < | 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 | * For some "pure" numeric Tcl_ObjTypes (no string rep), we can determine * whether a boolean conversion is possible without generating the string * rep. */ if (objPtr->bytes == NULL) { if (objPtr->typePtr == &tclIntType) { switch (objPtr->internalRep.wideValue) { case 0L: case 1L: return TCL_OK; } goto badBoolean; } if (objPtr->typePtr == &tclBignumType) { goto badBoolean; } if (objPtr->typePtr == &tclDoubleType) { goto badBoolean; } } if (ParseBoolean(objPtr) == TCL_OK) { return TCL_OK; |
︙ | ︙ | |||
2109 2110 2111 2112 2113 2114 2115 | TclFreeIntRep(objPtr); objPtr->internalRep.longValue = newBool; objPtr->typePtr = &tclBooleanType; return TCL_OK; numericBoolean: TclFreeIntRep(objPtr); | | | 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 | TclFreeIntRep(objPtr); objPtr->internalRep.longValue = newBool; objPtr->typePtr = &tclBooleanType; return TCL_OK; numericBoolean: TclFreeIntRep(objPtr); objPtr->internalRep.wideValue = newBool; objPtr->typePtr = &tclIntType; return TCL_OK; } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
2290 2291 2292 2293 2294 2295 2296 | } return TCL_ERROR; } *dblPtr = (double) objPtr->internalRep.doubleValue; return TCL_OK; } if (objPtr->typePtr == &tclIntType) { | | < < < < < < | 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 | } return TCL_ERROR; } *dblPtr = (double) objPtr->internalRep.doubleValue; return TCL_OK; } if (objPtr->typePtr == &tclIntType) { *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; } } while (SetDoubleFromAny(interp, objPtr) == TCL_OK); return TCL_ERROR; } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
2423 2424 2425 2426 2427 2428 2429 | Tcl_Obj * Tcl_NewIntObj( register int intValue) /* Int used to initialize the new object. */ { register Tcl_Obj *objPtr; | | | 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 | Tcl_Obj * Tcl_NewIntObj( register int intValue) /* Int used to initialize the new object. */ { register Tcl_Obj *objPtr; TclNewIntObj(objPtr, intValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
2456 2457 2458 2459 2460 2461 2462 | register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ register int intValue) /* Integer used to set object's value. */ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetIntObj"); } | | | > > > | | < < | < | | < | | | < < | | | 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 2481 2482 2483 | register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ register int intValue) /* Integer used to set object's value. */ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetIntObj"); } TclSetIntObj(objPtr, intValue); } /* *---------------------------------------------------------------------- * * Tcl_GetIntFromObj -- * * 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 Tcl_GetIntFromObj( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ |
︙ | ︙ | |||
2537 2538 2539 2540 2541 2542 2543 | */ static int SetIntFromAny( Tcl_Interp *interp, /* Tcl interpreter */ Tcl_Obj *objPtr) /* Pointer to the object to convert */ { | < | | | 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 | */ static int SetIntFromAny( Tcl_Interp *interp, /* Tcl interpreter */ Tcl_Obj *objPtr) /* Pointer to the object to convert */ { Tcl_WideInt w; return Tcl_GetWideIntFromObj(interp, objPtr, &w); } /* *---------------------------------------------------------------------- * * UpdateStringOfInt -- * |
︙ | ︙ | |||
2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 | static void 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.longValue); objPtr->bytes = ckalloc(len + 1); memcpy(objPtr->bytes, buffer, (unsigned) len + 1); objPtr->length = len; } /* *---------------------------------------------------------------------- * * Tcl_NewLongObj -- * * If a client is compiled with TCL_MEM_DEBUG defined, calls to | > > > > > > > > > > > > > > > > | 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 | static void 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 -- * * If a client is compiled with TCL_MEM_DEBUG defined, calls to |
︙ | ︙ | |||
2605 2606 2607 2608 2609 2610 2611 | * * Side effects: * None. * *---------------------------------------------------------------------- */ | < > | | 2606 2607 2608 2609 2610 2611 2612 2613 2614 2615 2616 2617 2618 2619 2620 2621 2622 2623 2624 2625 2626 2627 2628 2629 2630 2631 2632 2633 2634 2635 2636 2637 2638 2639 2640 | * * Side effects: * None. * *---------------------------------------------------------------------- */ #undef Tcl_NewLongObj #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_NewLongObj( register long longValue) /* Long integer used to initialize the * new object. */ { return Tcl_DbNewLongObj(longValue, "unknown", 0); } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_NewLongObj( register long longValue) /* Long integer used to initialize the * new object. */ { register Tcl_Obj *objPtr; TclNewIntObj(objPtr, longValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 | * * Side effects: * Allocates memory. * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewLongObj( register long longValue, /* Long integer used to initialize the new * object. */ const char *file, /* The name of the source file calling this * function; used for debugging. */ int line) /* Line number in the source file; used for * debugging. */ { register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); objPtr->bytes = NULL; | > | | 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 2677 2678 2679 2680 2681 2682 2683 2684 2685 2686 2687 2688 2689 2690 2691 2692 2693 2694 | * * Side effects: * Allocates memory. * *---------------------------------------------------------------------- */ #undef Tcl_DbNewLongObj #ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_DbNewLongObj( register long longValue, /* Long integer used to initialize the new * object. */ const char *file, /* The name of the source file calling this * function; used for debugging. */ int line) /* Line number in the source file; used for * debugging. */ { register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); objPtr->bytes = NULL; objPtr->internalRep.wideValue = longValue; objPtr->typePtr = &tclIntType; return objPtr; } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * |
︙ | ︙ | |||
2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 | * Side effects: * The object's old string rep, if any, is freed. Also, any old internal * rep is freed. * *---------------------------------------------------------------------- */ 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. */ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetLongObj"); } | > | | 2718 2719 2720 2721 2722 2723 2724 2725 2726 2727 2728 2729 2730 2731 2732 2733 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 | * Side effects: * The object's old string rep, if any, is freed. Also, any old internal * 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. */ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetLongObj"); } TclSetIntObj(objPtr, longValue); } /* *---------------------------------------------------------------------- * * Tcl_GetLongFromObj -- * |
︙ | ︙ | |||
2757 2758 2759 2760 2761 2762 2763 2764 | int Tcl_GetLongFromObj( 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 (objPtr->typePtr == &tclIntType) { | > | < > | | 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 | int Tcl_GetLongFromObj( 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.wideValue; return TCL_OK; } #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 * the internal rep. */ |
︙ | ︙ | |||
2819 2820 2821 2822 2823 2824 2825 | *longPtr = - (long) value; } else { *longPtr = (long) value; } return TCL_OK; } } | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 2823 2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 2839 2840 2841 2842 2843 2844 2845 2846 2847 2848 2849 2850 2851 2852 | *longPtr = - (long) value; } else { *longPtr = (long) value; } return TCL_OK; } } #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); Tcl_SetObjResult(interp, msg); Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", s, NULL); } return TCL_ERROR; } } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL, TCL_PARSE_INTEGER_ONLY)==TCL_OK); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * Tcl_NewWideIntObj -- * * If a client is compiled with TCL_MEM_DEBUG defined, calls to |
︙ | ︙ | |||
2927 2928 2929 2930 2931 2932 2933 | register Tcl_WideInt wideValue) /* Wide integer used to initialize the new * object. */ { register Tcl_Obj *objPtr; TclNewObj(objPtr); | | | 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 2901 2902 | register Tcl_WideInt wideValue) /* Wide integer used to initialize the new * object. */ { register Tcl_Obj *objPtr; TclNewObj(objPtr); TclSetIntObj(objPtr, wideValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
2979 2980 2981 2982 2983 2984 2985 | * function; used for debugging. */ int line) /* Line number in the source file; used for * debugging. */ { register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); | | | 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 | * function; used for debugging. */ int line) /* Line number in the source file; used for * debugging. */ { register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); TclSetIntObj(objPtr, wideValue); return objPtr; } #else /* if not TCL_MEM_DEBUG */ Tcl_Obj * Tcl_DbNewWideIntObj( |
︙ | ︙ | |||
3028 3029 3030 3031 3032 3033 3034 | /* Wide integer used to initialize the * object's value. */ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetWideIntObj"); } | < < < < < | < < < < < < < | 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 3001 3002 3003 | /* Wide integer used to initialize the * object's value. */ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetWideIntObj"); } TclSetIntObj(objPtr, wideValue); } /* *---------------------------------------------------------------------- * * Tcl_GetWideIntFromObj -- * |
︙ | ︙ | |||
3072 3073 3074 3075 3076 3077 3078 | Tcl_GetWideIntFromObj( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ register Tcl_Obj *objPtr, /* Object from which to get a wide int. */ register Tcl_WideInt *wideIntPtr) /* Place to store resulting long. */ { do { | < | < < < < < | 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 3034 3035 3036 | Tcl_GetWideIntFromObj( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ register Tcl_Obj *objPtr, /* Object from which to get a wide int. */ register Tcl_WideInt *wideIntPtr) /* Place to store resulting long. */ { do { if (objPtr->typePtr == &tclIntType) { *wideIntPtr = objPtr->internalRep.wideValue; return TCL_OK; } if (objPtr->typePtr == &tclDoubleType) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected integer but got \"%s\"", TclGetString(objPtr))); |
︙ | ︙ | |||
3132 3133 3134 3135 3136 3137 3138 | } return TCL_ERROR; } } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL, TCL_PARSE_INTEGER_ONLY)==TCL_OK); return TCL_ERROR; } | < < < < < < < < < < < < < < < < < < < < < < < < < < < | 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 | } return TCL_ERROR; } } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL, TCL_PARSE_INTEGER_ONLY)==TCL_OK); return TCL_ERROR; } /* *---------------------------------------------------------------------- * * FreeBignum -- * * This function frees the internal rep of a bignum. |
︙ | ︙ | |||
3401 3402 3403 3404 3405 3406 3407 | if (objPtr->bytes == NULL) { TclInitStringRep(objPtr, &tclEmptyString, 0); } } return TCL_OK; } if (objPtr->typePtr == &tclIntType) { | < < < < < < | 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 | if (objPtr->bytes == NULL) { TclInitStringRep(objPtr, &tclEmptyString, 0); } } return TCL_OK; } if (objPtr->typePtr == &tclIntType) { TclInitBignumFromWideInt(bignumValue, objPtr->internalRep.wideValue); return TCL_OK; } if (objPtr->typePtr == &tclDoubleType) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected integer but got \"%s\"", TclGetString(objPtr))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL); } |
︙ | ︙ | |||
3520 3521 3522 3523 3524 3525 3526 | Tcl_Obj *objPtr, /* Object to set */ mp_int *bignumValue) /* Value to store */ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetBignumObj"); } if ((size_t) bignumValue->used | < < < < < < < < < < < < < < < < < < < < < < < < < | | | | | | < | 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 3463 3464 3465 3466 3467 | Tcl_Obj *objPtr, /* Object to set */ mp_int *bignumValue) /* Value to store */ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetBignumObj"); } if ((size_t) bignumValue->used <= (CHAR_BIT * sizeof(Tcl_WideUInt) + DIGIT_BIT - 1) / DIGIT_BIT) { Tcl_WideUInt value = 0; 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) { value = (value << CHAR_BIT) | *bytes++; } if (value > (((~(Tcl_WideUInt)0) >> 1) + bignumValue->sign)) { goto tooLargeForWide; } if (bignumValue->sign) { TclSetIntObj(objPtr, -(Tcl_WideInt)value); } else { TclSetIntObj(objPtr, (Tcl_WideInt)value); } mp_clear(bignumValue); return; } tooLargeForWide: TclInvalidateStringRep(objPtr); TclFreeIntRep(objPtr); TclSetBignumIntRep(objPtr, bignumValue); } /* *---------------------------------------------------------------------- |
︙ | ︙ | |||
3651 3652 3653 3654 3655 3656 3657 | } else { *typePtr = TCL_NUMBER_DOUBLE; } *clientDataPtr = &objPtr->internalRep.doubleValue; return TCL_OK; } if (objPtr->typePtr == &tclIntType) { | < < < < < < < | 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 | } else { *typePtr = TCL_NUMBER_DOUBLE; } *clientDataPtr = &objPtr->internalRep.doubleValue; return TCL_OK; } if (objPtr->typePtr == &tclIntType) { *typePtr = TCL_NUMBER_WIDE; *clientDataPtr = &objPtr->internalRep.wideValue; return TCL_OK; } if (objPtr->typePtr == &tclBignumType) { static Tcl_ThreadDataKey bignumKey; mp_int *bigPtr = Tcl_GetThreadData(&bignumKey, (int) sizeof(mp_int)); UNPACK_BIGNUM(objPtr, *bigPtr); *typePtr = TCL_NUMBER_BIG; |
︙ | ︙ |
Changes to generic/tclPathObj.c.
︙ | ︙ | |||
1805 1806 1807 1808 1809 1810 1811 | Tcl_IncrRefCount(copy); /* * We now own a reference on both 'dir' and 'copy' */ (void) TclGetStringFromObj(dir, &cwdLen); | < | 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 | Tcl_IncrRefCount(copy); /* * We now own a reference on both 'dir' and 'copy' */ (void) TclGetStringFromObj(dir, &cwdLen); /* Normalize the combined string. */ if (PATHFLAGS(pathPtr) & TCLPATH_NEEDNORM) { /* * If the "tail" part has components (like /../) that cause the * combined path to need more complete normalizing, call on the |
︙ | ︙ | |||
1827 1828 1829 1830 1831 1832 1833 | copy = newCopy; } else { /* * ... 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 | | | | 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 | copy = newCopy; } else { /* * ... 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' 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); } /* Now we need to construct the new path object. */ if (pathType == TCL_PATH_RELATIVE) { Tcl_Obj *origDir = fsPathPtr->cwdPtr; |
︙ | ︙ |
Changes to generic/tclPkg.c.
︙ | ︙ | |||
414 415 416 417 418 419 420 | Tcl_Obj *const reqv[], /* 0 means to use the latest version * available. */ void *clientDataPtr) { Interp *iPtr = (Interp *) interp; Package *pkgPtr; PkgAvail *availPtr, *bestPtr, *bestStablePtr; | | | 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 | Tcl_Obj *const reqv[], /* 0 means to use the latest version * available. */ void *clientDataPtr) { Interp *iPtr = (Interp *) interp; Package *pkgPtr; PkgAvail *availPtr, *bestPtr, *bestStablePtr; char *availVersion, *bestVersion, *bestStableVersion; /* Internal rep. of versions */ int availStable, code, satisfies, pass; char *script, *pkgVersionI; Tcl_DString command; if (TCL_OK != CheckAllRequirements(interp, reqc, reqv)) { return NULL; |
︙ | ︙ | |||
462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 | * are actually locating the best, and the best stable version. One of * them is then chosen based on the selection mode. */ bestPtr = NULL; bestStablePtr = NULL; bestVersion = NULL; for (availPtr = pkgPtr->availPtr; availPtr != NULL; availPtr = availPtr->nextPtr) { if (CheckVersionAndConvert(interp, availPtr->version, &availVersion, &availStable) != TCL_OK) { /* * The provided version number has invalid syntax. This * should not happen. This should have been caught by the * 'package ifneeded' registering the package. */ continue; } | > < < | < < < < < < < < < < < < < < < < < < < < < < | > > > > | > > > > > | > > | > > > > > > > > > > | > | > > > > | > > | > > | > | > > > | > | > > | > > > > > > > > > > > > > | 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 | * are actually locating the best, and the best stable version. One of * them is then chosen based on the selection mode. */ 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) { /* * The provided version number has invalid syntax. This * should not happen. This should have been caught by the * 'package ifneeded' registering the package. */ continue; } /* Check satisfaction of requirements before considering the current version further. */ if (reqc > 0) { satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv); if (!satisfies) { ckfree(availVersion); availVersion = NULL; continue; } } 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 * stable, if there is any, or the best if there is nothing stable. */ |
︙ | ︙ | |||
917 918 919 920 921 922 923 924 925 926 927 928 929 930 | while (pkgPtr->availPtr != NULL) { availPtr = pkgPtr->availPtr; 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); } ckfree(availPtr); } ckfree(pkgPtr); } break; } | > | 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 | while (pkgPtr->availPtr != NULL) { availPtr = pkgPtr->availPtr; 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); } break; } |
︙ | ︙ | |||
970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 | Tcl_SetObjResult(interp, Tcl_NewStringObj(availPtr->script, -1)); return TCL_OK; } Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); if (availPtr->pkgIndex) { Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC); } break; } } ckfree(argv3i); if (objc == 4) { return TCL_OK; } if (availPtr == NULL) { availPtr = ckalloc(sizeof(PkgAvail)); | > | | 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 | Tcl_SetObjResult(interp, Tcl_NewStringObj(availPtr->script, -1)); return TCL_OK; } Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); if (availPtr->pkgIndex) { Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC); availPtr->pkgIndex = NULL; } break; } } ckfree(argv3i); if (objc == 4) { return TCL_OK; } if (availPtr == NULL) { availPtr = ckalloc(sizeof(PkgAvail)); availPtr->pkgIndex = NULL; DupBlock(availPtr->version, argv3, (unsigned) length + 1); if (prevPtr == NULL) { availPtr->nextPtr = pkgPtr->availPtr; pkgPtr->availPtr = availPtr; } else { availPtr->nextPtr = prevPtr->nextPtr; |
︙ | ︙ | |||
1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 | while (pkgPtr->availPtr != NULL) { availPtr = pkgPtr->availPtr; 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); } ckfree(availPtr); } ckfree(pkgPtr); } Tcl_DeleteHashTable(&iPtr->packageTable); if (iPtr->packageUnknown != NULL) { | > | 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 | while (pkgPtr->availPtr != NULL) { availPtr = pkgPtr->availPtr; 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); } Tcl_DeleteHashTable(&iPtr->packageTable); if (iPtr->packageUnknown != NULL) { |
︙ | ︙ |
Changes to generic/tclProc.c.
︙ | ︙ | |||
120 121 122 123 124 125 126 | ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { register Interp *iPtr = (Interp *) interp; Proc *procPtr; | | | < | | | | | | < < < < < < < < | | < < < < < < | < < < < < < < < | < | 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 | ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { register Interp *iPtr = (Interp *) interp; Proc *procPtr; const char *procName; const char *simpleName, *procArgs, *procBody; Namespace *nsPtr, *altNsPtr, *cxtNsPtr; Tcl_Command cmd; if (objc != 4) { Tcl_WrongNumArgs(interp, 1, objv, "name args body"); return TCL_ERROR; } /* * Determine the namespace where the procedure should reside. Unless the * command name includes namespace qualifiers, this will be the current * namespace. */ 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", procName)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); return TCL_ERROR; } if (simpleName == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create procedure \"%s\": bad procedure name", procName)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL); return TCL_ERROR; } /* * Create the data structure to represent the procedure. */ if (TclCreateProc(interp, nsPtr, simpleName, objv[2], objv[3], &procPtr) != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (creating proc \""); Tcl_AddErrorInfo(interp, simpleName); Tcl_AddErrorInfo(interp, "\")"); return TCL_ERROR; } 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 * namespace if the proc was renamed into a different namespace. */ |
︙ | ︙ | |||
810 811 812 813 814 815 816 | if (objPtr == NULL) { /* Do nothing */ } else if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &level) && (level >= 0)) { level = curLevel - level; result = 1; } else if (objPtr->typePtr == &levelReferenceType) { | | | | 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 | if (objPtr == NULL) { /* Do nothing */ } 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.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.wideValue = level; result = 1; } else { result = -1; } } else if (isdigit(UCHAR(name[0]))) { /* INTL: digit */ /* * If this were an integer, we'd have succeeded already. |
︙ | ︙ | |||
2400 2401 2402 2403 2404 2405 2406 | FreeLambdaInternalRep( register Tcl_Obj *objPtr) /* CmdName object with internal representation * to free. */ { Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1; Tcl_Obj *nsObjPtr = objPtr->internalRep.twoPtrValue.ptr2; | | | 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 | FreeLambdaInternalRep( register Tcl_Obj *objPtr) /* CmdName object with internal representation * to free. */ { Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1; Tcl_Obj *nsObjPtr = objPtr->internalRep.twoPtrValue.ptr2; if (procPtr->refCount-- <= 1) { TclProcCleanupProc(procPtr); } TclDecrRefCount(nsObjPtr); objPtr->typePtr = NULL; } static int |
︙ | ︙ |
Changes to generic/tclResult.c.
︙ | ︙ | |||
23 24 25 26 27 28 29 30 31 32 33 34 35 36 | /* * Function prototypes for local functions in this file: */ static Tcl_Obj ** GetKeys(void); static void ReleaseKeys(ClientData clientData); static void ResetObjResult(Interp *iPtr); /* * 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. */ | > > > | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | /* * Function prototypes for local functions in this file: */ 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. */ |
︙ | ︙ | |||
240 241 242 243 244 245 246 | /* * 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. */ | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 | /* * 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->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; } /* *---------------------------------------------------------------------- * * Tcl_RestoreResult -- * |
︙ | ︙ | |||
272 273 274 275 276 277 278 279 280 281 282 283 284 | Tcl_RestoreResult( Tcl_Interp *interp, /* Interpreter being restored. */ Tcl_SavedResult *statePtr) /* State returned by Tcl_SaveResult. */ { Interp *iPtr = (Interp *) interp; Tcl_ResetResult(interp); /* * Restore the object result. */ Tcl_DecrRefCount(iPtr->objResultPtr); | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 | Tcl_RestoreResult( Tcl_Interp *interp, /* Interpreter being restored. */ 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->objResultPtr; } /* *---------------------------------------------------------------------- * * Tcl_DiscardResult -- * |
︙ | ︙ | |||
304 305 306 307 308 309 310 | */ #undef Tcl_DiscardResult void Tcl_DiscardResult( Tcl_SavedResult *statePtr) /* State returned by Tcl_SaveResult. */ { | | > > > > > > > > | 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 | */ #undef Tcl_DiscardResult void Tcl_DiscardResult( Tcl_SavedResult *statePtr) /* State returned by Tcl_SaveResult. */ { 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); } } /* *---------------------------------------------------------------------- * * Tcl_SetResult -- * |
︙ | ︙ | |||
334 335 336 337 338 339 340 | * return value. */ register char *result, /* Value to be returned. If NULL, the result * 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. */ { | > > > | | > > > > > | > > > > > > | > > > > > > > > > > > > > | | | | | > > > > > > > | 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 | * return value. */ register char *result, /* Value to be returned. If NULL, the result * 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. */ { 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 { 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 */ /* *---------------------------------------------------------------------- * * Tcl_GetStringResult -- |
︙ | ︙ | |||
368 369 370 371 372 373 374 | */ const char * Tcl_GetStringResult( register Tcl_Interp *interp)/* Interpreter whose result to return. */ { Interp *iPtr = (Interp *) interp; | | > > > > > > > > > > > > | 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 | */ 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 } /* *---------------------------------------------------------------------- * * Tcl_SetObjResult -- * |
︙ | ︙ | |||
410 411 412 413 414 415 416 417 418 419 420 421 422 423 | /* * We wait until the end to release the old object result, in case we are * setting the result to itself. */ TclDecrRefCount(oldObjResult); } /* *---------------------------------------------------------------------- * * Tcl_GetObjResult -- * | > > > > > > > > > > > > > > > > > | 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 | /* * 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 } /* *---------------------------------------------------------------------- * * Tcl_GetObjResult -- * |
︙ | ︙ | |||
438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 | */ Tcl_Obj * Tcl_GetObjResult( Tcl_Interp *interp) /* Interpreter whose result to return. */ { register Interp *iPtr = (Interp *) interp; return iPtr->objResultPtr; } /* *---------------------------------------------------------------------- * * Tcl_AppendResultVA -- | > > > > > > > > > > > > > > > > > > > > > > > > > > > | 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 | */ 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; } /* *---------------------------------------------------------------------- * * Tcl_AppendResultVA -- |
︙ | ︙ | |||
475 476 477 478 479 480 481 482 483 484 485 486 487 488 | Tcl_Obj *objPtr = Tcl_GetObjResult(interp); if (Tcl_IsShared(objPtr)) { objPtr = Tcl_DuplicateObj(objPtr); } Tcl_AppendStringsToObjVA(objPtr, argList); Tcl_SetObjResult(interp, objPtr); } /* *---------------------------------------------------------------------- * * Tcl_AppendResult -- * | > > > > > > > > > > > > > > > > > | 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 | Tcl_Obj *objPtr = Tcl_GetObjResult(interp); 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 */ } /* *---------------------------------------------------------------------- * * Tcl_AppendResult -- * |
︙ | ︙ | |||
540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 | Tcl_AppendElement( Tcl_Interp *interp, /* Interpreter whose result is to be * extended. */ const char *element) /* String to convert to list element and add * to result. */ { Interp *iPtr = (Interp *) interp; Tcl_Obj *elementPtr = Tcl_NewStringObj(element, -1); Tcl_Obj *listPtr = Tcl_NewListObj(1, &elementPtr); const char *bytes; if (Tcl_IsShared(iPtr->objResultPtr)) { Tcl_SetObjResult(interp, Tcl_DuplicateObj(iPtr->objResultPtr)); } bytes = TclGetString(iPtr->objResultPtr); if (TclNeedSpace(bytes, bytes+iPtr->objResultPtr->length)) { Tcl_AppendToObj(iPtr->objResultPtr, " ", 1); } Tcl_AppendObjToObj(iPtr->objResultPtr, listPtr); Tcl_DecrRefCount(listPtr); | > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | > | > > > > > > > > > > > | 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 | Tcl_AppendElement( Tcl_Interp *interp, /* Interpreter whose result is to be * 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)) { Tcl_SetObjResult(interp, Tcl_DuplicateObj(iPtr->objResultPtr)); } bytes = TclGetString(iPtr->objResultPtr); 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 * 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 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 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); } /* *---------------------------------------------------------------------- * * Tcl_ResetResult -- |
︙ | ︙ | |||
611 612 613 614 615 616 617 618 619 620 621 622 623 624 | void Tcl_ResetResult( register Tcl_Interp *interp)/* Interpreter for which to clear result. */ { register Interp *iPtr = (Interp *) interp; ResetObjResult(iPtr); if (iPtr->errorCode) { /* Legacy support */ if (iPtr->flags & ERR_LEGACY_COPY) { Tcl_ObjSetVar2(interp, iPtr->ecVar, NULL, iPtr->errorCode, TCL_GLOBAL_ONLY); } Tcl_DecrRefCount(iPtr->errorCode); | > > > > > > > > > > > > | 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 | void Tcl_ResetResult( 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); } Tcl_DecrRefCount(iPtr->errorCode); |
︙ | ︙ |
Changes to generic/tclScan.c.
︙ | ︙ | |||
885 886 887 888 889 890 891 | * Scan a single Unicode character. */ offset = TclUtfToUniChar(string, &sch); i = (int)sch; #if TCL_UTF_MAX == 4 if (!offset) { | | | 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 | * Scan a single Unicode character. */ offset = TclUtfToUniChar(string, &sch); i = (int)sch; #if TCL_UTF_MAX == 4 if (!offset) { offset = TclUtfToUniChar(string, &sch); i = (((i<<10) & 0x0FFC00) + 0x10000) + (sch & 0x3FF); } #endif string += offset; if (!(flags & SCAN_SUPPRESS)) { objPtr = Tcl_NewIntObj(i); Tcl_IncrRefCount(objPtr); |
︙ | ︙ | |||
938 939 940 941 942 943 944 | } } if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) { sprintf(buf, "%" TCL_LL_MODIFIER "u", (Tcl_WideUInt)wideValue); Tcl_SetStringObj(objPtr, buf, -1); } else { | | | | 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 | } } if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) { sprintf(buf, "%" TCL_LL_MODIFIER "u", (Tcl_WideUInt)wideValue); Tcl_SetStringObj(objPtr, buf, -1); } else { TclSetIntObj(objPtr, wideValue); } } else if (!(flags & SCAN_BIG)) { if (TclGetLongFromObj(NULL, objPtr, &value) != TCL_OK) { if (TclGetString(objPtr)[0] == '-') { value = LONG_MIN; } else { value = LONG_MAX; } } if ((flags & SCAN_UNSIGNED) && (value < 0)) { sprintf(buf, "%lu", value); /* INTL: ISO digit */ Tcl_SetStringObj(objPtr, buf, -1); } else { TclSetIntObj(objPtr, value); } } objs[objIndex++] = objPtr; break; case 'f': /* |
︙ | ︙ |
Changes to generic/tclStrToD.c.
︙ | ︙ | |||
479 480 481 482 483 484 485 | const char **endPtrPtr, /* Place to store pointer to the character * that terminated the scan. */ int flags) /* Flags governing the parse. */ { enum State { INITIAL, SIGNUM, ZERO, ZERO_X, ZERO_O, ZERO_B, ZERO_D, BINARY, | | | 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 | const char **endPtrPtr, /* Place to store pointer to the character * that terminated the scan. */ int flags) /* Flags governing the parse. */ { enum State { INITIAL, SIGNUM, ZERO, ZERO_X, ZERO_O, ZERO_B, ZERO_D, BINARY, HEXADECIMAL, OCTAL, BAD_OCTAL, DECIMAL, LEADING_RADIX_POINT, FRACTION, EXPONENT_START, EXPONENT_SIGNUM, EXPONENT, sI, sIN, sINF, sINFI, sINFIN, sINFINI, sINFINIT, sINFINITY #ifdef IEEE_FLOATING_POINT , sN, sNA, sNAN, sNANPAREN, sNANHEX, sNANFINISH #endif } state = INITIAL; |
︙ | ︙ | |||
524 525 526 527 528 529 530 531 532 533 534 535 536 537 | * an acceptable number. */ size_t acceptLen; /* Number of characters following that * 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 */ #define ALL_BITS (~(Tcl_WideUInt)0) #define MOST_BITS (ALL_BITS >> 1) /* * Initialize bytes to start of the object's string rep if the caller * didn't pass anything else. | > | 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 | * an acceptable number. */ size_t acceptLen; /* Number of characters following that * 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) /* * Initialize bytes to start of the object's string rep if the caller * didn't pass anything else. |
︙ | ︙ | |||
655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 | state = ZERO_B; break; } if (flags & TCL_PARSE_BINARY_ONLY) { goto zerob; } if (c == 'o' || c == 'O') { state = ZERO_O; break; } if (c == 'd' || c == 'D') { state = ZERO_D; break; } goto decimal; case OCTAL: /* * Scanned an optional + or -, followed by a string of octal * digits. Acceptable inputs are more digits, period, or E. If 8 * or 9 is encountered, commit to floating point. */ | > > > > | 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 | state = ZERO_B; break; } 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 * or 9 is encountered, commit to floating point. */ |
︙ | ︙ | |||
725 726 727 728 729 730 731 732 733 734 735 736 737 738 | } else { numSigDigs = 1; } numTrailZeros = 0; state = OCTAL; break; } goto endgame; /* * Scanned 0x. If state is HEXADECIMAL, scanned at least one * character following the 0x. The only acceptable inputs are * hexadecimal digits. */ | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 | } else { numSigDigs = 1; } 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 * hexadecimal digits. */ |
︙ | ︙ | |||
839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 | case DECIMAL: /* * Scanned an optional + or - followed by a string of decimal * digits. */ decimal: acceptState = state; acceptPoint = p; acceptLen = len; if (c == '0') { numTrailZeros++; state = DECIMAL; break; | > > | 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 | case DECIMAL: /* * 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++; state = DECIMAL; break; |
︙ | ︙ | |||
1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 | * Generate and store the appropriate internal rep. */ if (status == TCL_OK && objPtr != NULL) { TclFreeIntRep(objPtr); switch (acceptState) { case SIGNUM: case ZERO_X: case ZERO_O: case ZERO_B: case ZERO_D: case LEADING_RADIX_POINT: case EXPONENT_START: case EXPONENT_SIGNUM: | > | 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 | * Generate and store the appropriate internal rep. */ 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: case EXPONENT_START: case EXPONENT_SIGNUM: |
︙ | ︙ | |||
1204 1205 1206 1207 1208 1209 1210 | octalSignificandWide <<= shift; } else { mp_mul_2d(&octalSignificandBig, shift, &octalSignificandBig); } } if (!octalSignificandOverflow) { | | < < < < < < < < < < < < < < | | | | | 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 | octalSignificandWide <<= shift; } else { mp_mul_2d(&octalSignificandBig, shift, &octalSignificandBig); } } if (!octalSignificandOverflow) { if (octalSignificandWide > (MOST_BITS + signum)) { TclInitBignumFromWideUInt(&octalSignificandBig, octalSignificandWide); octalSignificandOverflow = 1; } else { objPtr->typePtr = &tclIntType; if (signum) { objPtr->internalRep.wideValue = - (Tcl_WideInt) octalSignificandWide; } else { objPtr->internalRep.wideValue = (Tcl_WideInt) octalSignificandWide; } } } if (octalSignificandOverflow) { if (signum) { mp_neg(&octalSignificandBig, &octalSignificandBig); } |
︙ | ︙ | |||
1251 1252 1253 1254 1255 1256 1257 | &significandWide, &significandBig, significandOverflow); if (!significandOverflow && (significandWide > MOST_BITS+signum)){ significandOverflow = 1; TclInitBignumFromWideUInt(&significandBig, significandWide); } returnInteger: if (!significandOverflow) { | | < < < < < < < < < < < < < < | | | | | 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 | &significandWide, &significandBig, significandOverflow); if (!significandOverflow && (significandWide > MOST_BITS+signum)){ significandOverflow = 1; TclInitBignumFromWideUInt(&significandBig, significandWide); } returnInteger: if (!significandOverflow) { if (significandWide > MOST_BITS+signum) { TclInitBignumFromWideUInt(&significandBig, significandWide); significandOverflow = 1; } else { objPtr->typePtr = &tclIntType; if (signum) { objPtr->internalRep.wideValue = - (Tcl_WideInt) significandWide; } else { objPtr->internalRep.wideValue = (Tcl_WideInt) significandWide; } } } if (significandOverflow) { if (signum) { mp_neg(&significandBig, &significandBig); } |
︙ | ︙ | |||
1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 | if (status != TCL_OK) { if (interp != NULL) { Tcl_Obj *msg = Tcl_ObjPrintf("expected %s but got \"", expected); Tcl_AppendLimitedToObj(msg, bytes, numBytes, 50, ""); Tcl_AppendToObj(msg, "\"", -1); Tcl_SetObjResult(interp, msg); Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL); } } /* * Free memory. | > > > | 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 | if (status != TCL_OK) { if (interp != NULL) { 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); } } /* * Free memory. |
︙ | ︙ |
Changes to generic/tclStringObj.c.
︙ | ︙ | |||
414 415 416 417 418 419 420 | if ((objPtr->bytes) && (objPtr->length < 2)) { /* 0 bytes -> 0 chars; 1 byte -> 1 char */ return objPtr->length; } /* | | | > > > | > > | 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 | if ((objPtr->bytes) && (objPtr->length < 2)) { /* 0 bytes -> 0 chars; 1 byte -> 1 char */ return objPtr->length; } /* * 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; (void) Tcl_GetByteArrayFromObj(objPtr, &length); return length; |
︙ | ︙ | |||
513 514 515 516 517 518 519 | /* *---------------------------------------------------------------------- * * 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 | | | 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 | /* *---------------------------------------------------------------------- * * 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 created from the UTF * string format. * * Results: * Returns a pointer to the object's internal Unicode string. * * Side effects: * Converts the object to have the String internal rep. |
︙ | ︙ | |||
647 648 649 650 651 652 653 654 655 656 657 658 659 660 | stringPtr->numChars = newObjPtr->length; return newObjPtr; } FillUnicodeRep(objPtr); stringPtr = GET_STRING(objPtr); } return Tcl_NewUnicodeObj(stringPtr->unicode + first, last-first+1); } /* *---------------------------------------------------------------------- * * Tcl_SetStringObj -- | > > > > > > > > > > > | 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 | stringPtr->numChars = newObjPtr->length; return newObjPtr; } 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+1<stringPtr->numChars) && ((stringPtr->unicode[last+1]&0xFC00) == 0xDC00) && ((stringPtr->unicode[last]&0xFC00) == 0xD800)) { ++last; } #endif return Tcl_NewUnicodeObj(stringPtr->unicode + first, last-first+1); } /* *---------------------------------------------------------------------- * * Tcl_SetStringObj -- |
︙ | ︙ | |||
1865 1866 1867 1868 1869 1870 1871 | } else { useWide = 1; #endif } } else if (ch == 'I') { if ((format[1] == '6') && (format[2] == '4')) { format += (step + 2); | | | | | | | 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 1900 1901 1902 1903 1904 1905 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 | } else { useWide = 1; #endif } } else if (ch == 'I') { if ((format[1] == '6') && (format[2] == '4')) { format += (step + 2); 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 = TclUtfToUniChar(format, &ch); } else { format += step; step = TclUtfToUniChar(format, &ch); } } else if ((ch == 't') || (ch == 'z')) { format += step; 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 = TclUtfToUniChar(format, &ch); #ifndef TCL_WIDE_INT_IS_LONG useWide = 1; #endif } format += step; span = format; |
︙ | ︙ |
Changes to generic/tclStubInit.c.
︙ | ︙ | |||
27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 | #undef Tcl_Realloc #undef Tcl_NewBooleanObj #undef Tcl_NewByteArrayObj #undef Tcl_NewDoubleObj #undef Tcl_NewIntObj #undef Tcl_NewListObj #undef Tcl_NewLongObj #undef Tcl_NewObj #undef Tcl_NewStringObj #undef Tcl_DumpActiveMemory #undef Tcl_ValidateAllMemory #undef Tcl_FindHashEntry #undef Tcl_CreateHashEntry #undef Tcl_Panic #undef Tcl_FindExecutable #undef TclpGetPid #undef TclSockMinimumBuffers #undef Tcl_SetIntObj #undef TclpInetNtoa #undef TclWinGetServByName #undef TclWinGetSockOpt #undef TclWinSetSockOpt #undef TclWinNToHS /* See bug 510001: TclSockMinimumBuffers needs plat imp */ | > > | | > > > > > > > > > > > > | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 | #undef Tcl_Realloc #undef Tcl_NewBooleanObj #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 #undef Tcl_CreateHashEntry #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) || 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) || 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); } #define TclGetStartupScriptPath getStartupScriptPath |
︙ | ︙ | |||
94 95 96 97 98 99 100 | { Tcl_Obj *path = Tcl_GetStartupScript(NULL); if (path == NULL) { return NULL; } return Tcl_GetString(path); } | < > > > > > > > > > > > > > > > > > > | > > > > < < < < < < < < < < < < | | | 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 | { Tcl_Obj *path = Tcl_GetStartupScript(NULL); 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 */ #ifdef _WIN32 # define TclUnixWaitForFile 0 # define TclUnixCopyFile 0 # define TclUnixOpenTemporaryFile 0 # define TclpReaddir 0 # define TclpIsAtty 0 #elif defined(__CYGWIN__) # define TclpIsAtty TclPlatIsAtty #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 static int TclpIsAtty(int fd) { return isatty(fd); } void *TclWinGetTclInstance() { void *hInstance = NULL; GetModuleHandleExW(GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS, (const char *)&TclpIsAtty, &hInstance); return hInstance; } #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) { return setsockopt((int) s, level, optname, optval, optlen); } |
︙ | ︙ | |||
190 191 192 193 194 195 196 | int TclpGetPid(Tcl_Pid pid) { return (int) (size_t) pid; } | < < < < < < | | | | > > | > > > > | > | > > > | > > | > > > > | | 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 | int TclpGetPid(Tcl_Pid pid) { return (int) (size_t) pid; } char * Tcl_WinUtfToTChar( const char *string, int len, Tcl_DString *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) { 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; } #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 * signature. Tcl 9 must find a better solution, but that cannot be done * without introducing a binary incompatibility. */ #define Tcl_DbNewLongObj ((Tcl_Obj*(*)(long,const char*,int))dbNewLongObj) static Tcl_Obj *dbNewLongObj( int intValue, const char *file, int line ) { #ifdef TCL_MEM_DEBUG register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); objPtr->bytes = NULL; objPtr->internalRep.wideValue = (long) intValue; objPtr->typePtr = &tclIntType; return objPtr; #else return Tcl_NewIntObj(intValue); #endif } #define Tcl_GetLongFromObj (int(*)(Tcl_Interp*,Tcl_Obj*,long*))Tcl_GetIntFromObj |
︙ | ︙ | |||
307 308 309 310 311 312 313 | } #define TclFormatInt (int(*)(char *, long))formatInt #endif /* TCL_WIDE_INT_IS_LONG */ #endif /* __CYGWIN__ */ | | | 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 | } #define TclFormatInt (int(*)(char *, long))formatInt #endif /* TCL_WIDE_INT_IS_LONG */ #endif /* __CYGWIN__ */ #if defined(TCL_NO_DEPRECATED) # define Tcl_SeekOld 0 # define Tcl_TellOld 0 # undef Tcl_SetBooleanObj # define Tcl_SetBooleanObj 0 # undef Tcl_PkgPresent # define Tcl_PkgPresent 0 # undef Tcl_PkgProvide |
︙ | ︙ | |||
362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 | # undef Tcl_EvalObj # define Tcl_EvalObj 0 # undef Tcl_GlobalEvalObj # define Tcl_GlobalEvalObj 0 # define TclBackgroundException 0 # undef TclpReaddir # define TclpReaddir 0 # undef TclpGetDate # define TclpGetDate 0 # undef TclpLocaltime # define TclpLocaltime 0 # undef TclpGmtime # define TclpGmtime 0 # define TclpLocaltime_unix 0 # define TclpGmtime_unix 0 #else /* TCL_NO_DEPRECATED */ # define Tcl_SeekOld seekOld # define Tcl_TellOld tellOld # define TclBackgroundException Tcl_BackgroundException # define TclpLocaltime_unix TclpLocaltime # define TclpGmtime_unix TclpGmtime static int seekOld( Tcl_Channel chan, /* The channel on which to seek. */ int offset, /* Offset to seek to. */ | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 | # undef Tcl_EvalObj # define Tcl_EvalObj 0 # 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 # define TclpGmtime 0 # define TclpLocaltime_unix 0 # 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( Tcl_Channel chan, /* The channel on which to seek. */ int offset, /* Offset to seek to. */ |
︙ | ︙ | |||
526 527 528 529 530 531 532 | 0, /* 105 */ 0, /* 106 */ 0, /* 107 */ TclTeardownNamespace, /* 108 */ TclUpdateReturnInfo, /* 109 */ TclSockMinimumBuffers, /* 110 */ Tcl_AddInterpResolvers, /* 111 */ | | | | | | | | | | | | | | 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 | 0, /* 105 */ 0, /* 106 */ 0, /* 107 */ TclTeardownNamespace, /* 108 */ TclUpdateReturnInfo, /* 109 */ TclSockMinimumBuffers, /* 110 */ Tcl_AddInterpResolvers, /* 111 */ TclAppendExportList, /* 112 */ TclCreateNamespace, /* 113 */ TclDeleteNamespace, /* 114 */ TclExport, /* 115 */ TclFindCommand, /* 116 */ TclFindNamespace, /* 117 */ Tcl_GetInterpResolvers, /* 118 */ Tcl_GetNamespaceResolvers, /* 119 */ Tcl_FindNamespaceVar, /* 120 */ TclForgetImport, /* 121 */ TclGetCommandFromObj, /* 122 */ TclGetCommandFullName, /* 123 */ TclGetCurrentNamespace_, /* 124 */ TclGetGlobalNamespace_, /* 125 */ Tcl_GetVariableFullName, /* 126 */ TclImport, /* 127 */ Tcl_PopCallFrame, /* 128 */ Tcl_PushCallFrame, /* 129 */ Tcl_RemoveInterpResolvers, /* 130 */ Tcl_SetNamespaceResolvers, /* 131 */ TclpHasSockets, /* 132 */ TclpGetDate, /* 133 */ 0, /* 134 */ |
︙ | ︙ | |||
592 593 594 595 596 597 598 | TclCheckExecutionTraces, /* 171 */ TclInThreadExit, /* 172 */ TclUniCharMatch, /* 173 */ 0, /* 174 */ TclCallVarTraces, /* 175 */ TclCleanupVar, /* 176 */ TclVarErrMsg, /* 177 */ | | | | 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 | TclCheckExecutionTraces, /* 171 */ TclInThreadExit, /* 172 */ TclUniCharMatch, /* 173 */ 0, /* 174 */ TclCallVarTraces, /* 175 */ TclCleanupVar, /* 176 */ TclVarErrMsg, /* 177 */ TclSetStartupScript, /* 178 */ TclGetStartupScript, /* 179 */ 0, /* 180 */ 0, /* 181 */ TclpLocaltime, /* 182 */ TclpGmtime, /* 183 */ 0, /* 184 */ 0, /* 185 */ 0, /* 186 */ |
︙ | ︙ |
Changes to generic/tclStubLib.c.
︙ | ︙ | |||
62 63 64 65 66 67 68 | /* * We can't optimize this check by caching tclStubsPtr because that * 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))) { | | | | 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 | /* * We can't optimize this check by caching tclStubsPtr because that * 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->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) { return NULL; } |
︙ | ︙ |
Changes to generic/tclTest.c.
︙ | ︙ | |||
301 302 303 304 305 306 307 | static int TestinterpdeleteCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); 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[]); | < < < < < < < < | 301 302 303 304 305 306 307 308 309 310 311 312 313 314 | static int TestinterpdeleteCmd(ClientData dummy, Tcl_Interp *interp, int argc, const char **argv); 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[]); 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, Tcl_Interp *interp, int argc, const char **argv); static int TestpanicCmd(ClientData dummy, |
︙ | ︙ | |||
419 420 421 422 423 424 425 426 427 428 429 430 431 432 | static Tcl_FSOpenFileChannelProc SimpleOpenFileChannel; static Tcl_FSListVolumesProc SimpleListVolumes; 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 TestHashSystemHashCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static Tcl_NRPostProc NREUnwind_callback; static int TestNREUnwind(ClientData clientData, | > > > > > > | 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 | static Tcl_FSOpenFileChannelProc SimpleOpenFileChannel; static Tcl_FSListVolumesProc SimpleListVolumes; 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[]); static Tcl_NRPostProc NREUnwind_callback; static int TestNREUnwind(ClientData clientData, |
︙ | ︙ | |||
545 546 547 548 549 550 551 | *---------------------------------------------------------------------- */ int Tcltest_Init( Tcl_Interp *interp) /* Interpreter for application. */ { | < < < < | 543 544 545 546 547 548 549 550 551 552 553 554 555 556 | *---------------------------------------------------------------------- */ int Tcltest_Init( Tcl_Interp *interp) /* Interpreter for application. */ { Tcl_Obj *listPtr; Tcl_Obj **objv; int objc, index; static const char *const specialOptions[] = { "-appinitprocerror", "-appinitprocdeleteinterp", "-appinitprocclosestderr", "-appinitprocsetrcfile", NULL }; |
︙ | ︙ | |||
688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 | (ClientData) TCL_LEAVE_ERR_MSG, NULL); Tcl_CreateCommand(interp, "testseterrorcode", TestseterrorcodeCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testsetobjerrorcode", TestsetobjerrorcodeCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testnumutfchars", TestNumUtfCharsCmd, 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); | > > > > < < < < < < < < < < < | 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 | (ClientData) TCL_LEAVE_ERR_MSG, NULL); Tcl_CreateCommand(interp, "testseterrorcode", TestseterrorcodeCmd, 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); Tcl_CreateCommand(interp, "testmainthread", TestmainthreadCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsetmainloop", TestsetmainloopCmd, NULL, NULL); Tcl_CreateCommand(interp, "testexitmainloop", TestexitmainloopCmd, NULL, NULL); #if defined(HAVE_CPUID) || defined(_WIN32) Tcl_CreateObjCommand(interp, "testcpuid", TestcpuidCmd, (ClientData) 0, NULL); #endif Tcl_CreateObjCommand(interp, "testnreunwind", TestNREUnwind, NULL, NULL); Tcl_CreateObjCommand(interp, "testnrelevels", TestNRELevels, NULL, NULL); Tcl_CreateObjCommand(interp, "testinterpresolver", TestInterpResolverCmd, NULL, NULL); |
︙ | ︙ | |||
3343 3344 3345 3346 3347 3348 3349 | } return TCL_OK; } /* *---------------------------------------------------------------------- * | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 | } return TCL_OK; } /* *---------------------------------------------------------------------- * * CleanupTestSetassocdataTests -- * * This function is called when an interpreter is deleted to clean * up any data left over from running the testsetassocdata command. * * Results: * None. |
︙ | ︙ | |||
5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 5234 5235 5236 5237 | static int TestsaveresultCmd( ClientData dummy, /* Not used. */ register Tcl_Interp *interp,/* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { int discard, result, index; Tcl_SavedResult state; Tcl_Obj *objPtr; static const char *const optionStrings[] = { "append", "dynamic", "free", "object", "small", NULL }; enum options { | > | 5071 5072 5073 5074 5075 5076 5077 5078 5079 5080 5081 5082 5083 5084 5085 | static int TestsaveresultCmd( 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 }; enum options { |
︙ | ︙ | |||
5291 5292 5293 5294 5295 5296 5297 | Tcl_DiscardResult(&state); } else { Tcl_RestoreResult(interp, &state); result = TCL_OK; } switch ((enum options) index) { | | > > | > | 5139 5140 5141 5142 5143 5144 5145 5146 5147 5148 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 | Tcl_DiscardResult(&state); } else { Tcl_RestoreResult(interp, &state); result = TCL_OK; } switch ((enum options) index) { 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: break; } |
︙ | ︙ | |||
6876 6877 6878 6879 6880 6881 6882 6883 6884 6885 6886 6887 6888 6889 | (void) Tcl_GetIntFromObj(interp, objv[2], &len); } len = Tcl_NumUtfChars(Tcl_GetString(objv[1]), len); Tcl_SetObjResult(interp, Tcl_NewIntObj(len)); } return TCL_OK; } #if defined(HAVE_CPUID) || defined(_WIN32) /* *---------------------------------------------------------------------- * * TestcpuidCmd -- * | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 6727 6728 6729 6730 6731 6732 6733 6734 6735 6736 6737 6738 6739 6740 6741 6742 6743 6744 6745 6746 6747 6748 6749 6750 6751 6752 6753 6754 6755 6756 6757 6758 6759 6760 6761 6762 6763 6764 6765 6766 6767 6768 6769 6770 6771 6772 6773 6774 6775 6776 6777 6778 6779 6780 6781 6782 6783 6784 | (void) Tcl_GetIntFromObj(interp, objv[2], &len); } 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) /* *---------------------------------------------------------------------- * * TestcpuidCmd -- * |
︙ | ︙ |
Changes to generic/tclTestObj.c.
︙ | ︙ | |||
1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 | if (objc != 3) { goto wrongNumArgs; } if (objv[2]->typePtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1)); } else { typeName = objv[2]->typePtr->name; Tcl_SetObjResult(interp, Tcl_NewStringObj(typeName, -1)); } } else if (strcmp(subCmd, "refcount") == 0) { if (objc != 3) { goto wrongNumArgs; } index = Tcl_GetString(objv[2]); | > > > | 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 | if (objc != 3) { goto wrongNumArgs; } 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; } index = Tcl_GetString(objv[2]); |
︙ | ︙ | |||
1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 | return TCL_ERROR; } if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } if (varPtr[varIndex]->typePtr == NULL) { /* a string! */ Tcl_AppendToObj(Tcl_GetObjResult(interp), "string", -1); } else { Tcl_AppendToObj(Tcl_GetObjResult(interp), varPtr[varIndex]->typePtr->name, -1); } } else if (strcmp(subCmd, "types") == 0) { if (objc != 2) { goto wrongNumArgs; | > > > > > | 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 | return TCL_ERROR; } 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) { if (objc != 2) { goto wrongNumArgs; |
︙ | ︙ |
Changes to generic/tclTimer.c.
︙ | ︙ | |||
815 816 817 818 819 820 821 | } /* * First lets see if the command was passed a number as the first argument. */ if (objv[1]->typePtr == &tclIntType | < < < | 815 816 817 818 819 820 821 822 823 824 825 826 827 828 | } /* * First lets see if the command was passed a number as the first argument. */ if (objv[1]->typePtr == &tclIntType || 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) { const char *arg = Tcl_GetString(objv[1]); |
︙ | ︙ | |||
1041 1042 1043 1044 1045 1046 1047 | if (Tcl_LimitCheck(interp) != TCL_OK) { return TCL_ERROR; } } if (iPtr->limit.timeEvent == NULL || TCL_TIME_BEFORE(endTime, iPtr->limit.time)) { diff = TCL_TIME_DIFF_MS_CEILING(endTime, now); | < < < < < | | | | | | | | | < < < < < | | | 1038 1039 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 | if (Tcl_LimitCheck(interp) != TCL_OK) { return TCL_ERROR; } } if (iPtr->limit.timeEvent == NULL || TCL_TIME_BEFORE(endTime, iPtr->limit.time)) { diff = TCL_TIME_DIFF_MS_CEILING(endTime, now); 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; } } if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) { return TCL_ERROR; } if (Tcl_LimitCheck(interp) != TCL_OK) { return TCL_ERROR; } } Tcl_GetTime(&now); } while (TCL_TIME_BEFORE(now, endTime)); return TCL_OK; } /* *---------------------------------------------------------------------- * |
︙ | ︙ |
Changes to generic/tclUtf.c.
︙ | ︙ | |||
64 65 66 67 68 69 70 | 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, 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, | < < < < | 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 | 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, 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, 4,4,4,4,4,4,4,4, 1,1,1,1,1,1,1,1 }; /* *--------------------------------------------------------------------------- * * TclUtfCount -- |
︙ | ︙ | |||
90 91 92 93 94 95 96 | * None. * *--------------------------------------------------------------------------- */ int TclUtfCount( | | | 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 | * None. * *--------------------------------------------------------------------------- */ int TclUtfCount( int ch) /* The Unicode character whose size is returned. */ { if ((unsigned)(ch - 1) < (UNICODE_SELF - 1)) { return 1; } if (ch <= 0x7FF) { return 2; } |
︙ | ︙ | |||
324 325 326 327 328 329 330 | } /* * A three-byte-character lead-byte not followed by two trail-bytes * represents itself. */ } | < | > > > > > > > > > > | 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 | } /* * A three-byte-character lead-byte not followed by two trail-bytes * represents itself. */ } 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 == 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)); if (byte & 0x100000) { /* out of range, < 0x10000 or > 0x10ffff */ |
︙ | ︙ | |||
361 362 363 364 365 366 367 | } /* * A four-byte-character lead-byte not followed by two trail-bytes * represents itself. */ } | < | 366 367 368 369 370 371 372 373 374 375 376 377 378 379 | } /* * A four-byte-character lead-byte not followed by two trail-bytes * represents itself. */ } *chPtr = (Tcl_UniChar) byte; return 1; } /* *--------------------------------------------------------------------------- |
︙ | ︙ | |||
394 395 396 397 398 399 400 | const char *src, /* UTF-8 string to convert to Unicode. */ int length, /* Length of UTF-8 string in bytes, or -1 for * strlen(). */ Tcl_DString *dsPtr) /* Unicode representation of string is * appended to this previously initialized * DString. */ { | | | 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 | const char *src, /* UTF-8 string to convert to Unicode. */ int length, /* Length of UTF-8 string in bytes, or -1 for * strlen(). */ Tcl_DString *dsPtr) /* Unicode representation of string is * appended to this previously initialized * DString. */ { Tcl_UniChar ch = 0, *w, *wString; const char *p, *end; int oldLength; if (length < 0) { length = strlen(src); } |
︙ | ︙ | |||
495 496 497 498 499 500 501 | if (length < 0) { while (*src != '\0') { src += TclUtfToUniChar(src, &ch); i++; } if (i < 0) i = INT_MAX; /* Bug [2738427] */ } else { | | | | | | | | | > > > > > > > | | | | | | > > > > > > > | | 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 | if (length < 0) { while (*src != '\0') { src += TclUtfToUniChar(src, &ch); i++; } if (i < 0) i = INT_MAX; /* Bug [2738427] */ } else { register const char *endPtr = src + length - 4; while (src < endPtr) { src += TclUtfToUniChar(src, &ch); i++; } endPtr += 4; while ((src < endPtr) && Tcl_UtfCharComplete(src, endPtr - src)) { src += TclUtfToUniChar(src, &ch); i++; } if (src < endPtr) { i += endPtr - src; } } return i; } /* *--------------------------------------------------------------------------- * * Tcl_UtfFindFirst -- * * 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 Unicode character does not exist in the given string, * the return value is NULL. * * Side effects: * None. * *--------------------------------------------------------------------------- */ const char * Tcl_UtfFindFirst( const char *src, /* The UTF-8 string to be searched. */ int ch) /* The Unicode character to search for. */ { int len, fullchar; Tcl_UniChar find = 0; while (1) { len = TclUtfToUniChar(src, &find); 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; } src += len; } } /* *--------------------------------------------------------------------------- * * Tcl_UtfFindLast -- * * 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 Unicode character does not exist in the given string, the * return value is NULL. * * Side effects: * None. * *--------------------------------------------------------------------------- */ const char * Tcl_UtfFindLast( const char *src, /* The UTF-8 string to be searched. */ int ch) /* The Unicode character to search for. */ { int len, fullchar; Tcl_UniChar find = 0; const char *last; last = NULL; while (1) { len = TclUtfToUniChar(src, &find); 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; } src += len; } |
︙ | ︙ | |||
659 660 661 662 663 664 665 | const char *start) /* Pointer to the beginning of the string, to * avoid going backwards too far. */ { const char *look; int i, byte; look = --src; | | | 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 | const char *start) /* Pointer to the beginning of the string, to * avoid going backwards too far. */ { const char *look; int i, byte; look = --src; for (i = 0; i < 4; i++) { if (look < start) { if (src < start) { src = start; } break; } byte = *((unsigned char *) look); |
︙ | ︙ | |||
683 684 685 686 687 688 689 | } /* *--------------------------------------------------------------------------- * * Tcl_UniCharAtIndex -- * | | | < | 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 | } /* *--------------------------------------------------------------------------- * * Tcl_UniCharAtIndex -- * * Returns the Tcl_UniChar represented at the specified character * (not byte) position in the UTF-8 string. * * Results: * As above. * * Side effects: * None. * *--------------------------------------------------------------------------- */ Tcl_UniChar Tcl_UniCharAtIndex( 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) { src += TclUtfToUniChar(src, &ch); } return ch; } /* *--------------------------------------------------------------------------- |
︙ | ︙ | |||
733 734 735 736 737 738 739 | const char * Tcl_UtfAtIndex( register const char *src, /* The UTF-8 string. */ register int index) /* The position of the desired character. */ { Tcl_UniChar ch = 0; | | < | 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 | const char * Tcl_UtfAtIndex( register const char *src, /* The UTF-8 string. */ register int index) /* The position of the desired character. */ { Tcl_UniChar ch = 0; while (index-- > 0) { src += TclUtfToUniChar(src, &ch); } return src; } /* *--------------------------------------------------------------------------- |
︙ | ︙ | |||
1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 | * 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) { return (ch1 - ch2); } } return 0; } /* | > > > > > > > > > > | 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 | * 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 return (ch1 - ch2); } } return 0; } /* |
︙ | ︙ | |||
1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 | int Tcl_UtfNcasecmp( 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) { ch1 = Tcl_UniCharToLower(ch1); ch2 = Tcl_UniCharToLower(ch2); if (ch1 != ch2) { return (ch1 - ch2); } } } return 0; } | > > > > > > > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < | > > > > > > > > > > > | 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 | int Tcl_UtfNcasecmp( 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); } /* *---------------------------------------------------------------------- * * 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. * * Results: * Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct. * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclUtfCasecmp( 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 ch1 = Tcl_UniCharToLower(ch1); ch2 = Tcl_UniCharToLower(ch2); if (ch1 != ch2) { return ch1 - ch2; } } } |
︙ | ︙ |
Changes to generic/tclUtil.c.
︙ | ︙ | |||
970 971 972 973 974 975 976 | int Tcl_ScanCountedElement( 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. */ { | | | 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 | int Tcl_ScanCountedElement( 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. */ { char flags = CONVERT_ANY; int numBytes = TclScanElement(src, length, &flags); *flagPtr = flags; return numBytes; } /* |
︙ | ︙ | |||
1011 1012 1013 1014 1015 1016 1017 | *---------------------------------------------------------------------- */ int TclScanElement( const char *src, /* String to convert to Tcl list element. */ int length, /* Number of bytes in src, or -1. */ | | | 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 | *---------------------------------------------------------------------- */ int TclScanElement( const char *src, /* String to convert to Tcl list element. */ int length, /* Number of bytes in src, or -1. */ 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 * needs protection or escape. */ int requireEscape = 0; /* Force use of CONVERT_ESCAPE mode. For some |
︙ | ︙ | |||
1543 1544 1545 1546 1547 1548 1549 | */ char * Tcl_Merge( int argc, /* How many strings to merge. */ const char *const *argv) /* Array of string values. */ { | | | < < < < < < < < < < < < < < < | | 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 | */ char * Tcl_Merge( int argc, /* How many strings to merge. */ const char *const *argv) /* Array of string values. */ { #define LOCAL_SIZE 64 char localFlags[LOCAL_SIZE], *flagPtr = NULL; int i, bytesNeeded = 0; char *result, *dst; /* * Handle empty list case first, so logic of the general case can be * simpler. */ if (argc == 0) { result = ckalloc(1); result[0] = '\0'; return result; } /* * Pass 1: estimate space, gather flags. */ if (argc <= LOCAL_SIZE) { flagPtr = localFlags; } else { 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) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } |
︙ | ︙ | |||
1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 | if (flagPtr != localFlags) { ckfree(flagPtr); } return result; } /* *---------------------------------------------------------------------- * * Tcl_Backslash -- * * Figure out how to handle a backslash sequence. * | > | 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 | if (flagPtr != localFlags) { ckfree(flagPtr); } return result; } #if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 /* *---------------------------------------------------------------------- * * Tcl_Backslash -- * * Figure out how to handle a backslash sequence. * |
︙ | ︙ | |||
1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 | char buf[TCL_UTF_MAX]; Tcl_UniChar ch = 0; Tcl_UtfBackslash(src, readPtr, buf); TclUtfToUniChar(buf, &ch); return (char) ch; } /* *---------------------------------------------------------------------- * * TclTrimRight -- * * Takes two counted strings in the Tcl encoding which must both be null | > | 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 | char buf[TCL_UTF_MAX]; Tcl_UniChar ch = 0; Tcl_UtfBackslash(src, readPtr, buf); TclUtfToUniChar(buf, &ch); return (char) ch; } #endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- * * TclTrimRight -- * * Takes two counted strings in the Tcl encoding which must both be null |
︙ | ︙ | |||
1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 | const char *bytes, /* String to be trimmed... */ 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 + numBytes; int pInc; if ((bytes[numBytes] != '\0') || (trim[numTrim] != '\0')) { Tcl_Panic("TclTrimRight works only on null-terminated strings"); } /* * Empty strings -> nothing to do. */ if ((numBytes == 0) || (numTrim == 0)) { return 0; } /* * Outer loop: iterate over string to be trimmed. */ do { | > < < | 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 | const char *bytes, /* String to be trimmed... */ 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 + 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"); } /* * Empty strings -> nothing to do. */ if ((numBytes == 0) || (numTrim == 0)) { return 0; } /* * Outer loop: iterate over string to be trimmed. */ do { const char *q = trim; int bytesLeft = numTrim; p = Tcl_UtfPrev(p, bytes); pInc = TclUtfToUniChar(p, &ch1); /* * Inner loop: scan trim string for match to current character. */ do { int qInc = TclUtfToUniChar(q, &ch2); if (ch1 == ch2) { break; } q += qInc; |
︙ | ︙ | |||
1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 | TclTrimLeft( const char *bytes, /* String to be trimmed... */ 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; if ((bytes[numBytes] != '\0') || (trim[numTrim] != '\0')) { Tcl_Panic("TclTrimLeft works only on null-terminated strings"); } /* * Empty strings -> nothing to do. */ if ((numBytes == 0) || (numTrim == 0)) { return 0; } /* * Outer loop: iterate over string to be trimmed. */ do { | > < < | 1742 1743 1744 1745 1746 1747 1748 1749 1750 1751 1752 1753 1754 1755 1756 1757 1758 1759 1760 1761 1762 1763 1764 1765 1766 1767 1768 1769 1770 1771 1772 1773 1774 1775 1776 1777 1778 1779 1780 1781 1782 1783 | TclTrimLeft( const char *bytes, /* String to be trimmed... */ 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"); } /* * Empty strings -> nothing to do. */ if ((numBytes == 0) || (numTrim == 0)) { return 0; } /* * Outer loop: iterate over string to be trimmed. */ do { int pInc = TclUtfToUniChar(p, &ch1); const char *q = trim; int bytesLeft = numTrim; /* * Inner loop: scan trim string for match to current character. */ do { int qInc = TclUtfToUniChar(q, &ch2); if (ch1 == ch2) { break; } q += qInc; |
︙ | ︙ | |||
2118 2119 2120 2121 2122 2123 2124 | const char *str, /* String. */ const char *pattern, /* Pattern, which may contain special * characters. */ int nocase) /* 0 for case sensitive, 1 for insensitive */ { int p, charLen; const char *pstart = pattern; | | | 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 | const char *str, /* String. */ const char *pattern, /* Pattern, which may contain special * characters. */ int nocase) /* 0 for case sensitive, 1 for insensitive */ { int p, charLen; const char *pstart = pattern; Tcl_UniChar ch1 = 0, ch2 = 0; while (1) { p = *pattern; /* * See if we're at the end of both the pattern and the string. If so, * we succeeded. If we're at the end of the pattern but not at the end |
︙ | ︙ | |||
2228 2229 2230 2231 2232 2233 2234 | /* * Check for a "[" as the next pattern character. It is followed by a * list of characters that are acceptable, or by a range (two * characters separated by "-"). */ if (p == '[') { | | | 2213 2214 2215 2216 2217 2218 2219 2220 2221 2222 2223 2224 2225 2226 2227 | /* * Check for a "[" as the next pattern character. It is followed by a * list of characters that are acceptable, or by a range (two * characters separated by "-"). */ if (p == '[') { Tcl_UniChar startChar = 0, endChar = 0; pattern++; if (UCHAR(*str) < 0x80) { ch1 = (Tcl_UniChar) (nocase ? tolower(UCHAR(*str)) : UCHAR(*str)); str++; } else { |
︙ | ︙ | |||
2713 2714 2715 2716 2717 2718 2719 | Tcl_DStringAppendElement( Tcl_DString *dsPtr, /* Structure describing dynamic string. */ const char *element) /* String to append. Must be * null-terminated. */ { char *dst = dsPtr->string + dsPtr->length; int needSpace = TclNeedSpace(dsPtr->string, dst); | | | 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 | Tcl_DStringAppendElement( Tcl_DString *dsPtr, /* Structure describing dynamic string. */ const char *element) /* String to append. Must be * null-terminated. */ { char *dst = dsPtr->string + dsPtr->length; int needSpace = TclNeedSpace(dsPtr->string, dst); 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 * enough. Allocate extra space in the new buffer so that there will be * room to grow before we have to allocate again. SPECIAL NOTE: must use |
︙ | ︙ | |||
2919 2920 2921 2922 2923 2924 2925 | void 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. */ { | > | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 2930 2931 2932 2933 2934 2935 2936 2937 2938 2939 2940 2941 2942 2943 2944 2945 2946 2947 2948 2949 2950 2951 2952 2953 2954 2955 2956 2957 2958 2959 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 2976 2977 2978 2979 2980 2981 2982 2983 2984 2985 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 | void 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. */ { #ifdef TCL_NO_DEPRECATED Tcl_Obj *obj = Tcl_GetObjResult(interp); const char *bytes = TclGetString(obj); Tcl_DStringFree(dsPtr); 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 */ } /* *---------------------------------------------------------------------- * * TclDStringToObj -- * |
︙ | ︙ | |||
3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 | * If the new value doesn't make sense then this function undoes the * effect of the variable modification. Otherwise it modifies the format * string that's used by Tcl_PrintDouble. * *---------------------------------------------------------------------- */ /* ARGSUSED */ char * TclPrecTraceProc( ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Interpreter containing variable. */ const char *name1, /* Name of variable. */ const char *name2, /* Second part of variable name. */ | > | 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 | * If the new value doesn't make sense then this function undoes the * effect of the variable modification. Otherwise it modifies the format * 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. */ const char *name1, /* Name of variable. */ const char *name2, /* Second part of variable name. */ |
︙ | ︙ | |||
3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 | || Tcl_GetIntFromObj(NULL, value, &prec) != TCL_OK || prec < 0 || prec > TCL_MAX_PREC) { return (char *) "improper value for precision"; } *precisionPtr = prec; return NULL; } /* *---------------------------------------------------------------------- * * TclNeedSpace -- * * This function checks to see whether it is appropriate to add a space | > | 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 | || Tcl_GetIntFromObj(NULL, value, &prec) != TCL_OK || prec < 0 || prec > TCL_MAX_PREC) { return (char *) "improper value for precision"; } *precisionPtr = prec; return NULL; } #endif /* !TCL_NO_DEPRECATED)*/ /* *---------------------------------------------------------------------- * * TclNeedSpace -- * * This function checks to see whether it is appropriate to add a space |
︙ | ︙ | |||
3411 3412 3413 3414 3415 3416 3417 | *---------------------------------------------------------------------- */ int TclFormatInt( char *buffer, /* Points to the storage into which the * formatted characters are written. */ | | | | 3472 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 | *---------------------------------------------------------------------- */ int TclFormatInt( char *buffer, /* Points to the storage into which the * formatted characters are written. */ Tcl_WideInt n) /* The integer to format. */ { Tcl_WideInt intVal; int i; int numFormatted, j; const char *digits = "0123456789"; /* * Check first whether "n" is zero. */ |
︙ | ︙ | |||
3436 3437 3438 3439 3440 3441 3442 | * Check whether "n" is the maximum negative value. This is -2^(m-1) for * an m-bit word, and has no positive equivalent; negating it produces the * same value. */ intVal = -n; /* [Bug 3390638] Workaround for*/ if (n == -n || intVal == n) { /* broken compiler optimizers. */ | | | 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 | * Check whether "n" is the maximum negative value. This is -2^(m-1) for * an m-bit word, and has no positive equivalent; negating it produces the * same value. */ intVal = -n; /* [Bug 3390638] Workaround for*/ if (n == -n || intVal == n) { /* broken compiler optimizers. */ return sprintf(buffer, "%" TCL_LL_MODIFIER "d", n); } /* * Generate the characters of the result backwards in the buffer. */ intVal = (n < 0? -n : n); |
︙ | ︙ | |||
3475 3476 3477 3478 3479 3480 3481 | } /* *---------------------------------------------------------------------- * * TclGetIntForIndex -- * | | | | | | < | | < < < > | | < | | < | | | | 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 3554 3555 3556 3557 3558 3559 3560 3561 3562 3563 3564 3565 | } /* *---------------------------------------------------------------------- * * TclGetIntForIndex -- * * 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( Tcl_Interp *interp, /* Interpreter to use for error reporting. If * NULL, then no error message is left after |
︙ | ︙ | |||
3525 3526 3527 3528 3529 3530 3531 | if (SetEndOffsetFromAny(NULL, objPtr) == TCL_OK) { /* * If the object is already an offset from the end of the list, or can * be converted to one, use it. */ | | | 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 | if (SetEndOffsetFromAny(NULL, objPtr) == TCL_OK) { /* * 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.wideValue; return TCL_OK; } bytes = TclGetString(objPtr); length = objPtr->length; /* |
︙ | ︙ | |||
3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 | bytes = TclGetString(objPtr); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad index \"%s\": must be integer?[+-]integer? or" " end?[+-]integer?", bytes)); if (!strncmp(bytes, "end-", 4)) { bytes += 4; } Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL); } return TCL_ERROR; } /* | > | 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 | bytes = TclGetString(objPtr); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "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; } /* |
︙ | ︙ | |||
3616 3617 3618 3619 3620 3621 3622 | UpdateStringOfEndOffset( register Tcl_Obj *objPtr) { char buffer[TCL_INTEGER_SPACE + 5]; register int len = 3; memcpy(buffer, "end", 4); | | | | 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 3689 | UpdateStringOfEndOffset( register Tcl_Obj *objPtr) { char buffer[TCL_INTEGER_SPACE + 5]; register int len = 3; memcpy(buffer, "end", 4); if (objPtr->internalRep.wideValue != 0) { buffer[len++] = '-'; len += TclFormatInt(buffer+len, -(objPtr->internalRep.wideValue)); } objPtr->bytes = ckalloc((unsigned) len+1); memcpy(objPtr->bytes, buffer, (unsigned) len+1); objPtr->length = len; } /* |
︙ | ︙ | |||
3648 3649 3650 3651 3652 3653 3654 | */ static int SetEndOffsetFromAny( Tcl_Interp *interp, /* Tcl interpreter or NULL */ Tcl_Obj *objPtr) /* Pointer to the object to parse */ { | | | 3705 3706 3707 3708 3709 3710 3711 3712 3713 3714 3715 3716 3717 3718 3719 | */ static int SetEndOffsetFromAny( Tcl_Interp *interp, /* Tcl interpreter or NULL */ Tcl_Obj *objPtr) /* Pointer to the object to parse */ { 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. */ |
︙ | ︙ | |||
3684 3685 3686 3687 3688 3689 3690 | */ if (length <= 3) { offset = 0; } else if ((length > 4) && ((bytes[3] == '-') || (bytes[3] == '+'))) { /* * This is our limited string expression evaluator. Pass everything | | > | > > > > | 3741 3742 3743 3744 3745 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 | */ 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 TclParseNumber. */ if (TclIsSpaceProc(bytes[4])) { goto badIndexFormat; } 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 { /* * Conversion failed. Report the error. */ |
︙ | ︙ | |||
3716 3717 3718 3719 3720 3721 3722 | /* * The conversion succeeded. Free the old internal rep and set the new * one. */ TclFreeIntRep(objPtr); | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 3793 3794 3795 3796 3797 3798 3799 3800 3801 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 3858 3859 3860 3861 3862 3863 | /* * The conversion succeeded. Free the old internal rep and set the new * one. */ TclFreeIntRep(objPtr); 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 -- * * Remove all the entries in the hash table *tablePtr. |
︙ | ︙ | |||
3886 3887 3888 3889 3890 3891 3892 | * loss of the intrep. Increment newValue refCount early to handle case * where we set a PGV to itself. */ Tcl_IncrRefCount(newValue); cacheMap = GetThreadHash(&pgvPtr->key); ClearHash(cacheMap); | | | 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 | * loss of the intrep. Increment newValue refCount early to handle case * where we set a PGV to itself. */ Tcl_IncrRefCount(newValue); cacheMap = GetThreadHash(&pgvPtr->key); ClearHash(cacheMap); hPtr = Tcl_CreateHashEntry(cacheMap, (void *)(size_t)(pgvPtr->epoch), &dummy); Tcl_SetHashValue(hPtr, newValue); Tcl_MutexUnlock(&pgvPtr->mutex); } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
3912 3913 3914 3915 3916 3917 3918 | Tcl_Obj * TclGetProcessGlobalValue( ProcessGlobalValue *pgvPtr) { Tcl_Obj *value = NULL; Tcl_HashTable *cacheMap; Tcl_HashEntry *hPtr; | | | 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 | Tcl_Obj * TclGetProcessGlobalValue( ProcessGlobalValue *pgvPtr) { Tcl_Obj *value = NULL; Tcl_HashTable *cacheMap; Tcl_HashEntry *hPtr; unsigned int epoch = pgvPtr->epoch; if (pgvPtr->encoding) { Tcl_Encoding current = Tcl_GetEncoding(NULL, NULL); if (pgvPtr->encoding != current) { /* * The system encoding has changed since the master string value |
︙ | ︙ | |||
3946 3947 3948 3949 3950 3951 3952 | pgvPtr->encoding = current; Tcl_MutexUnlock(&pgvPtr->mutex); } else { Tcl_FreeEncoding(current); } } cacheMap = GetThreadHash(&pgvPtr->key); | | | 4075 4076 4077 4078 4079 4080 4081 4082 4083 4084 4085 4086 4087 4088 4089 | pgvPtr->encoding = current; Tcl_MutexUnlock(&pgvPtr->mutex); } else { Tcl_FreeEncoding(current); } } cacheMap = GetThreadHash(&pgvPtr->key); hPtr = Tcl_FindHashEntry(cacheMap, (void *)(size_t)epoch); if (NULL == hPtr) { int dummy; /* * No cache for the current epoch - must be a new one. * * First, clear the cacheMap, as anything in it must refer to some |
︙ | ︙ | |||
3979 3980 3981 3982 3983 3984 3985 | /* * Store a copy of the shared value in our epoch-indexed cache. */ value = Tcl_NewStringObj(pgvPtr->value, pgvPtr->numBytes); hPtr = Tcl_CreateHashEntry(cacheMap, | | | 4108 4109 4110 4111 4112 4113 4114 4115 4116 4117 4118 4119 4120 4121 4122 | /* * Store a copy of the shared value in our epoch-indexed cache. */ value = Tcl_NewStringObj(pgvPtr->value, pgvPtr->numBytes); hPtr = Tcl_CreateHashEntry(cacheMap, (void *)(size_t)(pgvPtr->epoch), &dummy); Tcl_MutexUnlock(&pgvPtr->mutex); Tcl_SetHashValue(hPtr, value); Tcl_IncrRefCount(value); } return Tcl_GetHashValue(hPtr); } |
︙ | ︙ |
Changes to generic/tclVar.c.
︙ | ︙ | |||
812 813 814 815 816 817 818 | || (cxtNsPtr == iPtr->globalNsPtr) || ((*varName == ':') && (*(varName+1) == ':')); if (lookGlobal) { *indexPtr = -1; flags = (flags | TCL_GLOBAL_ONLY) & ~TCL_NAMESPACE_ONLY; } else { | > | > > | > | 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 | || (cxtNsPtr == iPtr->globalNsPtr) || ((*varName == ':') && (*(varName+1) == ':')); if (lookGlobal) { *indexPtr = -1; flags = (flags | TCL_GLOBAL_ONLY) & ~TCL_NAMESPACE_ONLY; } else { 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! */ |
︙ | ︙ | |||
5701 5702 5703 5704 5705 5706 5707 | } } /* * Find the namespace(s) that contain the variable. */ | < < < < | 5705 5706 5707 5708 5709 5710 5711 5712 5713 5714 5715 5716 5717 5718 | } } /* * Find the namespace(s) that contain the variable. */ 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 * to check both possible search paths: from the specified namespace * context and from the global namespace. |
︙ | ︙ |
Changes to generic/tclZlib.c.
︙ | ︙ | |||
369 370 371 372 373 374 375 | /* * Catch-all. Should be unreachable because all cases are already * listed above. */ default: TclNewLiteralStringObj(objv[2], "UNKNOWN"); | | | 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 | /* * Catch-all. Should be unreachable because all cases are already * listed above. */ default: TclNewLiteralStringObj(objv[2], "UNKNOWN"); TclNewIntObj(objv[3], code); return Tcl_NewListObj(4, objv); } } /* *---------------------------------------------------------------------- * |
︙ | ︙ |
Changes to library/init.tcl.
︙ | ︙ | |||
12 13 14 15 16 17 18 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # 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]" } | | | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # # 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 8.7a2 # Compute the auto path to use in this interpreter. # The values on the path come from several locations: # # The environment variable TCLLIBPATH # # tcl_library, which is the directory containing this init.tcl script. |
︙ | ︙ | |||
69 70 71 72 73 74 75 | variable Path [encoding dirs] set Dir [file join $::tcl_library encoding] if {$Dir ni $Path} { lappend Path $Dir encoding dirs $Path } } | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 69 70 71 72 73 74 75 76 77 78 79 80 81 82 | variable Path [encoding dirs] set Dir [file join $::tcl_library encoding] if {$Dir ni $Path} { lappend Path $Dir encoding dirs $Path } } } namespace eval tcl::Pkg {} # Windows specific end of initialization if {(![interp issafe]) && ($tcl_platform(platform) eq "windows")} { |
︙ | ︙ | |||
652 653 654 655 656 657 658 | if {[info exists auto_execs($name)]} { return $auto_execs($name) } set auto_execs($name) "" set shellBuiltins [list assoc cls copy date del dir echo erase ftype \ | | < | 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 | if {[info exists auto_execs($name)]} { 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] 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] } |
︙ | ︙ | |||
687 688 689 690 691 692 693 | } set path "[file dirname [info nameof]];.;" if {[info exists env(WINDIR)]} { set windir $env(WINDIR) } if {[info exists windir]} { | < | < < | 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 | } set path "[file dirname [info nameof]];.;" if {[info exists env(WINDIR)]} { set windir $env(WINDIR) } if {[info exists windir]} { append path "$windir/system32;$windir/system;$windir;" } foreach var {PATH Path path} { if {[info exists env($var)]} { append path ";$env($var)" } } |
︙ | ︙ |
Changes to library/safe.tcl.
︙ | ︙ | |||
109 110 111 112 113 114 115 | # -> TODO (the app should share or access easily the program/value stored # by opt) # 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 | | | 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 | # -> TODO (the app should share or access easily the program/value stored # by opt) # 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 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 # we know that "slave" is our given argument because it also # checks for the "-help" option. |
︙ | ︙ |
Changes to macosx/README.
︙ | ︙ | |||
109 110 111 112 113 114 115 | ReleaseUniversal10.5SDK: build against the 10.5 SDK (with 10.5 deployment target). 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. | | | 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 | ReleaseUniversal10.5SDK: build against the 10.5 SDK (with 10.5 deployment target). 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. '../../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" This requires Mac OS X 10.4 and Xcode 2.4 (or Xcode 2.2 if -arch x86_64 is omitted, but _not_ Xcode 2.1) and will work on any architecture (on PowerPC |
︙ | ︙ | |||
137 138 139 140 141 142 143 | Detailed Instructions for building with macosx/GNUmakefile ---------------------------------------------------------- - Unpack the Tcl source release archive. - The following instructions assume the Tcl source tree is named "tcl${ver}", | | | | 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 | Detailed Instructions for building with macosx/GNUmakefile ---------------------------------------------------------- - 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. '8.7'). Setup this shell variable as follows: 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" export CFLAGS |
︙ | ︙ |
Changes to macosx/Tcl-Common.xcconfig.
︙ | ︙ | |||
30 31 32 33 34 35 36 | PER_ARCH_CFLAGS_ppc = -mcpu=G3 -mtune=G4 $(PER_ARCH_CFLAGS_ppc) PER_ARCH_CFLAGS_ppc64 = -mcpu=G5 -mpowerpc64 $(PER_ARCH_CFLAGS_ppc64) 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 | | | 30 31 32 33 34 35 36 37 | PER_ARCH_CFLAGS_ppc = -mcpu=G3 -mtune=G4 $(PER_ARCH_CFLAGS_ppc) PER_ARCH_CFLAGS_ppc64 = -mcpu=G5 -mpowerpc64 $(PER_ARCH_CFLAGS_ppc64) 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 = 8.7 |
Changes to tests/assemble.test.
︙ | ︙ | |||
777 778 779 780 781 782 783 | test assemble-7.43 {uplus} { -body { assemble { push NaN; uplus } } -returnCodes error | | | 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 | test assemble-7.43 {uplus} { -body { assemble { push NaN; uplus } } -returnCodes error -result {can't use non-numeric floating-point value as operand of "+"} } test assemble-7.43.1 {tryCvtToNumeric} { -body { assemble { push NaN; tryCvtToNumeric } } |
︙ | ︙ |
Changes to tests/basic.test.
︙ | ︙ | |||
979 980 981 982 983 984 985 986 987 988 989 990 991 992 | namespace eval ns { variable x namespace testevalex {set ::context $x} global } namespace delete ns set ::context } {global} # Clean up after expand tests unset noComp l1 l2 constraints rename l3 {} rename run {} #cleanup | > > > > > > > > > > | 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 | namespace eval ns { variable x namespace 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 {} #cleanup |
︙ | ︙ |
Changes to tests/chanio.test.
︙ | ︙ | |||
5862 5863 5864 5865 5866 5867 5868 5869 5870 5871 5872 5873 5874 5875 | chan event $f readable {script 2} chan event $f readable {} list [testfevent cmd "chan event $f readable"] [chan event $f readable] } -constraints {testfevent fileevent} -cleanup { testfevent delete chan close $f } -result {{script 1} {}} set path(bar) [makeFile {} bar] test chan-io-48.1 {testing readability conditions} {fileevent} { set f [open $path(bar) w] chan puts $f abcdefg chan puts $f abcdefg | > > | 5862 5863 5864 5865 5866 5867 5868 5869 5870 5871 5872 5873 5874 5875 5876 5877 | chan event $f readable {script 2} chan event $f readable {} 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] chan puts $f abcdefg chan puts $f abcdefg |
︙ | ︙ | |||
5957 5958 5959 5960 5961 5962 5963 5964 5965 5966 5967 5968 5969 5970 | chan puts $f {copy_slowly $f} chan puts $f {exit} 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}} 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 { set f [open $path(test1) w] chan configure $f -translation lf | > > > | 5959 5960 5961 5962 5963 5964 5965 5966 5967 5968 5969 5970 5971 5972 5973 5974 5975 | chan puts $f {copy_slowly $f} chan puts $f {exit} 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 { set f [open $path(test1) w] chan configure $f -translation lf |
︙ | ︙ | |||
6786 6787 6788 6789 6790 6791 6792 | # -translation binary is also -encoding binary chan configure $in -translation binary chan configure $out -encoding koi8-r -translation lf chan copy $in $out chan close $in chan close $out file size $path(kyrillic.txt) | < < | 6791 6792 6793 6794 6795 6796 6797 6798 6799 6800 6801 6802 6803 6804 | # -translation binary is also -encoding binary chan configure $in -translation binary chan configure $out -encoding koi8-r -translation lf chan copy $in $out chan close $in chan close $out file size $path(kyrillic.txt) } -result 3 test chan-io-53.1 {CopyData} -setup { file delete $path(test1) } -constraints {fcopy} -body { set f1 [open $thisScript] set f2 [open $path(test1) w] |
︙ | ︙ |
Changes to tests/cmdIL.test.
︙ | ︙ | |||
15 16 17 18 19 20 21 22 23 24 25 26 27 28 | ::tcltest::loadTestedCommands 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]] 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 { lsort -foo {1 3 2 5} } -result {bad option "-foo": must be -ascii, -command, -decreasing, -dictionary, -increasing, -index, -indices, -integer, -nocase, -real, -stride, or -unique} | > | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 | ::tcltest::loadTestedCommands 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 { lsort -foo {1 3 2 5} } -result {bad option "-foo": must be -ascii, -command, -decreasing, -dictionary, -increasing, -index, -indices, -integer, -nocase, -real, -stride, or -unique} |
︙ | ︙ | |||
143 144 145 146 147 148 149 150 151 152 153 154 155 156 | } -result {when used with "-stride", the leading "-index" value must be within the group} test cmdIL-1.36 {lsort -stride and -index: Bug 2918962} { 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}} # 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 { set result {} set r 1435753299 | > > > > > > > > > > > > | 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 | } -result {when used with "-stride", the leading "-index" value must be within the group} test cmdIL-1.36 {lsort -stride and -index: Bug 2918962} { 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 { set result {} set r 1435753299 |
︙ | ︙ |
Changes to tests/compExpr-old.test.
︙ | ︙ | |||
16 17 18 19 20 21 22 | package require tcltest 2 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] | < < < < < < | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 | package require tcltest 2 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] # Big test for correct ordering of data in [expr] proc testIEEE {} { variable ieeeValues binary scan [binary format dd -1.0 1.0] c* c switch -exact -- $c { {0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} { |
︙ | ︙ | |||
281 282 283 284 285 286 287 | expr 2***3|6 } -returnCodes error -match glob -result * 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 | | | | | | 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 | expr 2***3|6 } -returnCodes error -match glob -result * 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 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 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 test compExpr-old-7.5 {CompileBitAndExpr: error in equality expr} -body { expr x==3 } -returnCodes error -match glob -result * test compExpr-old-7.6 {CompileBitAndExpr: simple bitand exprs} {expr 7&0x13} 3 test compExpr-old-7.7 {CompileBitAndExpr: simple bitand exprs} {expr 0xf2&0x53} 82 test compExpr-old-7.8 {CompileBitAndExpr: simple bitand exprs} {expr 3&6} 2 test compExpr-old-7.9 {CompileBitAndExpr: simple bitand exprs} {expr -1&-7} -7 test compExpr-old-7.10 {CompileBitAndExpr: error compiling bitand arm} -body { expr 2***3&6 } -returnCodes error -match glob -result * 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 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 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 test compExpr-old-8.5 {CompileEqualityExpr: error in relational expr} -body { expr x>3 |
︙ | ︙ | |||
373 374 375 376 377 378 379 | expr 2***3>>6 } -returnCodes error -match glob -result * test compExpr-old-10.9 {CompileShiftExpr: error compiling shift arm} -body { expr 2<<x } -returnCodes error -match glob -result * test compExpr-old-10.10 {CompileShiftExpr: runtime error} { list [catch {expr {24.0>>43}} msg] $msg | | | | | | 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 | expr 2***3>>6 } -returnCodes error -match glob -result * test compExpr-old-10.9 {CompileShiftExpr: error compiling shift arm} -body { expr 2<<x } -returnCodes error -match glob -result * test compExpr-old-10.10 {CompileShiftExpr: runtime error} { list [catch {expr {24.0>>43}} msg] $msg } {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 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 test compExpr-old-11.5 {CompileAddExpr: error in multiply expr} -body { expr x*3 } -returnCodes error -match glob -result * test compExpr-old-11.6 {CompileAddExpr: simple add exprs} {expr 0xff++0x3} 258 test compExpr-old-11.7 {CompileAddExpr: simple add exprs} {expr -0xf2--0x3} -239 test compExpr-old-11.8 {CompileAddExpr: error compiling add arm} -body { expr 2***3+6 } -returnCodes error -match glob -result * 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 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 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 } {0 Inf} test compExpr-old-11.13b {CompileAddExpr: runtime error} !ieeeFloatingPoint { |
︙ | ︙ | |||
426 427 428 429 430 431 432 | expr 2*3%%6 } -returnCodes error -match glob -result * 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 | | | | | | 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 | expr 2*3%%6 } -returnCodes error -match glob -result * 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 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 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 test compExpr-old-13.5 {CompileUnaryExpr: unary exprs} {expr +--+-62.0} -62.0 test compExpr-old-13.6 {CompileUnaryExpr: unary exprs} {expr !0.0} 1 test compExpr-old-13.7 {CompileUnaryExpr: unary exprs} {expr !0xef} 0 test compExpr-old-13.8 {CompileUnaryExpr: error compiling unary expr} -body { expr ~x } -returnCodes error -match glob -result * test compExpr-old-13.9 {CompileUnaryExpr: error compiling unary expr} -body { 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 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 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 test compExpr-old-13.14 {CompileUnaryExpr: just primary expr} { expr double(27) |
︙ | ︙ | |||
598 599 600 601 602 603 604 | set ::errorInfo } -match glob -result {too few arguments for math function* while *ing "expr pow(1)"} test compExpr-old-15.6 {CompileMathFuncCall: missing ')'} -body { expr sin(1 } -returnCodes error -match glob -result * | < < < < < < < < < < < < < < < < | 592 593 594 595 596 597 598 599 600 601 602 603 604 605 | set ::errorInfo } -match glob -result {too few arguments for math function* while *ing "expr pow(1)"} test compExpr-old-15.6 {CompileMathFuncCall: missing ')'} -body { expr sin(1 } -returnCodes error -match glob -result * 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} { set i {} } |
︙ | ︙ |
Changes to tests/compExpr.test.
︙ | ︙ | |||
12 13 14 15 16 17 18 | package require tcltest 2 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] | < < < < < < | 12 13 14 15 16 17 18 19 20 21 22 23 24 25 | package require tcltest 2 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] # Constrain memory leak tests testConstraint memory [llength [info commands memory]] catch {unset a} test compExpr-1.1 {TclCompileExpr procedure, successful expr parse and compile} { expr 1+2 |
︙ | ︙ | |||
315 316 317 318 319 320 321 | test compExpr-5.1 {CompileMathFuncCall procedure, math function found} { 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"} | < < < < < < | 309 310 311 312 313 314 315 316 317 318 319 320 321 322 | test compExpr-5.1 {CompileMathFuncCall procedure, math function found} { 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.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)))] } 9.97424 test compExpr-5.7 {CompileMathFuncCall procedure, error in argument} -body { |
︙ | ︙ |
Changes to tests/compile.test.
︙ | ︙ | |||
319 320 321 322 323 324 325 | }} } -returnCodes error -result {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?} 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 }} | | | 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 | }} } -returnCodes error -result {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?} 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 {*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}} } -returnCodes error -result {wrong # args: should be "incr varName ?increment?"} test compile-11.6 {Tcl_Append*: ensure Tcl_ResetResult is used properly} -body { |
︙ | ︙ |
Changes to tests/exec.test.
︙ | ︙ | |||
296 297 298 299 300 301 302 | exec [interpreter] $path(sh) -c "\"$path(echo)\" foo bar 1>&2" \ |& [interpreter] $path(sh) -c "\"$path(echo)\" second msg 1>&2 ; \"$path(cat)\"" |& [interpreter] $path(cat) } "second msg\nfoo bar" # I/O redirection: combinations. set path(gorp.file2) [makeFile {} gorp.file2] | < | 296 297 298 299 300 301 302 303 304 305 306 307 308 309 | exec [interpreter] $path(sh) -c "\"$path(echo)\" foo bar 1>&2" \ |& [interpreter] $path(sh) -c "\"$path(echo)\" second msg 1>&2 ; \"$path(cat)\"" |& [interpreter] $path(cat) } "second msg\nfoo bar" # I/O redirection: combinations. set path(gorp.file2) [makeFile {} 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} test exec-7.2 {multiple I/O redirections} {exec} { exec < $path(gorp.file) << "command input" [interpreter] $path(cat) |
︙ | ︙ |
Changes to tests/execute.test.
︙ | ︙ | |||
170 171 172 173 174 175 176 | test execute-3.5 {TclExecuteByteCode, INST_ADD, op1 is string double} {testobj} { set x [teststringobj set 0 1.0] 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 | | | 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 | test execute-3.5 {TclExecuteByteCode, INST_ADD, op1 is string double} {testobj} { set x [teststringobj set 0 1.0] 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 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} { set x [testdoubleobj set 0 1] expr {1 + $x} |
︙ | ︙ | |||
195 196 197 198 199 200 201 | test execute-3.11 {TclExecuteByteCode, INST_ADD, op2 is string double} {testobj} { set x [teststringobj set 0 1.0] 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 | | | 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 | test execute-3.11 {TclExecuteByteCode, INST_ADD, op2 is string double} {testobj} { set x [teststringobj set 0 1.0] 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 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} } 0 test execute-3.14 {TclExecuteByteCode, INST_SUB, op1 is double} {testobj} { |
︙ | ︙ | |||
222 223 224 225 226 227 228 | test execute-3.17 {TclExecuteByteCode, INST_SUB, op1 is string double} {testobj} { set x [teststringobj set 0 1.0] 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 | | | 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 | test execute-3.17 {TclExecuteByteCode, INST_SUB, op1 is string double} {testobj} { set x [teststringobj set 0 1.0] 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 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} { set x [testdoubleobj set 0 1] expr {1 - $x} |
︙ | ︙ | |||
247 248 249 250 251 252 253 | test execute-3.23 {TclExecuteByteCode, INST_SUB, op2 is string double} {testobj} { set x [teststringobj set 0 1.0] 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 | | | 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 | test execute-3.23 {TclExecuteByteCode, INST_SUB, op2 is string double} {testobj} { set x [teststringobj set 0 1.0] 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 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} } 1 test execute-3.26 {TclExecuteByteCode, INST_MULT, op1 is double} {testobj} { |
︙ | ︙ | |||
274 275 276 277 278 279 280 | test execute-3.29 {TclExecuteByteCode, INST_MULT, op1 is string double} {testobj} { set x [teststringobj set 1 1.0] 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 | | | 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 | test execute-3.29 {TclExecuteByteCode, INST_MULT, op1 is string double} {testobj} { set x [teststringobj set 1 1.0] 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 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} { set x [testdoubleobj set 1 2.0] expr {1 * $x} |
︙ | ︙ | |||
299 300 301 302 303 304 305 | test execute-3.35 {TclExecuteByteCode, INST_MULT, op2 is string double} {testobj} { set x [teststringobj set 1 1.0] 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 | | | 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 | test execute-3.35 {TclExecuteByteCode, INST_MULT, op2 is string double} {testobj} { set x [teststringobj set 1 1.0] 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 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} } 1 test execute-3.38 {TclExecuteByteCode, INST_DIV, op1 is double} {testobj} { |
︙ | ︙ | |||
326 327 328 329 330 331 332 | test execute-3.41 {TclExecuteByteCode, INST_DIV, op1 is string double} {testobj} { set x [teststringobj set 1 1.0] 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 | | | 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 | test execute-3.41 {TclExecuteByteCode, INST_DIV, op1 is string double} {testobj} { set x [teststringobj set 1 1.0] 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 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} { set x [testdoubleobj set 1 1.0] expr {2 / $x} |
︙ | ︙ | |||
351 352 353 354 355 356 357 | test execute-3.47 {TclExecuteByteCode, INST_DIV, op2 is string double} {testobj} { set x [teststringobj set 1 1.0] 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 | | | 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 | test execute-3.47 {TclExecuteByteCode, INST_DIV, op2 is string double} {testobj} { set x [teststringobj set 1 1.0] 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 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} } 1 test execute-3.50 {TclExecuteByteCode, INST_UPLUS, op is double} {testobj} { |
︙ | ︙ | |||
378 379 380 381 382 383 384 | test execute-3.53 {TclExecuteByteCode, INST_UPLUS, op is string double} {testobj} { set x [teststringobj set 1 1.0] 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 | | | 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 | test execute-3.53 {TclExecuteByteCode, INST_UPLUS, op is string double} {testobj} { set x [teststringobj set 1 1.0] 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 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} } -1 test execute-3.56 {TclExecuteByteCode, INST_UMINUS, op is double} {testobj} { |
︙ | ︙ | |||
405 406 407 408 409 410 411 | test execute-3.59 {TclExecuteByteCode, INST_UMINUS, op is string double} {testobj} { set x [teststringobj set 1 1.0] 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 | | | 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 | test execute-3.59 {TclExecuteByteCode, INST_UMINUS, op is string double} {testobj} { set x [teststringobj set 1 1.0] 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 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} } 0 test execute-3.62 {TclExecuteByteCode, INST_LNOT, op is int} {testobj} { |
︙ | ︙ | |||
453 454 455 456 457 458 459 | test execute-3.70 {TclExecuteByteCode, INST_LNOT, op is string double} {testobj} { set x [teststringobj set 1 0.0] 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 | | | 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 | test execute-3.70 {TclExecuteByteCode, INST_LNOT, op is string double} {testobj} { set x [teststringobj set 1 0.0] 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 as operand of "!"}} # INST_BITNOT not tested # INST_CALL_BUILTIN_FUNC1 not tested # INST_CALL_FUNC1 not tested # INST_TRY_CVT_TO_NUMERIC is partially tested: test execute-3.72 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is int} {testobj} { |
︙ | ︙ |
Changes to tests/expr-old.test.
︙ | ︙ | |||
20 21 22 23 24 25 26 | catch [list package require -exact Tcltest [info patchlevel]] testConstraint testexprlong [llength [info commands testexprlong]] testConstraint testexprdouble [llength [info commands testexprdouble]] testConstraint testexprstring [llength [info commands testexprstring]] testConstraint longIs32bit [expr {int(0x80000000) < 0}] | < < < < < < | 20 21 22 23 24 25 26 27 28 29 30 31 32 33 | catch [list package require -exact Tcltest [info patchlevel]] testConstraint testexprlong [llength [info commands testexprlong]] testConstraint testexprdouble [llength [info commands testexprdouble]] testConstraint testexprstring [llength [info commands testexprstring]] testConstraint longIs32bit [expr {int(0x80000000) < 0}] # Big test for correct ordering of data in [expr] proc testIEEE {} { variable ieeeValues binary scan [binary format dd -1.0 1.0] c* c switch -exact -- $c { {0 0 0 0 0 0 -16 -65 0 0 0 0 0 0 -16 63} { |
︙ | ︙ | |||
193 194 195 196 197 198 199 | list [catch {expr 028.1 + 09.2} msg] $msg } {0 37.3} # 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 | | | | | | | | | | | | 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 | list [catch {expr 028.1 + 09.2} msg] $msg } {0 37.3} # 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 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 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 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 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 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 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 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 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 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 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 test expr-old-4.3 {string operators} {expr {"g" > "def"}} 1 test expr-old-4.4 {string operators} {expr {"abc" < "abd"}} 1 |
︙ | ︙ | |||
261 262 263 264 265 266 267 | test expr-old-4.31 {string operators} {expr {1?"foo":"bar"}} foo test expr-old-4.32 {string operators} {expr {0?"foo":"bar"}} bar # Operators that aren't legal on string operands. test expr-old-5.1 {illegal string operations} { list [catch {expr {-"a"}} msg] $msg | | | | | | | | | | | | | | | | 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 | test expr-old-4.31 {string operators} {expr {1?"foo":"bar"}} foo test expr-old-4.32 {string operators} {expr {0?"foo":"bar"}} bar # 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 as operand of "-"}} test expr-old-5.2 {illegal string operations} { list [catch {expr {+"a"}} msg] $msg } {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 as operand of "~"}} test expr-old-5.4 {illegal string operations} { list [catch {expr {!"a"}} msg] $msg } {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 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 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 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 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 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 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 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 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 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 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 } {1 {expected boolean value but got "a"}} test expr-old-5.17 {illegal string operations} { |
︙ | ︙ | |||
489 490 491 492 493 494 495 | test expr-old-25.19 {type conversions} {expr 2.0e15} 2000000000000000.0 test expr-old-25.20 {type conversions} {expr 10.0} 10.0 # Various error conditions. test expr-old-26.1 {error conditions} { list [catch {expr 2+"a"} msg] $msg | | | | | 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 | test expr-old-25.19 {type conversions} {expr 2.0e15} 2000000000000000.0 test expr-old-25.20 {type conversions} {expr 10.0} 10.0 # Various error conditions. test expr-old-26.1 {error conditions} { list [catch {expr 2+"a"} msg] $msg } {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*( } -returnCodes error -match glob -result * unset -nocomplain _non_existent_ test expr-old-26.4 {error conditions} { 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 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 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 } {1 {divide by zero} {ARITH DIVZERO {divide by zero}}} test expr-old-26.9 {error conditions} { |
︙ | ︙ | |||
530 531 532 533 534 535 536 | expr 2# } -returnCodes error -match glob -result * 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 | | | 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 | expr 2# } -returnCodes error -match glob -result * 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 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 } -returnCodes error -match glob -result * test expr-old-26.16 {error conditions} { |
︙ | ︙ | |||
843 844 845 846 847 848 849 | } -999999999999999949387135297074018866963645011013410073083904 test expr-old-32.41 {math functions in expressions} { 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} | < < < < < < | 837 838 839 840 841 842 843 844 845 846 847 848 849 850 | } -999999999999999949387135297074018866963645011013410073083904 test expr-old-32.41 {math functions in expressions} { 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.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 } -match glob -result {1 {too many arguments for math function*}} test expr-old-32.47 {math functions in expressions} -body { |
︙ | ︙ | |||
948 949 950 951 952 953 954 | } -5076964154930102272 test expr-old-34.15 {errors in math functions} { expr round(1.0e30) } 1000000000000000019884624838656 test expr-old-34.16 {errors in math functions} { expr round(-1.0e30) } -1000000000000000019884624838656 | < < < < < | | 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 | } -5076964154930102272 test expr-old-34.15 {errors in math functions} { expr round(1.0e30) } 1000000000000000019884624838656 test expr-old-34.16 {errors in math functions} { expr round(-1.0e30) } -1000000000000000019884624838656 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 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 list [catch {expr {$x+1}} msg] $msg } {0 290.1} |
︙ | ︙ | |||
999 1000 1001 1002 1003 1004 1005 | expr {$x+1} } 665802003400000000000001 # tests for [Bug #587140] test expr-old-36.12 {ExprLooksLikeInt procedure} { set x "10;" list [catch {expr {$x+1}} msg] $msg | | | | | 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 | expr {$x+1} } 665802003400000000000001 # 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 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 "+"}} 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 invalid octal number as operand of "+"}} test expr-old-36.16 {ExprLooksLikeInt procedure} { set x " 0xffffffffffffffffffffffffffffffffffffff " expr {$x+1} } [expr 0x100000000000000000000000000000000000000] test expr-old-37.1 {Check that Tcl_ExprLong doesn't modify interpreter result if no error} testexprlong { testexprlong 4+1 |
︙ | ︙ | |||
1155 1156 1157 1158 1159 1160 1161 | test expr-old-40.1 {min math function} -body { expr {min(0)} } -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 { | | | > > > > > > | | > > > > > > | 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 | test expr-old-40.1 {min math function} -body { expr {min(0)} } -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 { 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 { 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" puts "that performs arithmetic incorrectly. I recommend that you" puts "call Intel customer service immediately at 1-800-628-8686" |
︙ | ︙ |
Changes to tests/expr.test.
︙ | ︙ | |||
14 15 16 17 18 19 20 | package require tcltest 2.1 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] | < < < < | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | package require tcltest 2.1 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] # 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}] testConstraint wideIs64bit \ [expr {(wide(0x80000000) > 0) && (wide(0x8000000000000000) < 0)}] |
︙ | ︙ | |||
253 254 255 256 257 258 259 | test expr-4.9 {CompileLorExpr: long lor arm} { set a "abcdefghijkl" 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 | | | 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 | test expr-4.9 {CompileLorExpr: long lor arm} { set a "abcdefghijkl" 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 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 } {1 {expected boolean value but got "a"}} |
︙ | ︙ | |||
300 301 302 303 304 305 306 | expr 2***3|6 } -returnCodes error -match glob -result * 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 | | | | | | 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 | expr 2***3|6 } -returnCodes error -match glob -result * 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 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 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 test expr-7.5 {CompileBitAndExpr: error in equality expr} -body { expr x==3 } -returnCodes error -match glob -result * test expr-7.6 {CompileBitAndExpr: simple bitand exprs} {expr 7&0x13} 3 test expr-7.7 {CompileBitAndExpr: simple bitand exprs} {expr 0xf2&0x53} 82 test expr-7.8 {CompileBitAndExpr: simple bitand exprs} {expr 3&6} 2 test expr-7.9 {CompileBitAndExpr: simple bitand exprs} {expr -1&-7} -7 test expr-7.10 {CompileBitAndExpr: error compiling bitand arm} -body { expr 2***3&6 } -returnCodes error -match glob -result * 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 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 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 * test expr-8.1 {CompileEqualityExpr: just relational expr} {expr 3>=2} 1 |
︙ | ︙ | |||
452 453 454 455 456 457 458 | expr 2***3>>6 } -returnCodes error -match glob -result * test expr-10.9 {CompileShiftExpr: error compiling shift arm} -body { expr 2<<x } -returnCodes error -match glob -result * test expr-10.10 {CompileShiftExpr: runtime error} { list [catch {expr {24.0>>43}} msg] $msg | | | | | | 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 | expr 2***3>>6 } -returnCodes error -match glob -result * test expr-10.9 {CompileShiftExpr: error compiling shift arm} -body { expr 2<<x } -returnCodes error -match glob -result * test expr-10.10 {CompileShiftExpr: runtime error} { list [catch {expr {24.0>>43}} msg] $msg } {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 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 test expr-11.5 {CompileAddExpr: error in multiply expr} -body { expr x*3 } -returnCodes error -match glob -result * test expr-11.6 {CompileAddExpr: simple add exprs} {expr 0xff++0x3} 258 test expr-11.7 {CompileAddExpr: simple add exprs} {expr -0xf2--0x3} -239 test expr-11.8 {CompileAddExpr: error compiling add arm} -body { expr 2***3+6 } -returnCodes error -match glob -result * 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 as operand of "+"}} test expr-11.11 {CompileAddExpr: runtime error} { list [catch {expr {"a"-"b"}} msg] $msg } {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 } {1 {divide by zero}} test expr-11.13b {CompileAddExpr: runtime error} ieeeFloatingPoint { |
︙ | ︙ | |||
505 506 507 508 509 510 511 | expr 2*3%%6 } -returnCodes error -match glob -result * 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 | | | | | | 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 | expr 2*3%%6 } -returnCodes error -match glob -result * 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 as operand of "*"}} test expr-12.11 {CompileMultiplyExpr: runtime error} { list [catch {expr {"a"/"b"}} msg] $msg } {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 test expr-13.5 {CompileUnaryExpr: unary exprs} {expr +--+-62.0} -62.0 test expr-13.6 {CompileUnaryExpr: unary exprs} {expr !0.0} 1 test expr-13.7 {CompileUnaryExpr: unary exprs} {expr !0xef} 0 test expr-13.8 {CompileUnaryExpr: error compiling unary expr} -body { expr ~x } -returnCodes error -match glob -result * 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 as operand of "~"}} test expr-13.11 {CompileUnaryExpr: runtime error} { list [catch {expr ~4.0} msg] $msg } {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 test expr-13.14 {CompileUnaryExpr: just primary expr} { expr double(27) |
︙ | ︙ | |||
681 682 683 684 685 686 687 | set ::errorInfo } -match glob -result {too few arguments for math function* while *ing "expr pow(1)"} test expr-15.6 {CompileMathFuncCall: missing ')'} -body { expr sin(1 } -returnCodes error -match glob -result * | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 677 678 679 680 681 682 683 684 685 686 687 688 689 690 | set ::errorInfo } -match glob -result {too few arguments for math function* while *ing "expr pow(1)"} test expr-15.6 {CompileMathFuncCall: missing ')'} -body { expr sin(1 } -returnCodes error -match glob -result * test expr-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} { |
︙ | ︙ | |||
840 841 842 843 844 845 846 | test expr-21.11 {non-numeric boolean literals} {expr !no } 1 test expr-21.12 {non-numeric boolean literals} {expr !yes } 0 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 | | | | | | | | | | 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 | test expr-21.11 {non-numeric boolean literals} {expr !no } 1 test expr-21.12 {non-numeric boolean literals} {expr !yes } 0 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 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 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 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} { set v "fal" list [catch {expr {!$v}} err] $err } {0 1} test expr-21.19 {non-numeric boolean variables} { set v "y" list [catch {expr {!$v}} err] $err } {0 0} test expr-21.20 {non-numeric boolean variables} { set v "of" 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 as operand of "!"}} test expr-21.22 {non-numeric boolean variables} { set v "" list [catch {expr {!$v}} err] $err } {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 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 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} { list [catch {expr NaN} msg] $msg } {1 {domain error: argument not in valid range}} 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 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} { set x NaN expr {$x == $x} |
︙ | ︙ | |||
933 934 935 936 937 938 939 | expr (-3-)**6 } -returnCodes error -match glob -result * 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 | | | | 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 | expr (-3-)**6 } -returnCodes error -match glob -result * 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 as operand of "**"}} test expr-23.10 {CompileExponentialExpr: runtime error} { list [catch {expr {"a"**2}} msg] $msg } {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 } {1 {exponentiation of zero by negative power}} test expr-23.13 {CompileExponentialExpr: runtime error} { |
︙ | ︙ |
Changes to tests/fileSystem.test.
︙ | ︙ | |||
373 374 375 376 377 378 379 380 381 382 383 384 385 386 | file join $x bar } -result /foo/bar 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-2.0 {new native path} {unix} { foreach f [lsort [glob -nocomplain /usr/bin/c*]] { catch {file readlink $f} } # If we reach here we've succeeded. We used to crash above. return ok | > > > > > > > > > > > > > > > > | 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 | file join $x bar } -result /foo/bar 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} } # If we reach here we've succeeded. We used to crash above. return ok |
︙ | ︙ |
Changes to tests/get.test.
︙ | ︙ | |||
94 95 96 97 98 99 100 | foreach num $numbers { lappend result [catch {format %g $num} msg] $msg } 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 { | | | | | | 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 | foreach num $numbers { lappend result [catch {format %g $num} msg] $msg } 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 " " 007 " " 0o10 " " 0b10 "} { catch {testgetint 44 $x} x set x } } {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 " "07" "- 0" "-0" "0o12" "0b10"} { catch {testdoubleobj set 1 $x} x set x } } {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 # Local Variables: # mode: tcl |
︙ | ︙ |
Changes to tests/info.test.
︙ | ︙ | |||
2394 2395 2396 2397 2398 2399 2400 | } -cleanup { namespace delete foo } -result {type source line 2389 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- unset -nocomplain res | | | 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 | } -cleanup { namespace delete foo } -result {type source line 2389 file info.test cmd {info frame 0} proc ::foo::bar level 0} # ------------------------------------------------------------------------- unset -nocomplain res test info-39.2 {Bug 4b61afd660} -setup { proc probe {} { return [dict get [info frame -1] line] } set body { set cmd probe $cmd } |
︙ | ︙ |
Changes to tests/interp.test.
︙ | ︙ | |||
1843 1844 1845 1846 1847 1848 1849 | lappend l [lsort [interp aliases a]] [lsort [interp hidden a]] a hide bar 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 | | | 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 | lappend l [lsort [interp aliases a]] [lsort [interp hidden a]] a hide bar 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 {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 interp alias a foo {} apply {args {error $args}} interp eval a { |
︙ | ︙ |
Changes to tests/io.test.
︙ | ︙ | |||
6159 6160 6161 6162 6163 6164 6165 6166 6167 6168 6169 6170 6171 6172 | fileevent $f readable {} set x [list [testfevent cmd "fileevent $f readable"] \ [fileevent $f readable]] testfevent delete close $f set x } {{script 1} {}} set path(bar) [makeFile {} bar] test io-48.1 {testing readability conditions} {fileevent} { set f [open $path(bar) w] puts $f abcdefg puts $f abcdefg | > > | 6159 6160 6161 6162 6163 6164 6165 6166 6167 6168 6169 6170 6171 6172 6173 6174 | fileevent $f readable {} set x [list [testfevent cmd "fileevent $f readable"] \ [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] puts $f abcdefg puts $f abcdefg |
︙ | ︙ | |||
6261 6262 6263 6264 6265 6266 6267 6268 6269 6270 6271 6272 6273 6274 | puts $f "set f \[[list open $path(bar) r]]" puts $f {copy_slowly $f} 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}} 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] puts -nonewline $f $c close $f | > > > | 6263 6264 6265 6266 6267 6268 6269 6270 6271 6272 6273 6274 6275 6276 6277 6278 6279 | puts $f "set f \[[list open $path(bar) r]]" puts $f {copy_slowly $f} 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] puts -nonewline $f $c close $f |
︙ | ︙ |
Changes to tests/ioCmd.test.
︙ | ︙ | |||
380 381 382 383 384 385 386 | test iocmd-10.5 {fblocked command} { fblocked stdin } 0 set path(test4) [makeFile {} test4] set path(test5) [makeFile {} test5] | < | 380 381 382 383 384 385 386 387 388 389 390 391 392 393 | test iocmd-10.5 {fblocked command} { fblocked stdin } 0 set path(test4) [makeFile {} test4] set path(test5) [makeFile {} 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}} test iocmd-11.2 {I/O to command pipelines} {unixOrPc unixExecs} { list [catch {open "| echo > \"$path(test5)\"" r} msg] $msg $::errorCode |
︙ | ︙ | |||
3832 3833 3834 3835 3836 3837 3838 | rename track {} # cleanup foreach file [list test1 test2 test3 test4] { removeFile $file } # delay long enough for background processes to finish after 500 | < | < | 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 | rename track {} # cleanup foreach file [list test1 test2 test3 test4] { removeFile $file } # delay long enough for background processes to finish after 500 removeFile test5 cleanupTests return |
Changes to tests/lindex.test.
︙ | ︙ | |||
66 67 68 69 70 71 72 | test lindex-3.4 {integer 3} testevalex { set x [string range 33 0 0] 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 | | | | 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 | test lindex-3.4 {integer 3} testevalex { set x [string range 33 0 0] 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 {*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 {*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} # Indices relative to end |
︙ | ︙ | |||
101 102 103 104 105 106 107 | test lindex-4.5 {index = end-3} testevalex { set x end-3 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 | | | | 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 | test lindex-4.5 {index = end-3} testevalex { set x end-3 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 {*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 {*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 { set x end list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}] |
︙ | ︙ | |||
257 258 259 260 261 262 263 | list [lindex {a b c} $x] [lindex {a b c} $x] } result set result } {{} {}} test lindex-11.5 {bad octal} -body { set x 0o8 list [catch { lindex {a b c} $x } result] $result | | | | 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 | list [lindex {a b c} $x] [lindex {a b c} $x] } result 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 {*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 {*invalid octal number*}} # Indices relative to end test lindex-12.1 {index = end} { set x end catch { list [lindex {a b c} $x] [lindex {a b c} $x] |
︙ | ︙ | |||
303 304 305 306 307 308 309 | list [lindex {a b c} $x] [lindex {a b c} $x] } result set result } {{} {}} test lindex-12.6 {bad octal} -body { set x end-0o8 list [catch { lindex {a b c} $x } result] $result | | | | 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 | list [lindex {a b c} $x] [lindex {a b c} $x] } result 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 {*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 {*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} { set x end catch { |
︙ | ︙ |
Changes to tests/mathop.test.
︙ | ︙ | |||
110 111 112 113 114 115 116 | test mathop-1.6 {compiled +} { + 1 2 3.0 } 6.0 test mathop-1.7 {compiled +} { + 100000000000 2 3 } 100000000005 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 | | | | | | | | 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 | test mathop-1.6 {compiled +} { + 1 2 3.0 } 6.0 test mathop-1.7 {compiled +} { + 100000000000 2 3 } 100000000005 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 as operand of "+"} test mathop-1.12 {compiled +: errors} -returnCodes error -body { + nan 0 } -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 as operand of "+"} test mathop-1.14 {compiled +: errors} -returnCodes error -body { + 0 nan } -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 invalid octal number as operand of "+"} test mathop-1.16 {compiled +: errors} -returnCodes error -body { + 0 0o8 } -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 list [catch { + [set x 0] [incr x] NaN [incr x] [error expected] [incr x] |
︙ | ︙ | |||
148 149 150 151 152 153 154 | test mathop-1.24 {interpreted +} { $op 1 2 3.0 } 6.0 test mathop-1.25 {interpreted +} { $op 100000000000 2 3 } 100000000005 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 | | | | | | | | 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 | test mathop-1.24 {interpreted +} { $op 1 2 3.0 } 6.0 test mathop-1.25 {interpreted +} { $op 100000000000 2 3 } 100000000005 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 as operand of "+"} test mathop-1.30 {interpreted +: errors} -returnCodes error -body { $op nan 0 } -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 as operand of "+"} test mathop-1.32 {interpreted +: errors} -returnCodes error -body { $op 0 nan } -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 invalid octal number as operand of "+"} test mathop-1.34 {interpreted +: errors} -returnCodes error -body { $op 0 0o8 } -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 { $op [set x 0] [incr x] NaN [incr x] [error expected] [incr x] } msg] $msg $x |
︙ | ︙ | |||
185 186 187 188 189 190 191 | test mathop-2.6 {compiled *} { * 1 2 3.0 } 6.0 test mathop-2.7 {compiled *} { * 100000000000 2 3 } 600000000000 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 | | | | | | | | 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 | test mathop-2.6 {compiled *} { * 1 2 3.0 } 6.0 test mathop-2.7 {compiled *} { * 100000000000 2 3 } 600000000000 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 as operand of "*"} test mathop-2.12 {compiled *: errors} -returnCodes error -body { * nan 0 } -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 as operand of "*"} test mathop-2.14 {compiled *: errors} -returnCodes error -body { * 0 nan } -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 invalid octal number as operand of "*"} test mathop-2.16 {compiled *: errors} -returnCodes error -body { * 0 0o8 } -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 list [catch { * [set x 0] [incr x] NaN [incr x] [error expected] [incr x] |
︙ | ︙ | |||
223 224 225 226 227 228 229 | test mathop-2.24 {interpreted *} { $op 1 2 3.0 } 6.0 test mathop-2.25 {interpreted *} { $op 100000000000 2 3 } 600000000000 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 | | | | | | | | | | | | | | | | | | 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 | test mathop-2.24 {interpreted *} { $op 1 2 3.0 } 6.0 test mathop-2.25 {interpreted *} { $op 100000000000 2 3 } 600000000000 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 as operand of "*"} test mathop-2.30 {interpreted *: errors} -returnCodes error -body { $op nan 0 } -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 as operand of "*"} test mathop-2.32 {interpreted *: errors} -returnCodes error -body { $op 0 nan } -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 invalid octal number as operand of "*"} test mathop-2.34 {interpreted *: errors} -returnCodes error -body { $op 0 0o8 } -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 { $op [set x 0] [incr x] NaN [incr x] [error expected] [incr x] } msg] $msg $x } -result {1 expected 2} test mathop-3.1 {compiled !} {! 0} 1 test mathop-3.2 {compiled !} {! 1} 0 test mathop-3.3 {compiled !} {! false} 1 test mathop-3.4 {compiled !} {! true} 0 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 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 { ! } -returnCodes error -result "wrong # args: should be \"! boolean\"" set op ! test mathop-3.11 {interpreted !} {$op 0} 1 test mathop-3.12 {interpreted !} {$op 1} 0 test mathop-3.13 {interpreted !} {$op false} 1 test mathop-3.14 {interpreted !} {$op true} 0 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 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 as operand of "!"} test mathop-3.22 {interpreted !: error} -returnCodes error -body { $op NaN } -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 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 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 as operand of "~"} test mathop-4.12 {compiled ~: errors} -returnCodes error -body { ~ NaN } -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 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 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 as operand of "~"} test mathop-4.24 {interpreted ~: errors} -returnCodes error -body { $op NaN } -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 test mathop-5.5 {compiled eq} { eq } 1 test mathop-5.6 {compiled eq} {eq a} 1 |
︙ | ︙ | |||
373 374 375 376 377 378 379 | test mathop-6.1 {compiled &} { & } -1 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 | | | | | | | | | | | | | | | | | | 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 | test mathop-6.1 {compiled &} { & } -1 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 as operand of "&"} test mathop-6.6 {compiled &} -returnCodes error -body { & 1 2 3.0 } -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 as operand of "&"} test mathop-6.12 {compiled &: errors} -returnCodes error -body { & nan 0 } -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 as operand of "&"} test mathop-6.14 {compiled &: errors} -returnCodes error -body { & 0 nan } -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 invalid octal number as operand of "&"} test mathop-6.16 {compiled &: errors} -returnCodes error -body { & 0 0o8 } -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 list [catch { & [set x 0] [incr x] NaN [incr x] [error expected] [incr x] } msg] $msg $x } -result {1 expected 2} set op & test mathop-6.19 {interpreted &} { $op } -1 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 as operand of "&"} test mathop-6.24 {interpreted &} -returnCodes error -body { $op 1 2 3.0 } -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 as operand of "&"} test mathop-6.30 {interpreted &: errors} -returnCodes error -body { $op nan 0 } -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 as operand of "&"} test mathop-6.32 {interpreted &: errors} -returnCodes error -body { $op 0 nan } -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 invalid octal number as operand of "&"} test mathop-6.34 {interpreted &: errors} -returnCodes error -body { $op 0 0o8 } -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 { $op [set x 0] [incr x] NaN [incr x] [error expected] [incr x] } msg] $msg $x |
︙ | ︙ | |||
483 484 485 486 487 488 489 | test mathop-7.1 {compiled |} { | } 0 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 | | | | | | | | | | | | | | | | | | 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 | test mathop-7.1 {compiled |} { | } 0 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 as operand of "|"} test mathop-7.6 {compiled |} -returnCodes error -body { | 1 2 3.0 } -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 as operand of "|"} test mathop-7.12 {compiled |: errors} -returnCodes error -body { | nan 0 } -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 as operand of "|"} test mathop-7.14 {compiled |: errors} -returnCodes error -body { | 0 nan } -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 invalid octal number as operand of "|"} test mathop-7.16 {compiled |: errors} -returnCodes error -body { | 0 0o8 } -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 list [catch { | [set x 0] [incr x] NaN [incr x] [error expected] [incr x] } msg] $msg $x } -result {1 expected 2} set op | test mathop-7.19 {interpreted |} { $op } 0 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 as operand of "|"} test mathop-7.24 {interpreted |} -returnCodes error -body { $op 1 2 3.0 } -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 as operand of "|"} test mathop-7.30 {interpreted |: errors} -returnCodes error -body { $op nan 0 } -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 as operand of "|"} test mathop-7.32 {interpreted |: errors} -returnCodes error -body { $op 0 nan } -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 invalid octal number as operand of "|"} test mathop-7.34 {interpreted |: errors} -returnCodes error -body { $op 0 0o8 } -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 { $op [set x 0] [incr x] NaN [incr x] [error expected] [incr x] } msg] $msg $x |
︙ | ︙ | |||
593 594 595 596 597 598 599 | test mathop-8.1 {compiled ^} { ^ } 0 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 | | | | | | | | | | | | | | | | | | 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 | test mathop-8.1 {compiled ^} { ^ } 0 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 as operand of "^"} test mathop-8.6 {compiled ^} -returnCodes error -body { ^ 1 2 3.0 } -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 as operand of "^"} test mathop-8.12 {compiled ^: errors} -returnCodes error -body { ^ nan 0 } -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 as operand of "^"} test mathop-8.14 {compiled ^: errors} -returnCodes error -body { ^ 0 nan } -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 invalid octal number as operand of "^"} test mathop-8.16 {compiled ^: errors} -returnCodes error -body { ^ 0 0o8 } -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 list [catch { ^ [set x 0] [incr x] NaN [incr x] [error expected] [incr x] } msg] $msg $x } -result {1 expected 2} set op ^ test mathop-8.19 {interpreted ^} { $op } 0 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 as operand of "^"} test mathop-8.24 {interpreted ^} -returnCodes error -body { $op 1 2 3.0 } -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 as operand of "^"} test mathop-8.30 {interpreted ^: errors} -returnCodes error -body { $op nan 0 } -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 as operand of "^"} test mathop-8.32 {interpreted ^: errors} -returnCodes error -body { $op 0 nan } -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 invalid octal number as operand of "^"} test mathop-8.34 {interpreted ^: errors} -returnCodes error -body { $op 0 0o8 } -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 { $op [set x 0] [incr x] NaN [incr x] [error expected] [incr x] } msg] $msg $x |
︙ | ︙ | |||
771 772 773 774 775 776 777 | test mathop-20.6 { one arg, error } { set res {} set exp {} foreach vals {x {1 x} {1 1 x} {1 x 1}} { # skipping - for now, knownbug... foreach op {+ * / & | ^ **} { lappend res [TestOp $op {*}$vals] | | | | 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 | test mathop-20.6 { one arg, error } { set res {} 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 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 as operand of \"$op\"\ ARITH DOMAIN {non-numeric floating-point value}" } expr {$res eq $exp ? 0 : $res} } 0 test mathop-20.7 { multi arg } { set res {} foreach vals {{1 2} {3 4 5} {4 3 2 1}} { |
︙ | ︙ | |||
846 847 848 849 850 851 852 | set res } [list 1.0 0.2 0.17857142857142858 -0.125 \ 2.8196218755553604e-15 8.10000006561e-27] test mathop-21.5 { unary ops, bad values } { set res {} set exp {} lappend res [TestOp / x] | | | | | | | 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 | set res } [list 1.0 0.2 0.17857142857142858 -0.125 \ 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 as operand of \"/\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp - x] 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 as operand of \"~\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp ! x] 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 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 {~ !} { set res [TestOp $op 7 8] if {[string match "wrong # args: should be * TCL WRONGARGS" $res]} { |
︙ | ︙ | |||
961 962 963 964 965 966 967 | 70720 \ ] test mathop-22.4 { unary ops, bad values } { set res {} set exp {} foreach op {& | ^} { lappend res [TestOp $op x 5] | | | | 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 | 70720 \ ] 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 as operand of \"$op\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp $op 5 x] 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 } { set res {} set todo {5 {1 6} {1 2 2 3} {4 3 2 1} {5.0 5.0} {6 3 3 1} {5.0 5}} |
︙ | ︙ | |||
1076 1077 1078 1079 1080 1081 1082 | 0 \ ] test mathop-24.3 { binary ops, bad values } { set res {} set exp {} foreach op {% << >>} { lappend res [TestOp $op x 1] | | | | | | 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 | 0 \ ] 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 as operand of \"$op\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp $op 1 x] 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 as operand of \"$op\" ARITH DOMAIN {floating-point value}" lappend res [TestOp $op 1 5.0] 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" } lappend res [TestOp % 5 0] lappend exp "divide by zero ARITH DIVZERO {divide by zero}" |
︙ | ︙ | |||
1236 1237 1238 1239 1240 1241 1242 | lappend res [TestOp ** $small $wide] lappend exp "exponent too large NONE" 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] | | | | 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 | lappend res [TestOp ** $small $wide] lappend exp "exponent too large NONE" 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 as operand of \"**\" ARITH DOMAIN {non-numeric string}" lappend res [TestOp ** foo 2] 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 } { set big1 12135435435354435435342423948763867876 set big2 2746237174783836746262564892918327847 |
︙ | ︙ |
Changes to tests/namespace-old.test.
︙ | ︙ | |||
289 290 291 292 293 294 295 | proc test_ns_show {} {return "[namespace current]: 2"} namespace eval test_ns_hier3a {} namespace eval test_ns_hier3b {} } namespace eval test_ns_hier2a {} namespace eval test_ns_hier2b {} } | < | | | | 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 | proc test_ns_show {} {return "[namespace current]: 2"} namespace eval test_ns_hier3a {} namespace eval test_ns_hier3b {} } namespace eval test_ns_hier2a {} namespace eval test_ns_hier2b {} } test namespace-old-5.4 {nested namespaces can access global namespace} { 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 {test_ns_cmd_global}] } {{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} { list [test_ns_hier1::test_ns_show] \ [test_ns_hier1::test_ns_hier2::test_ns_show] |
︙ | ︙ | |||
465 466 467 468 469 470 471 | } test namespace-old-6.11 {commands affect all parent namespaces} { 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}} | < | | < | | < | | | | 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 | } test namespace-old-6.11 {commands affect all parent namespaces} { 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}} test namespace-old-6.12 {define test variables} { variable test_ns_cache_var "global version" set trigger {set test_ns_cache_var} 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" 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}] \ [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} 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] } {{cache2 version} {cache2 version}} test namespace-old-6.17 {usage for "namespace which"} { |
︙ | ︙ |
Changes to tests/namespace.test.
︙ | ︙ | |||
42 43 44 45 46 47 48 | list [namespace current] [namespace eval {} {namespace current}] \ [namespace eval {} {namespace current}] } {:: :: ::} test namespace-2.2 {Tcl_GetCurrentNamespace} { set l {} lappend l [namespace current] namespace eval test_ns_1 { | | | | 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 | list [namespace current] [namespace eval {} {namespace current}] \ [namespace eval {} {namespace current}] } {:: :: ::} test namespace-2.2 {Tcl_GetCurrentNamespace} { set l {} lappend l [namespace current] namespace eval test_ns_1 { lappend l [namespace current] namespace eval foo { lappend l [namespace current] } } lappend l [namespace current] } {:: ::test_ns_1 ::test_ns_1::foo ::} test namespace-3.1 {Tcl_GetGlobalNamespace} { namespace eval test_ns_1 {namespace eval foo {namespace eval bar {} } } |
︙ | ︙ | |||
191 192 193 194 195 196 197 198 199 200 201 202 203 204 | } } -body { slave eval foo slave invokehidden infocommands } -cleanup { interp delete slave } -result {} test namespace-8.1 {TclTeardownNamespace, delete global namespace} { catch {interp delete test_interp} interp create test_interp interp eval test_interp { namespace eval test_ns_1 { namespace export p | > > > > > > > > > > > > > | 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 | } } -body { 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 { namespace eval test_ns_1 { namespace export p |
︙ | ︙ | |||
629 630 631 632 633 634 635 | } } -body { 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"}} | < < | < | < | 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 | } } -body { 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"}} 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 } namespace eval test_ns_2 { variable v 30 } } -body { namespace eval test_ns_1 { list $v $test_ns_2::v } } -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 { list [namespace children test_ns_2] \ [catch {namespace children test_ns_1} msg] $msg |
︙ | ︙ | |||
707 708 709 710 711 712 713 | catch {rename test_ns_1::test_ns_2:: {}} set l {} } -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}} | < < | | | | 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 | catch {rename test_ns_1::test_ns_2:: {}} set l {} } -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}} 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 {} set test_ns_1::(x) y } 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 {} {} {} namespace eval {} {} {} |
︙ | ︙ | |||
890 891 892 893 894 895 896 | variable x 777 } } -body { namespace eval test_ns_1 { set x } } -result {777} | < < | | < < | | 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 | variable x 777 } } -body { namespace eval test_ns_1 { set x } } -result {777} test namespace-17.7 {Tcl_FindNamespaceVar, relative name found} { namespace eval test_ns_1 { variable x 777 unset x set x ;# must be global x now } } {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} test namespace-17.9 {Tcl_FindNamespaceVar, relative name and TCL_GLOBAL_ONLY} { namespace eval test_ns_1 { variable a hello } set test_ns_1::a } {hello} 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 } test_ns rename test_ns {} 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 1 catch {unset a} catch {unset x} catch {unset l} catch {rename foo {}} test namespace-18.1 {TclResetShadowedCmdRefs, one-level check for command shadowing} -setup { catch {namespace delete {*}[namespace children :: test_ns_*]} |
︙ | ︙ | |||
1546 1547 1548 1549 1550 1551 1552 | namespace eval test_ns_3 { list [namespace which foreach] \ [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} | < < | | | 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 | namespace eval test_ns_3 { list [namespace which foreach] \ [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} 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"} proc cmd2 {args} {return "cmd2: $args"} } namespace eval test_ns_2 { namespace export * namespace import ::test_ns_1::* variable v2 222 proc p {} {} } namespace eval test_ns_3 { variable v3 333 namespace import ::test_ns_2::* } } -body { namespace eval test_ns_3 { 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 {::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 { proc p {} { namespace delete [namespace current] |
︙ | ︙ | |||
1792 1793 1794 1795 1796 1797 1798 | proc x2 {} {format 2} proc x3 {} {format 3} namespace ensemble create } list [ns x0 z] [ns x1] [ns x2] [ns x3] } -cleanup { namespace delete ns | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1793 1794 1795 1796 1797 1798 1799 1800 1801 1802 1803 1804 1805 1806 1807 1808 1809 1810 1811 1812 1813 1814 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 1830 1831 1832 1833 1834 1835 1836 1837 1838 1839 1840 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 | proc x2 {} {format 2} proc x3 {} {format 3} namespace ensemble create } list [ns x0 z] [ns x1] [ns x2] [ns x3] } -cleanup { namespace delete ns } -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] } -body { foo bar } -cleanup { unset target 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} namespace ensemble create -map {a x1 b x2} } |
︙ | ︙ | |||
1928 1929 1930 1931 1932 1933 1934 | } {1 {ensemble subcommand implementations must be non-empty lists}} test namespace-44.5 {ensemble: errors} -setup { namespace ensemble create -command foobar -subcommands {foobarcget foobarconfigure} } -body { foobar foobarcon } -cleanup { rename foobar {} | | | 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 | } {1 {ensemble subcommand implementations must be non-empty lists}} test namespace-44.5 {ensemble: errors} -setup { namespace ensemble create -command foobar -subcommands {foobarcget foobarconfigure} } -body { foobar foobarcon } -cleanup { rename foobar {} } -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} { namespace eval ns { namespace export x |
︙ | ︙ | |||
2092 2093 2094 2095 2096 2097 2098 | set result {} lappend result [catch {ns a b c} msg] $msg 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] | | | 2124 2125 2126 2127 2128 2129 2130 2131 2132 2133 2134 2135 2136 2137 2138 | set result {} lappend result [catch {ns a b c} msg] $msg 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 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 } namespace ensemble create -unknown ::ns::Magic |
︙ | ︙ | |||
3191 3192 3193 3194 3195 3196 3197 | } -cleanup { namespace delete ns } -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"}\ | | | 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 | } -cleanup { namespace delete ns } -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 "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 { namespace export x namespace eval x { |
︙ | ︙ | |||
3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 | try { return [lsort $gone] } finally { namespace delete ::testing } } } {::testing::abc::def ::testing::abc::ghi} # cleanup catch {rename cmd1 {}} catch {unset l} catch {unset msg} catch {unset trigger} namespace delete {*}[namespace children :: test_ns_*] ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: | > > > > > > > > > > > > | 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 | try { return [lsort $gone] } 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} catch {unset trigger} namespace delete {*}[namespace children :: test_ns_*] ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: |
Changes to tests/oo.test.
︙ | ︙ | |||
43 44 45 46 47 48 49 | package require TclOO namespace delete :: } interp delete $i } {} test oo-0.3 {basic test of OO's ability to clean up its initial state} -body { leaktest { | | | 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 | package require TclOO namespace delete :: } 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 } } -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 foo new foo destroy |
︙ | ︙ | |||
124 125 126 127 128 129 130 131 132 133 134 135 136 137 | set errorInfo } "wrong # args: should be \"oo::define oo::object method name args body\" 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.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 } -returnCodes error -body { aninstance | > > > > > > > | 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 | set errorInfo } "wrong # args: should be \"oo::define oo::object method name args body\" 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 } -returnCodes error -body { aninstance |
︙ | ︙ | |||
1494 1495 1496 1497 1498 1499 1500 | # No segmentation fault return done } done test oo-11.6 { OO: cleanup ReleaseClassContents() where class is mixed into one of its instances | | | | > > | 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 | # No segmentation fault return done } 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 rename obj3 {} rename obj2 {} # No segmentation fault return done } -result done -cleanup { rename obj1 {} } test oo-12.1 {OO: filters} { oo::class create Aclass Aclass create Aobject oo::define Aclass { method concatenate args { global result |
︙ | ︙ | |||
3860 3861 3862 3863 3864 3865 3866 3867 3868 3869 3870 3871 3872 3873 | method e {} {} } 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-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 } -body { oo::define Cls self | > > > > > > > > > > > > > > > > > > > > > > | 3869 3870 3871 3872 3873 3874 3875 3876 3877 3878 3879 3880 3881 3882 3883 3884 3885 3886 3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 3901 3902 3903 3904 | method e {} {} } 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 } -body { oo::define Cls self |
︙ | ︙ |
Changes to tests/package.test.
︙ | ︙ | |||
16 17 18 19 20 21 22 | package require tcltest 2.3.3 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] | < < > | > > | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | package require tcltest 2.3.3 namespace import -force ::tcltest::* } ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] # 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] 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 { ::pkg::create -foo bar -bar baz -baz boo } -returnCodes error -match glob -result {unknown option "bar": *} |
︙ | ︙ | |||
135 136 137 138 139 140 141 | 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 | | | | | | | 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 | 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 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 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 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 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 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 {} foreach i {1.4 3.4 2.3 2.4 2.2} { package ifneeded t $i "set x $i" |
︙ | ︙ | |||
234 235 236 237 238 239 240 | } -match glob -result {1 * invoked} test package-3.12 {Tcl_PkgRequire procedure, self-deleting script} -setup { 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 | | | | 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 | } -match glob -result {1 * invoked} test package-3.12 {Tcl_PkgRequire procedure, self-deleting script} -setup { 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 set x } -result {1.2} test package-3.13 {Tcl_PkgRequire procedure, "package unknown" support} -setup { package forget t set x xxx } -body { proc pkgUnknown args { # args = name requirement # requirement = v-v (for exact version) global x set x $args package provide [lindex $args 0] [lindex [split [lindex $args 1] -] 0] } 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 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 set x xxx } -body { |
︙ | ︙ | |||
279 280 281 282 283 284 285 | } -body { proc pkgUnknown args { global x set x $args package provide [lindex $args 0] 2.0 } package require {a b} | | | 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 | } -body { proc pkgUnknown args { global x set x $args package provide [lindex $args 0] 2.0 } package require {a b} set x } -cleanup { package unknown {} } -result {{a b} 0-} test package-3.16 {Tcl_PkgRequire procedure, "package unknown" error} -setup { package forget t } -body { proc pkgUnknown args { |
︙ | ︙ | |||
571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 | package provide demo 1.2.3 } -body { 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 { testpreferstable package forget t set x xxx } -body { 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 | > > > > > | > > > | | > > > > > > > > > > > > | > > > > | > > | > > > > | > > > > > > > > > > > > > > > > | > > > > > > | > > | > > > > > > > | > > > > > > > | > > > > > | > > > > | > > > > > > > > > | 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 | package provide demo 1.2.3 } -body { 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 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 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 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} -setup { interp create child } -body { child eval { package forget {*}[package names] package names } } -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 package ifneeded a 1 } -cleanup { package forget a } -result {} test package-4.6 {Tcl_PackageCmd procedure, "ifneeded" option} -body { package ifneeded a } -returnCodes error -result {wrong # args: should be "package ifneeded package version ?script?"} test package-4.7 {Tcl_PackageCmd procedure, "ifneeded" option} -body { 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} -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 { 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 { 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 { 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" package ifneeded t 1.2 "second script" package ifneeded t 3.1 "last script" 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} -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 { package provide a b c } -returnCodes error -result {wrong # args: should be "package provide package ?version?"} |
︙ | ︙ | |||
1235 1236 1237 1238 1239 1240 1241 | } return $res } finally { interp delete $ip } } | | < < | | | | | > | | > | | 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 | } return $res } finally { interp delete $ip } } test package-13.0 {package prefer defaults} -body { prefer } -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) } -result latest test package-14.0 {wrong\#args} -returnCodes error -body { package prefer foo bar } -result {wrong # args: should be "package prefer ?latest|stable?"} test package-14.1 {bogus argument} -returnCodes error -body { 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} -result stable test package-15.1 {set stable, keep} -constraints testpreferstable -setup { testpreferstable } -body {package prefer stable} -result stable test package-15.2 {set latest, change} -constraints testpreferstable -setup { testpreferstable } -body {package prefer latest} -result latest test package-15.3 {set latest, keep} -constraints testpreferstable -setup { testpreferstable } -body { package prefer latest package prefer latest } -result latest test package-15.4 {set stable, rejected} -constraints testpreferstable -setup { testpreferstable } -body { package prefer latest package prefer stable } -result latest rename prefer {} set auto_path $oldPath package unknown $oldPkgUnknown cleanupTests |
︙ | ︙ |
Changes to tests/parse.test.
︙ | ︙ | |||
372 373 374 375 376 377 378 | variable ::aresult variable ::acode set aresult $result set acode $code return "new result" } set handler1 [testasync create async1] | | | | | 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 | variable ::aresult variable ::acode set aresult $result set acode $code return "new result" } set handler1 [testasync create async1] set aresult xxx set acode yyy } -cleanup { testasync delete } -body { 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 { rename ::unknown unknown.save proc ::unknown args {lappend ::info [info level]} |
︙ | ︙ |
Changes to tests/result.test.
︙ | ︙ | |||
27 28 29 30 31 32 33 | testsaveresult small {set x 42} 0 } {small result} 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 | | | | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 | testsaveresult small {set x 42} 0 } {small result} 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 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 } {42} 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 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 # for the following case |
︙ | ︙ |
Changes to tests/safe.test.
︙ | ︙ | |||
70 71 72 73 74 75 76 | test safe-2.3 {creating safe interpreters, should have no unexpected aliases} -setup { catch {safe::interpDelete a} } -body { interp create a -safe lsort [a aliases] } -cleanup { interp delete a | | | 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 | test safe-2.3 {creating safe interpreters, should have no unexpected aliases} -setup { catch {safe::interpDelete a} } -body { interp create a -safe lsort [a aliases] } -cleanup { interp delete a } -result {clock} test safe-3.1 {calling safe::interpInit is safe} -setup { catch {safe::interpDelete a} interp create a -safe } -body { safe::interpInit a interp eval a exec ls |
︙ | ︙ | |||
176 177 178 179 180 181 182 | lsort $r } {byteOrder engine pathSeparator platform pointerSize wordSize} # More test should be added to check that hostname, nameofexecutable, aren't # leaking infos, but they still do... # high level general test | | | | | | 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 | lsort $r } {byteOrder engine pathSeparator platform pointerSize wordSize} # 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} -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 2}] # no error shall occur: interp eval $i {http::config} safe::interpDelete $i set v } -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 set token2 [safe::interpAddToAccessPath $i "/dummy/unixlike/test/path"] # an error shall occur (http is not anymore in the secure 0-level |
︙ | ︙ |
Changes to tests/scan.test.
︙ | ︙ | |||
549 550 551 552 553 554 555 | } -result {3 207698809136909011942886895 207698809136909011942886895 207698809136909011942886895} test scan-5.18 {bigint scanning underflow} -setup { set a {}; } -body { list [scan "-207698809136909011942886895" \ %llu a] $a } -returnCodes 1 -result {unsigned bignum scans are invalid} | | | 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 | } -result {3 207698809136909011942886895 207698809136909011942886895 207698809136909011942886895} test scan-5.18 {bigint scanning underflow} -setup { set a {}; } -body { list [scan "-207698809136909011942886895" \ %llu a] $a } -returnCodes 1 -result {unsigned bignum scans are invalid} 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} test scan-6.1 {floating-point scanning} -setup { |
︙ | ︙ |
Changes to tests/split.test.
︙ | ︙ | |||
66 67 68 69 70 71 72 73 74 75 76 77 78 79 | } {{} ab cd {} ef {}} test split-1.13 {basic split commands} { split "12,34,56," {,} } {12 34 56 {}} test split-1.14 {basic split commands} { split ",12,,,34,56," {,} } {{} 12 {} {} 34 56 {}} 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} { list [catch {split a b c} msg] $msg $errorCode } {1 {wrong # args: should be "split string ?splitChars?"} {TCL WRONGARGS}} | > > > | 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 | } {{} ab cd {} ef {}} test split-1.13 {basic split commands} { 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} { list [catch {split a b c} msg] $msg $errorCode } {1 {wrong # args: should be "split string ?splitChars?"} {TCL WRONGARGS}} |
︙ | ︙ |
Changes to tests/string.test.
︙ | ︙ | |||
20 21 22 23 24 25 26 27 28 29 30 31 32 33 | ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] # Some tests require the testobj command testConstraint testobj [expr {[info commands testobj] != {}}] testConstraint testindexobj [expr {[info commands testindexobj] != {}}] # Used for constraining memory leak tests testConstraint memory [llength [info commands memory]] proc representationpoke s { set r [::tcl::unsupported::representation $s] list [lindex $r 3] [string match {*, string representation "*"} $r] | > | 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 | ::tcltest::loadTestedCommands catch [list package require -exact Tcltest [info patchlevel]] # 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 { set r [::tcl::unsupported::representation $s] list [lindex $r 3] [string match {*, string representation "*"} $r] |
︙ | ︙ | |||
288 289 290 291 292 293 294 | test string-5.16 {string index, bytearray object with string obj shimmering} { set str "0123456789\x00 abcdedfghi" 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 | | | | 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 | test string-5.16 {string index, bytearray object with string obj shimmering} { set str "0123456789\x00 abcdedfghi" 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 {*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 {*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 } {} |
︙ | ︙ | |||
1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 | list $input_hex $rxBuffer_hex $rxCRC_hex } {000341 000341 0341} 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-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} { list [catch {string repeat abc 10 oops} msg] $msg } {1 {wrong # args: should be "string repeat string count"}} | > > > | 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 | list $input_hex $rxBuffer_hex $rxCRC_hex } {000341 000341 0341} 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} { list [catch {string repeat abc 10 oops} msg] $msg } {1 {wrong # args: should be "string repeat string count"}} |
︙ | ︙ |
Changes to tests/stringComp.test.
︙ | ︙ | |||
351 352 353 354 355 356 357 | string compare [string index $str 10] \x00 } foo } 0 test stringComp-5.17 {string index, bad integer} -body { proc foo {} {string index "abc" 0o8} list [catch {foo} msg] $msg | | | | 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 | string compare [string index $str 10] \x00 } 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 {*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 {*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} { proc foo {} {string index [binary format I* {0x50515253 0x52}] 20} foo |
︙ | ︙ |
Changes to tests/tcltest.test.
︙ | ︙ | |||
540 541 542 543 544 545 546 | -match glob } # 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 | < | 540 541 542 543 544 545 546 547 548 549 550 551 552 553 | -match glob } # 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 } default { catch {file attributes $notWriteableDir -readonly 1} |
︙ | ︙ |
Changes to tests/utf.test.
︙ | ︙ | |||
82 83 84 85 86 87 88 89 90 91 92 93 94 95 | string length [testbytestring "\xF8\xA2\xA2\xA2\xA2"] } {5} test utf-3.1 {Tcl_UtfCharComplete} { } {} testConstraint testnumutfchars [llength [info commands testnumutfchars]] 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"] } {1} test utf-4.3 {Tcl_NumUtfChars: long string} {testnumutfchars testbytestring} { | > > > | 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 | string length [testbytestring "\xF8\xA2\xA2\xA2\xA2"] } {5} 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"] } {1} test utf-4.3 {Tcl_NumUtfChars: long string} {testnumutfchars testbytestring} { |
︙ | ︙ | |||
114 115 116 117 118 119 120 | test utf-4.9 {Tcl_NumUtfChars: #u20AC, calc len, incomplete} {testnumutfchars testbytestring} { testnumutfchars [testbytestring "\xE2\x82\xAC"] 2 } {2} test utf-4.10 {Tcl_NumUtfChars: #u0000, calc len, overcomplete} {testnumutfchars testbytestring} { testnumutfchars [testbytestring "\x00"] 2 } {2} | | > > > > | | 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 | test utf-4.9 {Tcl_NumUtfChars: #u20AC, calc len, incomplete} {testnumutfchars testbytestring} { testnumutfchars [testbytestring "\xE2\x82\xAC"] 2 } {2} test utf-4.10 {Tcl_NumUtfChars: #u0000, calc len, overcomplete} {testnumutfchars testbytestring} { testnumutfchars [testbytestring "\x00"] 2 } {2} 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} { } {} |
︙ | ︙ |
Changes to tests/var.test.
︙ | ︙ | |||
243 244 245 246 247 248 249 | catch {unset a} } -constraints testupvar -body { set a 456 namespace eval test_ns_var { catch {unset ::test_ns_var::vv} proc p {} { # create namespace var vv linked to global a | | < | 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 | catch {unset a} } -constraints testupvar -body { 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 1 a {} vv namespace } p } 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} } -body { set aaaaa 77777 |
︙ | ︙ | |||
439 440 441 442 443 444 445 | catch {unset six} } -body { set a "" set five 555 set six 666 namespace eval test_ns_var { variable five 5 six | | | 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 | catch {unset six} } -body { set a "" set five 555 set six 666 namespace eval test_ns_var { variable five 5 six 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} catch {unset six} } -result {5 5 6 6 666} |
︙ | ︙ | |||
466 467 468 469 470 471 472 | variable sev:::en 7 } } -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 | | | | 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 | variable sev:::en 7 } } -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 variable 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} } -body { set a "" |
︙ | ︙ |
Changes to tests/while-old.test.
︙ | ︙ | |||
88 89 90 91 92 93 94 | test while-old-4.3 {errors in while loops} { set err [catch {while 1 2 3} msg] 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 | | | 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 | test while-old-4.3 {errors in while loops} { set err [catch {while 1 2 3} msg] 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 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 } {1 {expected boolean value but got "foo"}} test while-old-4.6 {errors in while loops} { |
︙ | ︙ |
Changes to tests/while.test.
︙ | ︙ | |||
28 29 30 31 32 33 34 | catch {while {$i<} break} return $::errorInfo } -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"} | | | 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | catch {while {$i<} break} return $::errorInfo } -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 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 break } |
︙ | ︙ | |||
339 340 341 342 343 344 345 | return $::errorInfo } -match glob -cleanup { 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"} | | | 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 | return $::errorInfo } -match glob -cleanup { 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 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")} { incr value break |
︙ | ︙ |
Changes to tools/README.
︙ | ︙ | |||
8 9 10 11 12 13 14 | uniClass.tcl -- Script for generating regexp class tables from the Tcl "string is" classes 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 | | | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | uniClass.tcl -- Script for generating regexp class tables from the Tcl "string is" classes 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/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 2) On UNIX, (after autoconf and configure), do make |
︙ | ︙ |
Changes to tools/checkLibraryDoc.tcl.
1 2 3 4 5 | # 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 | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 | # 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., 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. # 5) Command APIs (e.g., Tcl_ArrayObjCmd.) # 6) Proc pointers (e.g., Tcl_CloseProc.) |
︙ | ︙ | |||
102 103 104 105 106 107 108 | global argv0 global argv set len [llength $argv] if {($len != 2) && ($len != 3)} { puts "usage: $argv0 pkgName pkgDir \[outFile\]" puts " pkgName == Tcl,Tk" | | | 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 | global argv0 global argv set len [llength $argv] if {($len != 2) && ($len != 3)} { puts "usage: $argv0 pkgName pkgDir \[outFile\]" puts " pkgName == Tcl,Tk" puts " pkgDir == /home/surles/cvs/tcl8.2" exit 1 } set pkg [lindex $argv 0] set dir [lindex $argv 1] if {[llength $argv] == 3} { set file [open [lindex $argv 2] w] |
︙ | ︙ |
Changes to tools/configure.
︙ | ︙ | |||
1677 1678 1679 1680 1681 1682 1683 | # Recover information that Tcl computed with its configure script. #-------------------------------------------------------------------- # 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. #-------------------------------------------------------------------- | | | 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 | # Recover information that Tcl computed with its configure script. #-------------------------------------------------------------------- # 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=8.7 # Check whether --with-tcl was given. if test "${with_tcl+set}" = set; then : withval=$with_tcl; TCL_BIN_DIR=$withval else TCL_BIN_DIR=`cd ../../tcl$DEF_VER$TCL_PATCH_LEVEL/unix; pwd` |
︙ | ︙ |
Changes to tools/configure.ac.
1 2 3 4 5 6 7 8 9 10 11 12 13 | dnl This file is an input file used by the GNU "autoconf" program to dnl generate the file "configure", which is run to configure the dnl Makefile in this directory. AC_INIT(man2tcl.c) AC_PREREQ(2.69) # Recover information that Tcl computed with its configure script. #-------------------------------------------------------------------- # 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. #-------------------------------------------------------------------- | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | dnl This file is an input file used by the GNU "autoconf" program to dnl generate the file "configure", which is run to configure the dnl Makefile in this directory. AC_INIT(man2tcl.c) AC_PREREQ(2.69) # Recover information that Tcl computed with its configure script. #-------------------------------------------------------------------- # 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=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 if test ! -f $TCL_BIN_DIR/tclConfig.sh; then AC_MSG_ERROR(There's no tclConfig.sh in $TCL_BIN_DIR; perhaps you didn't specify the Tcl *build* directory (not the toplevel Tcl directory) or you forgot to configure Tcl?) |
︙ | ︙ |
Changes to tools/tcl.hpj.in.
1 2 3 4 5 6 7 | ; This file is maintained by HCW. Do not modify this file directly. [OPTIONS] HCW=0 LCID=0x409 0x0 0x0 ;English (United States) REPORT=Yes TITLE=Tcl/Tk Reference Manual | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | ; This file is maintained by HCW. Do not modify this file directly. [OPTIONS] HCW=0 LCID=0x409 0x0 0x0 ;English (United States) REPORT=Yes TITLE=Tcl/Tk Reference Manual CNT=tcl87.cnt COPYRIGHT=Copyright � 2000 Ajuba Solutions HLP=tcl87.hlp [FILES] tcl.rtf [WINDOWS] main="Tcl/Tk Reference Manual",,0 |
︙ | ︙ |
Changes to tools/tcltk-man2html.tcl.
1 2 3 4 5 6 | #!/usr/bin/env tclsh 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\ | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 | #!/usr/bin/env tclsh 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\ tclsh8.7 (or the equivalent tclsh87.exe\non Windows)." exit 1 } # Convert Ousterhout format man pages into highly crosslinked hypertext. # # Along the way detect many unmatched font changes and other odd things. # # Note well, this program is a hack rather than a piece of software # engineering. In that sense it's probably a good example of things # that a scripting language, like Tcl, can do well. It is offered as # an example of how someone might convert a specific set of man pages # into hypertext, not as a general solution to the problem. If you # 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/8.7" set ::CSSFILE "docs.css" ## ## Source the utility functions that provide most of the ## implementation of the transformation from nroff to html. ## source [file join [file dirname [info script]] tcltk-man2html-utils.tcl] |
︙ | ︙ |
Changes to unix/Makefile.in.
︙ | ︙ | |||
825 826 827 828 829 830 831 | do \ if [ ! -d "$$i" ] ; then \ echo "Making directory $$i"; \ $(INSTALL_DATA_DIR) "$$i"; \ else true; \ fi; \ done; | | | | | | | | 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 | do \ if [ ! -d "$$i" ] ; then \ echo "Making directory $$i"; \ $(INSTALL_DATA_DIR) "$$i"; \ else true; \ fi; \ done; @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; \ fi; \ done; @echo "Installing library files to $(SCRIPT_INSTALL_DIR)/"; @for i in $(TOP_DIR)/library/*.tcl $(TOP_DIR)/library/tclIndex \ $(UNIX_DIR)/tclAppInit.c @LDAIX_SRC@ @DTRACE_SRC@; \ do \ $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"; \ done; @echo "Installing package http1.0 files to $(SCRIPT_INSTALL_DIR)/http1.0/"; @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)"/../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)"/../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)"/../tcl8/8.5/tcltest-2.4.1.tm; @echo "Installing package platform 1.0.14 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.14.tm; @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform/shell-1.1.4.tm; @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; @if [ -n "$(TCL_MODULE_PATH)" -a -f $(TOP_DIR)/library/tm.tcl ]; then \ echo "Customizing tcl module path"; \ |
︙ | ︙ | |||
2046 2047 2048 2049 2050 2051 2052 | $(TOP_DIR)/win/tclConfig.sh.in $(TOP_DIR)/win/tclooConfig.sh \ $(TOP_DIR)/win/tcl.m4 $(TOP_DIR)/win/aclocal.m4 \ $(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 | < | < | 2046 2047 2048 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 | $(TOP_DIR)/win/tclConfig.sh.in $(TOP_DIR)/win/tclooConfig.sh \ $(TOP_DIR)/win/tcl.m4 $(TOP_DIR)/win/aclocal.m4 \ $(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/*.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 cp -p $(MAC_OSX_DIR)/GNUmakefile $(MAC_OSX_DIR)/README \ $(MAC_OSX_DIR)/*.c $(MAC_OSX_DIR)/*.in \ |
︙ | ︙ | |||
2093 2094 2095 2096 2097 2098 2099 | rm -f $(DISTROOT)/$(DISTNAME)-src.tar.gz $(DISTROOT)/$(ZIPNAME) cd $(DISTROOT); tar cf $(DISTNAME)-src.tar $(DISTNAME); \ 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 | | | 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 | rm -f $(DISTROOT)/$(DISTNAME)-src.tar.gz $(DISTROOT)/$(ZIPNAME) cd $(DISTROOT); tar cf $(DISTNAME)-src.tar $(DISTNAME); \ 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 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 # to function on those of the Tcl/Tk maintainers. # |
︙ | ︙ |
Changes to unix/configure.
1 2 | #! /bin/sh # Guess values for system-dependent variables and create Makefiles. | | | 1 2 3 4 5 6 7 8 9 10 | #! /bin/sh # Guess values for system-dependent variables and create Makefiles. # Generated by GNU Autoconf 2.69 for tcl 8.7. # # # Copyright (C) 1992-1996, 1998-2012 Free Software Foundation, Inc. # # # This configure script is free software; the Free Software Foundation # gives unlimited permission to copy, distribute and modify it. |
︙ | ︙ | |||
573 574 575 576 577 578 579 | subdirs= MFLAGS= MAKEFLAGS= # Identity of this package. PACKAGE_NAME='tcl' PACKAGE_TARNAME='tcl' | | | | 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 | subdirs= MFLAGS= MAKEFLAGS= # Identity of this package. PACKAGE_NAME='tcl' PACKAGE_TARNAME='tcl' PACKAGE_VERSION='8.7' PACKAGE_STRING='tcl 8.7' PACKAGE_BUGREPORT='' PACKAGE_URL='' # Factoring default headers for most tests. ac_includes_default="\ #include <stdio.h> #ifdef HAVE_SYS_TYPES_H |
︙ | ︙ | |||
1315 1316 1317 1318 1319 1320 1321 | # # Report the --help message. # 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 | | | 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 | # # Report the --help message. # 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 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. Defaults for the options are specified in brackets. |
︙ | ︙ | |||
1376 1377 1378 1379 1380 1381 1382 | cat <<\_ACEOF _ACEOF fi if test -n "$ac_init_help"; then case $ac_init_help in | | | 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 | cat <<\_ACEOF _ACEOF fi if test -n "$ac_init_help"; then case $ac_init_help in short | recursive ) echo "Configuration of tcl 8.7:";; esac cat <<\_ACEOF Optional Features: --disable-option-checking ignore unrecognized --enable/--with options --disable-FEATURE do not include FEATURE (same as --enable-FEATURE=no) --enable-FEATURE[=ARG] include FEATURE [ARG=yes] |
︙ | ︙ | |||
1490 1491 1492 1493 1494 1495 1496 | cd "$ac_pwd" || { ac_status=$?; break; } done fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF | | | 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 | cd "$ac_pwd" || { ac_status=$?; break; } done fi test -n "$ac_init_help" && exit $ac_status if $ac_init_version; then cat <<\_ACEOF 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. _ACEOF exit |
︙ | ︙ | |||
1966 1967 1968 1969 1970 1971 1972 | eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # 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. | | | 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 | eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno } # 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 8.7, which was generated by GNU Autoconf 2.69. Invocation command line was $ $0 $@ _ACEOF exec 5>>config.log { |
︙ | ︙ | |||
2318 2319 2320 2321 2322 2323 2324 | ac_compiler_gnu=$ac_cv_c_compiler_gnu | | | | | | 2318 2319 2320 2321 2322 2323 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 | ac_compiler_gnu=$ac_cv_c_compiler_gnu 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:-"@:"} #------------------------------------------------------------------------ # Setup configure arguments for bundled packages |
︙ | ︙ | |||
3728 3729 3730 3731 3732 3733 3734 | $as_echo "$tcl_cv_dirent_h" >&6; } if test $tcl_cv_dirent_h = no; then $as_echo "#define NO_DIRENT_H 1" >>confdefs.h fi | < < < < < < < < < < < < < < < < < < < < | 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 | $as_echo "$tcl_cv_dirent_h" >&6; } 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" "stdlib.h" "ac_cv_header_stdlib_h" "$ac_includes_default" if test "x$ac_cv_header_stdlib_h" = xyes; then : tcl_ok=1 else tcl_ok=0 fi |
︙ | ︙ | |||
5315 5316 5317 5318 5319 5320 5321 | CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; Haiku*) LDFLAGS="$LDFLAGS -Wl,--export-dynamic" SHLIB_CFLAGS="-fPIC" SHLIB_SUFFIX=".so" | | | 5295 5296 5297 5298 5299 5300 5301 5302 5303 5304 5305 5306 5307 5308 5309 | CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; Haiku*) LDFLAGS="$LDFLAGS -Wl,--export-dynamic" SHLIB_CFLAGS="-fPIC" SHLIB_SUFFIX=".so" 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 : $as_echo_n "(cached) " >&6 else |
︙ | ︙ | |||
5637 5638 5639 5640 5641 5642 5643 | CFLAGS_OPTIMIZE="-O2" # 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" | | | 5617 5618 5619 5620 5621 5622 5623 5624 5625 5626 5627 5628 5629 5630 5631 | CFLAGS_OPTIMIZE="-O2" # 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} ${CFLAGS} ${LDFLAGS} -shared' DL_OBJS="tclLoadDl.o" DL_LIBS="-ldl" LDFLAGS="$LDFLAGS -Wl,--export-dynamic" if test $doRpath = yes; then : CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' fi |
︙ | ︙ | |||
5724 5725 5726 5727 5728 5729 5730 | alpha|sparc64) SHLIB_CFLAGS="-fPIC" ;; *) SHLIB_CFLAGS="-fpic" ;; esac | | | 5704 5705 5706 5707 5708 5709 5710 5711 5712 5713 5714 5715 5716 5717 5718 | alpha|sparc64) SHLIB_CFLAGS="-fPIC" ;; *) SHLIB_CFLAGS="-fpic" ;; esac SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" if test $doRpath = yes; then : CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' fi |
︙ | ︙ | |||
5751 5752 5753 5754 5755 5756 5757 | # OpenBSD doesn't do version numbers with dots. UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' TCL_LIB_VERSIONS_OK=nodots ;; NetBSD-*) # NetBSD has ELF and can use 'cc -shared' to build shared libs SHLIB_CFLAGS="-fPIC" | | | 5731 5732 5733 5734 5735 5736 5737 5738 5739 5740 5741 5742 5743 5744 5745 | # OpenBSD doesn't do version numbers with dots. UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' TCL_LIB_VERSIONS_OK=nodots ;; NetBSD-*) # NetBSD has ELF and can use 'cc -shared' to build shared libs SHLIB_CFLAGS="-fPIC" SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" LDFLAGS="$LDFLAGS -export-dynamic" if test $doRpath = yes; then : CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}' |
︙ | ︙ | |||
10962 10963 10964 10965 10966 10967 10968 | test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 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=" | | | 10942 10943 10944 10945 10946 10947 10948 10949 10950 10951 10952 10953 10954 10955 10956 | test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1 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 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 CONFIG_COMMANDS = $CONFIG_COMMANDS $ $0 $@ |
︙ | ︙ | |||
11019 11020 11021 11022 11023 11024 11025 | Report bugs to the package provider." _ACEOF cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1 ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`" ac_cs_version="\\ | | | 10999 11000 11001 11002 11003 11004 11005 11006 11007 11008 11009 11010 11011 11012 11013 | Report bugs to the package provider." _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 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 gives unlimited permission to copy, distribute and modify it." |
︙ | ︙ |
Changes to unix/configure.ac.
1 2 3 4 5 | #! /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. | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 | #! /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],[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]) AC_CONFIG_COMMANDS_PRE([DEFS="-DHAVE_TCL_CONFIG_H -imacros tclConfig.h"]) AH_TOP([ #ifndef _TCLCONFIG #define _TCLCONFIG]) AH_BOTTOM([ /* Undef unused package specific autoheader defines so that we can * include both tclConfig.h and tkConfig.h at the same time: */ /* override */ #undef PACKAGE_NAME /* override */ #undef PACKAGE_STRING /* override */ #undef PACKAGE_TARNAME #endif /* _TCLCONFIG */]) ]) 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:-"@:"} #------------------------------------------------------------------------ # Setup configure arguments for bundled packages |
︙ | ︙ |
Changes to unix/tcl.m4.
︙ | ︙ | |||
1246 1247 1248 1249 1250 1251 1252 | CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; Haiku*) LDFLAGS="$LDFLAGS -Wl,--export-dynamic" SHLIB_CFLAGS="-fPIC" SHLIB_SUFFIX=".so" | | | 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 | CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" ;; Haiku*) LDFLAGS="$LDFLAGS -Wl,--export-dynamic" SHLIB_CFLAGS="-fPIC" SHLIB_SUFFIX=".so" 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.*) # Use updated header definitions where possible AC_DEFINE(_XOPEN_SOURCE_EXTENDED, 1, [Do we want to use the XOPEN network library?]) |
︙ | ︙ | |||
1390 1391 1392 1393 1394 1395 1396 | CFLAGS_OPTIMIZE="-O2" # 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" | | | 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 | CFLAGS_OPTIMIZE="-O2" # 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} ${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}']) LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} AS_IF([test "`uname -m`" = "alpha"], [CFLAGS="$CFLAGS -mieee"]) |
︙ | ︙ | |||
1440 1441 1442 1443 1444 1445 1446 | alpha|sparc64) SHLIB_CFLAGS="-fPIC" ;; *) SHLIB_CFLAGS="-fpic" ;; esac | | | 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 | alpha|sparc64) SHLIB_CFLAGS="-fPIC" ;; *) SHLIB_CFLAGS="-fpic" ;; esac 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}']) LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} SHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.so.${SHLIB_VERSION}' |
︙ | ︙ | |||
1463 1464 1465 1466 1467 1468 1469 | # OpenBSD doesn't do version numbers with dots. UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' TCL_LIB_VERSIONS_OK=nodots ;; NetBSD-*) # NetBSD has ELF and can use 'cc -shared' to build shared libs SHLIB_CFLAGS="-fPIC" | | | 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 | # OpenBSD doesn't do version numbers with dots. UNSHARED_LIB_SUFFIX='${TCL_TRIM_DOTS}.a' TCL_LIB_VERSIONS_OK=nodots ;; NetBSD-*) # NetBSD has ELF and can use 'cc -shared' to build shared libs SHLIB_CFLAGS="-fPIC" SHLIB_LD='${CC} ${SHLIB_CFLAGS} -shared' SHLIB_SUFFIX=".so" DL_OBJS="tclLoadDl.o" DL_LIBS="" LDFLAGS="$LDFLAGS -export-dynamic" AS_IF([test $doRpath = yes], [ CC_SEARCH_FLAGS='-Wl,-rpath,${LIB_RUNTIME_DIR}']) LD_SEARCH_FLAGS=${CC_SEARCH_FLAGS} |
︙ | ︙ | |||
2036 2037 2038 2039 2040 2041 2042 | # Arguments: # none # # Results: # # Defines some of the following vars: # NO_DIRENT_H | < | 2036 2037 2038 2039 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 | # Arguments: # none # # Results: # # Defines some of the following vars: # NO_DIRENT_H # NO_STDLIB_H # NO_STRING_H # NO_SYS_WAIT_H # NO_DLFCN_H # HAVE_SYS_PARAM_H # # HAVE_STRING_H ? |
︙ | ︙ | |||
2074 2075 2076 2077 2078 2079 2080 | closedir(d); ], tcl_cv_dirent_h=yes, tcl_cv_dirent_h=no)]) if test $tcl_cv_dirent_h = no; then AC_DEFINE(NO_DIRENT_H, 1, [Do we have <dirent.h>?]) fi | < < | 2073 2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 | closedir(d); ], tcl_cv_dirent_h=yes, tcl_cv_dirent_h=no)]) if test $tcl_cv_dirent_h = no; then AC_DEFINE(NO_DIRENT_H, 1, [Do we have <dirent.h>?]) fi 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 AC_DEFINE(NO_STDLIB_H, 1, [Do we have <stdlib.h>?]) fi |
︙ | ︙ |
Changes to unix/tcl.spec.
1 2 3 4 5 6 | # This file is the basis for a binary Tcl RPM for Linux. %{!?directory:%define directory /usr/local} Name: tcl Summary: Tcl scripting language development environment | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | # This file is the basis for a binary Tcl RPM for Linux. %{!?directory:%define directory /usr/local} Name: tcl Summary: Tcl scripting language development environment 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/ Buildroot: /var/tmp/%{name}%{version} |
︙ | ︙ |
Changes to unix/tclConfig.h.in.
︙ | ︙ | |||
291 292 293 294 295 296 297 | /* Do we have <dlfcn.h>? */ #undef NO_DLFCN_H /* Do we have fd_set? */ #undef NO_FD_SET | < < < | 291 292 293 294 295 296 297 298 299 300 301 302 303 304 | /* Do we have <dlfcn.h>? */ #undef NO_DLFCN_H /* Do we have fd_set? */ #undef NO_FD_SET /* Do we have fstatfs()? */ #undef NO_FSTATFS /* Do we have gettimeofday()? */ #undef NO_GETTOD /* Do we have getwd() */ |
︙ | ︙ | |||
330 331 332 333 334 335 336 | /* Do we have uname() */ #undef NO_UNAME /* Do we have a usable 'union wait'? */ #undef NO_UNION_WAIT | < < < | 327 328 329 330 331 332 333 334 335 336 337 338 339 340 | /* Do we have uname() */ #undef NO_UNAME /* Do we have a usable 'union wait'? */ #undef NO_UNION_WAIT /* Do we have wait3() */ #undef NO_WAIT3 /* Define to the address where bug reports for this package should be sent. */ #undef PACKAGE_BUGREPORT /* Define to the full name of this package. */ |
︙ | ︙ |
Changes to unix/tclUnixInit.c.
︙ | ︙ | |||
35 36 37 38 39 40 41 | #ifdef __CYGWIN__ DLLIMPORT extern __stdcall unsigned char GetVersionExW(void *); 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 *); | < < < < < | 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | #ifdef __CYGWIN__ DLLIMPORT extern __stdcall unsigned char GetVersionExW(void *); 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 NUMPROCESSORS 11 static const char *const processors[NUMPROCESSORS] = { "intel", "mips", "alpha", "ppc", "shx", "arm", "ia64", "alpha64", "msil", "amd64", "ia32_on_win64" }; typedef struct { |
︙ | ︙ | |||
449 450 451 452 453 454 455 | * *------------------------------------------------------------------------- */ void TclpInitLibraryPath( char **valuePtr, | | | 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 | * *------------------------------------------------------------------------- */ void TclpInitLibraryPath( char **valuePtr, unsigned int *lengthPtr, Tcl_Encoding *encodingPtr) { #define LIBRARY_SIZE 32 Tcl_Obj *pathPtr, *objPtr; const char *str; Tcl_DString buffer; |
︙ | ︙ | |||
578 579 580 581 582 583 584 | { Tcl_DString encodingName; Tcl_SetSystemEncoding(NULL, Tcl_GetEncodingNameFromEnvironment(&encodingName)); Tcl_DStringFree(&encodingName); } | < < < < < < | 573 574 575 576 577 578 579 580 581 582 583 584 585 586 | { Tcl_DString encodingName; Tcl_SetSystemEncoding(NULL, Tcl_GetEncodingNameFromEnvironment(&encodingName)); Tcl_DStringFree(&encodingName); } static const char * SearchKnownEncodings( const char *encoding) { int left = 0; int right = sizeof(localeTable)/sizeof(LocaleTable); |
︙ | ︙ | |||
886 887 888 889 890 891 892 | GetVersionExW(&osInfo); } osInfoInitialized = 1; } GetSystemInfo(&sysInfo); | < | < < | 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 | GetVersionExW(&osInfo); } osInfoInitialized = 1; } GetSystemInfo(&sysInfo); 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], TCL_GLOBAL_ONLY); } |
︙ | ︙ |
Changes to unix/tclUnixNotfy.c.
︙ | ︙ | |||
528 529 530 531 532 533 534 | if (timeoutPtr->tv_usec) { pollTimeout += ((int)timeoutPtr->tv_usec / 1000); } } numFound = poll(pollFds, 1, pollTimeout); if (numFound == 1) { result = 0; | | | | | 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 | if (timeoutPtr->tv_usec) { pollTimeout += ((int)timeoutPtr->tv_usec / 1000); } } numFound = poll(pollFds, 1, pollTimeout); if (numFound == 1) { result = 0; if (pollFds[0].revents & (POLLIN | POLLHUP)) { result |= TCL_READABLE; } if (pollFds[0].revents & POLLOUT) { result |= TCL_WRITABLE; } if (pollFds[0].revents & POLLERR) { result |= TCL_EXCEPTION; } if (result) { break; } } if (timeout == 0) { |
︙ | ︙ |
Changes to unix/tclUnixPort.h.
︙ | ︙ | |||
83 84 85 86 87 88 89 | # define HANDLE void * # define HINSTANCE void * # 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); | | | | 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 | # define HANDLE void * # define HINSTANCE void * # 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 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(); __declspec(dllimport) extern __stdcall int GetFileAttributesW(const WCHAR *); __declspec(dllimport) extern __stdcall int SetFileAttributesW(const WCHAR *, int); |
︙ | ︙ | |||
177 178 179 180 181 182 183 | *--------------------------------------------------------------------------- * Some platforms (e.g. SunOS) don't define FLT_MAX and FLT_MIN, so we look * for an alternative definition. If no other alternative is available we use * a reasonable guess. *--------------------------------------------------------------------------- */ | < | < < < < < | 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 | *--------------------------------------------------------------------------- * Some platforms (e.g. SunOS) don't define FLT_MAX and FLT_MIN, so we look * for an alternative definition. If no other alternative is available we use * a reasonable guess. *--------------------------------------------------------------------------- */ #include <float.h> #ifndef FLT_MAX # ifdef MAXFLOAT # define FLT_MAX MAXFLOAT # else # define FLT_MAX 3.402823466E+38F # endif |
︙ | ︙ |
Changes to unix/tclUnixSock.c.
︙ | ︙ | |||
213 214 215 216 217 218 219 | * * ---------------------------------------------------------------------- */ static void InitializeHostName( char **valuePtr, | | | 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 | * * ---------------------------------------------------------------------- */ static void InitializeHostName( char **valuePtr, unsigned int *lengthPtr, Tcl_Encoding *encodingPtr) { const char *native = NULL; #ifndef NO_UNAME struct utsname u; struct hostent *hp; |
︙ | ︙ |
Changes to unix/tclUnixThrd.c.
︙ | ︙ | |||
11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 | * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #ifdef TCL_THREADS typedef struct { char nabuf[16]; } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; /* * 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. */ | > > | 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #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. */ |
︙ | ︙ |
Changes to win/Makefile.in.
︙ | ︙ | |||
626 627 628 629 630 631 632 | do \ if [ ! -d $$i ] ; then \ echo "Making directory $$i"; \ $(MKDIR) $$i; \ else true; \ fi; \ done; | | | 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 | do \ if [ ! -d $$i ] ; then \ echo "Making directory $$i"; \ $(MKDIR) $$i; \ else true; \ fi; \ done; @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; \ fi; \ done; |
︙ | ︙ | |||
654 655 656 657 658 659 660 | done; @echo "Installing library http1.0 directory"; @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"; | | | | | | | 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 | done; @echo "Installing library http1.0 directory"; @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)/../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)/../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)/../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)/../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)/../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; install-tzdata: @echo "Installing time zone data" |
︙ | ︙ | |||
854 855 856 857 858 859 860 | $(TCL_EXE) "$(ROOT_DIR_NATIVE)/tools/genStubs.tcl" \ "$(GENERIC_DIR_NATIVE)" \ "$(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 | | | 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 | $(TCL_EXE) "$(ROOT_DIR_NATIVE)/tools/genStubs.tcl" \ "$(GENERIC_DIR_NATIVE)" \ "$(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 tcl8.* & # tk8.* up two directories from the TOOL_DIR. # TOOL_DIR=$(ROOT_DIR)/tools HTML_INSTALL_DIR=$(ROOT_DIR)/html html: $(MAKE) shell SCRIPT="$(TOOL_DIR)/tcltk-man2html.tcl --htmldir=$(HTML_INSTALL_DIR) --srcdir=$(ROOT_DIR)/.. $(BUILD_HTML_FLAGS)" |
︙ | ︙ |
Changes to win/README.
|
| | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 | Tcl 8.7 for Windows 1. Introduction --------------- This is the directory where you configure and compile the Windows version of Tcl. This directory also contains source files for Tcl that are specific to Microsoft Windows. The information in this file is maintained on the web at: http://www.tcl.tk/doc/howto/compile.html#win 2. Compiling Tcl ---------------- In order to compile Tcl for Windows, you need the following: Tcl 8.7 Source Distribution (plus any patches) and Visual C++ 6 or newer or |
︙ | ︙ | |||
75 76 77 78 79 80 81 | and Msys, you can download a suitable win32 or win64 compiler from [https://sourceforge.net/projects/mingw-w64/files/] Use the Makefile "install" target to install Tcl. It will install it according to the prefix options you provided in the correct directory structure. | | | | 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 | and Msys, you can download a suitable win32 or win64 compiler from [https://sourceforge.net/projects/mingw-w64/files/] 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 tclsh87.exe, you must ensure that tcl87.dll is on your path, in the system directory, or in the directory containing tclsh87.exe. Note: Tcl no longer provides support for Win32s. 3. Test suite ------------- This distribution contains an extensive test suite for Tcl. Some of the |
︙ | ︙ |
Deleted win/coffbase.txt.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Changes to win/configure.
︙ | ︙ | |||
702 703 704 705 706 707 708 | ZLIB_OBJS ZLIB_LIBS ZLIB_DLL_FILE CFLAGS_WARNING CFLAGS_OPTIMIZE CFLAGS_DEBUG DL_LIBS | < | 702 703 704 705 706 707 708 709 710 711 712 713 714 715 | ZLIB_OBJS ZLIB_LIBS ZLIB_DLL_FILE CFLAGS_WARNING CFLAGS_OPTIMIZE CFLAGS_DEBUG DL_LIBS CYGPATH TCL_THREADS SET_MAKE RC RANLIB AR EGREP |
︙ | ︙ | |||
764 765 766 767 768 769 770 | ac_subst_files='' ac_user_opts=' enable_option_checking enable_threads with_encoding enable_shared enable_64bit | < < | 763 764 765 766 767 768 769 770 771 772 773 774 775 776 | ac_subst_files='' ac_user_opts=' enable_option_checking enable_threads with_encoding enable_shared enable_64bit enable_symbols enable_embedded_manifest ' ac_precious_vars='build_alias host_alias target_alias CC |
︙ | ︙ | |||
1388 1389 1390 1391 1392 1393 1394 | Optional Features: --disable-option-checking ignore unrecognized --enable/--with options --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) | < < | 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 | Optional Features: --disable-option-checking ignore unrecognized --enable/--with options --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-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 Some influential environment variables: CC C compiler command CFLAGS C compiler flags LDFLAGS linker flags, e.g. -L<lib dir> if you have libraries in a nonstandard directory <lib dir> LIBS libraries to pass to the linker, e.g. -l<library> |
︙ | ︙ | |||
2095 2096 2097 2098 2099 2100 2101 | # 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 | | | | | | 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 | # 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=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 DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION |
︙ | ︙ | |||
3807 3808 3809 3810 3811 3812 3813 | else do64bit=no fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $do64bit" >&5 $as_echo "$do64bit" >&6; } | < < < < < < < < < < < < < < < < < < < < < < < < < < < | 3802 3803 3804 3805 3806 3807 3808 3809 3810 3811 3812 3813 3814 3815 | else do64bit=no fi { $as_echo "$as_me:${as_lineno-$LINENO}: result: $do64bit" >&5 $as_echo "$do64bit" >&6; } # Set some defaults (may get changed below) EXTRA_CFLAGS="" $as_echo "#define MODULE_SCOPE extern" >>confdefs.h # Extract the first word of "cygpath", so it can be a program name with args. |
︙ | ︙ | |||
4332 4333 4334 4335 4336 4337 4338 | CFLAGS_DEBUG="-nologo -Z7 -Od -WX ${runtime}d" # -O2 - create fast code (/Og /Oi /Ot /Oy /Ob2 /Gs /GF /Gy) CFLAGS_OPTIMIZE="-nologo -O2 ${runtime}" lflags="${lflags} -nologo" LINKBIN="link" fi | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < | 4300 4301 4302 4303 4304 4305 4306 4307 4308 4309 4310 4311 4312 4313 4314 | CFLAGS_DEBUG="-nologo -Z7 -Od -WX ${runtime}d" # -O2 - create fast code (/Og /Oi /Ot /Oy /Ob2 /Gs /GF /Gy) CFLAGS_OPTIMIZE="-nologo -O2 ${runtime}" lflags="${lflags} -nologo" LINKBIN="link" 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}" RC_OUT=-fo RC_TYPE=-r |
︙ | ︙ | |||
4463 4464 4465 4466 4467 4468 4469 | # Specify the CC output file names based on the target name CC_OBJNAME="-Fo\$@" CC_EXENAME="-Fe\"\$(shell \$(CYGPATH) '\$@')\"" # Specify linker flags depending on the type of app being # built -- Console vs. Window. | | | 4331 4332 4333 4334 4335 4336 4337 4338 4339 4340 4341 4342 4343 4344 4345 | # Specify the CC output file names based on the target name CC_OBJNAME="-Fo\$@" CC_EXENAME="-Fe\"\$(shell \$(CYGPATH) '\$@')\"" # Specify linker flags depending on the type of app being # built -- Console vs. Window. 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}" fi fi |
︙ | ︙ |
Changes to win/configure.ac.
1 2 3 4 5 6 7 8 9 10 11 12 13 | #! /bin/bash -norc # This file is an input file used by the GNU "autoconf" program to # generate the file "configure", which is run during Tcl installation # to configure the system for the local environment. AC_INIT(../generic/tcl.h) AC_PREREQ(2.69) # 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 | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | #! /bin/bash -norc # This file is an input file used by the GNU "autoconf" program to # generate the file "configure", which is run during Tcl installation # to configure the system for the local environment. AC_INIT(../generic/tcl.h) AC_PREREQ(2.69) # 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=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 DDEVER=$TCL_DDE_MAJOR_VERSION$TCL_DDE_MINOR_VERSION |
︙ | ︙ |
Changes to win/makefile.vc.
|
| | < | > < < < < < < < < | | < < < < < < < < < < < < < < > | < < > < < < < > > > | < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < > > | < | < < < | < < | < < > > > > < < < < < < | < < < < < < | < | < < < < < < < < < < < < < < | | < < < < | < > > | < < < | | < < < < < | < < < | < | < < < < < > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 | #------------------------------------------------------------- -*- 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 |
︙ | ︙ | |||
456 457 458 459 460 461 462 | TCLOBJS = $(COREOBJS) $(ZLIBOBJS) $(TOMMATHOBJS) $(PLATFORMOBJS) TCLSTUBOBJS = \ $(TMP_DIR)\tclStubLib.obj \ $(TMP_DIR)\tclTomMathStubLib.obj \ $(TMP_DIR)\tclOOStubLib.obj | | | < < < < < < < | < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < | | < < < < | < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 | 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) |
︙ | ︙ | |||
591 592 593 594 595 596 597 598 599 600 601 | 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 | > < < < < < < < < < < < < < | < < < | > | > | > > | > | | | | < | | < | | 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 | 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" & \ |
︙ | ︙ | |||
702 703 704 705 706 707 708 | @if exist "%~fd\win\makefile.vc" ( \ pushd "%~fd\win" & \ $(MAKE) -$(MAKEFLAGS) -f makefile.vc TCLDIR=$(ROOT) clean &\ popd \ ) $(CAT32): $(WINDIR)\cat.c | | | < | 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 | @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: |
︙ | ︙ | |||
742 743 744 745 746 747 748 | > "$(GENERICDIR)\tclTomMath.h" !endif #--------------------------------------------------------------------- # Build the Windows HTML help file. #--------------------------------------------------------------------- | | > > > | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | > | > > > > | | | > > > > > > > | | | | 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 | > "$(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@ |
︙ | ︙ | |||
934 935 936 937 938 939 940 | $(GENERICDIR)/tclGetDate.y #--------------------------------------------------------------------- # Special case object file targets #--------------------------------------------------------------------- $(TMP_DIR)\testMain.obj: $(WINDIR)\tclAppInit.c | | | | | | | | | | | | | | | | | | 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 | $(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 |
︙ | ︙ | |||
1046 1047 1048 1049 1050 1051 1052 | !endif ### add a spacer in the output !message #--------------------------------------------------------------------- | > | < < < < < | < < < < < < < < < < | < < < < < < < | < < < < < | | | | | > > | | | > > > > | 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 | !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)\" |
︙ | ︙ | |||
1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 | @$(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" \ | > > > > | | | | | | 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 | @$(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)\" |
︙ | ︙ | |||
1185 1186 1187 1188 1189 1190 1191 | @$(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\" | | < | 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 | @$(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" |
︙ | ︙ | |||
1220 1221 1222 1223 1224 1225 1226 | @echo Removing $(TCLTEST) ... @if exist $(TCLTEST) del $(TCLTEST) @echo Removing $(TCLDDELIB) ... @if exist $(TCLDDELIB) del $(TCLDDELIB) @echo Removing $(TCLREGLIB) ... @if exist $(TCLREGLIB) del $(TCLREGLIB) | | < < < < < < < < < < < < < < < < | < < < < | 934 935 936 937 938 939 940 941 942 943 944 945 946 947 | @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: |
Changes to win/nmakehlp.c.
︙ | ︙ | |||
35 36 37 38 39 40 41 | /* ISO hack for dumb VC++ */ #ifdef _MSC_VER #define snprintf _snprintf #endif | < > | 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 | /* ISO hack for dumb VC++ */ #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 */ #define CHUNK 25 #define STATICBUFFERSIZE 1000 |
︙ | ︙ | |||
168 169 170 171 172 173 174 175 176 177 178 179 180 181 | "Emit the fully qualified path\n" "exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]); WriteFile(GetStdHandle(STD_ERROR_HANDLE), msg, chars, &dwWritten, NULL); return 2; } return QualifyPath(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" "Win9x and get nmake.exe to accomplish its job.\n", argv[0]); | > > > > > > > > > > > > | 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 | "Emit the fully qualified path\n" "exitcodes: 0 == no, 1 == yes, 2 == error\n", argv[0]); 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" "Win9x and get nmake.exe to accomplish its job.\n", argv[0]); |
︙ | ︙ | |||
695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 | while ((p = strchr(szPath, '/')) && *p) *p = '\\'; PathCombine(szTmp, szCwd, szPath); PathCanonicalize(szCwd, szTmp); printf("%s\n", szCwd); return 0; } /* * Local variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * indent-tabs-mode: t * tab-width: 8 * End: */ | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 | while ((p = strchr(szPath, '/')) && *p) *p = '\\'; 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=<full path of located directory> * 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 * fill-column: 78 * indent-tabs-mode: t * tab-width: 8 * End: */ |
Added win/rules-ext.vc.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 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 |
Changes to win/rules.vc.
|
| | | | > > > > > > > > > > > | > | > > | > > > | > > > > > > > > | > | < > > > > | > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < < < < < < > < < < < < < < < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > | > > > > > > > | > > > > > > > > > > > > > > > > > > > > < < < < < | < > | | < > | > > > > > > > > > > > > > | | > > > | > > > > | < < < > > > > > < < < < | | | > > > > > > > > | > > | < < < > > > | < | < > > > > < < | < < < < < | | < < | < < < < < < < < < < < < < < < < < < < | > > > > > > > > | > | | < > | > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > | < < < < < < < < < < < < < > > | > < > > > > > > > > > > > > > > > > > > > | < > > > > > > < > < > > > > > > > > > > > > | | > > > > | > > > > > > > | < < < > > > < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | < < | < | | < | < | > > > > | > > > > > > > > > > > > | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 521 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 572 573 574 575 576 577 578 579 580 581 582 583 584 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 768 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 823 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 846 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 924 925 926 927 928 929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 | #------------------------------------------------------------- -*- makefile -*- # rules.vc -- # # 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 # 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 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. #---------------------------------------------------------- RMDIR = rmdir /S /Q CPY = xcopy /i /y >NUL CPYDIR = xcopy /e /i /y >NUL COPY = copy /y >NUL MKDIR = mkdir ###################################################################### # 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 !if ![echo VCVERSION=_MSC_VER > vercl.x] \ && ![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] \ && ![$(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 !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 # Since MSVC8 we must deal with manifest resources. !if $(VCVERSION) >= 1400 _VC_MANIFEST_EMBED_EXE=if exist [email protected] mt -nologo -manifest [email protected] -outputresource:$@;1 _VC_MANIFEST_EMBED_DLL=if exist [email protected] mt -nologo -manifest [email protected] -outputresource:$@;2 !endif !ifndef CFG_ENCODING CFG_ENCODING = \"cp1252\" !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] FPOPTS = -Op !endif # Strict floating point semantics - present in newer compilers in lieu of -Op !if [nmakehlp -c -fp:strict] FPOPTS = $(FPOPTS) -fp:strict !endif !if "$(MACHINE)" == "IX86" ### test for pentium errata !if [nmakehlp -c -QI0f] !message *** Compiler has 'Pentium 0x0f fix' FPOPTS = $(FPOPTS) -QI0f !else !message *** Compiler does not have 'Pentium 0x0f fix' !endif !endif ### 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 # 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 #---------------------------------------------------------------- # 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: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 = $(LINKERFLAGS) -ltcg !endif !endif ######################################################################## # 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. # Default values for all the above STATIC_BUILD = 0 TCL_THREADS = 1 DEBUG = 0 SYMBOLS = 0 PROFILE = 0 PGO = 0 MSVCRT = 1 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 !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"] !message *** Doing msvcrt MSVCRT = 1 !else !if !$(STATIC_BUILD) MSVCRT = 1 !else MSVCRT = 0 !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 *** 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"] 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. # 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. # # 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 BUILDDIRTOP = Release !endif |
︙ | ︙ | |||
377 378 379 380 381 382 383 384 | !endif !else !ifndef OUT_DIR OUT_DIR = $(TMP_DIR) !endif !endif | > > > > > > > > > > > > | > > | > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | < > | | < > > > > > > | > | > > > > > | | | > | > | > > > > > < > > > > > > > > < < < > > > > > > < < < | | > | | > > > > > > | | > > > > > > > > > < < | < < | > | < | > | > > > > | > > | > > > > > > > > > > > > > > > > > > > > > > | < < > | < < < > > | | < | | < > | > > > > > | < > > > | < > > > > > > > > > > > > > > > > | 1040 1041 1042 1043 1044 1045 1046 1047 1048 1049 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 1065 1066 1067 1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 1138 1139 1140 1141 1142 1143 1144 1145 1146 1147 1148 1149 1150 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 1176 1177 1178 1179 1180 1181 1182 1183 1184 1185 1186 1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 | !endif !else !ifndef OUT_DIR OUT_DIR = $(TMP_DIR) !endif !endif # 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 !endif !if $(TCL_COMPILE_DEBUG) |
︙ | ︙ | |||
473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 | !if $(STATIC_BUILD) OPTDEFINES = $(OPTDEFINES) -DSTATIC_BUILD !endif !if $(TCL_NO_DEPRECATED) OPTDEFINES = $(OPTDEFINES) -DTCL_NO_DEPRECATED !endif !if !$(DEBUG) OPTDEFINES = $(OPTDEFINES) -DNDEBUG !if $(OPTIMIZING) OPTDEFINES = $(OPTDEFINES) -DTCL_CFG_OPTIMIZED !endif !endif !if $(PROFILE) OPTDEFINES = $(OPTDEFINES) -DTCL_CFG_PROFILED !endif | > > > > > > > > > > > | < | > | > > > > > > > > > > > > | > > > > > | > > > > > > > > > > > > > > > > > > > > | > > | < | < < < | | | | | < < | | > | | | > > > > > | > | > | < > | < < < < > > > > | > > > > | > > > | > > | > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > | < > > > | > > | > > | > > > | > > > > > > > > | < | > | < < < | > | > > | < > | | | | | | | | | | | > > > > > > > > > < > > > < < < > < > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | < | > | | | | | < < < < | | | | | | | | | | | | | < < | > > > > | < < > > > | < | > > > > > > > > > > > > > > > | | | > | > > | | | | < < | | > > > > > > > > | < > | | | | | > | > > | < > > > > > | > > > | > | | | > > > > > | > > > > | > > > > | > > > > < > > > > > > | > > | > > | > > | < | > > > > > > | > > > > > > > > > > | < < | < < < < < | | | | | | > | > > > > > > > > > > < | < < < | | 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 1310 1311 1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 1347 1348 1349 1350 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 1434 1435 1436 1437 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 1453 1454 1455 1456 1457 1458 1459 1460 1461 1462 1463 1464 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 1495 1496 1497 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 1514 1515 1516 1517 1518 1519 1520 1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 1539 1540 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 1561 1562 1563 1564 1565 1566 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 1631 1632 1633 1634 1635 1636 1637 1638 1639 1640 1641 1642 1643 1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 1658 1659 1660 1661 1662 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 1678 1679 1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 1693 1694 1695 1696 1697 1698 1699 1700 1701 1702 1703 1704 1705 1706 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 1735 1736 1737 1738 1739 1740 | !if $(STATIC_BUILD) OPTDEFINES = $(OPTDEFINES) -DSTATIC_BUILD !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)" == "AMD64" OPTDEFINES = $(OPTDEFINES) -DTCL_CFG_DO64BIT !endif !if $(VCVERSION) < 1300 OPTDEFINES = $(OPTDEFINES) -DNO_STRTOI64 !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 <winver.h> 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 *** Compiler version $(VCVER). Target $(MACHINE), host $(NATIVE_ARCH). !endif # ifdef _RULES_VC |
Added win/targets.vc.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 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 |
Changes to win/tcl.dsp.
︙ | ︙ | |||
146 147 148 149 150 151 152 | SOURCE=..\compat\dlfcn.h # End Source File # Begin Source File SOURCE=..\compat\fixstrtod.c # End Source File | < < < < | 146 147 148 149 150 151 152 153 154 155 156 157 158 159 | SOURCE=..\compat\dlfcn.h # End Source File # Begin Source File SOURCE=..\compat\fixstrtod.c # End Source File # Begin Source File SOURCE=..\compat\gettod.c # End Source File # Begin Source File SOURCE=..\compat\limits.h |
︙ | ︙ |
Changes to win/tcl.hpj.in.
1 2 3 4 5 6 7 | ; This file is maintained by HCW. Do not modify this file directly. [OPTIONS] HCW=0 LCID=0x409 0x0 0x0 ;English (United States) REPORT=Yes TITLE=Tcl/Tk Reference Manual | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 | ; This file is maintained by HCW. Do not modify this file directly. [OPTIONS] HCW=0 LCID=0x409 0x0 0x0 ;English (United States) REPORT=Yes TITLE=Tcl/Tk Reference Manual CNT=tcl87.cnt COPYRIGHT=Copyright � 2000 Ajuba Solutions HLP=tcl87.hlp [FILES] tcl.rtf [WINDOWS] main="Tcl/Tk Reference Manual",,0 |
︙ | ︙ |
Changes to win/tcl.m4.
︙ | ︙ | |||
540 541 542 543 544 545 546 | # Step 0: Enable 64 bit support? 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) | < < < < < < < < < < < | 540 541 542 543 544 545 546 547 548 549 550 551 552 553 | # Step 0: Enable 64 bit support? 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) # 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) SHLIB_SUFFIX=".dll" |
︙ | ︙ | |||
867 868 869 870 871 872 873 | CFLAGS_DEBUG="-nologo -Z7 -Od -WX ${runtime}d" # -O2 - create fast code (/Og /Oi /Ot /Oy /Ob2 /Gs /GF /Gy) CFLAGS_OPTIMIZE="-nologo -O2 ${runtime}" lflags="${lflags} -nologo" LINKBIN="link" fi | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < | 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 | CFLAGS_DEBUG="-nologo -Z7 -Od -WX ${runtime}d" # -O2 - create fast code (/Og /Oi /Ot /Oy /Ob2 /Gs /GF /Gy) CFLAGS_OPTIMIZE="-nologo -O2 ${runtime}" lflags="${lflags} -nologo" LINKBIN="link" 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}" RC_OUT=-fo RC_TYPE=-r |
︙ | ︙ | |||
989 990 991 992 993 994 995 | # Specify the CC output file names based on the target name CC_OBJNAME="-Fo\[$]@" CC_EXENAME="-Fe\"\$(shell \$(CYGPATH) '\[$]@')\"" # Specify linker flags depending on the type of app being # built -- Console vs. Window. | | | 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 | # Specify the CC output file names based on the target name CC_OBJNAME="-Fo\[$]@" CC_EXENAME="-Fe\"\$(shell \$(CYGPATH) '\[$]@')\"" # Specify linker flags depending on the type of app being # built -- Console vs. Window. 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}" fi fi |
︙ | ︙ | |||
1122 1123 1124 1125 1126 1127 1128 | # --with-tcl=... # # Defines the following vars: # TCL_BIN_DIR Full path to the tcl build dir. #------------------------------------------------------------------------ AC_DEFUN([SC_WITH_TCL], [ | | | | | | 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 1037 1038 1039 1040 | # --with-tcl=... # # Defines the following vars: # TCL_BIN_DIR Full path to the tcl build dir. #------------------------------------------------------------------------ AC_DEFUN([SC_WITH_TCL], [ if test -d ../../tcl8.7$1/win; then TCL_BIN_DEFAULT=../../tcl8.7$1/win else TCL_BIN_DEFAULT=../../tcl8.7/win fi 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 AC_MSG_ERROR(There is no Makefile in $TCL_BIN_DIR: perhaps you did not specify the Tcl *build* directory (not the toplevel Tcl directory) or you forgot to configure Tcl?) else |
︙ | ︙ |
Changes to win/tclWin32Dll.c.
︙ | ︙ | |||
19 20 21 22 23 24 25 | /* * The following variables keep track of information about this DLL on a * 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. */ | < < < | 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 | /* * The following variables keep track of information about this DLL on a * 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. */ /* * 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 /* * The following declaration is for the VC++ DLL entry point. */ BOOL APIENTRY DllMain(HINSTANCE hInst, DWORD reason, LPVOID reserved); |
︙ | ︙ | |||
182 183 184 185 186 187 188 | HINSTANCE hInst) /* Library instance handle. */ { OSVERSIONINFOW os; hInstance = hInst; os.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW); GetVersionExW(&os); | < | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 | HINSTANCE hInst) /* Library instance handle. */ { OSVERSIONINFOW os; hInstance = hInst; os.dwOSVersionInfoSize = sizeof(OSVERSIONINFOW); GetVersionExW(&os); /* * 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"); } } /* *------------------------------------------------------------------------- * * TclWinNoBackslash -- * |
︙ | ︙ | |||
260 261 262 263 264 265 266 | } return path; } /* *--------------------------------------------------------------------------- * | < < < < < < < < < < < < < < < < < < < < < < < | < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < | 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 265 266 267 268 269 270 | } return path; } /* *--------------------------------------------------------------------------- * * TclWinEncodingsCleanup -- * * 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: * None. * *--------------------------------------------------------------------------- */ void TclWinEncodingsCleanup(void) { MountPointMap *dlIter, *dlIter2; /* * Clean up the mount point map. */ Tcl_MutexLock(&mountPointMap); dlIter = driveLetterLookup; while (dlIter != NULL) { dlIter2 = dlIter->nextPtr; ckfree(dlIter->volumeName); ckfree(dlIter); dlIter = dlIter2; } Tcl_MutexUnlock(&mountPointMap); } /* *-------------------------------------------------------------------- * * TclWinDriveLetterForVolMountPoint * * Unfortunately, Windows provides no easy way at all to get hold of the |
︙ | ︙ | |||
509 510 511 512 513 514 515 | } /* *--------------------------------------------------------------------------- * * Tcl_WinUtfToTChar, Tcl_WinTCharToUtf -- * | | < | | | | | | | | | < | | | < < < | < | < | | | > > | > > > | > > > > | < | > > | > > > > > > > | > > > > | 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 438 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 502 503 504 505 506 507 508 509 510 511 512 513 514 515 516 | } /* *--------------------------------------------------------------------------- * * Tcl_WinUtfToTChar, Tcl_WinTCharToUtf -- * * 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 * "char" oriented encoding. The following two functions are used in * 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: * * 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. * * Side effects: * None. * *--------------------------------------------------------------------------- */ TCHAR * Tcl_WinUtfToTChar( const char *string, /* Source string in UTF-8. */ 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. */ { 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. */ 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. */ { 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; } /* *------------------------------------------------------------------------ * * TclWinCPUID -- * |
︙ | ︙ |
Changes to win/tclWinDde.c.
︙ | ︙ | |||
148 149 150 151 152 153 154 | Dde_Init( Tcl_Interp *interp) { if (!Tcl_InitStubs(interp, "8.1", 0)) { return TCL_ERROR; } | < < < < < < < | 148 149 150 151 152 153 154 155 156 157 158 159 160 161 | Dde_Init( Tcl_Interp *interp) { if (!Tcl_InitStubs(interp, "8.1", 0)) { return TCL_ERROR; } Tcl_CreateObjCommand(interp, "dde", DdeObjCmd, NULL, NULL); Tcl_CreateExitHandler(DdeExitProc, NULL); return Tcl_PkgProvide(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION); } /* *---------------------------------------------------------------------- |
︙ | ︙ |
Changes to win/tclWinError.c.
︙ | ︙ | |||
26 27 28 29 30 31 32 | ENOMEM, /* ERROR_ARENA_TRASHED 7 */ ENOMEM, /* ERROR_NOT_ENOUGH_MEMORY 8 */ 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 */ | | | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 | ENOMEM, /* ERROR_ARENA_TRASHED 7 */ ENOMEM, /* ERROR_NOT_ENOUGH_MEMORY 8 */ 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 */ 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 */ ENXIO, /* ERROR_BAD_UNIT 20 */ EBUSY, /* ERROR_NOT_READY 21 */ |
︙ | ︙ |
Changes to win/tclWinInit.c.
︙ | ︙ | |||
80 81 82 83 84 85 86 | /* * Windows version dependend functions */ TclWinProcs tclWinProcs; /* * The following arrays contain the human readable strings for the Windows | | < < < < < | 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 | /* * Windows version dependend functions */ TclWinProcs tclWinProcs; /* * The following arrays contain the human readable strings for the Windows * processor values. */ #define NUMPROCESSORS 11 static const char *const processors[NUMPROCESSORS] = { "intel", "mips", "alpha", "ppc", "shx", "arm", "ia64", "alpha64", "msil", "amd64", "ia32_on_win64" }; /* |
︙ | ︙ | |||
183 184 185 186 187 188 189 | * *------------------------------------------------------------------------- */ void TclpInitLibraryPath( char **valuePtr, | | | 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 | * *------------------------------------------------------------------------- */ void TclpInitLibraryPath( char **valuePtr, unsigned int *lengthPtr, Tcl_Encoding *encodingPtr) { #define LIBRARY_SIZE 64 Tcl_Obj *pathPtr; char installLib[LIBRARY_SIZE]; const char *bytes; |
︙ | ︙ | |||
346 347 348 349 350 351 352 | * *--------------------------------------------------------------------------- */ static void InitializeDefaultLibraryDir( char **valuePtr, | | | 341 342 343 344 345 346 347 348 349 350 351 352 353 354 355 | * *--------------------------------------------------------------------------- */ static void InitializeDefaultLibraryDir( char **valuePtr, unsigned int *lengthPtr, Tcl_Encoding *encodingPtr) { HMODULE hModule = TclWinGetTclInstance(); WCHAR wName[MAX_PATH + LIBRARY_SIZE]; char name[(MAX_PATH + LIBRARY_SIZE) * TCL_UTF_MAX]; char *end, *p; |
︙ | ︙ | |||
397 398 399 400 401 402 403 | * *--------------------------------------------------------------------------- */ static void InitializeSourceLibraryDir( char **valuePtr, | | | 392 393 394 395 396 397 398 399 400 401 402 403 404 405 406 | * *--------------------------------------------------------------------------- */ static void InitializeSourceLibraryDir( char **valuePtr, unsigned int *lengthPtr, Tcl_Encoding *encodingPtr) { HMODULE hModule = TclWinGetTclInstance(); WCHAR wName[MAX_PATH + LIBRARY_SIZE]; char name[(MAX_PATH + LIBRARY_SIZE) * TCL_UTF_MAX]; char *end, *p; |
︙ | ︙ | |||
488 489 490 491 492 493 494 | */ void TclpSetInitialEncodings(void) { Tcl_DString encodingName; | < < < < < < < | 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 498 499 500 501 | */ void TclpSetInitialEncodings(void) { Tcl_DString encodingName; Tcl_SetSystemEncoding(NULL, Tcl_GetEncodingNameFromEnvironment(&encodingName)); Tcl_DStringFree(&encodingName); } const char * Tcl_GetEncodingNameFromEnvironment( Tcl_DString *bufPtr) { Tcl_DStringInit(bufPtr); Tcl_DStringSetLength(bufPtr, 2+TCL_INTEGER_SPACE); wsprintfA(Tcl_DStringValue(bufPtr), "cp%d", GetACP()); |
︙ | ︙ | |||
565 566 567 568 569 570 571 | /* * Define the tcl_platform array. */ Tcl_SetVar2(interp, "tcl_platform", "platform", "windows", TCL_GLOBAL_ONLY); | < | < < | 553 554 555 556 557 558 559 560 561 562 563 564 565 566 567 | /* * Define the tcl_platform array. */ Tcl_SetVar2(interp, "tcl_platform", "platform", "windows", 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], TCL_GLOBAL_ONLY); } |
︙ | ︙ |
Changes to win/tclWinInt.h.
︙ | ︙ | |||
36 37 38 39 40 41 42 | */ typedef struct TclWinProcs { BOOL (WINAPI *cancelSynchronousIo)(HANDLE); } TclWinProcs; MODULE_SCOPE TclWinProcs tclWinProcs; | < < < < < < < < < < < < < | 36 37 38 39 40 41 42 43 44 45 46 47 48 49 | */ typedef struct TclWinProcs { BOOL (WINAPI *cancelSynchronousIo)(HANDLE); } TclWinProcs; MODULE_SCOPE TclWinProcs tclWinProcs; #ifdef _WIN64 # define TCL_I_MODIFIER "I" #else # define TCL_I_MODIFIER "" #endif /* |
︙ | ︙ |
Changes to win/tclWinPipe.c.
︙ | ︙ | |||
1091 1092 1093 1094 1095 1096 1097 | * provided by this application, and run in the background. * * 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. */ | < | | | | | | | | | | | | | | | < < < < < < < < < < < < < < < < | 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 | * provided by this application, and run in the background. * * 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 (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 * in argv[] are stored in cmdLine separated by spaces. Special characters * in individual arguments from argv[] must be quoted when being stored in |
︙ | ︙ |
Changes to win/tclWinSerial.c.
︙ | ︙ | |||
1734 1735 1736 1737 1738 1739 1740 | * control characters to something large and custom, they'll know the * hex/octal value rather than the printable form. */ dcb.XonChar = argv[0][0]; dcb.XoffChar = argv[1][0]; if (argv[0][0] & 0x80 || argv[1][0] & 0x80) { | | | 1734 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 | * control characters to something large and custom, they'll know the * hex/octal value rather than the printable form. */ dcb.XonChar = argv[0][0]; dcb.XoffChar = argv[1][0]; if (argv[0][0] & 0x80 || argv[1][0] & 0x80) { Tcl_UniChar character = 0; int charLen; charLen = Tcl_UtfToUniChar(argv[0], &character); if (argv[0][charLen]) { goto badXchar; } dcb.XonChar = (char) character; |
︙ | ︙ |
Changes to win/tclWinSock.c.
︙ | ︙ | |||
356 357 358 359 360 361 362 | * *---------------------------------------------------------------------- */ void InitializeHostName( char **valuePtr, | | | 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 | * *---------------------------------------------------------------------- */ void InitializeHostName( char **valuePtr, unsigned int *lengthPtr, Tcl_Encoding *encodingPtr) { TCHAR tbuf[MAX_COMPUTERNAME_LENGTH + 1]; DWORD length = MAX_COMPUTERNAME_LENGTH + 1; Tcl_DString ds; if (GetComputerName(tbuf, &length) != 0) { |
︙ | ︙ |
Changes to win/tclWinThrd.c.
︙ | ︙ | |||
9 10 11 12 13 14 15 | * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclWinInt.h" | < < | 9 10 11 12 13 14 15 16 17 18 19 20 21 22 | * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclWinInt.h" /* 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 */ _CRTIMP unsigned int __cdecl _controlfp (unsigned int unNew, unsigned int unMask); #endif |
︙ | ︙ |