Many hyperlinks are disabled.
Use anonymous login
to enable hyperlinks.
Overview
Comment: | merge novem |
---|---|
Downloads: | Tarball | ZIP archive |
Timelines: | family | ancestors | descendants | both | novem-purge-literals |
Files: | files | file ages | folders |
SHA3-256: |
700b9a198fe8b92e062db4b62c2349a3 |
User & Date: | dgp 2018-03-15 15:43:14.254 |
Context
2019-06-12
| ||
19:34 | merge novem check-in: a72a317ba0 user: dgp tags: novem-purge-literals | |
2018-03-15
| ||
15:43 | merge novem check-in: 700b9a198f user: dgp tags: novem-purge-literals | |
14:55 | merge trunk check-in: 4a5c8f2780 user: dgp tags: novem | |
2017-11-01
| ||
16:16 | merge novem check-in: ceec7bcd98 user: dgp tags: novem-purge-literals | |
Changes
Changes to .fossil-settings/crlf-glob.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | compat/zlib/contrib/dotzlib/DotZLib/UnitTests.cs compat/zlib/contrib/vstudio/readme.txt compat/zlib/contrib/vstudio/*/zlib.rc compat/zlib/win32/*.txt compat/zlib/win64/*.txt libtommath/*.dsp libtommath/*.sln libtommath/*.vcproj tools/tcl.hpj.in tools/tcl.wse.in win/buildall.vc.bat win/makefile.vc win/rules.vc win/tcl.dsp win/tcl.dsw win/tcl.hpj.in | > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | compat/zlib/contrib/dotzlib/DotZLib/UnitTests.cs compat/zlib/contrib/vstudio/readme.txt compat/zlib/contrib/vstudio/*/zlib.rc compat/zlib/win32/*.txt compat/zlib/win64/*.txt libtommath/*.dsp libtommath/*.sln 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.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 | compat/zlib/contrib/dotzlib/DotZLib/UnitTests.cs compat/zlib/contrib/vstudio/readme.txt compat/zlib/contrib/vstudio/*/zlib.rc compat/zlib/win32/*.txt compat/zlib/win64/*.txt libtommath/*.dsp libtommath/*.sln libtommath/*.vcproj tools/tcl.hpj.in tools/tcl.wse.in win/buildall.vc.bat win/makefile.vc win/rules.vc win/tcl.dsp win/tcl.dsw win/tcl.hpj.in | > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | compat/zlib/contrib/dotzlib/DotZLib/UnitTests.cs compat/zlib/contrib/vstudio/readme.txt compat/zlib/contrib/vstudio/*/zlib.rc compat/zlib/win32/*.txt compat/zlib/win64/*.txt libtommath/*.dsp libtommath/*.sln 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/encoding-glob.
1 2 3 4 5 6 7 8 | tools/tcl.hpj.in tools/tcl.wse.in win/buildall.vc.bat win/makefile.vc win/rules.vc win/tcl.dsp win/tcl.dsw win/tcl.hpj.in | > | 1 2 3 4 5 6 7 8 9 | 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 |
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>tcl9</name> <comment></comment> <projects> </projects> <buildSpec> </buildSpec> <natures> </natures> |
︙ | ︙ |
Changes to ChangeLog.
︙ | ︙ | |||
472 473 474 475 476 477 478 479 480 481 482 483 484 485 | * library/http/http.tcl (http::geturl): [Bug 2911139]: Do not do vwait for connect to avoid reentrancy problems (except when operating without a -command option). Internally, this means that all sockets created by the http package will always be operated in asynchronous mode. 2013-01-18 Jan Nijtmans <[email protected]> * generic/tclPort.h: [Bug 3598300]: unix: tcl.h does not include sys/stat.h 2013-01-17 Donal K. Fellows <[email protected]> | > > > > > > > | 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 | * library/http/http.tcl (http::geturl): [Bug 2911139]: Do not do vwait for connect to avoid reentrancy problems (except when operating without a -command option). Internally, this means that all sockets created by the http package will always be operated in asynchronous mode. 2013-01-21 Jan Nijtmans <[email protected]> * generic/tclInt.decls: Put back Tcl[GS]etStartupScript(Path|FileName) in private stub table, so extensions using this (like Tk 8.4) will continue to work in all Tcl 8.x versions. Extensions using this still cannot be compiled against Tcl 8.6 headers. 2013-01-18 Jan Nijtmans <[email protected]> * generic/tclPort.h: [Bug 3598300]: unix: tcl.h does not include sys/stat.h 2013-01-17 Donal K. Fellows <[email protected]> |
︙ | ︙ | |||
513 514 515 516 517 518 519 520 521 522 523 524 525 526 | stub table, so extensions using this, compiled against 8.5 headers still run in Tcl 8.6. 2013-01-13 Alexandre Ferrieux <[email protected]> * doc/fileevent.n: [Bug 3436609]: Clarify readable fileevent "false positives" in the case of multibyte encodings/transforms. 2013-01-09 Jan Nijtmans <[email protected]> * library/http/http.tcl: [Bug 3599395]: http assumes status line is a proper Tcl list. 2013-01-08 Jan Nijtmans <[email protected]> | > > > > > > > > > > > > | 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 | stub table, so extensions using this, compiled against 8.5 headers still run in Tcl 8.6. 2013-01-13 Alexandre Ferrieux <[email protected]> * doc/fileevent.n: [Bug 3436609]: Clarify readable fileevent "false positives" in the case of multibyte encodings/transforms. 2013-01-13 Jan Nijtmans <[email protected]> * generic/tclIntDecls.h: If TCL_NO_DEPRECATED is defined, make sure that TIP #139 functions all are taken from the public stub table, even if the inclusion is through tclInt.h. 2013-01-12 Jan Nijtmans <[email protected]> * generic/tclInt.decls: Put back TclBackgroundException in internal stub table, so extensions using this, compiled against 8.5 headers still run in Tcl 8.6. 2013-01-09 Jan Nijtmans <[email protected]> * library/http/http.tcl: [Bug 3599395]: http assumes status line is a proper Tcl list. 2013-01-08 Jan Nijtmans <[email protected]> |
︙ | ︙ | |||
536 537 538 539 540 541 542 | Tcl_AppendResult, not any other function. This puts least restrictions on eventual Tcl 9 stubs re-organization, and it works on the widest range of Tcl versions. 2013-01-06 Jan Nijtmans <[email protected]> * library/http/http.tcl: Don't depend on Spencer-specific regexp | | < | 555 556 557 558 559 560 561 562 563 564 565 566 567 568 569 570 | Tcl_AppendResult, not any other function. This puts least restrictions on eventual Tcl 9 stubs re-organization, and it works on the widest range of Tcl versions. 2013-01-06 Jan Nijtmans <[email protected]> * library/http/http.tcl: Don't depend on Spencer-specific regexp * tests/env.test: syntax (/u and /U) any more in unrelated places. * tests/exec.test: Bump http package to 2.8.6. 2013-01-04 Donal K. Fellows <[email protected]> * generic/tclEnsemble.c (CompileBasicNArgCommand): Added very simple compiler (which just compiles to a normal invoke of the implementation command) for many ensemble subcommands where we can prove that there |
︙ | ︙ | |||
663 664 665 666 667 668 669 | * generic/tclIO.c: Fix busyloop at exit under TCL_FINALIZE_ON_EXIT when there are unflushed nonblocking channels. Thanks Miguel for spotting. 2012-12-07 Jan Nijtmans <[email protected]> | | | | 681 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 | * generic/tclIO.c: Fix busyloop at exit under TCL_FINALIZE_ON_EXIT when there are unflushed nonblocking channels. Thanks Miguel for spotting. 2012-12-07 Jan Nijtmans <[email protected]> * unix/dltest/pkgb.c: Turn pkgb.so into a Tcl9 interoperability test library: Whatever Tcl9 looks like, loading pkgb.so in Tcl 9 should either result in an error-message, either succeed, but never crash. 2012-11-28 Donal K. Fellows <[email protected]> * generic/tclZlib.c (ZlibStreamSubcmd): [Bug 3590483]: Use a mechanism for complex option resolution that has fewer problems with more finicky compilers. |
︙ | ︙ | |||
8821 8822 8823 8824 8825 8826 8827 | * unix/tcl.m4 (SC_CONFIG_CFLAGS): [Bug 878333]: Force the use of the compatibility version of mkstemp() on IRIX. * unix/configure.in, unix/Makefile.in (mkstemp.o): * compat/mkstemp.c (new file): [Bug 741967]: Added a compatibility implementation of the mkstemp() function, which is apparently needed on some platforms. | | | | | | | | | | | | < | 8839 8840 8841 8842 8843 8844 8845 8846 8847 8848 8849 8850 8851 8852 8853 8854 8855 8856 | * unix/tcl.m4 (SC_CONFIG_CFLAGS): [Bug 878333]: Force the use of the compatibility version of mkstemp() on IRIX. * unix/configure.in, unix/Makefile.in (mkstemp.o): * compat/mkstemp.c (new file): [Bug 741967]: Added a compatibility implementation of the mkstemp() function, which is apparently needed on some platforms. ****************************************************************** *** CHANGELOG ENTRIES FOR 2008 IN "ChangeLog.2008" *** *** CHANGELOG ENTRIES FOR 2006-2007 IN "ChangeLog.2007" *** *** CHANGELOG ENTRIES FOR 2005 IN "ChangeLog.2005" *** *** CHANGELOG ENTRIES FOR 2004 IN "ChangeLog.2004" *** *** CHANGELOG ENTRIES FOR 2003 IN "ChangeLog.2003" *** *** CHANGELOG ENTRIES FOR 2002 IN "ChangeLog.2002" *** *** CHANGELOG ENTRIES FOR 2001 IN "ChangeLog.2001" *** *** CHANGELOG ENTRIES FOR 2000 IN "ChangeLog.2000" *** *** CHANGELOG ENTRIES FOR 1999 AND EARLIER IN "ChangeLog.1999" *** ****************************************************************** |
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 8882 8883 8884 8885 8886 | 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 2018-03-12 (TIP 490) add oo support for msgcat => msgcat 1.7.0 (oehlmann) 2018-03-12 (TIP 499) custom locale preference list (oehlmann) => msgcat 1.7.0 |
Changes to doc/AddErrInfo.3.
1 2 3 4 5 6 7 8 9 10 11 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_AddErrorInfo 3 8.5 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME | | > > < < > > > > > | 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 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_AddErrorInfo 3 8.5 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_GetReturnOptions, Tcl_SetReturnOptions, Tcl_AddErrorInfo, Tcl_AppendObjToErrorInfo, Tcl_AddObjErrorInfo, Tcl_SetObjErrorCode, Tcl_SetErrorCode, Tcl_SetErrorLine, Tcl_GetErrorLine, Tcl_PosixError, Tcl_LogCommandInfo \- retrieve or record information about errors and other return options .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_Obj * \fBTcl_GetReturnOptions\fR(\fIinterp, code\fR) .sp int \fBTcl_SetReturnOptions\fR(\fIinterp, options\fR) .sp \fBTcl_AddErrorInfo\fR(\fIinterp, message\fR) .sp \fBTcl_AppendObjToErrorInfo\fR(\fIinterp, objPtr\fR) .sp \fBTcl_AddObjErrorInfo\fR(\fIinterp, message, length\fR) .sp \fBTcl_SetObjErrorCode\fR(\fIinterp, errorObjPtr\fR) .sp \fBTcl_SetErrorCode\fR(\fIinterp, element, element, ... \fB(char *) NULL\fR) .sp \fBTcl_GetErrorLine\fR(\fIinterp\fR) .sp \fBTcl_SetErrorLine\fR(\fIinterp, lineNum\fR) .sp const char * \fBTcl_PosixError\fR(\fIinterp\fR) .sp void \fBTcl_LogCommandInfo\fR(\fIinterp, script, command, commandLength\fR) .SH ARGUMENTS .AS Tcl_Interp commandLength .AP Tcl_Interp *interp in Interpreter in which to record information. .AP int code The code returned from script evaluation. .AP Tcl_Obj *options A dictionary of return options. .AP char *message in For \fBTcl_AddErrorInfo\fR, this is a conventional C string to append to the \fB\-errorinfo\fR return option. For \fBTcl_AddObjErrorInfo\fR, this points to the first byte of an array of \fIlength\fR bytes containing a string to append to the \fB\-errorinfo\fR return option. This byte array may contain embedded null bytes unless \fIlength\fR is negative. .AP Tcl_Obj *objPtr in A message to be appended to the \fB\-errorinfo\fR return option in the form of a Tcl_Obj value. .AP int length in The number of bytes to copy from \fImessage\fR when appending to the \fB\-errorinfo\fR return option. If negative, all bytes up to the first null byte are used. |
︙ | ︙ | |||
211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 | a useful part of the \fImessage\fR passed to \fBTcl_AddErrorInfo\fR. .PP \fBTcl_AppendObjToErrorInfo\fR is an alternative interface to the same functionality as \fBTcl_AddErrorInfo\fR. \fBTcl_AppendObjToErrorInfo\fR is called when the string value to be appended to the \fB\-errorinfo\fR option is available as a \fBTcl_Obj\fR instead of as a \fBchar\fR array. .PP The procedure \fBTcl_SetObjErrorCode\fR is used to set the \fB\-errorcode\fR return option to the list value \fIerrorObjPtr\fR built up by the caller. \fBTcl_SetObjErrorCode\fR is typically invoked just before returning an error. If an error is returned without calling \fBTcl_SetObjErrorCode\fR or \fBTcl_SetErrorCode\fR the Tcl interpreter automatically sets the \fB\-errorcode\fR return option to \fBNONE\fR. .PP The procedure \fBTcl_SetErrorCode\fR is also used to set the \fB\-errorcode\fR return option. However, it takes one or more strings to record instead of a value. Otherwise, it is similar to \fBTcl_SetObjErrorCode\fR in behavior. .PP | > > > > > > > > > < < < | 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 | a useful part of the \fImessage\fR passed to \fBTcl_AddErrorInfo\fR. .PP \fBTcl_AppendObjToErrorInfo\fR is an alternative interface to the same functionality as \fBTcl_AddErrorInfo\fR. \fBTcl_AppendObjToErrorInfo\fR is called when the string value to be appended to the \fB\-errorinfo\fR option is available as a \fBTcl_Obj\fR instead of as a \fBchar\fR array. .PP \fBTcl_AddObjErrorInfo\fR is nearly identical to \fBTcl_AddErrorInfo\fR, except that it has an additional \fIlength\fR argument. This allows the \fImessage\fR string to contain embedded null bytes. This is essentially never a good idea. If the \fImessage\fR needs to contain the null character \fBU+0000\fR, Tcl's usual internal encoding rules should be used to avoid the need for a null byte. If the \fBTcl_AddObjErrorInfo\fR interface is used at all, it should be with a negative \fIlength\fR value. .PP The procedure \fBTcl_SetObjErrorCode\fR is used to set the \fB\-errorcode\fR return option to the list value \fIerrorObjPtr\fR built up by the caller. \fBTcl_SetObjErrorCode\fR is typically invoked just before returning an error. If an error is returned without calling \fBTcl_SetObjErrorCode\fR or \fBTcl_SetErrorCode\fR the Tcl interpreter automatically sets the \fB\-errorcode\fR return option to \fBNONE\fR. .PP The procedure \fBTcl_SetErrorCode\fR is also used to set the \fB\-errorcode\fR return option. However, it takes one or more strings to record instead of a value. Otherwise, it is similar to \fBTcl_SetObjErrorCode\fR in behavior. .PP The procedure \fBTcl_GetErrorLine\fR is used to read the integer value of the \fB\-errorline\fR return option without the overhead of a full call to \fBTcl_GetReturnOptions\fR. Likewise, \fBTcl_SetErrorLine\fR sets the \fB\-errorline\fR return option value. .PP \fBTcl_PosixError\fR sets the \fB\-errorcode\fR variable after an error in a POSIX kernel call. |
︙ | ︙ |
Changes to doc/AllowExc.3.
︙ | ︙ | |||
25 26 27 28 29 30 31 | .PP If a script is evaluated at top-level (i.e. no other scripts are pending evaluation when the script is invoked), and if the script terminates with a completion code other than \fBTCL_OK\fR, \fBTCL_ERROR\fR or \fBTCL_RETURN\fR, then Tcl normally converts this into a \fBTCL_ERROR\fR return with an appropriate message. The particular script evaluation procedures of Tcl that act in the manner are | | > | 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 | .PP If a script is evaluated at top-level (i.e. no other scripts are pending evaluation when the script is invoked), and if the script terminates with a completion code other than \fBTCL_OK\fR, \fBTCL_ERROR\fR or \fBTCL_RETURN\fR, then Tcl normally converts this into a \fBTCL_ERROR\fR return with an appropriate message. The particular script evaluation procedures of Tcl that act in the manner are \fBTcl_EvalObjEx\fR, \fBTcl_EvalObjv\fR, \fBTcl_Eval\fR, \fBTcl_EvalEx\fR, \fBTcl_GlobalEval\fR, \fBTcl_GlobalEvalObj\fR and \fBTcl_VarEval\fR. .PP However, if \fBTcl_AllowExceptions\fR is invoked immediately before calling one of those a procedures, then arbitrary completion codes are permitted from the script, and they are returned without modification. This is useful in cases where the caller can deal with exceptions such as \fBTCL_BREAK\fR or \fBTCL_CONTINUE\fR in a meaningful way. |
︙ | ︙ |
Changes to doc/CrtInterp.3.
︙ | ︙ | |||
104 105 106 107 108 109 110 | extension consisting of new Tcl commands, no special code is needed to protect interpreters received as arguments. This covers the majority of all uses. .TP \fBInterpreter Creation And Deletion\fR . When a new interpreter is created and used in a call to \fBTcl_Eval\fR, | > | | | | | | | < | | > | | | | | | | | | | 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 | extension consisting of new Tcl commands, no special code is needed to protect interpreters received as arguments. This covers the majority of all uses. .TP \fBInterpreter Creation And Deletion\fR . When a new interpreter is created and used in a call to \fBTcl_Eval\fR, \fBTcl_VarEval\fR, \fBTcl_GlobalEval\fR, \fBTcl_SetVar\fR, or \fBTcl_GetVar\fR, a pair of calls to \fBTcl_Preserve\fR and \fBTcl_Release\fR should be wrapped around all uses of the interpreter. Remember that it is unsafe to use the interpreter once \fBTcl_Release\fR has been called. To ensure that the interpreter is properly deleted when it is no longer needed, call \fBTcl_InterpDeleted\fR to test if some other code already called \fBTcl_DeleteInterp\fR; if not, call \fBTcl_DeleteInterp\fR before calling \fBTcl_Release\fR in your own code. .TP \fBRetrieving An Interpreter From A Data Structure\fR . When an interpreter is retrieved from a data structure (e.g. the client data of a callback) for use in one of the evaluation functions (\fBTcl_Eval\fR, \fBTcl_VarEval\fR, \fBTcl_GlobalEval\fR, \fBTcl_EvalObjv\fR, etc.) or variable access functions (\fBTcl_SetVar\fR, \fBTcl_GetVar\fR, \fBTcl_SetVar2Ex\fR, etc.), a pair of calls to \fBTcl_Preserve\fR and \fBTcl_Release\fR should be wrapped around all uses of the interpreter; it is unsafe to reuse the interpreter once \fBTcl_Release\fR has been called. If an interpreter is stored inside a callback data structure, an appropriate deletion cleanup mechanism should be set up by the code that creates the data structure so that the interpreter is removed from the data structure (e.g. by setting the field to NULL) when the interpreter is deleted. Otherwise, you may be using an interpreter that has been freed and whose memory may already have been reused. .PP All uses of interpreters in Tcl and Tk have already been protected. Extension writers should ensure that their code also properly protects any additional interpreters used, as described above. .PP .VS 8.6 Note that the protection mechanisms do not work well with conventional garbage |
︙ | ︙ |
Changes to doc/Encoding.3.
︙ | ︙ | |||
250 251 252 253 254 255 256 | \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. | < < < < | 250 251 252 253 254 255 256 257 258 259 260 261 262 263 | \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/Eval.3.
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" Copyright (c) 2000 Scriptics Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_Eval 3 8.1 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME | | > > > > > > > > > > > > | 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 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" Copyright (c) 2000 Scriptics Corporation. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_Eval 3 8.1 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_EvalObjEx, Tcl_EvalFile, Tcl_EvalObjv, Tcl_Eval, Tcl_EvalEx, Tcl_GlobalEval, Tcl_GlobalEvalObj, Tcl_VarEval \- execute Tcl scripts .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp int \fBTcl_EvalObjEx\fR(\fIinterp, objPtr, flags\fR) .sp int \fBTcl_EvalFile\fR(\fIinterp, fileName\fR) .sp int \fBTcl_EvalObjv\fR(\fIinterp, objc, objv, flags\fR) .sp int \fBTcl_Eval\fR(\fIinterp, script\fR) .sp int \fBTcl_EvalEx\fR(\fIinterp, script, numBytes, flags\fR) .sp int \fBTcl_GlobalEval\fR(\fIinterp, script\fR) .sp int \fBTcl_GlobalEvalObj\fR(\fIinterp, objPtr\fR) .sp int \fBTcl_VarEval\fR(\fIinterp, part, part, ... \fB(char *) NULL\fR) .SH ARGUMENTS .AS Tcl_Interp **termPtr .AP Tcl_Interp *interp in Interpreter in which to execute the script. The interpreter's result is modified to hold the result or error message from the script. .AP Tcl_Obj *objPtr in A Tcl value containing the script to execute. |
︙ | ︙ | |||
48 49 50 51 52 53 54 | The number of bytes in \fIscript\fR, not including any null terminating character. If \-1, then all characters up to the first null byte are used. .AP "const char" *script in Points to first byte of script to execute (null-terminated and UTF-8). .AP char *part in String forming part of a Tcl script. | < < < | 60 61 62 63 64 65 66 67 68 69 70 71 72 73 | The number of bytes in \fIscript\fR, not including any null terminating character. If \-1, then all characters up to the first null byte are used. .AP "const char" *script in Points to first byte of script to execute (null-terminated and UTF-8). .AP char *part in String forming part of a Tcl script. .BE .SH DESCRIPTION .PP The procedures described here are invoked to execute Tcl scripts in various forms. \fBTcl_EvalObjEx\fR is the core procedure and is used by many of the others. |
︙ | ︙ | |||
73 74 75 76 77 78 79 80 81 82 83 84 85 86 | The return value from \fBTcl_EvalObjEx\fR (and all the other procedures described here) is a Tcl completion code with one of the values \fBTCL_OK\fR, \fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR, or possibly some other integer value originating in an extension. In addition, a result value or error message is left in \fIinterp\fR's result; it can be retrieved using \fBTcl_GetObjResult\fR. .PP \fBTcl_EvalObjv\fR executes a single pre-parsed command instead of a script. The \fIobjc\fR and \fIobjv\fR arguments contain the values of the words for the Tcl command, one word in each value in \fIobjv\fR. \fBTcl_EvalObjv\fR evaluates the command and returns a completion code and result just like \fBTcl_EvalObjEx\fR. The caller of \fBTcl_EvalObjv\fR has to manage the reference count of the | > > > > > > > > > > > > > > > > | 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 | The return value from \fBTcl_EvalObjEx\fR (and all the other procedures described here) is a Tcl completion code with one of the values \fBTCL_OK\fR, \fBTCL_ERROR\fR, \fBTCL_RETURN\fR, \fBTCL_BREAK\fR, or \fBTCL_CONTINUE\fR, or possibly some other integer value originating in an extension. In addition, a result value or error message is left in \fIinterp\fR's result; it can be retrieved using \fBTcl_GetObjResult\fR. .PP \fBTcl_EvalFile\fR reads the file given by \fIfileName\fR and evaluates its contents as a Tcl script. It returns the same information as \fBTcl_EvalObjEx\fR. If the file could not be read then a Tcl error is returned to describe why the file could not be read. The eofchar for files is .QW \e32 (^Z) for all platforms. If you require a .QW ^Z in code for string comparison, you can use .QW \e032 or .QW \eu001a , which will be safely substituted by the Tcl interpreter into .QW ^Z . .PP \fBTcl_EvalObjv\fR executes a single pre-parsed command instead of a script. The \fIobjc\fR and \fIobjv\fR arguments contain the values of the words for the Tcl command, one word in each value in \fIobjv\fR. \fBTcl_EvalObjv\fR evaluates the command and returns a completion code and result just like \fBTcl_EvalObjEx\fR. The caller of \fBTcl_EvalObjv\fR has to manage the reference count of the |
︙ | ︙ | |||
96 97 98 99 100 101 102 | (using \fBTcl_EvalObjv\fR) instead of compiling it and executing the bytecodes. In situations where it is known that the script will never be executed again, \fBTcl_Eval\fR may be faster than \fBTcl_EvalObjEx\fR. \fBTcl_Eval\fR returns a completion code and result just like \fBTcl_EvalObjEx\fR. .PP \fBTcl_EvalEx\fR is an extended version of \fBTcl_Eval\fR that takes | | > > > > > > > > > > > > | > > | < | | > | 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 | (using \fBTcl_EvalObjv\fR) instead of compiling it and executing the bytecodes. In situations where it is known that the script will never be executed again, \fBTcl_Eval\fR may be faster than \fBTcl_EvalObjEx\fR. \fBTcl_Eval\fR returns a completion code and result just like \fBTcl_EvalObjEx\fR. .PP \fBTcl_EvalEx\fR is an extended version of \fBTcl_Eval\fR that takes additional arguments \fInumBytes\fR and \fIflags\fR. .PP \fBTcl_GlobalEval\fR and \fBTcl_GlobalEvalObj\fR are older procedures that are now deprecated. They are similar to \fBTcl_EvalEx\fR and \fBTcl_EvalObjEx\fR except that the script is evaluated in the global namespace and its variable context consists of global variables only (it ignores any Tcl procedures that are active). These functions are equivalent to using the \fBTCL_EVAL_GLOBAL\fR flag (see below). .PP \fBTcl_VarEval\fR takes any number of string arguments of any length, concatenates them into a single string, then calls \fBTcl_Eval\fR to execute that string as a Tcl command. It returns the result of the command and also modifies \fIinterp->result\fR in the same way as \fBTcl_Eval\fR. The last argument to \fBTcl_VarEval\fR must be NULL to indicate the end of arguments. \fBTcl_VarEval\fR is now deprecated. .SH "FLAG BITS" .PP Any ORed combination of the following values may be used for the \fIflags\fR argument to procedures such as \fBTcl_EvalObjEx\fR: .TP 23 \fBTCL_EVAL_DIRECT\fR . This flag is only used by \fBTcl_EvalObjEx\fR; it is ignored by other procedures. If this flag bit is set, the script is not compiled to bytecodes; instead it is executed directly as is done by \fBTcl_EvalEx\fR. The \fBTCL_EVAL_DIRECT\fR flag is useful in situations where the contents of a value are going to change immediately, so the bytecodes will not be reused in a future execution. In this case, it is faster to execute the script directly. .TP 23 \fBTCL_EVAL_GLOBAL\fR . If this flag is set, the script is evaluated in the global namespace instead of the current namespace and its variable context consists of global variables only (it ignores any Tcl procedures that are active). .\" TODO: document TCL_EVAL_INVOKE and TCL_EVAL_NOERR. .SH "MISCELLANEOUS DETAILS" .PP During the processing of a Tcl command it is legal to make nested calls to evaluate other commands (this is how procedures and some control structures are implemented). If a code other than \fBTCL_OK\fR is returned |
︙ | ︙ |
Changes to doc/IntObj.3.
︙ | ︙ | |||
93 94 95 96 97 98 99 | with which values might be exchanged. The C integral types for which Tcl provides value exchange routines are \fBint\fR, \fBlong int\fR, \fBTcl_WideInt\fR, and \fBmp_int\fR. The \fBint\fR and \fBlong int\fR types are provided by the C language standard. The \fBTcl_WideInt\fR type is a typedef defined to be whatever signed integral type covers at least the 64-bit integer range (-9223372036854775808 to 9223372036854775807). Depending on the platform and the C compiler, the actual type might be | | | 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 | with which values might be exchanged. The C integral types for which Tcl provides value exchange routines are \fBint\fR, \fBlong int\fR, \fBTcl_WideInt\fR, and \fBmp_int\fR. The \fBint\fR and \fBlong int\fR types are provided by the C language standard. The \fBTcl_WideInt\fR type is a typedef defined to be whatever signed integral type covers at least the 64-bit integer range (-9223372036854775808 to 9223372036854775807). Depending on the platform and the C compiler, the actual type might be \fBlong long int\fR, \fB__int64\fR, or something else. The \fBmp_int\fR type is a multiple-precision integer type defined by the LibTomMath multiple-precision integer library. .PP The \fBTcl_NewIntObj\fR, \fBTcl_NewLongObj\fR, \fBTcl_NewWideIntObj\fR, and \fBTcl_NewBignumObj\fR routines each create and return a new Tcl value initialized to the integral value of the argument. The returned Tcl value is unshared. |
︙ | ︙ |
Changes to doc/Interp.3.
︙ | ︙ | |||
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 | | | 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 | 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/NRE.3.
1 2 3 4 5 6 7 8 9 | .\" .\" Copyright (c) 2008 by Kevin B. Kenny. .\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH NRE 3 8.6 Tcl "Tcl Library Procedures" .so man.macros .BS | > | 1 2 3 4 5 6 7 8 9 10 | .\" .\" Copyright (c) 2008 by Kevin B. Kenny. .\" Copyright (c) 2018 by Nathan Coulter. .\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH NRE 3 8.6 Tcl "Tcl Library Procedures" .so man.macros .BS |
︙ | ︙ | |||
34 35 36 37 38 39 40 | .sp void \fBTcl_NRAddCallback\fR(\fIinterp, postProcPtr, data0, data1, data2, data3\fR) .fi .SH ARGUMENTS .AS Tcl_CmdDeleteProc *interp in .AP Tcl_Interp *interp in | | | | > | > < < > | | | | < | < | | > | < < < | | | | | < | > | > > > | > | < > | < < < < < < < | < < < < < | < < < > | | < < | < < < < < < < < < < < < < < < < | | | > > | < < < < < < < < < | > | < < | < < > | < < | < < | | < < < | | < | | | < < < | < < < | < < < | < < < | < < < | < > | 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 | .sp void \fBTcl_NRAddCallback\fR(\fIinterp, postProcPtr, data0, data1, data2, data3\fR) .fi .SH ARGUMENTS .AS Tcl_CmdDeleteProc *interp in .AP Tcl_Interp *interp in The relevant Interpreter. .AP char *cmdName in Name of the command to create. .AP Tcl_ObjCmdProc *proc in Called in order to evaluate a command. Is often just a small wrapper that uses \fBTcl_NRCallObjProc\fR to call \fInreProc\fR using a new trampoline. Behaves in the same way as the \fIproc\fR argument to \fBTcl_CreateObjCommand\fR(3) (\fIq.v.\fR). .AP Tcl_ObjCmdProc *nreProc in Called instead of \fIproc\fR when a trampoline is already in use. .AP ClientData clientData in Arbitrary one-word value passed to \fIproc\fR, \fInreProc\fR, \fIdeleteProc\fR and \fIobjProc\fR. .AP Tcl_CmdDeleteProc *deleteProc in/out Called before \fIcmdName\fR is deleted from the interpreter, allowing for command-specific cleanup. May be NULL. .AP int objc in Number of items in \fIobjv\fR. .AP Tcl_Obj **objv in Words in the command. .AP Tcl_Obj *objPtr in A script or expression to evaluate. .AP int flags in As described for \fITcl_EvalObjv\fR. .PP .AP Tcl_Command cmd in Token to use instead of one derived from the first word of \fIobjv\fR in order to evaluate a command. .AP Tcl_Obj *resultPtr out Pointer to an unshared Tcl_Obj where the result of the evaluation is stored if the return code is TCL_OK. .AP Tcl_NRPostProc *postProcPtr in A function to push. .AP ClientData data0 in .AP ClientData data1 in .AP ClientData data2 in .AP ClientData data3 in \fIdata0\fR through \fIdata3\fR are four one-word values that will be passed to the function designated by \fIpostProcPtr\fR when it is invoked. .BE .SH DESCRIPTION .PP These functions provide an interface to the function stack that an interpreter iterates through to evaluate commands. The routine behind a command is implemented by an initial function and any additional functions that the routine pushes onto the stack as it progresses. The interpreter itself pushes functions onto the stack to react to the end of a routine and to exercise other forms of control such as switching between in-progress stacks and the evaluation of other scripts at additional levels without adding frames to the C stack. To execute a routine, the initial function for the routine is called and then a small bit of code called a \fItrampoline\fR iteratively takes functions off the stack and calls them, using the value of the last call as the value of the routine. .PP \fBTcl_NRCallObjProc\fR calls \fInreProc\fR using a new trampoline. .PP \fBTcl_NRCreateCommand\fR, an alternative to \fBTcl_CreateObjCommand\fR, resolves \fIcmdName\fR, which may contain namespace qualifiers, relative to the current namespace, creates a command by that name, and returns a token for the command which may be used in subsequent calls to \fBTcl_GetCommandName\fR. Except for a few cases noted below any existing command by the same name is first deleted. If \fIinterp\fR is in the process of being deleted \fBTcl_NRCreateCommand\fR does not create any command, does not delete any command, and returns NULL. .PP \fBTcl_NREvalObj\fR pushes a function that is like \fBTcl_EvalObjEx\fR but consumes no space on the C stack. .PP \fBTcl_NREvalObjv\fR pushes a function that is like \fBTcl_EvalObjv\fR but consumes no space on the C stack. .PP \fBTcl_NRCmdSwap\fR is like \fBTcl_NREvalObjv\fR, but uses \fIcmd\fR, a token previously returned by \fBTcl_CreateObjCommand\fR or \fBTcl_GetCommandFromObj\fR, instead of resolving the first word of \fIobjv\fR. . The name of this command must be the same as \fIobjv[0]\fR. .PP \fBTcl_NRExprObj\fR pushes a function that evaluates \fIobjPtr\fR as an expression in the same manner as \fBTcl_ExprObj\fR but without consuming space on the C stack. .PP All of the functions return \fBTCL_OK\fR if the evaluation of the script, command, or expression has been scheduled successfully. Otherwise (for example if the command name cannot be resolved), they return \fBTCL_ERROR\fR and store a message as the interpreter's result. .PP \fBTcl_NRAddCallback\fR pushes \fIpostProcPtr\fR. The signature for \fBTcl_NRPostProc\fR is: .PP .CS typedef int \fBTcl_NRPostProc\fR( \fBClientData\fR \fIdata\fR[], \fBTcl_Interp\fR *\fIinterp\fR, int \fIresult\fR); .CE .PP \fIdata\fR is a pointer to an array containing \fIdata0\fR through \fIdata3\fR. \fIresult\fR is the value returned by the previous function implementing part the routine. .SH EXAMPLE .PP The following command uses \fBTcl_EvalObjEx\fR, which consumes space on the C stack, to evalute a script: .PP .CS int \fITheCmdOldObjProc\fR( ClientData clientData, Tcl_Interp *interp, int objc, |
︙ | ︙ | |||
224 225 226 227 228 229 230 | return result; } \fBTcl_CreateObjCommand\fR(interp, "theCommand", \fITheCmdOldObjProc\fR, clientData, TheCmdDeleteProc); .CE .PP | | | < | | | < > | < < < < < < < < < < | < < < | 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 | return result; } \fBTcl_CreateObjCommand\fR(interp, "theCommand", \fITheCmdOldObjProc\fR, clientData, TheCmdDeleteProc); .CE .PP To avoid consuming space on the C stack, \fITheCmdOldObjProc\fR is renamed to \fITheCmdNRObjProc\fR and the postprocessing step is split into a separate function, \fITheCmdPostProc\fR, which is pushed onto the function stack. \fITcl_EvalObjEx\fR is replaced with \fITcl_NREvalObj\fR, which uses a trampoline instead of consuming space on the C stack. A new version of \fITheCmdOldObjProc\fR is just a a wrapper that uses \fBTcl_NRCallObjProc\fR to call \fITheCmdNRObjProc\fR: .PP .CS int \fITheCmdOldObjProc\fR( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { return \fBTcl_NRCallObjProc\fR(interp, \fITheCmdNRObjProc\fR, clientData, objc, objv); } .CE .PP .CS int \fITheCmdNRObjProc\fR ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) |
︙ | ︙ | |||
280 281 282 283 284 285 286 | /* \fIdata0 .. data3\fR are up to four one-word items to * pass to the postprocessing procedure */ return \fBTcl_NREvalObj\fR(interp, objPtr, 0); } .CE .PP | < < < | < < < | < < < < < < < < < < < | > | 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 | /* \fIdata0 .. data3\fR are up to four one-word items to * pass to the postprocessing procedure */ return \fBTcl_NREvalObj\fR(interp, objPtr, 0); } .CE .PP .CS int \fITheCmdNRPostProc\fR( ClientData data[], Tcl_Interp *interp, int result) { /* \fIdata[0] .. data[3]\fR are the four words of data * passed to \fBTcl_NRAddCallback\fR */ \fI... postprocessing ...\fR return result; } .CE .PP Any function comprising a routine can push other functions, making it possible implement looping and sequencing constructs using the function stack. .PP .SH "SEE ALSO" Tcl_CreateCommand(3), Tcl_CreateObjCommand(3), Tcl_EvalObjEx(3), Tcl_GetCommandFromObj(3), Tcl_ExprObj(3) .SH KEYWORDS stackless, nonrecursive, execute, command, global, value, result, script .SH COPYRIGHT Copyright (c) 2008 by Kevin B. Kenny. Copyright (c) 2018 by Nathan Coulter. |
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/Panic.3.
1 2 3 4 5 6 7 8 9 | '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_Panic 3 8.4 Tcl "Tcl Library Procedures" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME | | < < < | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_Panic 3 8.4 Tcl "Tcl Library Procedures" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME Tcl_Panic, Tcl_SetPanicProc \- report fatal error and abort .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp void \fBTcl_Panic\fR(\fIformat\fR, \fIarg\fR, \fIarg\fR, \fI...\fR) .sp void \fBTcl_SetPanicProc\fR(\fIpanicProc\fR) .sp .SH ARGUMENTS .AS Tcl_PanicProc *panicProc .AP "const char*" format in A printf-style format string. |
︙ | ︙ | |||
76 77 78 79 80 81 82 | application or the platform. .PP Although the primary callers of \fBTcl_Panic\fR are the procedures of the Tcl library, \fBTcl_Panic\fR is a public function and may be called by any extension or application that wishes to abort the process and have a panic message displayed the same way that panic messages from Tcl will be displayed. | < < < | 73 74 75 76 77 78 79 80 81 82 83 | application or the platform. .PP Although the primary callers of \fBTcl_Panic\fR are the procedures of the Tcl library, \fBTcl_Panic\fR is a public function and may be called by any extension or application that wishes to abort the process and have a panic message displayed the same way that panic messages from Tcl will be displayed. .SH "SEE ALSO" abort(3), printf(3), exec(n), format(n) .SH KEYWORDS abort, fatal, error |
Changes to doc/PrintDbl.3.
︙ | ︙ | |||
14 15 16 17 18 19 20 | .nf \fB#include <tcl.h>\fR .sp \fBTcl_PrintDouble\fR(\fIinterp, value, dst\fR) .SH ARGUMENTS .AS Tcl_Interp *interp out .AP Tcl_Interp *interp in | < | < < < < | | 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 | .nf \fB#include <tcl.h>\fR .sp \fBTcl_PrintDouble\fR(\fIinterp, value, dst\fR) .SH ARGUMENTS .AS Tcl_Interp *interp out .AP Tcl_Interp *interp in This argument is ignored. .AP double value in Floating-point value to be converted. .AP char *dst out Where to store the string representing \fIvalue\fR. Must have at least \fBTCL_DOUBLE_SPACE\fR characters of storage. .BE .SH DESCRIPTION .PP \fBTcl_PrintDouble\fR generates a string that represents the value of \fIvalue\fR and stores it in memory at the location given by \fIdst\fR. It uses \fB%g\fR format to generate the string, with one special twist: the string is guaranteed to contain either a .QW . or an .QW e so that it does not look like an integer. Where \fB%g\fR would generate an integer with no decimal point, \fBTcl_PrintDouble\fR adds .QW .0 . .PP The result will have the fewest digits needed to represent the number in such a way that \fBTcl_NewDoubleObj\fR will generate the same number when presented with the given string. IEEE semantics of rounding to even apply to the conversion. .SH KEYWORDS conversion, double-precision, floating-point, string |
Changes to doc/RecordEval.3.
︙ | ︙ | |||
27 28 29 30 31 32 33 | command but do not evaluate it. \fBTCL_EVAL_GLOBAL\fR means evaluate the command at global level instead of the current stack level. .BE .SH DESCRIPTION .PP \fBTcl_RecordAndEval\fR is invoked to record a command as an event | | > | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | command but do not evaluate it. \fBTCL_EVAL_GLOBAL\fR means evaluate the command at global level instead of the current stack level. .BE .SH DESCRIPTION .PP \fBTcl_RecordAndEval\fR is invoked to record a command as an event on the history list and then execute it using \fBTcl_Eval\fR (or \fBTcl_GlobalEval\fR if the \fBTCL_EVAL_GLOBAL\fR bit is set in \fIflags\fR). It returns a completion code such as \fBTCL_OK\fR just like \fBTcl_Eval\fR and it leaves information in the interpreter's result. If you do not want the command recorded on the history list then you should invoke \fBTcl_Eval\fR instead of \fBTcl_RecordAndEval\fR. Normally \fBTcl_RecordAndEval\fR is only called with top-level commands typed by the user, since the purpose of history is to allow the user to re-issue recently-invoked commands. |
︙ | ︙ |
Changes to doc/SaveResult.3.
︙ | ︙ | |||
50 51 52 53 54 55 56 | value may then be passed back to one of \fBTcl_RestoreInterpState\fR or \fBTcl_DiscardInterpState\fR, depending on whether the interp state is to be restored. So long as one of the latter two routines is called, Tcl will take care of memory management. .PP The second triplet stores the snapshot of only the interpreter result (not its complete state) in memory allocated by the caller. | | | | 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 | value may then be passed back to one of \fBTcl_RestoreInterpState\fR or \fBTcl_DiscardInterpState\fR, depending on whether the interp state is to be restored. So long as one of the latter two routines is called, Tcl will take care of memory management. .PP The second triplet stores the snapshot of only the interpreter result (not its complete state) in memory allocated by the caller. These routines are passed a pointer to \fBTcl_SavedResult\fR that is used to store enough information to restore the interpreter result. \fBTcl_SavedResult\fR can be allocated on the stack of the calling procedure. These routines do not save the state of any error information in the interpreter (e.g. the \fB\-errorcode\fR or \fB\-errorinfo\fR return options, when an error is in progress). .PP Because the routines \fBTcl_SaveInterpState\fR, \fBTcl_RestoreInterpState\fR, and \fBTcl_DiscardInterpState\fR perform a superset of the functions provided by the other routines, |
︙ | ︙ |
Changes to doc/SetRecLmt.3.
︙ | ︙ | |||
26 27 28 29 30 31 32 | .BE .SH DESCRIPTION .PP At any given time Tcl enforces a limit on the number of recursive calls that may be active for \fBTcl_Eval\fR and related procedures such as \fBTcl_EvalEx\fR. | | | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 | .BE .SH DESCRIPTION .PP At any given time Tcl enforces a limit on the number of recursive calls that may be active for \fBTcl_Eval\fR and related procedures such as \fBTcl_EvalEx\fR. Any call to \fBTcl_Eval\fR that exceeds this depth is aborted with an error. By default the recursion limit is 1000. .PP \fBTcl_SetRecursionLimit\fR may be used to change the maximum allowable nesting depth for an interpreter. The \fIdepth\fR argument specifies a new limit for \fIinterp\fR, and \fBTcl_SetRecursionLimit\fR returns the old limit. |
︙ | ︙ |
Changes to doc/SetResult.3.
1 2 3 4 5 6 7 8 9 10 11 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_SetResult 3 8.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME | | < < | 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 | '\" '\" Copyright (c) 1989-1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_SetResult 3 8.0 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_SetObjResult, Tcl_GetObjResult, Tcl_SetResult, Tcl_GetStringResult, Tcl_AppendResult, Tcl_AppendElement, Tcl_ResetResult, Tcl_TransferResult, Tcl_FreeResult \- manipulate Tcl result .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp \fBTcl_SetObjResult\fR(\fIinterp, objPtr\fR) .sp Tcl_Obj * \fBTcl_GetObjResult\fR(\fIinterp\fR) .sp \fBTcl_SetResult\fR(\fIinterp, result, freeProc\fR) .sp const char * \fBTcl_GetStringResult\fR(\fIinterp\fR) .sp \fBTcl_AppendResult\fR(\fIinterp, result, result, ... , \fB(char *) NULL\fR) .sp \fBTcl_ResetResult\fR(\fIinterp\fR) .sp .VS 8.6 \fBTcl_TransferResult\fR(\fIsourceInterp, result, targetInterp\fR) .VE 8.6 .sp \fBTcl_AppendElement\fR(\fIinterp, element\fR) |
︙ | ︙ | |||
147 148 149 150 151 152 153 | result, such as allocating a larger result area if necessary. It also manages conversion to and from the \fIresult\fR field of the \fIinterp\fR so as to handle backward-compatibility with old-style extensions. Any number of \fIresult\fR arguments may be passed in a single call; the last argument in the list must be a NULL pointer. .PP | < < < | 145 146 147 148 149 150 151 152 153 154 155 156 157 158 | result, such as allocating a larger result area if necessary. It also manages conversion to and from the \fIresult\fR field of the \fIinterp\fR so as to handle backward-compatibility with old-style extensions. Any number of \fIresult\fR arguments may be passed in a single call; the last argument in the list must be a NULL pointer. .PP .VS 8.6 \fBTcl_TransferResult\fR moves a result from one interpreter to another, optionally (dependent on the \fIresult\fR parameter) including the error information dictionary as well. The interpreters must be in the same thread. The source interpreter will have its result reset by this operation. .VE 8.6 .SH "DEPRECATED INTERFACES" |
︙ | ︙ | |||
192 193 194 195 196 197 198 | \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. | < < < < < < < | 187 188 189 190 191 192 193 194 195 196 197 198 199 200 | \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 |
︙ | ︙ |
Changes to doc/StringObj.3.
1 2 3 4 5 6 7 8 9 10 | '\" '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_StringObj 3 8.1 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 | '\" '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH Tcl_StringObj 3 8.1 Tcl "Tcl Library Procedures" .so man.macros .BS .SH NAME Tcl_NewStringObj, Tcl_NewUnicodeObj, Tcl_SetStringObj, Tcl_SetUnicodeObj, Tcl_GetStringFromObj, Tcl_GetString, Tcl_GetUnicodeFromObj, Tcl_GetUnicode, Tcl_GetUniChar, Tcl_GetCharLength, Tcl_GetRange, Tcl_AppendToObj, Tcl_AppendUnicodeToObj, Tcl_AppendObjToObj, Tcl_AppendStringsToObj, Tcl_AppendLimitedToObj, Tcl_Format, Tcl_AppendFormatToObj, Tcl_ObjPrintf, Tcl_AppendPrintfToObj, Tcl_SetObjLength, Tcl_AttemptSetObjLength, Tcl_ConcatObj \- manipulate Tcl values as strings .SH SYNOPSIS .nf \fB#include <tcl.h>\fR .sp Tcl_Obj * \fBTcl_NewStringObj\fR(\fIbytes, length\fR) .sp |
︙ | ︙ | |||
54 55 56 57 58 59 60 | .sp void \fBTcl_AppendObjToObj\fR(\fIobjPtr, appendObjPtr\fR) .sp void \fBTcl_AppendStringsToObj\fR(\fIobjPtr, string, string, ... \fB(char *) NULL\fR) .sp | < < < | 54 55 56 57 58 59 60 61 62 63 64 65 66 67 | .sp void \fBTcl_AppendObjToObj\fR(\fIobjPtr, appendObjPtr\fR) .sp void \fBTcl_AppendStringsToObj\fR(\fIobjPtr, string, string, ... \fB(char *) NULL\fR) .sp void \fBTcl_AppendLimitedToObj\fR(\fIobjPtr, bytes, length, limit, ellipsis\fR) .sp Tcl_Obj * \fBTcl_Format\fR(\fIinterp, format, objc, objv\fR) .sp int |
︙ | ︙ | |||
242 243 244 245 246 247 248 | \fBTcl_AppendStringsToObj\fR is similar to \fBTcl_AppendToObj\fR except that it can be passed more than one value to append and each value must be a null-terminated string (i.e. none of the values may contain internal null characters). Any number of \fIstring\fR arguments may be provided, but the last argument must be a NULL pointer to indicate the end of the list. .PP | < < < < | 239 240 241 242 243 244 245 246 247 248 249 250 251 252 | \fBTcl_AppendStringsToObj\fR is similar to \fBTcl_AppendToObj\fR except that it can be passed more than one value to append and each value must be a null-terminated string (i.e. none of the values may contain internal null characters). Any number of \fIstring\fR arguments may be provided, but the last argument must be a NULL pointer to indicate the end of the list. .PP \fBTcl_AppendLimitedToObj\fR is similar to \fBTcl_AppendToObj\fR except that it imposes a limit on how many bytes are appended. This can be handy when the string to be appended might be very large, but the value being constructed should not be allowed to grow without bound. A common usage is when constructing an error message, where the end result should be kept short enough to be read. Bytes from \fIbytes\fR are appended to \fIobjPtr\fR, but no more |
︙ | ︙ |
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 |
︙ | ︙ | |||
98 99 100 101 102 103 104 | The length of the UTF-8 string in bytes (not UTF-8 characters). If negative, all bytes up to the first null byte are used. .AP int uniLength in The length of the Unicode string in characters. Must be greater than or equal to 0. .AP "Tcl_DString" *dsPtr in/out A pointer to a previously initialized \fBTcl_DString\fR. | | | 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 | The length of the UTF-8 string in bytes (not UTF-8 characters). If negative, all bytes up to the first null byte are used. .AP int uniLength in The length of the Unicode string in characters. Must be greater than or equal to 0. .AP "Tcl_DString" *dsPtr in/out A pointer to a previously initialized \fBTcl_DString\fR. .AP "unsigned long" numChars in The number of characters to compare. .AP "const char" *start in Pointer to the beginning of a UTF-8 string. .AP int index in The index of a character (not byte) in the UTF-8 string. .AP int *readPtr out If non-NULL, filled with the number of bytes in the backslash sequence, |
︙ | ︙ |
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 94 95 96 97 98 99 100 101 | 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, \fB0o\fR will be added to the beginning of the result unless it is zero. For \fBx\fR or \fBX\fR conversions, \fB0x\fR 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 there is no effect unless the \fB0\fR specifier is used as well: In that case, \fB0d\fR will be added to the beginning. For all floating-point conversions (\fBe\fR, \fBE\fR, \fBf\fR, \fBg\fR, and \fBG\fR) it guarantees that the result always has a decimal point. For \fBg\fR and \fBG\fR conversions it specifies that trailing zeroes should not be removed. .SS "OPTIONAL FIELD WIDTH" .PP |
︙ | ︙ | |||
126 127 128 129 130 131 132 | printed; if the string is longer than this then the trailing characters will be dropped. If the precision is specified with \fB*\fR rather than a number then the next argument to the \fBformat\fR command determines the precision; it must be a numeric string. .SS "OPTIONAL SIZE MODIFIER" .PP The fifth part of a conversion specifier is a size modifier, | | > > | | 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 | printed; if the string is longer than this then the trailing characters will be dropped. If the precision is specified with \fB*\fR rather than a number then the next argument to the \fBformat\fR command determines the precision; it must be a numeric string. .SS "OPTIONAL SIZE MODIFIER" .PP The fifth part of a conversion specifier is a size modifier, which must be \fBll\fR, \fBh\fR, \fBl\fR, or \fBL\fR. If it is \fBll\fR it specifies that an integer value is taken without truncation for conversion to a formatted substring. If it is \fBh\fR it specifies that an integer value is truncated to a 16-bit range before converting. This option is rarely useful. If it is \fBl\fR it specifies that the integer value is truncated to the same range as that produced by the \fBwide()\fR function of the \fBexpr\fR command (at least a 64-bit range). If it is \fBL\fR it specifies that an integer or double value is taken without truncation for conversion to a formatted substring. If neither \fBh\fR nor \fBl\fR nor \fBL\fR are present, the integer value is truncated to the same range as that produced by the \fBint()\fR function of the \fBexpr\fR command (at least a 32-bit range, but determined by the value of the \fBwordSize\fR element of the \fBtcl_platform\fR array). .SS "MANDATORY CONVERSION TYPE" .PP The last thing in a conversion specifier is an alphabetic character |
︙ | ︙ | |||
165 166 167 168 169 170 171 | Convert integer to unsigned hexadecimal string, using digits .QW 0123456789abcdef for \fBx\fR and .QW 0123456789ABCDEF for \fBX\fR). .TP 10 \fBb\fR | | | 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 | 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 |
︙ | ︙ | |||
194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 | \fBg\fR or \fBG\fR If the exponent is less than \-4 or greater than or equal to the precision, then convert number as for \fB%e\fR or \fB%E\fR. Otherwise convert as for \fB%f\fR. Trailing zeroes and a trailing decimal point are omitted. .TP 10 \fB%\fR No conversion: just insert \fB%\fR. .SH "DIFFERENCES FROM ANSI SPRINTF" .PP The behavior of the format command is the same as the ANSI C \fBsprintf\fR procedure except for the following differences: .IP [1] Tcl guarantees that it will be working with UNICODE characters. .IP [2] | > > > > > > > > > > > | < | 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 | \fBg\fR or \fBG\fR If the exponent is less than \-4 or greater than or equal to the precision, then convert number as for \fB%e\fR or \fB%E\fR. Otherwise convert as for \fB%f\fR. Trailing zeroes and a trailing decimal point are omitted. .TP 10 \fBa\fR or \fBA\fR Convert double to hexadecimal notation in the form \fI0x1.yyy\fBp\(+-\fIzz\fR, where the number of \fIy\fR's is determined by the precision (default: 13). If the \fBA\fR form is used then the hex characters are printed in uppercase. .TP 10 \fB%\fR No conversion: just insert \fB%\fR. .TP 10 \fBp\fR Shorthand form for \fB0x%zx\fR, so it outputs the integer in hexadecimal form with \fB0x\fR prefix. .SH "DIFFERENCES FROM ANSI SPRINTF" .PP The behavior of the format command is the same as the ANSI C \fBsprintf\fR procedure except for the following differences: .IP [1] Tcl guarantees that it will be working with UNICODE characters. .IP [2] \fB%n\fR specifier is not supported. .IP [3] For \fB%c\fR conversions the argument must be an integer value, which will then be converted to the corresponding character value. .IP [4] The size modifiers are ignored when formatting floating-point values. The \fBb\fR specifier has no \fBsprintf\fR counterpart. .SH EXAMPLES .PP Convert the numeric value of a UNICODE character to the character itself: .PP .CS |
︙ | ︙ |
Changes to doc/info.n.
︙ | ︙ | |||
353 354 355 356 357 358 359 | the global namespace if \fIpattern\fR starts with \fB::\fR) to match within; the matching pattern is taken to be the part after the last namespace separator. .TP \fBinfo script\fR ?\fIfilename\fR? . If a Tcl script file is currently being evaluated (i.e. there is a | | | 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 | the global namespace if \fIpattern\fR starts with \fB::\fR) to match within; the matching pattern is taken to be the part after the last namespace separator. .TP \fBinfo script\fR ?\fIfilename\fR? . If a Tcl script file is currently being evaluated (i.e. there is a call to \fBTcl_EvalFile\fR active or there is an active invocation of the \fBsource\fR command), then this command returns the name of the innermost file being processed. If \fIfilename\fR is specified, then the return value of this command will be modified for the duration of the active invocation to return that name. This is useful in virtual file system applications. Otherwise the command returns an empty string. .TP |
︙ | ︙ |
Changes to doc/lsearch.n.
︙ | ︙ | |||
143 144 145 146 147 148 149 150 151 152 153 154 155 156 | This option implies \fB\-sorted\fR and cannot be used with either \fB\-all\fR or \fB\-not\fR. .VE 8.6 .SS "NESTED LIST OPTIONS" .PP These options are used to search lists of lists. They may be used with any other options. .TP \fB\-index\fR\0\fIindexList\fR . This option is designed for use when searching within nested lists. The \fIindexList\fR argument gives a path of indices (much as might be used with the \fBlindex\fR or \fBlset\fR commands) within each element to allow the location of the term being matched against. | > > > > > > > > > > > > > | 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 | This option implies \fB\-sorted\fR and cannot be used with either \fB\-all\fR or \fB\-not\fR. .VE 8.6 .SS "NESTED LIST OPTIONS" .PP These options are used to search lists of lists. They may be used with any other options. .TP \fB\-stride\0\fIstrideLength\fR . If this option is specified, the list is treated as consisting of groups of \fIstrideLength\fR elements and the groups are searched by either their first element or, if the \fB\-index\fR option is used, by the element within each group given by the first index passed to \fB\-index\fR (which is then ignored by \fB\-index\fR). The resulting index always points to the first element in a group. .PP The list length must be an integer multiple of \fIstrideLength\fR, which in turn must be at least 1. A \fIstrideLength\fR of 1 is the default and indicates no grouping. .TP \fB\-index\fR\0\fIindexList\fR . This option is designed for use when searching within nested lists. The \fIindexList\fR argument gives a path of indices (much as might be used with the \fBlindex\fR or \fBlset\fR commands) within each element to allow the location of the term being matched against. |
︙ | ︙ | |||
204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 | .PP It is also possible to search inside elements: .PP .CS \fBlsearch\fR -index 1 -all -inline {{a abc} {b bcd} {c cde}} *bc* \fI\(-> {a abc} {b bcd}\fR .CE .SH "SEE ALSO" foreach(n), list(n), lappend(n), lindex(n), linsert(n), llength(n), lset(n), lsort(n), lrange(n), lreplace(n), string(n) .SH KEYWORDS binary search, linear search, list, match, pattern, regular expression, search, string '\" Local Variables: '\" mode: nroff '\" End: | > > > > > > > | 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 | .PP It is also possible to search inside elements: .PP .CS \fBlsearch\fR -index 1 -all -inline {{a abc} {b bcd} {c cde}} *bc* \fI\(-> {a abc} {b bcd}\fR .CE .PP The same thing for a flattened list: .PP .CS \fBlsearch\fR -stride 2 -index 1 -all -inline {a abc b bcd c cde} *bc* \fI\(-> {a abc b bcd}\fR .CE .SH "SEE ALSO" foreach(n), list(n), lappend(n), lindex(n), linsert(n), llength(n), lset(n), lsort(n), lrange(n), lreplace(n), string(n) .SH KEYWORDS binary search, linear search, list, match, pattern, regular expression, search, string '\" Local Variables: '\" mode: nroff '\" End: |
Changes to doc/msgcat.n.
1 2 3 4 5 6 7 8 9 10 11 12 13 | '\" '\" Copyright (c) 1998 Mark Harrison. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH "msgcat" n 1.5 msgcat "Tcl Bundled Packages" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME msgcat \- Tcl message catalog .SH SYNOPSIS | | | > > > > > | > | 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 | '\" '\" Copyright (c) 1998 Mark Harrison. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH "msgcat" n 1.5 msgcat "Tcl Bundled Packages" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME msgcat \- Tcl message catalog .SH SYNOPSIS \fBpackage require Tcl 8.7\fR .sp \fBpackage require msgcat 1.7\fR .sp \fB::msgcat::mc \fIsrc-string\fR ?\fIarg arg ...\fR? .sp \fB::msgcat::mcmax ?\fIsrc-string src-string ...\fR? .sp .VS "TIP 412" \fB::msgcat::mcexists\fR ?\fB-exactnamespace\fR? ?\fB-exactlocale\fR? \fIsrc-string\fR .VE "TIP 412" .sp .VS "TIP 490" \fB::msgcat::mcpackagenamespaceget\fR .VE "TIP 490" .sp \fB::msgcat::mclocale \fR?\fInewLocale\fR? .sp .VS "TIP 499" \fB::msgcat::mcpreferences\fR ?\fIlocale preference\fR? ... .VE "TIP 499" .sp .VS "TIP 412" \fB::msgcat::mcloadedlocales subcommand\fR ?\fIlocale\fR? .VE "TIP 412" .sp \fB::msgcat::mcload \fIdirname\fR .sp |
︙ | ︙ | |||
46 47 48 49 50 51 52 53 54 55 56 57 58 59 | .VS "TIP 412" \fB::msgcat::mcpackagelocale subcommand\fR ?\fIlocale\fR? .sp \fB::msgcat::mcpackageconfig subcommand\fR \fIoption\fR ?\fIvalue\fR? .sp \fB::msgcat::mcforgetpackage\fR .VE "TIP 412" .BE .SH DESCRIPTION .PP The \fBmsgcat\fR package provides a set of functions that can be used to manage multi-lingual user interfaces. Text strings are defined in a .QW "message catalog" | > > > > | 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 | .VS "TIP 412" \fB::msgcat::mcpackagelocale subcommand\fR ?\fIlocale\fR? .sp \fB::msgcat::mcpackageconfig subcommand\fR \fIoption\fR ?\fIvalue\fR? .sp \fB::msgcat::mcforgetpackage\fR .VE "TIP 412" .sp .VS "TIP 499" \fB::msgcat::mcutil subcommand\fR ?\fIlocale\fR? .VS "TIP 499" .BE .SH DESCRIPTION .PP The \fBmsgcat\fR package provides a set of functions that can be used to manage multi-lingual user interfaces. Text strings are defined in a .QW "message catalog" |
︙ | ︙ | |||
67 68 69 70 71 72 73 74 75 76 77 78 79 80 | Each package has its own message catalog and configuration settings in \fBmsgcat\fR. .PP A \fIlocale\fR is a specification string describing a user language like \fBde_ch\fR for Swiss German. In \fBmsgcat\fR, there is a global locale initialized by the system locale of the current system. Each package may decide to use the global locale or to use a package specific locale. .PP The global locale may be changed on demand, for example by a user initiated language change or within a multi user application like a web server. .SH COMMANDS .TP \fB::msgcat::mc \fIsrc-string\fR ?\fIarg arg ...\fR? . Returns a translation of \fIsrc-string\fR according to the current locale. If additional arguments past \fIsrc-string\fR are given, the \fBformat\fR command is used to substitute the | > > > > > | 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 | Each package has its own message catalog and configuration settings in \fBmsgcat\fR. .PP A \fIlocale\fR is a specification string describing a user language like \fBde_ch\fR for Swiss German. In \fBmsgcat\fR, there is a global locale initialized by the system locale of the current system. Each package may decide to use the global locale or to use a package specific locale. .PP The global locale may be changed on demand, for example by a user initiated language change or within a multi user application like a web server. .PP .VS tip490 Object oriented programming is supported by the use of a package namespace. .VE tip490 .PP .SH COMMANDS .TP \fB::msgcat::mc \fIsrc-string\fR ?\fIarg arg ...\fR? . Returns a translation of \fIsrc-string\fR according to the current locale. If additional arguments past \fIsrc-string\fR are given, the \fBformat\fR command is used to substitute the |
︙ | ︙ | |||
91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 | \fB::msgcat::mc\fR is the main function used to localize an application. Instead of using an English string directly, an application can pass the English string through \fB::msgcat::mc\fR and use the result. If an application is written for a single language in this fashion, then it is easy to add support for additional languages later simply by defining new message catalog entries. .RE .TP \fB::msgcat::mcmax ?\fIsrc-string src-string ...\fR? . Given several source strings, \fB::msgcat::mcmax\fR returns the length of the longest translated string. This is useful when designing localized GUIs, which may require that all buttons, for example, be a fixed width (which will be the width of the widest button). .TP | > > > > > > > > > > > > | < > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > < | | > > > > > > > > > > < | | | | > > > | > > | > | > | < > > > > | 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 | \fB::msgcat::mc\fR is the main function used to localize an application. Instead of using an English string directly, an application can pass the English string through \fB::msgcat::mc\fR and use the result. If an application is written for a single language in this fashion, then it is easy to add support for additional languages later simply by defining new message catalog entries. .RE .VS "TIP 490" .TP \fB::msgcat::mcn \fInamespace\fR \fIsrc-string\fR ?\fIarg arg ...\fR? . Like \fB::msgcat::mc\fR, but with the message namespace specified as first argument. .PP .RS \fBmcn\fR may be used for cases where the package namespace is not the namespace of the caller. An example is shown within the description of the command \fB::msgcat::mcpackagenamespaceget\fR below. .RE .PP .TP \fB::msgcat::mcmax ?\fIsrc-string src-string ...\fR? . Given several source strings, \fB::msgcat::mcmax\fR returns the length of the longest translated string. This is useful when designing localized GUIs, which may require that all buttons, for example, be a fixed width (which will be the width of the widest button). .TP .VS "TIP 412" \fB::msgcat::mcexists\fR ?\fB-exactnamespace\fR? ?\fB-exactlocale\fR? ?\fB-namespace\fR \fInamespace\fR? \fIsrc-string\fR . Return true, if there is a translation for the given \fIsrc-string\fR. .PP .RS The search may be limited by the option \fB\-exactnamespace\fR to only check the current namespace and not any parent namespaces. .PP It may also be limited by the option \fB\-exactlocale\fR to only check the first prefered locale (e.g. first element returned by \fB::msgcat::mcpreferences\fR if global locale is used). .PP .VE "TIP 412" .VS "TIP 490" An explicit package namespace may be specified by the option \fB-namespace\fR. The namespace of the caller is used if not explicitly specified. .RE .PP .VE "TIP 490" .VS "TIP 490" .TP \fB::msgcat::mcpackagenamespaceget\fR . Return the package namespace of the caller. This command handles all cases described in section \fBOBJECT ORIENTED PROGRAMMING\fR. .PP .RS Example usage is a tooltip package, which saves the caller package namespace to update the translation each time the tooltip is shown: .CS proc ::tooltip::tooltip {widget message} { ... set messagenamespace [uplevel 1 {::msgcat::mcpackagenamespaceget}] ... bind $widget [list ::tooltip::show $widget $messagenamespace $message] } proc ::tooltip::show {widget messagenamespace message} { ... set message [::msgcat::mcn $messagenamespace $message] ... } .CE .RE .PP .VE "TIP 490" .TP \fB::msgcat::mclocale \fR?\fInewLocale\fR? . If \fInewLocale\fR is omitted, the current locale is returned, otherwise the current locale is set to \fInewLocale\fR. .PP .RS If the new locale is set to \fInewLocale\fR, the corresponding preferences are calculated and set. For example, if the current locale is en_US_funky, then \fB::msgcat::mcpreferences\fR returns \fB{en_us_funky en_us en {}}\fR. .PP The same result may be acheved by \fB::msgcat::mcpreferences\fR {*}[\fB::msgcat::mcutil getpreferences\fR \fInewLocale\fR]. .PP The current locale is always the first element of the list returned by \fBmcpreferences\fR. .PP msgcat stores and compares the locale in a case-insensitive manner, and returns locales in lowercase. The initial locale is determined by the locale specified in the user's environment. See \fBLOCALE SPECIFICATION\fR below for a description of the locale string format. .PP .VS "TIP 412" If the locale is set, the preference list of locales is evaluated. Locales in this list are loaded now, if not jet loaded. .VE "TIP 412" .RE .TP \fB::msgcat::mcpreferences\fR ?\fIlocale preference\fR? ... . Without arguments, returns an ordered list of the locales preferred by the user. The list is ordered from most specific to least preference. .PP .VS "TIP 499" .RS A set of locale preferences may be given to set the list of locale preferences. The current locale is also set, which is the first element of the locale preferences list. .PP Locale preferences are loaded now, if not jet loaded. .PP As an example, the user may prefer French or English text. This may be configured by: .CS ::msgcat::mcpreferences fr en {} .CE .RE .PP .VS "TIP 499" .TP \fB::msgcat:mcloadedlocales subcommand\fR ?\fIlocale\fR? . This group of commands manage the list of loaded locales for packages not setting a package locale. .PP .RS The subcommand \fBget\fR returns the list of currently loaded locales. |
︙ | ︙ | |||
227 228 229 230 231 232 233 234 235 236 237 238 239 240 | Note that this routine is only called if the concerned package did not set a package locale unknown command name. .RE .TP \fB::msgcat::mcforgetpackage\fR . The calling package clears all its state within the \fBmsgcat\fR package including all settings and translations. .VE "TIP 412" .PP .SH "LOCALE SPECIFICATION" .PP The locale is specified to \fBmsgcat\fR by a locale string passed to \fB::msgcat::mclocale\fR. The locale string consists of a language code, an optional country code, and an optional | > > > > > > > > > > > > > > > > | 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 | Note that this routine is only called if the concerned package did not set a package locale unknown command name. .RE .TP \fB::msgcat::mcforgetpackage\fR . The calling package clears all its state within the \fBmsgcat\fR package including all settings and translations. .VE "TIP 412" .PP .VS "TIP 499" .TP \fB::msgcat::mcutil getpreferences\fR \fIlocale\fR . Return the preferences list of the given locale as described in section \fBLOCALE SPECIFICATION\fR. An example is the composition of a preference list for the bilingual region "Biel/Bienne" as a concatenation of swiss german and swiss french: .CS % concat [lrange [msgcat::mcutil getpreferences fr_CH] 0 end-1] [msgcat::mcutil getpreferences de_CH] fr_ch fr de_ch de {} .CE .TP \fB::msgcat::mcutil getsystemlocale\fR . The system locale is returned as described by the section \fBLOCALE SPECIFICATION\fR. .VE "TIP 499" .PP .SH "LOCALE SPECIFICATION" .PP The locale is specified to \fBmsgcat\fR by a locale string passed to \fB::msgcat::mclocale\fR. The locale string consists of a language code, an optional country code, and an optional |
︙ | ︙ | |||
433 434 435 436 437 438 439 | .PP .CS \fBmsgcat::mc\fR {Produced %1$d at %2$s} $num $city # ... where that key is mapped to one of the # human-oriented versions by \fBmsgcat::mcset\fR .CE .VS "TIP 412" | | | 525 526 527 528 529 530 531 532 533 534 535 536 537 538 539 | .PP .CS \fBmsgcat::mc\fR {Produced %1$d at %2$s} $num $city # ... where that key is mapped to one of the # human-oriented versions by \fBmsgcat::mcset\fR .CE .VS "TIP 412" .SH "PACKAGE PRIVATE LOCALE" .PP A package using \fBmsgcat\fR may choose to use its own package private locale and its own set of loaded locales, independent to the global locale set by \fB::msgcat::mclocale\fR. .PP This allows a package to change its locale without causing any locales load or removal in other packages and not to invoke the global locale change callback (see below). .PP |
︙ | ︙ | |||
457 458 459 460 461 462 463 | This command may cause the load of locales. .RE .TP \fB::msgcat::mcpackagelocale get\fR . Return the package private locale or the global locale, if no package private locale is set. .TP | | | > > > > > > > > > > > > | 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 | This command may cause the load of locales. .RE .TP \fB::msgcat::mcpackagelocale get\fR . Return the package private locale or the global locale, if no package private locale is set. .TP \fB::msgcat::mcpackagelocale preferences\fR ?\fIlocale preference\fR? ... . With no parameters, return the package private preferences or the global preferences, if no package private locale is set. The package locale state (set or not) is not changed (in contrast to the command \fB::msgcat::mcpackagelocale set\fR). .PP .RS .VS "TIP 499" If a set of locale preferences is given, it is set as package locale preference list. The package locale is set to the first element of the preference list. A package locale is activated, if it was not set so far. .PP Locale preferences are loaded now for the package, if not jet loaded. .VE "TIP 499" .RE .PP .TP \fB::msgcat::mcpackagelocale loaded\fR . Return the list of locales loaded for this package. .TP \fB::msgcat::mcpackagelocale isset\fR . |
︙ | ︙ | |||
484 485 486 487 488 489 490 | . Returns true, if the given locale is loaded for the package. .TP \fB::msgcat::mcpackagelocale clear\fR . Clear any loaded locales of the package not present in the package preferences. .PP | | | 588 589 590 591 592 593 594 595 596 597 598 599 600 601 602 | . Returns true, if the given locale is loaded for the package. .TP \fB::msgcat::mcpackagelocale clear\fR . Clear any loaded locales of the package not present in the package preferences. .PP .SH "CHANGING PACKAGE OPTIONS" .PP Each package using msgcat has a set of options within \fBmsgcat\fR. The package options are described in the next sectionPackage options. Each package option may be set or unset individually using the following ensemble: .TP \fB::msgcat::mcpackageconfig get\fR \fIoption\fR . |
︙ | ︙ | |||
559 560 561 562 563 564 565 | The called procedure must return the formatted message which will finally be returned by msgcat::mc. .PP A generic unknown handler is used if set to the empty string. This consists in returning the key if no arguments are given. With given arguments, format is used to process the arguments. .PP See section \fBcallback invocation\fR below. The appended arguments are identical to \fB::msgcat::mcunknown\fR. .RE | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | The called procedure must return the formatted message which will finally be returned by msgcat::mc. .PP A generic unknown handler is used if set to the empty string. This consists in returning the key if no arguments are given. With given arguments, format is used to process the arguments. .PP See section \fBcallback invocation\fR below. The appended arguments are identical to \fB::msgcat::mcunknown\fR. .RE .SH "Callback invocation" A package may decide to register one or multiple callbacks, as described above. .PP Callbacks are invoked, if: .PP 1. the callback command is set, .PP 2. the command is not the empty string, .PP 3. the registering namespace exists. .PP If a called routine fails with an error, the \fBbgerror\fR routine for the interpreter is invoked after command completion. Only exception is the callback \fBunknowncmd\fR, where an error causes the invoking \fBmc\fR-command to fail with that error. .PP .VS tip490 .SH "OBJECT ORIENTED PROGRAMMING" \fBmsgcat\fR supports packages implemented by object oriented programming. Objects and classes should be defined within a package namespace. .PP There are 3 supported cases where package namespace sensitive commands of msgcat (\fBmc\fR, \fBmcexists\fR, \fBmcpackagelocale\fR, \fBmcforgetpackage\fR, \fBmcpackagenamespaceget\fR, \fBmcpackageconfig\fR, \fBmcset\fR and \fBmcmset\fR) may be called: .PP .TP \fB1) In class definition script\fR . \fBmsgcat\fR command is called within a class definition script. .CS namespace eval ::N2 { mcload $dir/msgs oo::class create C1 {puts [mc Hi!]} } .CE .PP .TP \fB2) method defined in a class\fR . \fBmsgcat\fR command is called from a method in an object and the method is defined in a class. .CS namespace eval ::N3Class { mcload $dir/msgs oo::class create C1 oo::define C1 method m1 { puts [mc Hi!] } } .CE .PP .TP \fB3) method defined in a classless object\fR . \fBmsgcat\fR command is called from a method of a classless object. .CS namespace eval ::N4 { mcload $dir/msgs oo::object create O1 oo::objdefine O1 method m1 {} { puts [mc Hi!] } } .CE .PP .VE tip490 .SH EXAMPLES Packages which display a GUI may update their widgets when the global locale changes. To register to a callback, use: .CS namespace eval gui { msgcat::mcpackageconfig changecmd updateGUI proc updateGui args { |
︙ | ︙ | |||
639 640 641 642 643 644 645 | } .CE .VE "TIP 412" .SH CREDITS .PP The message catalog code was developed by Mark Harrison. .SH "SEE ALSO" | | | | 790 791 792 793 794 795 796 797 798 799 800 801 802 | } .CE .VE "TIP 412" .SH CREDITS .PP The message catalog code was developed by Mark Harrison. .SH "SEE ALSO" format(n), scan(n), namespace(n), package(n), oo::class(n), oo::object .SH KEYWORDS internationalization, i18n, localization, l10n, message, text, translation, class, object .\" Local Variables: .\" mode: nroff .\" End: |
Changes to doc/tclvars.n.
1 2 3 4 5 6 7 8 9 10 11 12 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH tclvars n 8.0 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | '\" '\" Copyright (c) 1993 The Regents of the University of California. '\" Copyright (c) 1994-1997 Sun Microsystems, Inc. '\" '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" .TH tclvars n 8.0 Tcl "Tcl Built-In Commands" .so man.macros .BS '\" Note: do not modify the .SH NAME line immediately below! .SH NAME argc, argv, argv0, auto_path, env, errorCode, errorInfo, tcl_interactive, tcl_library, tcl_nonwordchars, tcl_patchLevel, tcl_pkgPath, tcl_platform, tcl_rcFileName, tcl_traceCompile, tcl_traceExec, tcl_wordchars, tcl_version \- Variables used by Tcl .BE .SH DESCRIPTION .PP The following global variables are created and managed automatically by the Tcl library. Except where noted below, these variables should normally be treated as read-only by application-specific code and by users. .TP |
︙ | ︙ | |||
352 353 354 355 356 357 358 | .TP \fBwordSize\fR . This gives the size of the native-machine word in bytes (strictly, it is same as the result of evaluating \fIsizeof(long)\fR in C.) .RE .TP | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 352 353 354 355 356 357 358 359 360 361 362 363 364 365 | .TP \fBwordSize\fR . This gives the size of the native-machine word in bytes (strictly, it is same as the result of evaluating \fIsizeof(long)\fR in C.) .RE .TP \fBtcl_traceCompile\fR . The value of this variable can be set to control how much tracing information is displayed during bytecode compilation. By default, \fBtcl_traceCompile\fR is zero and no information is displayed. Setting \fBtcl_traceCompile\fR to 1 generates a one-line summary in \fBstdout\fR |
︙ | ︙ |
Changes to generic/tcl.decls.
︙ | ︙ | |||
102 103 104 105 106 107 108 | } declare 20 { void Tcl_DbIncrRefCount(Tcl_Obj *objPtr, const char *file, int line) } declare 21 { int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file, int line) } | | > | | < > | 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 | } declare 20 { void Tcl_DbIncrRefCount(Tcl_Obj *objPtr, const char *file, int line) } declare 21 { int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file, int line) } # Removed in 9.0 (changed to macro): #declare 22 { # Tcl_Obj *Tcl_DbNewBooleanObj(int boolValue, const char *file, int line) #} declare 23 { Tcl_Obj *Tcl_DbNewByteArrayObj(const unsigned char *bytes, int length, const char *file, int line) } declare 24 { Tcl_Obj *Tcl_DbNewDoubleObj(double doubleValue, const char *file, int line) } declare 25 { Tcl_Obj *Tcl_DbNewListObj(int objc, Tcl_Obj *const *objv, const char *file, int line) } # Removed in 9.0 (changed to macro): #declare 26 { # Tcl_Obj *Tcl_DbNewLongObj(long longValue, const char *file, int line) #} declare 27 { Tcl_Obj *Tcl_DbNewObj(const char *file, int line) } declare 28 { Tcl_Obj *Tcl_DbNewStringObj(const char *bytes, int length, const char *file, int line) } |
︙ | ︙ | |||
198 199 200 201 202 203 204 | int Tcl_ListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr, int *lengthPtr) } declare 48 { int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, int objc, Tcl_Obj *const objv[]) } | | > | | < > > | | < > | > | | < > > | | < > | 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 | int Tcl_ListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr, int *lengthPtr) } declare 48 { int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, int objc, Tcl_Obj *const objv[]) } # Removed in 9.0 (changed to macro): #declare 49 { # Tcl_Obj *Tcl_NewBooleanObj(int boolValue) #} declare 50 { Tcl_Obj *Tcl_NewByteArrayObj(const unsigned char *bytes, int length) } declare 51 { Tcl_Obj *Tcl_NewDoubleObj(double doubleValue) } # Removed in 9.0 (changed to macro): #declare 52 { # Tcl_Obj *Tcl_NewIntObj(int intValue) #} declare 53 { Tcl_Obj *Tcl_NewListObj(int objc, Tcl_Obj *const objv[]) } # Removed in 9.0 (changed to macro): #declare 54 { # Tcl_Obj *Tcl_NewLongObj(long longValue) #} declare 55 { Tcl_Obj *Tcl_NewObj(void) } declare 56 { Tcl_Obj *Tcl_NewStringObj(const char *bytes, int length) } # Removed in 9.0 (changed to macro): #declare 57 { # void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue) #} declare 58 { unsigned char *Tcl_SetByteArrayLength(Tcl_Obj *objPtr, int length) } declare 59 { void Tcl_SetByteArrayObj(Tcl_Obj *objPtr, const unsigned char *bytes, int length) } declare 60 { void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue) } # Removed in 9.0 (changed to macro): #declare 61 { # void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue) #} declare 62 { void Tcl_SetListObj(Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[]) } # Removed in 9.0 (changed to macro): #declare 63 { # void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue) #} declare 64 { void Tcl_SetObjLength(Tcl_Obj *objPtr, int length) } declare 65 { void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, int length) } # Removed in 9.0: |
︙ | ︙ | |||
288 289 290 291 292 293 294 | } declare 75 { int Tcl_AsyncReady(void) } declare 76 { void Tcl_BackgroundError(Tcl_Interp *interp) } | | | | 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 | } declare 75 { int Tcl_AsyncReady(void) } declare 76 { void Tcl_BackgroundError(Tcl_Interp *interp) } # Removed in 9.0: #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 { |
︙ | ︙ | |||
356 357 358 359 360 361 362 | } declare 93 { void Tcl_CreateExitHandler(Tcl_ExitProc *proc, ClientData clientData) } declare 94 { Tcl_Interp *Tcl_CreateInterp(void) } | > | | 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 | } declare 93 { void Tcl_CreateExitHandler(Tcl_ExitProc *proc, ClientData clientData) } declare 94 { Tcl_Interp *Tcl_CreateInterp(void) } # Removed in 9.0: #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, |
︙ | ︙ | |||
474 475 476 477 478 479 480 | declare 128 { const char *Tcl_ErrnoMsg(int err) } # Removed in 9.0: #declare 129 { # int Tcl_Eval(Tcl_Interp *interp, const char *script) #} | < | | < > | | 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 496 497 | declare 128 { const char *Tcl_ErrnoMsg(int err) } # Removed in 9.0: #declare 129 { # int Tcl_Eval(Tcl_Interp *interp, const char *script) #} declare 130 { int Tcl_EvalFile(Tcl_Interp *interp, const char *fileName) } # Removed in 9.0, replaced by macro. #declare 131 { # int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr) #} declare 132 { void Tcl_EventuallyFree(ClientData clientData, Tcl_FreeProc *freeProc) } declare 133 { |
︙ | ︙ | |||
645 646 647 648 649 650 651 | const char *Tcl_GetVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags) } # Removed in 9.0 #declare 177 { # int Tcl_GlobalEval(Tcl_Interp *interp, const char *command) #} | | | 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 | const char *Tcl_GetVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags) } # Removed in 9.0 #declare 177 { # int Tcl_GlobalEval(Tcl_Interp *interp, const char *command) #} # Removed in 9.0, replaced by macro. #declare 178 { # int Tcl_GlobalEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr) #} declare 179 { int Tcl_HideCommand(Tcl_Interp *interp, const char *cmdName, const char *hiddenCmdToken) } |
︙ | ︙ | |||
790 791 792 793 794 795 796 | } declare 218 { int Tcl_ScanElement(const char *src, int *flagPtr) } declare 219 { int Tcl_ScanCountedElement(const char *src, int length, int *flagPtr) } | | | 795 796 797 798 799 800 801 802 803 804 805 806 807 808 809 | } declare 218 { int Tcl_ScanElement(const char *src, int *flagPtr) } declare 219 { int Tcl_ScanCountedElement(const char *src, int length, int *flagPtr) } # Removed in 9.0: #declare 220 { # int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode) #} declare 221 { int Tcl_ServiceAll(void) } declare 222 { |
︙ | ︙ | |||
881 882 883 884 885 886 887 | 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) } | | | | 886 887 888 889 890 891 892 893 894 895 896 897 898 899 900 901 902 903 904 | 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) } # Removed in 9.0: #declare 246 { # int Tcl_TellOld(Tcl_Channel chan) #} # Removed in 9.0: #declare 247 { # int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, int flags, # Tcl_VarTraceProc *proc, ClientData clientData) #} declare 248 { int Tcl_TraceVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData) |
︙ | ︙ | |||
964 965 966 967 968 969 970 | } declare 265 { int Tcl_DumpActiveMemory(const char *fileName) } declare 266 { void Tcl_ValidateAllMemory(const char *file, int line) } | > | | < > > | | < > | 969 970 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 | } declare 265 { int Tcl_DumpActiveMemory(const char *fileName) } declare 266 { void Tcl_ValidateAllMemory(const char *file, int line) } # Removed in 9.0: #declare 267 { # void Tcl_AppendResultVA(Tcl_Interp *interp, va_list argList) #} # Removed in 9.0: #declare 268 { # 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) } |
︙ | ︙ | |||
998 999 1000 1001 1002 1003 1004 | } # TIP #268: The internally used new Require function is in slot 573. # Removed in 9.0, converted to macro #declare 274 { # const char *Tcl_PkgRequire(Tcl_Interp *interp, const char *name, # const char *version, int exact) #} | > | | < > | > | | < > | 1005 1006 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 | } # TIP #268: The internally used new Require function is in slot 573. # Removed in 9.0, converted to macro #declare 274 { # const char *Tcl_PkgRequire(Tcl_Interp *interp, const char *name, # const char *version, int exact) #} # Removed in 9.0: #declare 275 { # void Tcl_SetErrorCodeVA(Tcl_Interp *interp, va_list argList) #} # Removed in 9.0: #declare 276 { # int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList) #} declare 277 { Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options) } # Removed in 9.0: #declare 278 { # 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) } |
︙ | ︙ | |||
1240 1241 1242 1243 1244 1245 1246 | } declare 339 { int Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr) } declare 340 { char *Tcl_GetString(Tcl_Obj *objPtr) } | | | | | | 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 | } declare 339 { int Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr) } declare 340 { char *Tcl_GetString(Tcl_Obj *objPtr) } # Removed in 9.0: #declare 341 {deprecated {Use Tcl_GetEncodingSearchPath}} { # const char *Tcl_GetDefaultEncodingDir(void) #} # Removed in 9.0: #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) |
︙ | ︙ | |||
1280 1281 1282 1283 1284 1285 1286 | int Tcl_UniCharIsWordChar(int ch) } declare 352 { int Tcl_UniCharLen(const Tcl_UniChar *uniStr) } declare 353 { int Tcl_UniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, | | | | 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 | int Tcl_UniCharIsWordChar(int ch) } declare 352 { int Tcl_UniCharLen(const Tcl_UniChar *uniStr) } declare 353 { int Tcl_UniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned long numChars) } declare 354 { char *Tcl_UniCharToUtfDString(const Tcl_UniChar *uniStr, int uniLength, Tcl_DString *dsPtr) } declare 355 { 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) } # Removed in 9.0: #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 { |
︙ | ︙ | |||
1342 1343 1344 1345 1346 1347 1348 | declare 367 { int Tcl_Access(const char *path, int mode) } declare 368 { int Tcl_Stat(const char *path, struct stat *bufPtr) } declare 369 { | | | | 1351 1352 1353 1354 1355 1356 1357 1358 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 | declare 367 { int Tcl_Access(const char *path, int mode) } declare 368 { int Tcl_Stat(const char *path, struct stat *bufPtr) } declare 369 { int Tcl_UtfNcmp(const char *s1, const char *s2, unsigned long n) } declare 370 { int Tcl_UtfNcasecmp(const char *s1, const char *s2, unsigned long n) } declare 371 { int Tcl_StringCaseMatch(const char *str, const char *pattern, int nocase) } declare 372 { int Tcl_UniCharIsControl(int ch) } |
︙ | ︙ | |||
1516 1517 1518 1519 1520 1521 1522 | void Tcl_ClearChannelHandlers(Tcl_Channel channel) } declare 418 { int Tcl_IsChannelExisting(const char *channelName) } declare 419 { int Tcl_UniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, | | > > | 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 | void Tcl_ClearChannelHandlers(Tcl_Channel channel) } declare 418 { int Tcl_IsChannelExisting(const char *channelName) } declare 419 { int Tcl_UniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned long numChars) } declare 420 { int Tcl_UniCharCaseMatch(const Tcl_UniChar *uniStr, const Tcl_UniChar *uniPattern, int nocase) } # Removed in 9.0, as it is actually a macro: #declare 421 { # Tcl_HashEntry *Tcl_FindHashEntry(Tcl_HashTable *tablePtr, const void *key) #} # Removed in 9.0, as it is actually a macro: #declare 422 { # Tcl_HashEntry *Tcl_CreateHashEntry(Tcl_HashTable *tablePtr, # const void *key, int *newPtr) #} declare 423 { void Tcl_InitCustomHashTable(Tcl_HashTable *tablePtr, int keyType, const Tcl_HashKeyType *typePtr) |
︙ | ︙ | |||
1577 1578 1579 1580 1581 1582 1583 | # introduced in 8.4a3 declare 434 { Tcl_UniChar *Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr) } # TIP#15 (math function introspection) dkf | > | > | < | 1588 1589 1590 1591 1592 1593 1594 1595 1596 1597 1598 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 | # introduced in 8.4a3 declare 434 { Tcl_UniChar *Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr) } # TIP#15 (math function introspection) dkf # Removed in 9.0: #declare 435 {deprecated {}} { # int Tcl_GetMathFuncInfo(Tcl_Interp *interp, const char *name, # int *numArgsPtr, Tcl_ValueType **argTypesPtr, # Tcl_MathProc **procPtr, ClientData *clientDataPtr) #} # Removed in 9.0: #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) } # TIP#17 (virtual filesystem layer) vdarley declare 438 { |
︙ | ︙ | |||
1901 1902 1903 1904 1905 1906 1907 | declare 518 { int Tcl_FSEvalFileEx(Tcl_Interp *interp, Tcl_Obj *fileName, const char *encodingName) } # TIP#121 (exit handler) dkf for Joe Mistachkin declare 519 { | | | 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 | declare 518 { int Tcl_FSEvalFileEx(Tcl_Interp *interp, Tcl_Obj *fileName, const char *encodingName) } # TIP#121 (exit handler) dkf for Joe Mistachkin declare 519 { Tcl_ExitProc *Tcl_SetExitProc(TCL_NORETURN Tcl_ExitProc *proc) } # TIP#143 (resource limits) dkf declare 520 { void Tcl_LimitAddHandler(Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, ClientData clientData, Tcl_LimitHandlerDeleteProc *deleteProc) |
︙ | ︙ |
Changes to generic/tcl.h.
︙ | ︙ | |||
90 91 92 93 94 95 96 | * providing it for them rather than #include-ing it themselves as they * should, so also for their sake, we keep the #include to be consistent with * prior Tcl releases. */ #include <stdio.h> | < < < < < < < | 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 | * providing it for them rather than #include-ing it themselves as they * should, so also for their sake, we keep the #include to be consistent with * prior Tcl releases. */ #include <stdio.h> #if defined(__GNUC__) && (__GNUC__ > 2) # define TCL_FORMAT_PRINTF(a,b) __attribute__ ((__format__ (__printf__, a, b))) # define TCL_NORETURN __attribute__ ((noreturn)) # define TCL_NORETURN1 __attribute__ ((noreturn)) # define TCL_NOINLINE __attribute__ ((noinline)) #else # define TCL_FORMAT_PRINTF(a,b) # if defined(_MSC_VER) && (_MSC_VER >= 1310) # define TCL_NORETURN _declspec(noreturn) # define TCL_NOINLINE __declspec(noinline) # else # define TCL_NORETURN /* nothing */ # define TCL_NOINLINE /* nothing */ # endif #endif /* * Allow a part of Tcl's API to be explicitly marked as deprecated. * * Used to make TIP 330/336 generate moans even if people use the * compatibility macros. Change your code, guys! We won't support you forever. |
︙ | ︙ | |||
175 176 177 178 179 180 181 | /* * These macros are used to control whether functions are being declared for * import or export. If a function is being declared while it is being built * to be included in a shared library, then it should have the DLLEXPORT * storage class. If is being declared for use by a module that is going to * link against the shared library, then it should have the DLLIMPORT storage | | > > > > | 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 | /* * These macros are used to control whether functions are being declared for * import or export. If a function is being declared while it is being built * to be included in a shared library, then it should have the DLLEXPORT * storage class. If is being declared for use by a module that is going to * link against the shared library, then it should have the DLLIMPORT storage * class. If the symbol is being declared for a static build or for use from a * stub library, then the storage class should be empty. * * The convention is that a macro called BUILD_xxxx, where xxxx is the name of * a library we are building, is set on the compile line for sources that are * to be placed in the library. When this macro is set, the storage class will * be set to DLLEXPORT. At the end of the header file, the storage class will * be reset to DLLIMPORT. */ #ifdef BUILD_tcl # define TCLAPI extern DLLEXPORT #else # define TCLAPI extern DLLIMPORT #endif #if !defined(CONST86) && !defined(TCL_NO_DEPRECATED) # define CONST86 const #endif /* * Miscellaneous declarations. */ typedef void *ClientData; |
︙ | ︙ | |||
240 241 242 243 244 245 246 247 | * sprintf(...,"%" TCL_LL_MODIFIER "d",...). */ #if !defined(TCL_WIDE_INT_TYPE)&&!defined(TCL_WIDE_INT_IS_LONG) # if defined(_WIN32) # define TCL_WIDE_INT_TYPE __int64 # define TCL_LL_MODIFIER "I64" # elif defined(__GNUC__) | > > > < | | < < | | | | < | | | | < | < < | > | | | < | 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 | * sprintf(...,"%" TCL_LL_MODIFIER "d",...). */ #if !defined(TCL_WIDE_INT_TYPE)&&!defined(TCL_WIDE_INT_IS_LONG) # if defined(_WIN32) # define TCL_WIDE_INT_TYPE __int64 # define TCL_LL_MODIFIER "I64" # if defined(_WIN64) # define TCL_Z_MODIFIER "I" # endif # elif defined(__GNUC__) # define TCL_Z_MODIFIER "z" # else /* ! _WIN32 && ! __GNUC__ */ /* * Don't know what platform it is and configure hasn't discovered what is * going on for us. Try to guess... */ # include <limits.h> # if defined(LLONG_MAX) && (LLONG_MAX == LONG_MAX) # define TCL_WIDE_INT_IS_LONG 1 # endif # endif /* _WIN32 */ #endif /* !TCL_WIDE_INT_TYPE & !TCL_WIDE_INT_IS_LONG */ #ifndef TCL_WIDE_INT_TYPE # define TCL_WIDE_INT_TYPE long long #endif /* !TCL_WIDE_INT_TYPE */ typedef TCL_WIDE_INT_TYPE Tcl_WideInt; typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; #ifndef TCL_LL_MODIFIER # define TCL_LL_MODIFIER "ll" #endif /* !TCL_LL_MODIFIER */ #ifndef TCL_Z_MODIFIER # if defined(__GNUC__) && !defined(_WIN32) # define TCL_Z_MODIFIER "z" # else # define TCL_Z_MODIFIER "" # endif #endif /* !TCL_Z_MODIFIER */ #define Tcl_WideAsLong(val) ((long)((Tcl_WideInt)(val))) #define Tcl_LongAsWide(val) ((Tcl_WideInt)((long)(val))) #define Tcl_WideAsDouble(val) ((double)((Tcl_WideInt)(val))) #define Tcl_DoubleAsWide(val) ((Tcl_WideInt)((double)(val))) #if defined(_WIN32) # ifdef __BORLANDC__ |
︙ | ︙ | |||
502 503 504 505 506 507 508 | /* * 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; | < < | 495 496 497 498 499 500 501 502 503 504 505 506 507 508 | /* * 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, |
︙ | ︙ | |||
653 654 655 656 657 658 659 | void Tcl_IncrRefCount(Tcl_Obj *objPtr); void Tcl_DecrRefCount(Tcl_Obj *objPtr); int Tcl_IsShared(Tcl_Obj *objPtr); /* *---------------------------------------------------------------------------- | | | | 644 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 | void Tcl_IncrRefCount(Tcl_Obj *objPtr); void Tcl_DecrRefCount(Tcl_Obj *objPtr); int Tcl_IsShared(Tcl_Obj *objPtr); /* *---------------------------------------------------------------------------- * The following type contains the state needed by Tcl_SaveResult. It * is typically allocated on the stack. */ typedef Tcl_Obj *Tcl_SavedResult; /* *---------------------------------------------------------------------------- * The following definitions support Tcl's namespace facility. Note: the first |
︙ | ︙ | |||
785 786 787 788 789 790 791 | } Tcl_DString; #define Tcl_DStringLength(dsPtr) ((dsPtr)->length) #define Tcl_DStringValue(dsPtr) ((dsPtr)->string) /* * Definitions for the maximum number of digits of precision that may be | | | | 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 791 | } Tcl_DString; #define Tcl_DStringLength(dsPtr) ((dsPtr)->length) #define Tcl_DStringValue(dsPtr) ((dsPtr)->string) /* * Definitions for the maximum number of digits of precision that may be * produced by Tcl_PrintDouble, and the number of bytes of buffer space * required by Tcl_PrintDouble. */ #define TCL_MAX_PREC 17 #define TCL_DOUBLE_SPACE (TCL_MAX_PREC+10) /* * Definition for a number of bytes of buffer space sufficient to hold the |
︙ | ︙ | |||
953 954 955 956 957 958 959 | * should access any of these fields directly; use the macros defined below. */ struct Tcl_HashEntry { Tcl_HashEntry *nextPtr; /* Pointer to next entry in this hash bucket, * or NULL for end of chain. */ Tcl_HashTable *tablePtr; /* Pointer to table containing entry. */ | | | | 944 945 946 947 948 949 950 951 952 953 954 955 956 957 958 959 | * should access any of these fields directly; use the macros defined below. */ struct Tcl_HashEntry { Tcl_HashEntry *nextPtr; /* Pointer to next entry in this hash bucket, * or NULL for end of chain. */ Tcl_HashTable *tablePtr; /* Pointer to table containing entry. */ unsigned int hash; /* Hash value. */ ClientData clientData; /* Application stores something here with * Tcl_SetHashValue. */ union { /* Key has one of these forms: */ char *oneWordValue; /* One-word value for key. */ Tcl_Obj *objPtr; /* Tcl_Obj * key value. */ int words[1]; /* Multiple integer words for key. The actual * size will be as large as necessary for this * table's keys. */ |
︙ | ︙ | |||
1113 1114 1115 1116 1117 1118 1119 | * dictionaries. These fields should not be accessed by code outside * tclDictObj.c */ typedef struct { void *next; /* Search position for underlying hash * table. */ | | | 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 1116 1117 1118 | * dictionaries. These fields should not be accessed by code outside * tclDictObj.c */ typedef struct { void *next; /* Search position for underlying hash * table. */ unsigned int epoch; /* Epoch marker for dictionary being searched, * or 0 if search has terminated. */ Tcl_Dict dictionaryPtr; /* Reference to dictionary being searched. */ } Tcl_DictSearch; /* *---------------------------------------------------------------------------- * Flag values to pass to Tcl_DoOneEvent to disable searches for some kinds of |
︙ | ︙ | |||
2334 2335 2336 2337 2338 2339 2340 | 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__) | < < < | 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 | 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 |
︙ | ︙ |
Changes to generic/tclAlloc.c.
︙ | ︙ | |||
657 658 659 660 661 662 663 | fprintf(stderr, " %u", j); } totalFree += ((size_t)j) * (1 << (i + 3)); } fprintf(stderr, "\nused:\t"); for (i = 0; i < NBUCKETS; i++) { | | | | | | | 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 672 673 674 675 676 677 678 | fprintf(stderr, " %u", j); } totalFree += ((size_t)j) * (1 << (i + 3)); } fprintf(stderr, "\nused:\t"); for (i = 0; i < NBUCKETS; i++) { fprintf(stderr, " %" TCL_Z_MODIFIER "u", numMallocs[i]); totalUsed += numMallocs[i] * (1 << (i + 3)); } fprintf(stderr, "\n\tTotal small in use: %" TCL_Z_MODIFIER "u, total free: %" TCL_Z_MODIFIER "u\n", totalUsed, totalFree); fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %" TCL_Z_MODIFIER "u\n", MAXMALLOC, numMallocs[NBUCKETS]); Tcl_MutexUnlock(allocMutexPtr); } #endif #else /* !USE_TCLALLOC */ |
︙ | ︙ |
Changes to generic/tclAssembly.c.
︙ | ︙ | |||
402 403 404 405 406 407 408 | {"jump4", ASSEM_JUMP4, INST_JUMP4, 0, 0}, {"jumpFalse", ASSEM_JUMP, INST_JUMP_FALSE1, 1, 0}, {"jumpFalse4", ASSEM_JUMP4, INST_JUMP_FALSE4, 1, 0}, {"jumpTable", ASSEM_JUMPTABLE,INST_JUMP_TABLE, 1, 0}, {"jumpTrue", ASSEM_JUMP, INST_JUMP_TRUE1, 1, 0}, {"jumpTrue4", ASSEM_JUMP4, INST_JUMP_TRUE4, 1, 0}, {"label", ASSEM_LABEL, 0, 0, 0}, | < | 402 403 404 405 406 407 408 409 410 411 412 413 414 415 | {"jump4", ASSEM_JUMP4, INST_JUMP4, 0, 0}, {"jumpFalse", ASSEM_JUMP, INST_JUMP_FALSE1, 1, 0}, {"jumpFalse4", ASSEM_JUMP4, INST_JUMP_FALSE4, 1, 0}, {"jumpTable", ASSEM_JUMPTABLE,INST_JUMP_TABLE, 1, 0}, {"jumpTrue", ASSEM_JUMP, INST_JUMP_TRUE1, 1, 0}, {"jumpTrue4", ASSEM_JUMP4, INST_JUMP_TRUE4, 1, 0}, {"label", ASSEM_LABEL, 0, 0, 0}, {"lappend", ASSEM_LVT, (INST_LAPPEND_SCALAR1<<8 | INST_LAPPEND_SCALAR4), 1, 1}, {"lappendArray", ASSEM_LVT, (INST_LAPPEND_ARRAY1<<8 | INST_LAPPEND_ARRAY4),2, 1}, {"lappendArrayStk", ASSEM_1BYTE, INST_LAPPEND_ARRAY_STK, 3, 1}, {"lappendList", ASSEM_LVT4, INST_LAPPEND_LIST, 1, 1}, |
︙ | ︙ | |||
430 431 432 433 434 435 436 | {"listNotIn", ASSEM_1BYTE, INST_LIST_NOT_IN, 2, 1}, {"load", ASSEM_LVT, (INST_LOAD_SCALAR1 << 8 | INST_LOAD_SCALAR4), 0, 1}, {"loadArray", ASSEM_LVT, (INST_LOAD_ARRAY1<<8 | INST_LOAD_ARRAY4), 1, 1}, {"loadArrayStk", ASSEM_1BYTE, INST_LOAD_ARRAY_STK, 2, 1}, {"loadStk", ASSEM_1BYTE, INST_LOAD_STK, 1, 1}, | < | 429 430 431 432 433 434 435 436 437 438 439 440 441 442 | {"listNotIn", ASSEM_1BYTE, INST_LIST_NOT_IN, 2, 1}, {"load", ASSEM_LVT, (INST_LOAD_SCALAR1 << 8 | INST_LOAD_SCALAR4), 0, 1}, {"loadArray", ASSEM_LVT, (INST_LOAD_ARRAY1<<8 | INST_LOAD_ARRAY4), 1, 1}, {"loadArrayStk", ASSEM_1BYTE, INST_LOAD_ARRAY_STK, 2, 1}, {"loadStk", ASSEM_1BYTE, INST_LOAD_STK, 1, 1}, {"lsetFlat", ASSEM_LSET_FLAT,INST_LSET_FLAT, INT_MIN,1}, {"lsetList", ASSEM_1BYTE, INST_LSET_LIST, 3, 1}, {"lshift", ASSEM_1BYTE, INST_LSHIFT, 2, 1}, {"lt", ASSEM_1BYTE, INST_LT, 2, 1}, {"mod", ASSEM_1BYTE, INST_MOD, 2, 1}, {"mult", ASSEM_1BYTE, INST_MULT, 2, 1}, {"neq", ASSEM_1BYTE, INST_NEQ, 2, 1}, |
︙ | ︙ | |||
2242 2243 2244 2245 2246 2247 2248 | CompileEnv* envPtr = assemEnvPtr->envPtr; /* Compilation environment */ Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; /* Tcl interpreter */ Tcl_Token* tokenPtr = *tokenPtrPtr; /* INOUT: Pointer to the next token in the * source code */ | | | < < < | | | > > > | > > < | | 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 | CompileEnv* envPtr = assemEnvPtr->envPtr; /* Compilation environment */ Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; /* Tcl interpreter */ Tcl_Token* tokenPtr = *tokenPtrPtr; /* INOUT: Pointer to the next token in the * source code */ Tcl_Obj *value; int status; /* General operand validity check */ if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &value) != TCL_OK) { return TCL_ERROR; } /* Convert to an integer, advance to the next token and return. */ /* * NOTE: Indexing a list with an index before it yields the * same result as indexing after it, and might be more easily portable * when list size limits grow. */ status = TclIndexEncode(interp, value, TCL_INDEX_BEFORE,TCL_INDEX_BEFORE, result); Tcl_DecrRefCount(value); *tokenPtrPtr = TokenAfter(tokenPtr); return status; } /* *----------------------------------------------------------------------------- * |
︙ | ︙ | |||
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) { | | | 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 | 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.
︙ | ︙ | |||
102 103 104 105 106 107 108 109 110 111 112 113 114 115 | 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, | > > | 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 | 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, |
︙ | ︙ | |||
213 214 215 216 217 218 219 | {"lrange", Tcl_LrangeObjCmd, TclCompileLrangeCmd, NULL, CMD_IS_SAFE}, {"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, CMD_IS_SAFE}, {"lreverse", Tcl_LreverseObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lsearch", Tcl_LsearchObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, CMD_IS_SAFE}, {"lsort", Tcl_LsortObjCmd, NULL, NULL, CMD_IS_SAFE}, | | | 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 | {"lrange", Tcl_LrangeObjCmd, TclCompileLrangeCmd, NULL, CMD_IS_SAFE}, {"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, CMD_IS_SAFE}, {"lreverse", Tcl_LreverseObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lsearch", Tcl_LsearchObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, CMD_IS_SAFE}, {"lsort", Tcl_LsortObjCmd, NULL, NULL, CMD_IS_SAFE}, {"package", Tcl_PackageObjCmd, NULL, TclNRPackageObjCmd, CMD_IS_SAFE}, {"proc", Tcl_ProcObjCmd, NULL, NULL, CMD_IS_SAFE}, {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, CMD_IS_SAFE}, {"regsub", Tcl_RegsubObjCmd, TclCompileRegsubCmd, NULL, CMD_IS_SAFE}, {"rename", Tcl_RenameObjCmd, NULL, NULL, CMD_IS_SAFE}, {"return", Tcl_ReturnObjCmd, TclCompileReturnCmd, NULL, CMD_IS_SAFE}, {"scan", Tcl_ScanObjCmd, NULL, NULL, CMD_IS_SAFE}, {"set", Tcl_SetObjCmd, TclCompileSetCmd, NULL, CMD_IS_SAFE}, |
︙ | ︙ | |||
300 301 302 303 304 305 306 307 308 309 310 311 312 313 | { "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 }, | > > | 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 | { "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 }, |
︙ | ︙ | |||
776 777 778 779 780 781 782 783 784 785 786 787 788 789 | TclInitDictCmd(interp); TclInitEncodingCmd(interp); TclInitFileCmd(interp); TclInitInfoCmd(interp); TclInitNamespaceCmd(interp); TclInitStringCmd(interp); TclInitPrefixCmd(interp); /* * Register "clock" subcommands. These *do* go through * Tcl_CreateObjCommand, since they aren't in the global namespace and * involve ensembles. */ | > | 780 781 782 783 784 785 786 787 788 789 790 791 792 793 794 | TclInitDictCmd(interp); TclInitEncodingCmd(interp); TclInitFileCmd(interp); TclInitInfoCmd(interp); TclInitNamespaceCmd(interp); TclInitStringCmd(interp); TclInitPrefixCmd(interp); TclInitProcessCmd(interp); /* * Register "clock" subcommands. These *do* go through * Tcl_CreateObjCommand, since they aren't in the global namespace and * involve ensembles. */ |
︙ | ︙ | |||
913 914 915 916 917 918 919 | /* * Set up other variables such as tcl_version and tcl_library */ Tcl_SetVar(interp, "tcl_patchLevel", TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY); Tcl_SetVar(interp, "tcl_version", TCL_VERSION, TCL_GLOBAL_ONLY); | < < < | 918 919 920 921 922 923 924 925 926 927 928 929 930 931 | /* * Set up other variables such as tcl_version and tcl_library */ Tcl_SetVar(interp, "tcl_patchLevel", TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY); Tcl_SetVar(interp, "tcl_version", TCL_VERSION, TCL_GLOBAL_ONLY); 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 |
︙ | ︙ | |||
2047 2048 2049 2050 2051 2052 2053 | } else { nsPtr = iPtr->globalNsPtr; tail = cmdName; } hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &isNew); | | | | 2049 2050 2051 2052 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 | } 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 |
︙ | ︙ | |||
2194 2195 2196 2197 2198 2199 2200 | * 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. */ | | > < < < < < > | > > > > > > > > > > > > > | | > > > | > > > > > > > > > > > > > > > > > > > > > > > > < < < < < < < < < < < < < < < < < < < < | | | > > > > > > > < | 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 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 | * 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); /* * Command already exists; delete it. Be careful to preserve any * existing import links so we can restore them down below. That way, * you can redefine a command and its import status will remain * 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). */ |
︙ | ︙ | |||
2299 2300 2301 2302 2303 2304 2305 | * 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. */ | | | 2324 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 | * 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. */ |
︙ | ︙ | |||
2522 2523 2524 2525 2526 2527 2528 | 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; } | < < < < | < > > > > > | 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 | 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, |
︙ | ︙ | |||
3037 3038 3039 3040 3041 3042 3043 | return 0; } /* * We must delete this command, even though both traces and delete procs * may try to avoid this (renaming the command etc). Also traces and | | > > | 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 | return 0; } /* * We must delete this command, even though both traces and delete procs * may try to avoid this (renaming the command etc). Also traces and * delete procs may try to delete the command themselves. This flag * declares that a delete is in progress and that recursive deletes should * be ignored. */ 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. |
︙ | ︙ | |||
3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 | /* * 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 | > | 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 | /* * 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 |
︙ | ︙ | |||
4133 4134 4135 4136 4137 4138 4139 | Interp *iPtr = (Interp *) interp; int allowExceptions = (PTR2INT(data[0]) & TCL_ALLOW_EXCEPTIONS); if (result != TCL_OK) { if (result == TCL_RETURN) { result = TclUpdateReturnInfo(iPtr); } | | | 4161 4162 4163 4164 4165 4166 4167 4168 4169 4170 4171 4172 4173 4174 4175 | 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 |
︙ | ︙ | |||
5883 5884 5885 5886 5887 5888 5889 | Tcl_DecrRefCount(resultPtr); if (Tcl_InitBignumFromDouble(interp, d, &big) != TCL_OK) { return TCL_ERROR; } resultPtr = Tcl_NewBignumObj(&big); /* FALLTHROUGH */ } | < | 5911 5912 5913 5914 5915 5916 5917 5918 5919 5920 5921 5922 5923 5924 | 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); |
︙ | ︙ | |||
6180 6181 6182 6183 6184 6185 6186 | /* * 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) { | | | 6207 6208 6209 6210 6211 6212 6213 6214 6215 6216 6217 6218 6219 6220 6221 | /* * 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) { iPtr->errorInfo = iPtr->objResultPtr; Tcl_IncrRefCount(iPtr->errorInfo); if (!iPtr->errorCode) { Tcl_SetErrorCode(interp, "NONE", NULL); } } /* |
︙ | ︙ | |||
6658 6659 6660 6661 6662 6663 6664 | return TCL_ERROR; } if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { return TCL_ERROR; } | | | | | | | | | 6685 6686 6687 6688 6689 6690 6691 6692 6693 6694 6695 6696 6697 6698 6699 6700 6701 6702 6703 6704 6705 6706 6707 6708 6709 6710 6711 6712 6713 6714 6715 6716 6717 6718 6719 6720 | 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; |
︙ | ︙ | |||
6703 6704 6705 6706 6707 6708 6709 | } else if (d > -0.0) { goto unChanged; } Tcl_SetObjResult(interp, Tcl_NewDoubleObj(-d)); return TCL_OK; } | < < < < < < < < < < < < < < < < | | 6730 6731 6732 6733 6734 6735 6736 6737 6738 6739 6740 6741 6742 6743 6744 6745 | } else if (d > -0.0) { goto unChanged; } Tcl_SetObjResult(interp, Tcl_NewDoubleObj(-d)); return TCL_OK; } if (type == TCL_NUMBER_BIG) { if (mp_isneg((const mp_int *) ptr)) { Tcl_GetBignumFromObj(NULL, objv[1], &big); tooLarge: mp_neg(&big, &big); Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big)); } else { unChanged: Tcl_SetObjResult(interp, objv[1]); |
︙ | ︙ | |||
6914 6915 6916 6917 6918 6919 6920 6921 6922 6923 6924 6925 6926 6927 | 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. */ | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 6925 6926 6927 6928 6929 6930 6931 6932 6933 6934 6935 6936 6937 6938 6939 6940 6941 6942 6943 6944 6945 6946 6947 6948 6949 6950 6951 6952 6953 6954 6955 6956 6957 6958 6959 6960 6961 6962 6963 6964 6965 6966 6967 6968 6969 6970 6971 6972 6973 6974 6975 6976 6977 6978 6979 6980 6981 6982 6983 6984 6985 6986 6987 6988 6989 6990 6991 6992 6993 6994 6995 6996 6997 6998 6999 7000 7001 7002 7003 | 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. */ |
︙ | ︙ | |||
6938 6939 6940 6941 6942 6943 6944 | return TCL_ERROR; } if (!(iPtr->flags & RAND_SEED_INITIALIZED)) { iPtr->flags |= RAND_SEED_INITIALIZED; /* | > | < | 7014 7015 7016 7017 7018 7019 7020 7021 7022 7023 7024 7025 7026 7027 7028 7029 | 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. */ |
︙ | ︙ | |||
7400 7401 7402 7403 7404 7405 7406 7407 7408 7409 7410 7411 7412 7413 | 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 ****************************************************************************/ | > > > > > > > > > > > > > > > > | 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 | 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 ****************************************************************************/ |
︙ | ︙ | |||
8188 8189 8190 8191 8192 8193 8194 | ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Command *cmdPtr; CoroutineData *corPtr; | | | | < < < < < | | | | | | < < < < < < < < < < < < < < < | | < > | 8280 8281 8282 8283 8284 8285 8286 8287 8288 8289 8290 8291 8292 8293 8294 8295 8296 8297 8298 8299 8300 8301 8302 8303 8304 8305 8306 8307 8308 8309 8310 8311 8312 8313 8314 8315 8316 8317 8318 8319 8320 8321 8322 8323 8324 8325 8326 8327 8328 8329 8330 8331 8332 | 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 |
︙ | ︙ | |||
8307 8308 8309 8310 8311 8312 8313 | corPtr->callerEEPtr = iPtr->execEnvPtr; RESTORE_CONTEXT(corPtr->running); iPtr->execEnvPtr = corPtr->eePtr; TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr, NULL, NULL, NULL); | | | 8379 8380 8381 8382 8383 8384 8385 8386 8387 8388 8389 8390 8391 8392 8393 | corPtr->callerEEPtr = iPtr->execEnvPtr; RESTORE_CONTEXT(corPtr->running); iPtr->execEnvPtr = corPtr->eePtr; TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr, NULL, NULL, NULL); /* ensure that the command is looked up in the correct namespace */ iPtr->lookupNsPtr = lookupNsPtr; Tcl_NREvalObj(interp, Tcl_NewListObj(objc-2, objv+2), 0); iPtr->numLevels--; SAVE_CONTEXT(corPtr->running); RESTORE_CONTEXT(corPtr->caller); iPtr->execEnvPtr = corPtr->callerEEPtr; |
︙ | ︙ |
Changes to generic/tclBinary.c.
︙ | ︙ | |||
2454 2455 2456 2457 2458 2459 2460 | static const char *const optStrings[] = { "-strict", NULL }; if (objc < 2 || objc > 3) { Tcl_WrongNumArgs(interp, 1, objv, "?options? data"); return TCL_ERROR; } for (i = 1; i < objc-1; ++i) { | | | | 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 2469 | static const char *const optStrings[] = { "-strict", NULL }; if (objc < 2 || objc > 3) { Tcl_WrongNumArgs(interp, 1, objv, "?options? data"); return TCL_ERROR; } for (i = 1; i < objc-1; ++i) { if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option", TCL_EXACT, &index) != TCL_OK) { return TCL_ERROR; } switch (index) { case OPT_STRICT: strict = 1; break; } |
︙ | ︙ | |||
2576 2577 2578 2579 2580 2581 2582 | if (objc < 2 || objc%2 != 0) { Tcl_WrongNumArgs(interp, 1, objv, "?-maxlen len? ?-wrapchar char? data"); return TCL_ERROR; } for (i = 1; i < objc-1; i += 2) { | | | | 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 | if (objc < 2 || objc%2 != 0) { Tcl_WrongNumArgs(interp, 1, objv, "?-maxlen len? ?-wrapchar char? data"); return TCL_ERROR; } for (i = 1; i < objc-1; i += 2) { if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option", TCL_EXACT, &index) != TCL_OK) { return TCL_ERROR; } switch (index) { case OPT_MAXLEN: if (Tcl_GetIntFromObj(interp, objv[i+1], &maxlen) != TCL_OK) { return TCL_ERROR; } |
︙ | ︙ | |||
2796 2797 2798 2799 2800 2801 2802 | static const char *const optStrings[] = { "-strict", NULL }; if (objc < 2 || objc > 3) { Tcl_WrongNumArgs(interp, 1, objv, "?options? data"); return TCL_ERROR; } for (i = 1; i < objc-1; ++i) { | | | | 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 | static const char *const optStrings[] = { "-strict", NULL }; if (objc < 2 || objc > 3) { Tcl_WrongNumArgs(interp, 1, objv, "?options? data"); return TCL_ERROR; } for (i = 1; i < objc-1; ++i) { if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option", TCL_EXACT, &index) != TCL_OK) { return TCL_ERROR; } switch (index) { case OPT_STRICT: strict = 1; break; } |
︙ | ︙ | |||
2960 2961 2962 2963 2964 2965 2966 | static const char *const optStrings[] = { "-strict", NULL }; if (objc < 2 || objc > 3) { Tcl_WrongNumArgs(interp, 1, objv, "?options? data"); return TCL_ERROR; } for (i = 1; i < objc-1; ++i) { | | | | 2960 2961 2962 2963 2964 2965 2966 2967 2968 2969 2970 2971 2972 2973 2974 2975 | static const char *const optStrings[] = { "-strict", NULL }; if (objc < 2 || objc > 3) { Tcl_WrongNumArgs(interp, 1, objv, "?options? data"); return TCL_ERROR; } for (i = 1; i < objc-1; ++i) { if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option", TCL_EXACT, &index) != TCL_OK) { return TCL_ERROR; } switch (index) { case OPT_STRICT: strict = 1; break; } |
︙ | ︙ |
Changes to generic/tclCkalloc.c.
︙ | ︙ | |||
183 184 185 186 187 188 189 | if (clientData == NULL) { return 0; } sprintf(buf, "total mallocs %10u\n" "total frees %10u\n" "current packets allocated %10u\n" | | | | | | 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205 | if (clientData == NULL) { return 0; } sprintf(buf, "total mallocs %10u\n" "total frees %10u\n" "current packets allocated %10u\n" "current bytes allocated %10" TCL_Z_MODIFIER "u\n" "maximum packets allocated %10u\n" "maximum bytes allocated %10" TCL_Z_MODIFIER "u\n", total_mallocs, total_frees, current_malloc_packets, current_bytes_malloced, maximum_malloc_packets, maximum_bytes_malloced); if (flags == 0) { fprintf((FILE *)clientData, "%s", buf); } else { /* Assume objPtr to append to */ Tcl_AppendToObj((Tcl_Obj *) clientData, buf, -1); } return 1; |
︙ | ︙ | |||
250 251 252 253 254 255 256 | } } if (guard_failed) { TclDumpMemoryInfo((ClientData) stderr, 0); fprintf(stderr, "low guard failed at %p, %s %d\n", memHeaderP->body, file, line); fflush(stderr); /* In case name pointer is bad. */ | | | 250 251 252 253 254 255 256 257 258 259 260 261 262 263 264 | } } if (guard_failed) { TclDumpMemoryInfo((ClientData) stderr, 0); fprintf(stderr, "low guard failed at %p, %s %d\n", memHeaderP->body, file, line); fflush(stderr); /* In case name pointer is bad. */ fprintf(stderr, "%" TCL_Z_MODIFIER "u bytes allocated at (%s %d)\n", memHeaderP->length, memHeaderP->file, memHeaderP->line); Tcl_Panic("Memory validation failure"); } hiPtr = (unsigned char *)memHeaderP->body + memHeaderP->length; for (idx = 0; idx < HIGH_GUARD_SIZE; idx++) { byte = *(hiPtr + idx); |
︙ | ︙ | |||
272 273 274 275 276 277 278 | } if (guard_failed) { TclDumpMemoryInfo((ClientData) stderr, 0); fprintf(stderr, "high guard failed at %p, %s %d\n", memHeaderP->body, file, line); fflush(stderr); /* In case name pointer is bad. */ | | | | 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 | } if (guard_failed) { TclDumpMemoryInfo((ClientData) stderr, 0); fprintf(stderr, "high guard failed at %p, %s %d\n", memHeaderP->body, file, line); fflush(stderr); /* In case name pointer is bad. */ fprintf(stderr, "%" TCL_Z_MODIFIER "u bytes allocated at (%s %d)\n", memHeaderP->length, memHeaderP->file, memHeaderP->line); Tcl_Panic("Memory validation failure"); } if (nukeGuards) { memset(memHeaderP->low_guard, 0, LOW_GUARD_SIZE); memset(hiPtr, 0, HIGH_GUARD_SIZE); |
︙ | ︙ | |||
355 356 357 358 359 360 361 | return TCL_ERROR; } } Tcl_MutexLock(ckallocMutexPtr); for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) { address = &memScanP->body[0]; | | | | 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 | return TCL_ERROR; } } Tcl_MutexLock(ckallocMutexPtr); for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) { address = &memScanP->body[0]; fprintf(fileP, "%p - %p %" TCL_Z_MODIFIER "u @ %s %d %s", address, address + memScanP->length - 1, memScanP->length, memScanP->file, memScanP->line, (memScanP->tagPtr == NULL) ? "" : memScanP->tagPtr->string); (void) fputc('\n', fileP); } Tcl_MutexUnlock(ckallocMutexPtr); if (fileP != stderr) { fclose(fileP); |
︙ | ︙ | |||
607 608 609 610 611 612 613 | * such as Crays (will subtract only bytes, even though BODY_OFFSET is in * words on these machines). */ memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET); if (alloc_tracing) { | | | | 607 608 609 610 611 612 613 614 615 616 617 618 619 620 621 622 | * such as Crays (will subtract only bytes, even though BODY_OFFSET is in * words on these machines). */ memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET); if (alloc_tracing) { fprintf(stderr, "ckfree %p %" TCL_Z_MODIFIER "u %s %d\n", memp->body, memp->length, file, line); } if (validate_memory) { Tcl_ValidateAllMemory(file, line); } Tcl_MutexLock(ckallocMutexPtr); |
︙ | ︙ | |||
855 856 857 858 859 860 861 | return TCL_ERROR; } break_on_malloc = (unsigned int) value; return TCL_OK; } if (strcmp(argv[1],"info") == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( | | | | | 855 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 871 872 873 874 | return TCL_ERROR; } break_on_malloc = (unsigned int) value; return TCL_OK; } if (strcmp(argv[1],"info") == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "%-25s %10u\n%-25s %10u\n%-25s %10u\n%-25s %10" TCL_Z_MODIFIER"u\n%-25s %10u\n%-25s %10" TCL_Z_MODIFIER "u\n", "total mallocs", total_mallocs, "total frees", total_frees, "current packets allocated", current_malloc_packets, "current bytes allocated", current_bytes_malloced, "maximum packets allocated", maximum_malloc_packets, "maximum bytes allocated", maximum_bytes_malloced)); return TCL_OK; } if (strcmp(argv[1], "init") == 0) { if (argc != 3) { goto bad_suboption; } init_malloced_bodies = (strcmp(argv[2],"on") == 0); |
︙ | ︙ |
Changes to generic/tclCmdAH.c.
︙ | ︙ | |||
409 410 411 412 413 414 415 | ENC_CONVERTFROM, ENC_CONVERTTO, ENC_DIRS, ENC_NAMES, ENC_SYSTEM }; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); return TCL_ERROR; } | | | | 409 410 411 412 413 414 415 416 417 418 419 420 421 422 423 424 | ENC_CONVERTFROM, ENC_CONVERTTO, ENC_DIRS, ENC_NAMES, ENC_SYSTEM }; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum options) index) { case ENC_CONVERTTO: return EncodingConverttoObjCmd(dummy, interp, objc, objv); case ENC_CONVERTFROM: |
︙ | ︙ |
Changes to generic/tclCmdIL.c.
︙ | ︙ | |||
60 61 62 63 64 65 66 | int isIncreasing; /* Nonzero means sort in increasing order. */ int sortMode; /* The sort mode. One of SORTMODE_* values * defined below. */ Tcl_Obj *compareCmdPtr; /* The Tcl comparison command when sortMode is * SORTMODE_COMMAND. Pre-initialized to hold * base of command. */ int *indexv; /* If the -index option was specified, this | | | > | 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 | int isIncreasing; /* Nonzero means sort in increasing order. */ int sortMode; /* The sort mode. One of SORTMODE_* values * defined below. */ Tcl_Obj *compareCmdPtr; /* The Tcl comparison command when sortMode is * SORTMODE_COMMAND. Pre-initialized to hold * base of command. */ int *indexv; /* If the -index option was specified, this * holds an encoding of the indexes contained * in the list supplied as an argument to * that option. * NULL if no indexes supplied, and points to * singleIndex field when only one * supplied. */ int indexc; /* Number of indexes in indexv array. */ int singleIndex; /* Static space for common index case. */ int unique; int numElements; |
︙ | ︙ | |||
88 89 90 91 92 93 94 | #define SORTMODE_ASCII 0 #define SORTMODE_INTEGER 1 #define SORTMODE_REAL 2 #define SORTMODE_COMMAND 3 #define SORTMODE_DICTIONARY 4 #define SORTMODE_ASCII_NC 8 | < < < < < < < < | 89 90 91 92 93 94 95 96 97 98 99 100 101 102 | #define SORTMODE_ASCII 0 #define SORTMODE_INTEGER 1 #define SORTMODE_REAL 2 #define SORTMODE_COMMAND 3 #define SORTMODE_DICTIONARY 4 #define SORTMODE_ASCII_NC 8 /* * Forward declarations for procedures defined in this file: */ static int DictionaryCompare(const char *left, const char *right); static Tcl_NRPostProc IfConditionCallback; static int InfoArgsCmd(ClientData dummy, Tcl_Interp *interp, |
︙ | ︙ | |||
2156 2157 2158 2159 2160 2161 2162 | int Tcl_JoinObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { | | | 2149 2150 2151 2152 2153 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 | int Tcl_JoinObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { int length, listLen; Tcl_Obj *resObjPtr = NULL, *joinObjPtr, **elemPtrs; if ((objc < 2) || (objc > 3)) { Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?"); return TCL_ERROR; } |
︙ | ︙ | |||
2187 2188 2189 2190 2191 2192 2193 | Tcl_SetObjResult(interp, elemPtrs[0]); return TCL_OK; } joinObjPtr = (objc == 2) ? Tcl_NewStringObj(" ", 1) : objv[2]; Tcl_IncrRefCount(joinObjPtr); | > | | < | 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 | Tcl_SetObjResult(interp, elemPtrs[0]); return TCL_OK; } joinObjPtr = (objc == 2) ? Tcl_NewStringObj(" ", 1) : objv[2]; Tcl_IncrRefCount(joinObjPtr); (void) Tcl_GetStringFromObj(joinObjPtr, &length); if (length == 0) { resObjPtr = TclStringCat(interp, listLen, elemPtrs, 0); } else { int i; resObjPtr = Tcl_NewObj(); for (i = 0; i < listLen; i++) { if (i > 0) { |
︙ | ︙ | |||
2783 2784 2785 2786 2787 2788 2789 | /* * Complain if the user asked for a start element that is greater than the * list length. This won't ever trigger for the "end-*" case as that will * be properly constrained by TclGetIntForIndex because we use listLen-1 * (to allow for replacing the last elem). */ | | | 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 | /* * Complain if the user asked for a start element that is greater than the * list length. This won't ever trigger for the "end-*" case as that will * be properly constrained by TclGetIntForIndex because we use listLen-1 * (to allow for replacing the last elem). */ if ((first >= listLen) && (listLen > 0)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "list doesn't contain element %s", TclGetString(objv[2]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LREPLACE", "BADIDX", NULL); return TCL_ERROR; } if (last >= listLen) { |
︙ | ︙ | |||
2934 2935 2936 2937 2938 2939 2940 | Tcl_LsearchObjCmd( ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument values. */ { const char *bytes, *patternBytes; | | > | | | | > | > | | < < < | 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 2998 2999 3000 3001 3002 | Tcl_LsearchObjCmd( ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument values. */ { const char *bytes, *patternBytes; int i, match, index, result=TCL_OK, listc, length, elemLen, bisect; int allocatedIndexVector = 0; int dataType, isIncreasing, lower, upper, start, groupSize, groupOffset; 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", "-stride", "-subindices", NULL }; enum options { LSEARCH_ALL, LSEARCH_ASCII, LSEARCH_BISECT, LSEARCH_DECREASING, LSEARCH_DICTIONARY, LSEARCH_EXACT, LSEARCH_GLOB, LSEARCH_INCREASING, LSEARCH_INDEX, LSEARCH_INLINE, LSEARCH_INTEGER, LSEARCH_NOCASE, LSEARCH_NOT, LSEARCH_REAL, LSEARCH_REGEXP, LSEARCH_SORTED, LSEARCH_START, LSEARCH_STRIDE, LSEARCH_SUBINDICES }; enum datatypes { ASCII, DICTIONARY, INTEGER, REAL }; enum modes { EXACT, GLOB, REGEXP, SORTED }; enum modes mode; mode = GLOB; dataType = ASCII; isIncreasing = 1; allMatches = 0; inlineReturn = 0; returnSubindices = 0; negatedMatch = 0; bisect = 0; listPtr = NULL; startPtr = NULL; groupSize = 1; groupOffset = 0; start = 0; noCase = 0; sortInfo.compareCmdPtr = NULL; sortInfo.isIncreasing = 1; sortInfo.sortMode = 0; sortInfo.interp = interp; sortInfo.resultCode = TCL_OK; sortInfo.indexv = NULL; sortInfo.indexc = 0; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "?-option value ...? list pattern"); return TCL_ERROR; } for (i = 1; i < objc-2; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) != TCL_OK) { result = TCL_ERROR; goto done; } switch ((enum options) index) { case LSEARCH_ALL: /* -all */ allMatches = 1; break; |
︙ | ︙ | |||
3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 | /* * If there was a previous -start option, release its saved index * because it will either be replaced or there will be an error. */ if (startPtr != NULL) { Tcl_DecrRefCount(startPtr); } if (i > objc-4) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing starting index", -1)); Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); result = TCL_ERROR; goto done; } i++; if (objv[i] == objv[objc - 2]) { /* * Take copy to prevent shimmering problems. Note that it does * not matter if the index obj is also a component of the list * being searched. We only need to copy where the list and the * index are one-and-the-same. */ startPtr = Tcl_DuplicateObj(objv[i]); } else { startPtr = objv[i]; | > > | > > > > > > > > > > > > > > > > > > > > > > | > < < < | > < < < | > > > > | | > > > > > > > > > > > > < > < < < | > | > | 3053 3054 3055 3056 3057 3058 3059 3060 3061 3062 3063 3064 3065 3066 3067 3068 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 3083 3084 3085 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 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 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 | /* * If there was a previous -start option, release its saved index * because it will either be replaced or there will be an error. */ if (startPtr != NULL) { Tcl_DecrRefCount(startPtr); startPtr = NULL; } if (i > objc-4) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing starting index", -1)); Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); result = TCL_ERROR; goto done; } i++; if (objv[i] == objv[objc - 2]) { /* * Take copy to prevent shimmering problems. Note that it does * not matter if the index obj is also a component of the list * being searched. We only need to copy where the list and the * index are one-and-the-same. */ startPtr = Tcl_DuplicateObj(objv[i]); } else { startPtr = objv[i]; } Tcl_IncrRefCount(startPtr); break; case LSEARCH_STRIDE: /* -stride */ if (i > objc-4) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-stride\" option must be " "followed by stride length", -1)); Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); result = TCL_ERROR; goto done; } if (Tcl_GetIntFromObj(interp, objv[i+1], &groupSize) != TCL_OK) { result = TCL_ERROR; goto done; } if (groupSize < 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "stride length must be at least 1", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", "BADSTRIDE", NULL); result = TCL_ERROR; goto done; } i++; break; case LSEARCH_INDEX: { /* -index */ Tcl_Obj **indices; int j; if (allocatedIndexVector) { TclStackFree(interp, sortInfo.indexv); allocatedIndexVector = 0; } if (i > objc-4) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-index\" option must be followed by list index", -1)); Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); result = TCL_ERROR; goto done; } /* * Store the extracted indices for processing by sublist * extraction. Note that we don't do this using objects because * that has shimmering problems. */ i++; if (TclListObjGetElements(interp, objv[i], &sortInfo.indexc, &indices) != TCL_OK) { result = TCL_ERROR; goto done; } switch (sortInfo.indexc) { case 0: sortInfo.indexv = NULL; break; case 1: sortInfo.indexv = &sortInfo.singleIndex; break; default: sortInfo.indexv = TclStackAlloc(interp, sizeof(int) * sortInfo.indexc); allocatedIndexVector = 1; /* Cannot use indexc field, as it * might be decreased by 1 later. */ } /* * Fill the array by parsing each index. We don't know whether * their scale is sensible yet, but we at least perform the * syntactic check here. */ for (j=0 ; j<sortInfo.indexc ; j++) { int encoded = 0; if (TclIndexEncode(interp, indices[j], TCL_INDEX_BEFORE, TCL_INDEX_AFTER, &encoded) != TCL_OK) { result = TCL_ERROR; } if ((encoded == TCL_INDEX_BEFORE) || (encoded == TCL_INDEX_AFTER)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "index \"%s\" cannot select an element " "from any list", Tcl_GetString(indices[j]))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX" "OUTOFRANGE", NULL); result = TCL_ERROR; } if (result == TCL_ERROR) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (-index option item number %d)", j)); goto done; } sortInfo.indexv[j] = encoded; } break; } } } /* * Subindices only make sense if asked for with -index option set. */ if (returnSubindices && sortInfo.indexc==0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "-subindices cannot be used without -index option", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", "BAD_OPTION_MIX", NULL); result = TCL_ERROR; goto done; } if (bisect && (allMatches || negatedMatch)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "-bisect is not compatible with -all or -not", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", "BAD_OPTION_MIX", NULL); result = TCL_ERROR; goto done; } if (mode == REGEXP) { /* * We can shimmer regexp/list if listv[i] == pattern, so get the * regexp rep before the list rep. First time round, omit the interp * and hope that the compilation will succeed. If it fails, we'll |
︙ | ︙ | |||
3193 3194 3195 3196 3197 3198 3199 | */ regexp = Tcl_GetRegExpFromObj(interp, objv[objc - 1], TCL_REG_ADVANCED | (noCase ? TCL_REG_NOCASE : 0)); } if (regexp == NULL) { | < < < > > | > > > > | > > > > > > > > > > > > > > > > > > > > > > > | | > > > > > > > > > > > > | < | | | < < < > > | > > > > > > | 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 3285 3286 3287 3288 3289 3290 3291 3292 3293 3294 3295 3296 3297 3298 3299 3300 3301 3302 3303 3304 3305 3306 3307 3308 3309 3310 3311 3312 3313 3314 3315 3316 3317 3318 3319 3320 3321 3322 3323 3324 3325 3326 | */ regexp = Tcl_GetRegExpFromObj(interp, objv[objc - 1], TCL_REG_ADVANCED | (noCase ? TCL_REG_NOCASE : 0)); } if (regexp == NULL) { result = TCL_ERROR; goto done; } } /* * Make sure the list argument is a list object and get its length and a * pointer to its array of element pointers. */ result = TclListObjGetElements(interp, objv[objc - 2], &listc, &listv); if (result != TCL_OK) { goto done; } /* * Check for sanity when grouping elements of the overall list together * because of the -stride option. [TIP #351] */ if (groupSize > 1) { if (listc % groupSize) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "list size must be a multiple of the stride length", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", "BADSTRIDE", NULL); result = TCL_ERROR; goto done; } if (sortInfo.indexc > 0) { /* * Use the first value in the list supplied to -index as the * offset of the element within each group by which to sort. */ groupOffset = TclIndexDecode(sortInfo.indexv[0], groupSize - 1); if (groupOffset < 0 || groupOffset >= groupSize) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "when used with \"-stride\", the leading \"-index\"" " value must be within the group", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", "BADINDEX", NULL); result = TCL_ERROR; goto done; } if (sortInfo.indexc == 1) { sortInfo.indexc = 0; sortInfo.indexv = NULL; } else { sortInfo.indexc--; for (i = 0; i < sortInfo.indexc; i++) { sortInfo.indexv[i] = sortInfo.indexv[i+1]; } } } } /* * Get the user-specified start offset. */ if (startPtr) { result = TclGetIntForIndexM(interp, startPtr, listc-1, &start); if (result != TCL_OK) { goto done; } if (start < 0) { start = 0; } /* * If the search started past the end of the list, we just return a * "did not match anything at all" result straight away. [Bug 1374778] */ if (start > listc-1) { if (allMatches || inlineReturn) { Tcl_ResetResult(interp); } else { Tcl_SetObjResult(interp, Tcl_NewIntObj(-1)); } goto done; } /* * If start points within a group, it points to the start of the group. */ if (groupSize > 1) { start -= (start % groupSize); } } patObj = objv[objc - 1]; patternBytes = NULL; if (mode == EXACT || mode == SORTED) { switch ((enum datatypes) dataType) { |
︙ | ︙ | |||
3301 3302 3303 3304 3305 3306 3307 | /* * If the data is sorted, we can do a more intelligent search. Note * that there is no point in being smart when -all was specified; in * that case, we have to look at all items anyway, and there is no * sense in doing this when the match sense is inverted. */ | > > > > | | > | | | 3371 3372 3373 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 3389 3390 3391 3392 3393 3394 3395 3396 3397 3398 3399 3400 3401 | /* * If the data is sorted, we can do a more intelligent search. Note * that there is no point in being smart when -all was specified; in * that case, we have to look at all items anyway, and there is no * sense in doing this when the match sense is inverted. */ /* * With -stride, lower, upper and i are kept as multiples of groupSize. */ lower = start - groupSize; upper = listc; while (lower + groupSize != upper && sortInfo.resultCode == TCL_OK) { i = (lower + upper)/2; i -= i % groupSize; if (sortInfo.indexc != 0) { itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo); if (sortInfo.resultCode != TCL_OK) { result = sortInfo.resultCode; goto done; } } else { itemPtr = listv[i+groupOffset]; } switch ((enum datatypes) dataType) { case ASCII: bytes = TclGetString(itemPtr); match = strCmpFn(patternBytes, bytes); break; case DICTIONARY: |
︙ | ︙ | |||
3401 3402 3403 3404 3405 3406 3407 | * - our matching sense is negated * - we're building a list of all matched items */ if (allMatches) { listPtr = Tcl_NewListObj(0, NULL); } | | | | | 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 | * - our matching sense is negated * - we're building a list of all matched items */ if (allMatches) { listPtr = Tcl_NewListObj(0, NULL); } for (i = start; i < listc; i += groupSize) { match = 0; if (sortInfo.indexc != 0) { itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo); if (sortInfo.resultCode != TCL_OK) { if (listPtr != NULL) { Tcl_DecrRefCount(listPtr); } result = sortInfo.resultCode; goto done; } } else { itemPtr = listv[i+groupOffset]; } switch (mode) { case SORTED: case EXACT: switch ((enum datatypes) dataType) { case ASCII: |
︙ | ︙ | |||
3503 3504 3505 3506 3507 3508 3509 | break; } else if (inlineReturn) { /* * Note that these appends are not expected to fail. */ if (returnSubindices && (sortInfo.indexc != 0)) { | | > > > > > < | > | | | | | | > > > > > > | > | > > > | 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 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 | break; } else if (inlineReturn) { /* * Note that these appends are not expected to fail. */ if (returnSubindices && (sortInfo.indexc != 0)) { itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo); Tcl_ListObjAppendElement(interp, listPtr, itemPtr); } else if (groupSize > 1) { Tcl_ListObjReplace(interp, listPtr, LIST_MAX, 0, groupSize, &listv[i]); } else { itemPtr = listv[i]; Tcl_ListObjAppendElement(interp, listPtr, itemPtr); } } else if (returnSubindices) { int j; itemPtr = Tcl_NewIntObj(i+groupOffset); for (j=0 ; j<sortInfo.indexc ; j++) { Tcl_ListObjAppendElement(interp, itemPtr, Tcl_NewIntObj( TclIndexDecode(sortInfo.indexv[j], listc))); } Tcl_ListObjAppendElement(interp, listPtr, itemPtr); } else { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewIntObj(i)); } } } /* * Return everything or a single value. */ if (allMatches) { Tcl_SetObjResult(interp, listPtr); } else if (!inlineReturn) { if (returnSubindices) { int j; itemPtr = Tcl_NewIntObj(index+groupOffset); for (j=0 ; j<sortInfo.indexc ; j++) { Tcl_ListObjAppendElement(interp, itemPtr, Tcl_NewIntObj( TclIndexDecode(sortInfo.indexv[j], listc))); } Tcl_SetObjResult(interp, itemPtr); } else { Tcl_SetObjResult(interp, Tcl_NewIntObj(index)); } } else if (index < 0) { /* * Is this superfluous? The result should be a blank object by * default... */ Tcl_SetObjResult(interp, Tcl_NewObj()); } else { if (returnSubindices) { Tcl_SetObjResult(interp, SelectObjFromSublist(listv[i+groupOffset], &sortInfo)); } else if (groupSize > 1) { Tcl_SetObjResult(interp, Tcl_NewListObj(groupSize, &listv[index])); } else { Tcl_SetObjResult(interp, listv[index]); } } result = TCL_OK; /* * Cleanup the index list array. */ done: if (startPtr != NULL) { Tcl_DecrRefCount(startPtr); } if (allocatedIndexVector) { TclStackFree(interp, sortInfo.indexv); } return result; } /* *---------------------------------------------------------------------- |
︙ | ︙ | |||
3721 3722 3723 3724 3725 3726 3727 | cmdPtr = NULL; indices = 0; group = 0; groupSize = 1; groupOffset = 0; indexPtr = NULL; for (i = 1; i < objc-1; i++) { | | | | 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 | cmdPtr = NULL; indices = 0; group = 0; groupSize = 1; groupOffset = 0; indexPtr = NULL; for (i = 1; i < objc-1; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], switches, "option", 0, &index) != TCL_OK) { sortInfo.resultCode = TCL_ERROR; goto done; } switch ((enum Lsort_Switches) index) { case LSORT_ASCII: sortInfo.sortMode = SORTMODE_ASCII; break; |
︙ | ︙ | |||
3753 3754 3755 3756 3757 3758 3759 | case LSORT_DICTIONARY: sortInfo.sortMode = SORTMODE_DICTIONARY; break; case LSORT_INCREASING: sortInfo.isIncreasing = 1; break; case LSORT_INDEX: { | | | 3843 3844 3845 3846 3847 3848 3849 3850 3851 3852 3853 3854 3855 3856 3857 | case LSORT_DICTIONARY: sortInfo.sortMode = SORTMODE_DICTIONARY; break; case LSORT_INCREASING: sortInfo.isIncreasing = 1; break; case LSORT_INDEX: { int indexc; Tcl_Obj **indexv; if (i == objc-2) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-index\" option must be followed by list index", -1)); Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); |
︙ | ︙ | |||
3779 3780 3781 3782 3783 3784 3785 | * we do not store the converted values here because we do not * know if this is the only -index option yet and so we can't * allocate any space; that happens after the scan through all the * options is done. */ for (j=0 ; j<indexc ; j++) { | > | > | > > > > > > > > > > | 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 | * we do not store the converted values here because we do not * know if this is the only -index option yet and so we can't * allocate any space; that happens after the scan through all the * options is done. */ for (j=0 ; j<indexc ; j++) { int encoded = 0; int result = TclIndexEncode(interp, indexv[j], TCL_INDEX_BEFORE, TCL_INDEX_AFTER, &encoded); if ((result == TCL_OK) && ((encoded == TCL_INDEX_BEFORE) || (encoded == TCL_INDEX_AFTER))) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "index \"%s\" cannot select an element " "from any list", Tcl_GetString(indexv[j]))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX" "OUTOFRANGE", NULL); result = TCL_ERROR; } if (result == TCL_ERROR) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (-index option item number %d)", j)); sortInfo.resultCode = TCL_ERROR; goto done; } } indexPtr = objv[i+1]; |
︙ | ︙ | |||
3860 3861 3862 3863 3864 3865 3866 | default: sortInfo.indexv = TclStackAlloc(interp, sizeof(int) * sortInfo.indexc); allocatedIndexVector = 1; /* Cannot use indexc field, as it * might be decreased by 1 later. */ } for (j=0 ; j<sortInfo.indexc ; j++) { | | | | 3962 3963 3964 3965 3966 3967 3968 3969 3970 3971 3972 3973 3974 3975 3976 3977 | default: sortInfo.indexv = TclStackAlloc(interp, sizeof(int) * sortInfo.indexc); allocatedIndexVector = 1; /* Cannot use indexc field, as it * might be decreased by 1 later. */ } for (j=0 ; j<sortInfo.indexc ; j++) { /* Prescreened values, no errors or out of range possible */ TclIndexEncode(NULL, indexv[j], 0, 0, &sortInfo.indexv[j]); } } listObj = objv[objc-1]; if (sortInfo.sortMode == SORTMODE_COMMAND) { Tcl_Obj *newCommandPtr, *newObjPtr; |
︙ | ︙ | |||
3932 3933 3934 3935 3936 3937 3938 | length = length / groupSize; if (sortInfo.indexc > 0) { /* * Use the first value in the list supplied to -index as the * offset of the element within each group by which to sort. */ | | < < < > > > | 4034 4035 4036 4037 4038 4039 4040 4041 4042 4043 4044 4045 4046 4047 4048 4049 4050 4051 4052 4053 4054 4055 4056 4057 4058 4059 4060 4061 4062 4063 4064 4065 4066 4067 4068 4069 | length = length / groupSize; if (sortInfo.indexc > 0) { /* * Use the first value in the list supplied to -index as the * offset of the element within each group by which to sort. */ groupOffset = TclIndexDecode(sortInfo.indexv[0], groupSize - 1); if (groupOffset < 0 || groupOffset >= groupSize) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "when used with \"-stride\", the leading \"-index\"" " value must be within the group", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", "BADINDEX", NULL); sortInfo.resultCode = TCL_ERROR; goto done; } if (sortInfo.indexc == 1) { sortInfo.indexc = 0; sortInfo.indexv = NULL; } else { sortInfo.indexc--; /* * Do not shrink the actual memory block used; that doesn't * work with TclStackAlloc-allocated memory. [Bug 2918962] * * TODO: Consider a pointer increment to replace this * array shift. */ for (i = 0; i < sortInfo.indexc; i++) { sortInfo.indexv[i] = sortInfo.indexv[i+1]; } } } |
︙ | ︙ | |||
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) { | | | 4361 4362 4363 4364 4365 4366 4367 4368 4369 4370 4371 4372 4373 4374 4375 | /* 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); |
︙ | ︙ | |||
4522 4523 4524 4525 4526 4527 4528 | int listLen, index; Tcl_Obj *currentObj; if (TclListObjLength(infoPtr->interp, objPtr, &listLen) != TCL_OK) { infoPtr->resultCode = TCL_ERROR; return NULL; } | < < < < | < < < | 4624 4625 4626 4627 4628 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 | int listLen, index; Tcl_Obj *currentObj; if (TclListObjLength(infoPtr->interp, objPtr, &listLen) != TCL_OK) { infoPtr->resultCode = TCL_ERROR; return NULL; } index = TclIndexDecode(infoPtr->indexv[i], listLen - 1); if (Tcl_ListObjIndex(infoPtr->interp, objPtr, index, ¤tObj) != TCL_OK) { infoPtr->resultCode = TCL_ERROR; return NULL; } if (currentObj == NULL) { |
︙ | ︙ |
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); |
︙ | ︙ | |||
331 332 333 334 335 336 337 | /* * If inlining, the interpreter's object result remains an * empty list, otherwise set it to an integer object w/ value * 0. */ if (!doinline) { | | | 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 | /* * If inlining, the interpreter's object result remains an * empty list, otherwise set it to an integer object w/ value * 0. */ if (!doinline) { Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); } return TCL_OK; } break; } /* |
︙ | ︙ | |||
453 454 455 456 457 458 459 | * if -all wasn't specified, otherwise it's all-1 (the number of times * through the while - 1). */ if (doinline) { Tcl_SetObjResult(interp, resultPtr); } else { | | | 453 454 455 456 457 458 459 460 461 462 463 464 465 466 467 | * if -all wasn't specified, otherwise it's all-1 (the number of times * through the while - 1). */ if (doinline) { Tcl_SetObjResult(interp, resultPtr); } else { Tcl_SetObjResult(interp, Tcl_NewIntObj(all ? all-1 : 1)); } return TCL_OK; } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
594 595 596 597 598 599 600 | && (strpbrk(TclGetString(objv[0]), "*+?{}()[].\\|^$") == NULL)) { /* * This is a simple one pair string map situation. We make use of a * slightly modified version of the one pair STR_MAP code. */ int slen, nocase; | | | 594 595 596 597 598 599 600 601 602 603 604 605 606 607 608 | && (strpbrk(TclGetString(objv[0]), "*+?{}()[].\\|^$") == NULL)) { /* * This is a simple one pair string map situation. We make use of a * slightly modified version of the one pair STR_MAP code. */ int slen, nocase; int (*strCmpFn)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long); Tcl_UniChar *p, wsrclc; numMatches = 0; nocase = (cflags & TCL_REG_NOCASE); strCmpFn = nocase ? Tcl_UniCharNcasecmp : Tcl_UniCharNcmp; wsrc = Tcl_GetUnicodeFromObj(objv[0], &slen); |
︙ | ︙ | |||
629 630 631 632 633 634 635 | } } else { wsrclc = Tcl_UniCharToLower(*wsrc); for (p = wfirstChar = wstring; wstring < wend; wstring++) { if ((*wstring == *wsrc || (nocase && Tcl_UniCharToLower(*wstring)==wsrclc)) && (slen==1 || (strCmpFn(wstring, wsrc, | | | 629 630 631 632 633 634 635 636 637 638 639 640 641 642 643 | } } else { wsrclc = Tcl_UniCharToLower(*wsrc); for (p = wfirstChar = wstring; wstring < wend; wstring++) { if ((*wstring == *wsrc || (nocase && Tcl_UniCharToLower(*wstring)==wsrclc)) && (slen==1 || (strCmpFn(wstring, wsrc, (unsigned long) slen) == 0))) { if (numMatches == 0) { resultPtr = Tcl_NewUnicodeObj(wstring, 0); Tcl_IncrRefCount(resultPtr); } if (p != wstring) { Tcl_AppendUnicodeToObj(resultPtr, p, wstring - p); p = wstring + slen; |
︙ | ︙ | |||
955 956 957 958 959 960 961 | result = TCL_ERROR; } else { /* * Set the interpreter's object result to an integer object * holding the number of matches. */ | | | 955 956 957 958 959 960 961 962 963 964 965 966 967 968 969 | result = TCL_ERROR; } else { /* * Set the interpreter's object result to an integer object * holding the number of matches. */ Tcl_SetObjResult(interp, Tcl_NewIntObj(numMatches)); } } else { /* * No varname supplied, so just return the modified string. */ Tcl_SetObjResult(interp, resultPtr); |
︙ | ︙ | |||
1114 1115 1116 1117 1118 1119 1120 | if (objc == 4) { static const char *const options[] = { "-encoding", NULL }; int index; | | | | 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 | if (objc == 4) { static const char *const options[] = { "-encoding", NULL }; int index; if (TCL_ERROR == Tcl_GetIndexFromObj(interp, objv[1], options, "option", TCL_EXACT, &index)) { return TCL_ERROR; } encodingName = TclGetString(objv[2]); } else if (objc == 3) { /* Handle undocumented -nopkg option. This should only be * used by the internal ::tcl::Pkg::source utility function. */ static const char *const nopkgoptions[] = { |
︙ | ︙ | |||
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... */ |
︙ | ︙ | |||
1322 1323 1324 1325 1326 1327 1328 | if (objc == 4) { int size = Tcl_GetCharLength(objv[2]); if (TCL_OK != TclGetIntForIndexM(interp, objv[3], size - 1, &start)) { return TCL_ERROR; } | | < < < < | < < < < | 1331 1332 1333 1334 1335 1336 1337 1338 1339 1340 1341 1342 1343 1344 1345 1346 | if (objc == 4) { int size = Tcl_GetCharLength(objv[2]); if (TCL_OK != TclGetIntForIndexM(interp, objv[3], size - 1, &start)) { return TCL_ERROR; } } Tcl_SetObjResult(interp, Tcl_NewIntObj(TclStringFirst(objv[1], objv[2], start))); return TCL_OK; } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
1375 1376 1377 1378 1379 1380 1381 | if (objc == 4) { int size = Tcl_GetCharLength(objv[2]); if (TCL_OK != TclGetIntForIndexM(interp, objv[3], size - 1, &last)) { return TCL_ERROR; } | < < < < < < < < | 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 | if (objc == 4) { int size = Tcl_GetCharLength(objv[2]); if (TCL_OK != TclGetIntForIndexM(interp, objv[3], size - 1, &last)) { return TCL_ERROR; } } Tcl_SetObjResult(interp, Tcl_NewIntObj(TclStringLast(objv[1], objv[2], last))); return TCL_OK; } /* |
︙ | ︙ | |||
1512 1513 1514 1515 1516 1517 1518 | }; if (objc < 3 || objc > 6) { Tcl_WrongNumArgs(interp, 1, objv, "class ?-strict? ?-failindex var? str"); return TCL_ERROR; } | | | | | | 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 | }; if (objc < 3 || objc > 6) { Tcl_WrongNumArgs(interp, 1, objv, "class ?-strict? ?-failindex var? str"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], isClasses, "class", 0, &index) != TCL_OK) { return TCL_ERROR; } if (objc != 3) { for (i = 2; i < objc-1; i++) { int idx2; if (Tcl_GetIndexFromObj(interp, objv[i], isOptions, "option", 0, &idx2) != TCL_OK) { return TCL_ERROR; } switch ((enum isOptions) idx2) { case OPT_STRICT: strict = 1; break; case OPT_FAILIDX: |
︙ | ︙ | |||
1575 1576 1577 1578 1579 1580 1581 | && (TCL_OK != TclSetBooleanFromAny(NULL, objPtr))) { if (strict) { result = 0; } else { string1 = TclGetStringFromObj(objPtr, &length1); result = length1 == 0; } | < | | < < < < | 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 | && (TCL_OK != TclSetBooleanFromAny(NULL, objPtr))) { if (strict) { result = 0; } else { string1 = TclGetStringFromObj(objPtr, &length1); result = length1 == 0; } } else if ((objPtr->internalRep.wideValue != 0) ? (index == STR_IS_FALSE) : (index == STR_IS_TRUE)) { result = 0; } break; case STR_IS_CONTROL: chcomp = Tcl_UniCharIsControl; break; 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) || | < < < | 1617 1618 1619 1620 1621 1622 1623 1624 1625 1626 1627 1628 1629 1630 | 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); | > > > > > > > > | | | | 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 | 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; } } } /* * Only set the failVarObj when we will return 0 and we have indicated a * valid fail index (>= 0). */ str_is_done: if ((result == 0) && (failVarObj != NULL) && Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(failat), TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); return TCL_OK; } static int UniCharIsAscii( int character) { |
︙ | ︙ | |||
1876 1877 1878 1879 1880 1881 1882 | int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int length1, length2, mapElemc, index; int nocase = 0, mapWithDict = 0, copySource = 0; Tcl_Obj **mapElemv, *sourceObj, *resultPtr; Tcl_UniChar *ustring1, *ustring2, *p, *end; | | | 1869 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 | int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int length1, length2, mapElemc, index; int nocase = 0, mapWithDict = 0, copySource = 0; Tcl_Obj **mapElemv, *sourceObj, *resultPtr; Tcl_UniChar *ustring1, *ustring2, *p, *end; int (*strCmpFn)(const Tcl_UniChar*, const Tcl_UniChar*, unsigned long); if (objc < 3 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "?-nocase? charMap string"); return TCL_ERROR; } if (objc == 4) { |
︙ | ︙ | |||
2017 2018 2019 2020 2021 2022 2023 | } else { mapString = Tcl_GetUnicodeFromObj(mapElemv[1], &mapLen); u2lc = (nocase ? Tcl_UniCharToLower(*ustring2) : 0); for (; ustring1 < end; ustring1++) { if (((*ustring1 == *ustring2) || (nocase&&Tcl_UniCharToLower(*ustring1)==u2lc)) && (length2==1 || strCmpFn(ustring1, ustring2, | | | 2010 2011 2012 2013 2014 2015 2016 2017 2018 2019 2020 2021 2022 2023 2024 | } else { mapString = Tcl_GetUnicodeFromObj(mapElemv[1], &mapLen); u2lc = (nocase ? Tcl_UniCharToLower(*ustring2) : 0); for (; ustring1 < end; ustring1++) { if (((*ustring1 == *ustring2) || (nocase&&Tcl_UniCharToLower(*ustring1)==u2lc)) && (length2==1 || strCmpFn(ustring1, ustring2, (unsigned long) length2) == 0)) { if (p != ustring1) { Tcl_AppendUnicodeToObj(resultPtr, p, ustring1-p); p = ustring1 + length2; } else { p += length2; } ustring1 = p - 1; |
︙ | ︙ | |||
2065 2066 2067 2068 2069 2070 2071 | ustring2 = mapStrings[index]; length2 = mapLens[index]; if ((length2 > 0) && ((*ustring1 == *ustring2) || (nocase && (Tcl_UniCharToLower(*ustring1) == u2lc[index/2]))) && /* Restrict max compare length. */ (end-ustring1 >= length2) && ((length2 == 1) || | | | 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 | ustring2 = mapStrings[index]; length2 = mapLens[index]; if ((length2 > 0) && ((*ustring1 == *ustring2) || (nocase && (Tcl_UniCharToLower(*ustring1) == u2lc[index/2]))) && /* Restrict max compare length. */ (end-ustring1 >= length2) && ((length2 == 1) || !strCmpFn(ustring2, ustring1, (unsigned) length2))) { if (p != ustring1) { /* * Put the skipped chars onto the result first. */ Tcl_AppendUnicodeToObj(resultPtr, p, ustring1-p); p = ustring1 + length2; |
︙ | ︙ | |||
2164 2165 2166 2167 2168 2169 2170 | Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad option \"%s\": must be -nocase", string)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", string, NULL); return TCL_ERROR; } } | | | | 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 | Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad option \"%s\": must be -nocase", string)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option", string, NULL); return TCL_ERROR; } } Tcl_SetObjResult(interp, Tcl_NewBooleanObj( TclStringMatchObj(objv[objc-1], objv[objc-2], nocase))); return TCL_OK; } /* *---------------------------------------------------------------------- * * StringRangeCmd -- |
︙ | ︙ | |||
2273 2274 2275 2276 2277 2278 2279 | if (count == 1) { Tcl_SetObjResult(interp, objv[1]); return TCL_OK; } else if (count < 1) { return TCL_OK; } | | > > | < | | 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 | if (count == 1) { Tcl_SetObjResult(interp, objv[1]); return TCL_OK; } else if (count < 1) { return TCL_OK; } resultPtr = TclStringRepeat(interp, objv[1], count, TCL_STRING_IN_PLACE); if (resultPtr) { Tcl_SetObjResult(interp, resultPtr); return TCL_OK; } return TCL_ERROR; } /* *---------------------------------------------------------------------- * * StringRplcCmd -- * |
︙ | ︙ | |||
2305 2306 2307 2308 2309 2310 2311 | static int StringRplcCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { | < | | | | | > > > > > > > > | > > > > > < < < > > | < < < | < | | > | | 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 2339 2340 2341 2342 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 | static int StringRplcCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { int first, last, length, end; if (objc < 4 || objc > 5) { Tcl_WrongNumArgs(interp, 1, objv, "string first last ?string?"); return TCL_ERROR; } length = Tcl_GetCharLength(objv[1]); end = length - 1; if (TclGetIntForIndexM(interp, objv[2], end, &first) != TCL_OK || TclGetIntForIndexM(interp, objv[3], end, &last) != TCL_OK){ return TCL_ERROR; } /* * The following test screens out most empty substrings as * candidates for replacement. When they are detected, no * replacement is done, and the result is the original string, */ if ((last < 0) || /* Range ends before start of string */ (first > end) || /* Range begins after end of string */ (last < first)) { /* Range begins after it starts */ /* * BUT!!! when (end < 0) -- an empty original string -- we can * have (first <= end < 0 <= last) and an empty string is permitted * to be replaced. */ Tcl_SetObjResult(interp, objv[1]); } else { Tcl_Obj *resultPtr; if (first < 0) { first = 0; } if (last > end) { last = end; } resultPtr = TclStringReplace(interp, objv[1], first, last + 1 - first, (objc == 5) ? objv[4] : NULL, TCL_STRING_IN_PLACE); Tcl_SetObjResult(interp, resultPtr); } return TCL_OK; } /* *---------------------------------------------------------------------- |
︙ | ︙ | |||
2376 2377 2378 2379 2380 2381 2382 | Tcl_Obj *const objv[]) /* Argument objects. */ { if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "string"); return TCL_ERROR; } | | | 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 | Tcl_Obj *const objv[]) /* Argument objects. */ { if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "string"); return TCL_ERROR; } Tcl_SetObjResult(interp, TclStringReverse(objv[1], TCL_STRING_IN_PLACE)); return TCL_OK; } /* *---------------------------------------------------------------------- * * StringStartCmd -- |
︙ | ︙ | |||
2438 2439 2440 2441 2442 2443 2444 | } p = Tcl_UtfPrev(p, string); } if (cur != index) { cur += 1; } } | | | 2440 2441 2442 2443 2444 2445 2446 2447 2448 2449 2450 2451 2452 2453 2454 | } p = Tcl_UtfPrev(p, string); } if (cur != index) { cur += 1; } } Tcl_SetObjResult(interp, Tcl_NewIntObj(cur)); return TCL_OK; } /* *---------------------------------------------------------------------- * * StringEndCmd -- |
︙ | ︙ | |||
2500 2501 2502 2503 2504 2505 2506 | } if (cur == index) { cur++; } } else { cur = numChars; } | | | 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 | } if (cur == index) { cur++; } } else { cur = numChars; } Tcl_SetObjResult(interp, Tcl_NewIntObj(cur)); return TCL_OK; } /* *---------------------------------------------------------------------- * * StringEqualCmd -- |
︙ | ︙ | |||
2537 2538 2539 2540 2541 2542 2543 | * Remember to keep code here in some sync with the byte-compiled versions * in tclExecute.c (INST_STR_EQ, INST_STR_NEQ and INST_STR_CMP as well as * the expr string comparison in INST_EQ/INST_NEQ/INST_LT/...). */ const char *string1, *string2; int length1, length2, i, match, length, nocase = 0, reqlength = -1; | | | 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 | * Remember to keep code here in some sync with the byte-compiled versions * in tclExecute.c (INST_STR_EQ, INST_STR_NEQ and INST_STR_CMP as well as * the expr string comparison in INST_EQ/INST_NEQ/INST_LT/...). */ const char *string1, *string2; int length1, length2, i, match, length, nocase = 0, reqlength = -1; typedef int (*strCmpFn_t)(const char *, const char *, unsigned int); strCmpFn_t strCmpFn; if (objc < 3 || objc > 6) { str_cmp_args: Tcl_WrongNumArgs(interp, 1, objv, "?-nocase? ?-length int? string1 string2"); return TCL_ERROR; |
︙ | ︙ | |||
2582 2583 2584 2585 2586 2587 2588 | objv += objc-2; if ((reqlength == 0) || (objv[0] == objv[1])) { /* * Always match at 0 chars of if it is the same obj. */ | | | 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 | objv += objc-2; if ((reqlength == 0) || (objv[0] == objv[1])) { /* * Always match at 0 chars of if it is the same obj. */ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1)); return TCL_OK; } if (!nocase && TclIsPureByteArray(objv[0]) && TclIsPureByteArray(objv[1])) { /* * Use binary versions of comparisons since that won't cause undue |
︙ | ︙ | |||
2650 2651 2652 2653 2654 2655 2656 | match = strCmpFn(string1, string2, (unsigned) length); if ((match == 0) && (reqlength > length)) { match = length1 - length2; } } | | | 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 | match = strCmpFn(string1, string2, (unsigned) length); if ((match == 0) && (reqlength > length)) { match = length1 - length2; } } Tcl_SetObjResult(interp, Tcl_NewBooleanObj(match ? 0 : 1)); return TCL_OK; } /* *---------------------------------------------------------------------- * * StringCmpCmd -- |
︙ | ︙ | |||
2687 2688 2689 2690 2691 2692 2693 | * Remember to keep code here in some sync with the byte-compiled versions * in tclExecute.c (INST_STR_EQ, INST_STR_NEQ and INST_STR_CMP as well as * the expr string comparison in INST_EQ/INST_NEQ/INST_LT/...). */ const char *string1, *string2; int length1, length2, i, match, length, nocase = 0, reqlength = -1; | | | 2689 2690 2691 2692 2693 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 | * Remember to keep code here in some sync with the byte-compiled versions * in tclExecute.c (INST_STR_EQ, INST_STR_NEQ and INST_STR_CMP as well as * the expr string comparison in INST_EQ/INST_NEQ/INST_LT/...). */ const char *string1, *string2; int length1, length2, i, match, length, nocase = 0, reqlength = -1; typedef int (*strCmpFn_t)(const char *, const char *, unsigned int); strCmpFn_t strCmpFn; if (objc < 3 || objc > 6) { str_cmp_args: Tcl_WrongNumArgs(interp, 1, objv, "?-nocase? ?-length int? string1 string2"); return TCL_ERROR; |
︙ | ︙ | |||
2732 2733 2734 2735 2736 2737 2738 | objv += objc-2; if ((reqlength == 0) || (objv[0] == objv[1])) { /* * Always match at 0 chars of if it is the same obj. */ | | | 2734 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 | objv += objc-2; if ((reqlength == 0) || (objv[0] == objv[1])) { /* * Always match at 0 chars of if it is the same obj. */ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); return TCL_OK; } if (!nocase && TclIsPureByteArray(objv[0]) && TclIsPureByteArray(objv[1])) { /* * Use binary versions of comparisons since that won't cause undue |
︙ | ︙ | |||
2771 2772 2773 2774 2775 2776 2777 | * utf rep). We can use the more efficient TclpUtfNcmp2 if we are * case-sensitive and no specific length was requested. */ string1 = (char *) TclGetStringFromObj(objv[0], &length1); string2 = (char *) TclGetStringFromObj(objv[1], &length2); if ((reqlength < 0) && !nocase) { | | | | | | 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 | * utf rep). We can use the more efficient TclpUtfNcmp2 if we are * case-sensitive and no specific length was requested. */ string1 = (char *) TclGetStringFromObj(objv[0], &length1); string2 = (char *) TclGetStringFromObj(objv[1], &length2); if ((reqlength < 0) && !nocase) { strCmpFn = (strCmpFn_t) TclpUtfNcmp2; } else { length1 = Tcl_NumUtfChars(string1, length1); length2 = Tcl_NumUtfChars(string2, length2); strCmpFn = (strCmpFn_t) (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp); } } length = (length1 < length2) ? length1 : length2; if (reqlength > 0 && reqlength < length) { length = reqlength; } else if (reqlength < 0) { /* * The requested length is negative, so we ignore it by setting it to * length + 1 so we correct the match var. */ reqlength = length + 1; } match = strCmpFn(string1, string2, (unsigned) length); if ((match == 0) && (reqlength > length)) { match = length1 - length2; } Tcl_SetObjResult(interp, Tcl_NewIntObj((match > 0) ? 1 : (match < 0) ? -1 : 0)); return TCL_OK; } /* *---------------------------------------------------------------------- * * StringCatCmd -- |
︙ | ︙ | |||
2825 2826 2827 2828 2829 2830 2831 | static int StringCatCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { | < < < < < < < | > < | < < | | 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 2853 2854 2855 2856 2857 2858 | static int StringCatCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Obj *objResultPtr; if (objc < 2) { /* * If there are no args, the result is an empty object. * Just leave the preset empty interp result. */ return TCL_OK; } objResultPtr = TclStringCat(interp, objc-1, objv+1, TCL_STRING_IN_PLACE); if (objResultPtr) { Tcl_SetObjResult(interp, objResultPtr); return TCL_OK; } return TCL_ERROR; } /* *---------------------------------------------------------------------- * * StringBytesCmd -- * |
︙ | ︙ | |||
2888 2889 2890 2891 2892 2893 2894 | if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "string"); return TCL_ERROR; } (void) TclGetStringFromObj(objv[1], &length); | | | 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 | if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "string"); return TCL_ERROR; } (void) TclGetStringFromObj(objv[1], &length); Tcl_SetObjResult(interp, Tcl_NewIntObj(length)); return TCL_OK; } /* *---------------------------------------------------------------------- * * StringLenCmd -- |
︙ | ︙ | |||
2922 2923 2924 2925 2926 2927 2928 | Tcl_Obj *const objv[]) /* Argument objects. */ { if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "string"); return TCL_ERROR; } | | | 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 2926 2927 2928 2929 | Tcl_Obj *const objv[]) /* Argument objects. */ { if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "string"); return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_GetCharLength(objv[1]))); return TCL_OK; } /* *---------------------------------------------------------------------- * * StringLowerCmd -- |
︙ | ︙ | |||
3220 3221 3222 3223 3224 3225 3226 | length2 = strlen(tclDefaultTrimSet); } else { Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?"); return TCL_ERROR; } string1 = TclGetStringFromObj(objv[1], &length1); | | < | 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 | length2 = strlen(tclDefaultTrimSet); } else { Tcl_WrongNumArgs(interp, 1, objv, "string ?chars?"); return TCL_ERROR; } string1 = TclGetStringFromObj(objv[1], &length1); triml = TclTrim(string1, length1, string2, length2, &trimr); Tcl_SetObjResult(interp, Tcl_NewStringObj(string1 + triml, length1 - triml - trimr)); return TCL_OK; } /* |
︙ | ︙ | |||
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 *); | | | | | 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 | "--", 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; for (i = 1; i < objc-2; i++) { if (TclGetString(objv[i])[0] != '-') { break; } if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum options) index) { /* * General options. */ |
︙ | ︙ | |||
3815 3816 3817 3818 3819 3820 3821 | if (indexVarObj != NULL) { Tcl_Obj *rangeObjAry[2]; if (info.matches[j].end > 0) { rangeObjAry[0] = Tcl_NewLongObj(info.matches[j].start); rangeObjAry[1] = Tcl_NewLongObj(info.matches[j].end-1); } else { | | | 3807 3808 3809 3810 3811 3812 3813 3814 3815 3816 3817 3818 3819 3820 3821 | if (indexVarObj != NULL) { Tcl_Obj *rangeObjAry[2]; if (info.matches[j].end > 0) { rangeObjAry[0] = Tcl_NewLongObj(info.matches[j].start); rangeObjAry[1] = Tcl_NewLongObj(info.matches[j].end-1); } else { rangeObjAry[0] = rangeObjAry[1] = Tcl_NewIntObj(-1); } /* * Never fails; the object is always clean at this point. */ Tcl_ListObjAppendElement(NULL, indicesObj, |
︙ | ︙ | |||
4135 4136 4137 4138 4139 4140 4141 | #endif if (count <= 1) { /* * Use int obj since we know time is not fractional. [Bug 1202178] */ | | | 4127 4128 4129 4130 4131 4132 4133 4134 4135 4136 4137 4138 4139 4140 4141 | #endif if (count <= 1) { /* * Use int obj since we know time is not fractional. [Bug 1202178] */ objs[0] = Tcl_NewIntObj((count <= 0) ? 0 : (int) totalMicroSec); } else { objs[0] = Tcl_NewDoubleObj(totalMicroSec/count); } /* * Construct the result as a list because many programs have always parsed * as such (extracting the first element, typically). |
︙ | ︙ | |||
4215 4216 4217 4218 4219 4220 4221 | handlersObj = Tcl_NewObj(); bodyShared = 0; haveHandlers = 0; for (i=2 ; i<objc ; i++) { int type; Tcl_Obj *info[5]; | | | | 4207 4208 4209 4210 4211 4212 4213 4214 4215 4216 4217 4218 4219 4220 4221 4222 | handlersObj = Tcl_NewObj(); bodyShared = 0; haveHandlers = 0; for (i=2 ; i<objc ; i++) { int type; Tcl_Obj *info[5]; if (Tcl_GetIndexFromObj(interp, objv[i], handlerNames, "handler type", 0, &type) != TCL_OK) { Tcl_DecrRefCount(handlersObj); return TCL_ERROR; } switch ((enum Handlers) type) { case TryFinally: /* finally script */ if (i < objc-2) { Tcl_SetObjResult(interp, Tcl_NewStringObj( |
︙ | ︙ | |||
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 */ | | | 4281 4282 4283 4284 4285 4286 4287 4288 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 */ 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/tclCompCmdsGR.c.
︙ | ︙ | |||
24 25 26 27 28 29 30 | static void CompileReturnInternal(CompileEnv *envPtr, unsigned char op, int code, int level, Tcl_Obj *returnOpts); static int IndexTailVarIfKnown(Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr); | < | | | < > | | | > > | | | < < < < < < < | | < < < < < < < < < < < | 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 | static void CompileReturnInternal(CompileEnv *envPtr, unsigned char op, int code, int level, Tcl_Obj *returnOpts); static int IndexTailVarIfKnown(Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr); /* *---------------------------------------------------------------------- * * TclGetIndexFromToken -- * * Parse a token to determine if an index value is known at * compile time. * * Returns: * TCL_OK if parsing succeeded, and TCL_ERROR if it failed. * * Side effects: * When TCL_OK is returned, the encoded index value is written * to *index. * *---------------------------------------------------------------------- */ int TclGetIndexFromToken( Tcl_Token *tokenPtr, int before, int after, int *indexPtr) { Tcl_Obj *tmpObj = Tcl_NewObj(); int result = TCL_ERROR; if (TclWordKnownAtCompileTime(tokenPtr, tmpObj)) { result = TclIndexEncode(NULL, tmpObj, before, after, indexPtr); } Tcl_DecrRefCount(tmpObj); return result; } /* *---------------------------------------------------------------------- * * TclCompileGlobalCmd -- |
︙ | ︙ | |||
140 141 142 143 144 145 146 | for (i=1; i<numWords; varTokenPtr = TokenAfter(varTokenPtr),i++) { localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr); if (localIndex < 0) { return TCL_ERROR; } | | | 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 | for (i=1; i<numWords; varTokenPtr = TokenAfter(varTokenPtr),i++) { localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr); if (localIndex < 0) { return TCL_ERROR; } /* TODO: Consider what value can pass through the * IndexTailVarIfKnown() screen. Full CompileWord() * likely does not apply here. Push known value instead. */ CompileWord(envPtr, varTokenPtr, interp, i); TclEmitInstInt4( INST_NSUPVAR, localIndex, envPtr); } /* |
︙ | ︙ | |||
1049 1050 1051 1052 1053 1054 1055 | } /* * Generate code to leave the rest of the list on the stack. */ TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr); | | | 1032 1033 1034 1035 1036 1037 1038 1039 1040 1041 1042 1043 1044 1045 1046 | } /* * Generate code to leave the rest of the list on the stack. */ TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr); TclEmitInt4( TCL_INDEX_END, envPtr); return TCL_OK; } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
1100 1101 1102 1103 1104 1105 1106 | valTokenPtr = TokenAfter(parsePtr->tokenPtr); if (numWords != 3) { goto emitComplexLindex; } idxTokenPtr = TokenAfter(valTokenPtr); | > | < | | > | < | | 1083 1084 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 1102 1103 1104 | valTokenPtr = TokenAfter(parsePtr->tokenPtr); if (numWords != 3) { goto emitComplexLindex; } idxTokenPtr = TokenAfter(valTokenPtr); if (TclGetIndexFromToken(idxTokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_BEFORE, &idx) == TCL_OK) { /* * The idxTokenPtr parsed as a valid index value and was * encoded as expected by INST_LIST_INDEX_IMM. * * NOTE: that we rely on indexing before a list producing the * same result as indexing after a list. */ CompileWord(envPtr, valTokenPtr, interp, 1); TclEmitInstInt4( INST_LIST_INDEX_IMM, idx, envPtr); return TCL_OK; } |
︙ | ︙ | |||
1254 1255 1256 1257 1258 1259 1260 | * at this point. We use an [lrange ... 0 end] for this (instead of * [llength], as with literals) as we must drop any string representation * that might be hanging around. */ if (concat && numWords == 2) { TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); | | | 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 | * at this point. We use an [lrange ... 0 end] for this (instead of * [llength], as with literals) as we must drop any string representation * that might be hanging around. */ if (concat && numWords == 2) { TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); TclEmitInt4( TCL_INDEX_END, envPtr); } return TCL_OK; } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
1328 1329 1330 1331 1332 1333 1334 | int idx1, idx2; if (parsePtr->numWords != 4) { return TCL_ERROR; } listTokenPtr = TokenAfter(parsePtr->tokenPtr); | < < < < < < > | > > > > > | > > > > | 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 | int idx1, idx2; if (parsePtr->numWords != 4) { return TCL_ERROR; } listTokenPtr = TokenAfter(parsePtr->tokenPtr); tokenPtr = TokenAfter(listTokenPtr); if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_AFTER, &idx1) != TCL_OK) { return TCL_ERROR; } /* * Token was an index value, and we treat all "first" indices * before the list same as the start of the list. */ tokenPtr = TokenAfter(tokenPtr); if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_END, &idx2) != TCL_OK) { return TCL_ERROR; } /* * Token was an index value, and we treat all "last" indices * after the list same as the end of the list. */ /* * Issue instructions. It's not safe to skip doing the LIST_RANGE, as * we've not proved that the 'list' argument is really a list. Not that it * is worth trying to do that given current knowledge. */ |
︙ | ︙ | |||
1392 1393 1394 1395 1396 1397 1398 | /* * Parse the index. Will only compile if it is constant and not an * _integer_ less than zero (since we reserve negative indices here for * end-relative indexing) or an end-based index greater than 'end' itself. */ tokenPtr = TokenAfter(listTokenPtr); | > > > > > > > > > | | | | | > > > > > > > > > > > > | | | 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 | /* * Parse the index. Will only compile if it is constant and not an * _integer_ less than zero (since we reserve negative indices here for * end-relative indexing) or an end-based index greater than 'end' itself. */ tokenPtr = TokenAfter(listTokenPtr); /* * NOTE: This command treats all inserts at indices before the list * the same as inserts at the start of the list, and all inserts * after the list the same as inserts at the end of the list. We * make that transformation here so we can use the optimized bytecode * as much as possible. */ if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_END, &idx) != TCL_OK) { return TCL_ERROR; } /* * There are four main cases. If there are no values to insert, this is * just a confirm-listiness check. If the index is '0', this is a prepend. * If the index is 'end' (== TCL_INDEX_END), this is an append. Otherwise, * this is a splice (== split, insert values as list, concat-3). */ CompileWord(envPtr, listTokenPtr, interp, 1); if (parsePtr->numWords == 3) { TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); TclEmitInt4( TCL_INDEX_END, envPtr); return TCL_OK; } for (i=3 ; i<parsePtr->numWords ; i++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, i); } TclEmitInstInt4( INST_LIST, i-3, envPtr); if (idx == TCL_INDEX_START) { TclEmitInstInt4( INST_REVERSE, 2, envPtr); TclEmitOpcode( INST_LIST_CONCAT, envPtr); } else if (idx == TCL_INDEX_END) { TclEmitOpcode( INST_LIST_CONCAT, envPtr); } else { /* * Here we handle two ranges for idx. First when idx > 0, we * want the first half of the split to end at index idx-1 and * the second half to start at index idx. * Second when idx < TCL_INDEX_END, indicating "end-N" indexing, * we want the first half of the split to end at index end-N and * the second half to start at index end-N+1. We accomplish this * with a pre-adjustment of the end-N value. * The root of this is that the commands [lrange] and [linsert] * differ in their interpretation of the "end" index. */ if (idx < TCL_INDEX_END) { idx++; } TclEmitInstInt4( INST_OVER, 1, envPtr); TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); TclEmitInt4( idx-1, envPtr); TclEmitInstInt4( INST_REVERSE, 3, envPtr); TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr); TclEmitInt4( TCL_INDEX_END, envPtr); TclEmitOpcode( INST_LIST_CONCAT, envPtr); TclEmitOpcode( INST_LIST_CONCAT, envPtr); } return TCL_OK; } |
︙ | ︙ | |||
1460 1461 1462 1463 1464 1465 1466 | * command. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds the resulting instructions. */ { Tcl_Token *tokenPtr, *listTokenPtr; DefineLineInformation; /* TIP #280 */ | < > < < < < < < > | > | | < < | < < > > > > | < < < > > > | < < < < < < | > > > > > > > < < < < | < < | < < | | > > | < | < < > | < < < | < > > | < | > > > > > | | | | | < < < < < | < < < < < < < | < < > | | < < | < | < < > | < > > > > > > > | < | | < < | < | < < < < < < < | < < | > | | < < < | < < < < > < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < | > > > > > | | > > > | > > > > | > | > | < | < | < < < < < < < < < < | | | > > | < > | < > > > | | < > | < < < | < < < | < < < | | 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 | * command. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds the resulting instructions. */ { Tcl_Token *tokenPtr, *listTokenPtr; DefineLineInformation; /* TIP #280 */ int idx1, idx2, i, offset, offset2; int emptyPrefix=1, suffixStart = 0; if (parsePtr->numWords < 4) { return TCL_ERROR; } listTokenPtr = TokenAfter(parsePtr->tokenPtr); tokenPtr = TokenAfter(listTokenPtr); if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_AFTER, &idx1) != TCL_OK) { return TCL_ERROR; } tokenPtr = TokenAfter(tokenPtr); if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_END, &idx2) != TCL_OK) { return TCL_ERROR; } /* * idx1, idx2 are the conventional encoded forms of the tokens parsed * as all forms of index values. Values of idx1 that come before the * list are treated the same as if they were the start of the list. * Values of idx2 that come after the list are treated the same as if * they were the end of the list. */ if (idx1 == TCL_INDEX_AFTER) { /* * [lreplace] treats idx1 value end+1 differently from end+2, etc. * The operand encoding cannot distinguish them, so we must bail * out to direct evaluation. */ return TCL_ERROR; } /* * General structure of the [lreplace] result is * prefix replacement suffix * In a few cases we can predict various parts will be empty and * take advantage. * * The proper suffix begins with the greater of indices idx1 or * idx2 + 1. If we cannot tell at compile time which is greater, * we must defer to direct evaluation. */ if (idx2 == TCL_INDEX_BEFORE) { suffixStart = idx1; } else if (idx2 == TCL_INDEX_END) { suffixStart = TCL_INDEX_AFTER; } else if (((idx2 < TCL_INDEX_END) && (idx1 <= TCL_INDEX_END)) || ((idx2 >= TCL_INDEX_START) && (idx1 >= TCL_INDEX_START))) { suffixStart = (idx1 > idx2 + 1) ? idx1 : idx2 + 1; } else { return TCL_ERROR; } /* All paths start with computing/pushing the original value. */ CompileWord(envPtr, listTokenPtr, interp, 1); /* * Push all the replacement values next so any errors raised in * creating them get raised first. */ if (parsePtr->numWords > 4) { /* Push the replacement arguments */ tokenPtr = TokenAfter(tokenPtr); for (i=4 ; i<parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } /* Make a list of them... */ TclEmitInstInt4( INST_LIST, i - 4, envPtr); emptyPrefix = 0; } /* * [lreplace] raises an error when idx1 points after the list, but * only when the list is not empty. This is maximum stupidity. * * TODO: TIP this nonsense away! */ if (idx1 >= TCL_INDEX_START) { if (emptyPrefix) { TclEmitOpcode( INST_DUP, envPtr); } else { TclEmitInstInt4( INST_OVER, 1, envPtr); } TclEmitOpcode( INST_LIST_LENGTH, envPtr); TclEmitOpcode( INST_DUP, envPtr); offset = CurrentOffset(envPtr); TclEmitInstInt1( INST_JUMP_FALSE1, 0, envPtr); /* List is not empty */ TclEmitPush(TclAddLiteralObj(envPtr, Tcl_NewIntObj(idx1), NULL), envPtr); TclEmitOpcode( INST_GT, envPtr); offset2 = CurrentOffset(envPtr); TclEmitInstInt1( INST_JUMP_TRUE1, 0, envPtr); /* Idx1 >= list length ===> raise an error */ TclEmitPush(TclAddLiteralObj(envPtr, Tcl_ObjPrintf( "list doesn't contain element %d", idx1), NULL), envPtr); CompileReturnInternal(envPtr, INST_RETURN_IMM, TCL_ERROR, 0, Tcl_ObjPrintf("-errorcode {TCL OPERATION LREPLACE BADIDX}")); TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset, envPtr->codeStart + offset + 1); TclEmitOpcode( INST_POP, envPtr); TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset2, envPtr->codeStart + offset2 + 1); } if ((idx1 == suffixStart) && (parsePtr->numWords == 4)) { /* * This is a "no-op". Example: [lreplace {a b c} 2 0] * We still do a list operation to get list-verification * and canonicalization side effects. */ TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); TclEmitInt4( TCL_INDEX_END, envPtr); return TCL_OK; } if (idx1 != TCL_INDEX_START) { /* Prefix may not be empty; generate bytecode to push it */ if (emptyPrefix) { TclEmitOpcode( INST_DUP, envPtr); } else { TclEmitInstInt4( INST_OVER, 1, envPtr); } TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); TclEmitInt4( idx1 - 1, envPtr); if (!emptyPrefix) { TclEmitInstInt4( INST_REVERSE, 2, envPtr); TclEmitOpcode( INST_LIST_CONCAT, envPtr); } emptyPrefix = 0; } if (!emptyPrefix) { TclEmitInstInt4( INST_REVERSE, 2, envPtr); } if (suffixStart == TCL_INDEX_AFTER) { TclEmitOpcode( INST_POP, envPtr); if (emptyPrefix) { PushStringLiteral(envPtr, ""); } } else { /* Suffix may not be empty; generate bytecode to push it */ TclEmitInstInt4( INST_LIST_RANGE_IMM, suffixStart, envPtr); TclEmitInt4( TCL_INDEX_END, envPtr); if (!emptyPrefix) { TclEmitOpcode( INST_LIST_CONCAT, envPtr); } } return TCL_OK; } /* *---------------------------------------------------------------------- * * TclCompileLsetCmd -- |
︙ | ︙ | |||
2929 2930 2931 2932 2933 2934 2935 | localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr); if (localIndex < 0) { return TCL_ERROR; } | | | 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 2867 2868 | localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr); if (localIndex < 0) { return TCL_ERROR; } /* TODO: Consider what value can pass through the * IndexTailVarIfKnown() screen. Full CompileWord() * likely does not apply here. Push known value instead. */ CompileWord(envPtr, varTokenPtr, interp, i); TclEmitInstInt4( INST_VARIABLE, localIndex, envPtr); if (i+1 < numWords) { /* |
︙ | ︙ |
Changes to generic/tclCompCmdsSZ.c.
︙ | ︙ | |||
103 104 105 106 107 108 109 | #define LOAD(idx) \ if ((idx)<256) {OP1(LOAD_SCALAR1,(idx));} else {OP4(LOAD_SCALAR4,(idx));} #define STORE(idx) \ if ((idx)<256) {OP1(STORE_SCALAR1,(idx));} else {OP4(STORE_SCALAR4,(idx));} #define INVOKE(name) \ TclEmitInvoke(envPtr,INST_##name) | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 103 104 105 106 107 108 109 110 111 112 113 114 115 116 | #define LOAD(idx) \ if ((idx)<256) {OP1(LOAD_SCALAR1,(idx));} else {OP4(LOAD_SCALAR4,(idx));} #define STORE(idx) \ if ((idx)<256) {OP1(STORE_SCALAR1,(idx));} else {OP4(STORE_SCALAR4,(idx));} #define INVOKE(name) \ TclEmitInvoke(envPtr,INST_##name) /* *---------------------------------------------------------------------- * * TclCompileSetCmd -- * * Procedure called to compile the "set" command. |
︙ | ︙ | |||
978 979 980 981 982 983 984 985 986 987 988 | if (parsePtr->numWords != 4) { return TCL_ERROR; } stringTokenPtr = TokenAfter(parsePtr->tokenPtr); fromTokenPtr = TokenAfter(stringTokenPtr); toTokenPtr = TokenAfter(fromTokenPtr); /* * Parse the two indices. */ | > > > | > > > > > > > > > > > > > > | > > > > > > > > > > < < | | > > > | > > > | | > | | < < < > > > > | < < < | > > > > > | < < > | > > > > > | > > | < < < < > > > | > | > | | > > | > > > > > > > > > > > > > > | < | < < | | | > > | < < < > | < < < > | | | | | | > > | > > | > > > > > | | > > > > > > | > | > > > > | > > > | > | | > | > > | | | < < < < < < < < < < > | | > < | > > > | < < | < > > > > > > > > > > > > > > > > > > > > > > > > > > > > < > | | < | 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 1002 1003 1004 1005 1006 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 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 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 | if (parsePtr->numWords != 4) { return TCL_ERROR; } stringTokenPtr = TokenAfter(parsePtr->tokenPtr); fromTokenPtr = TokenAfter(stringTokenPtr); toTokenPtr = TokenAfter(fromTokenPtr); /* Every path must push the string argument */ CompileWord(envPtr, stringTokenPtr, interp, 1); /* * Parse the two indices. */ if (TclGetIndexFromToken(fromTokenPtr, TCL_INDEX_START, TCL_INDEX_AFTER, &idx1) != TCL_OK) { goto nonConstantIndices; } /* * Token parsed as an index expression. We treat all indices before * the string the same as the start of the string. */ if (idx1 == TCL_INDEX_AFTER) { /* [string range $s end+1 $last] must be empty string */ OP( POP); PUSH( ""); return TCL_OK; } if (TclGetIndexFromToken(toTokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_END, &idx2) != TCL_OK) { goto nonConstantIndices; } /* * Token parsed as an index expression. We treat all indices after * the string the same as the end of the string. */ if (idx2 == TCL_INDEX_BEFORE) { /* [string range $s $first -1] must be empty string */ OP( POP); PUSH( ""); return TCL_OK; } /* * Push the operand onto the stack and then the substring operation. */ OP44( STR_RANGE_IMM, idx1, idx2); return TCL_OK; /* * Push the operands onto the stack and then the substring operation. */ nonConstantIndices: CompileWord(envPtr, fromTokenPtr, interp, 2); CompileWord(envPtr, toTokenPtr, interp, 3); OP( STR_RANGE); return TCL_OK; } int TclCompileStringReplaceCmd( Tcl_Interp *interp, /* Tcl interpreter for context. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the * command. */ Command *cmdPtr, /* Points to defintion of command being * compiled. */ CompileEnv *envPtr) /* Holds the resulting instructions. */ { Tcl_Token *tokenPtr, *valueTokenPtr; DefineLineInformation; /* TIP #280 */ int first, last; if (parsePtr->numWords < 4 || parsePtr->numWords > 5) { return TCL_ERROR; } /* Bytecode to compute/push string argument being replaced */ valueTokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, valueTokenPtr, interp, 1); /* * Check for first index known and useful at compile time. */ tokenPtr = TokenAfter(valueTokenPtr); if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_AFTER, &first) != TCL_OK) { goto genericReplace; } /* * Check for last index known and useful at compile time. */ tokenPtr = TokenAfter(tokenPtr); if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_AFTER, &last) != TCL_OK) { goto genericReplace; } /* * [string replace] is an odd bird. For many arguments it is * a conventional substring replacer. However it also goes out * of its way to become a no-op for many cases where it would be * replacing an empty substring. Precisely, it is a no-op when * * (last < first) OR * (last < 0) OR * (end < first) * * For some compile-time values we can detect these cases, and * compile direct to bytecode implementing the no-op. */ if ((last == TCL_INDEX_BEFORE) /* Know (last < 0) */ || (first == TCL_INDEX_AFTER) /* Know (first > end) */ /* * Tricky to determine when runtime (last < first) can be * certainly known based on the encoded values. Consider the * cases... * * (first <= TCL_INDEX_END) && * (last == TCL_INDEX_AFTER) => cannot tell REJECT * (last <= TCL_INDEX END) && (last < first) => ACCEPT * else => cannot tell REJECT */ || ((first <= TCL_INDEX_END) && (last <= TCL_INDEX_END) && (last < first)) /* Know (last < first) */ /* * (first == TCL_INDEX_BEFORE) && * (last == TCL_INDEX_AFTER) => (first < last) REJECT * (last <= TCL_INDEX_END) => cannot tell REJECT * else => (first < last) REJECT * * else [[first >= TCL_INDEX_START]] && * (last == TCL_INDEX_AFTER) => cannot tell REJECT * (last <= TCL_INDEX_END) => cannot tell REJECT * else [[last >= TCL_INDEX START]] && (last < first) => ACCEPT */ || ((first >= TCL_INDEX_START) && (last >= TCL_INDEX_START) && (last < first))) { /* Know (last < first) */ if (parsePtr->numWords == 5) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 4); OP( POP); /* Pop newString */ } /* Original string argument now on TOS as result */ return TCL_OK; } if (parsePtr->numWords == 5) { /* * When we have a string replacement, we have to take care about * not replacing empty substrings that [string replace] promises * not to replace * * The remaining index values might be suitable for conventional * string replacement, but only if they cannot possibly meet the * conditions described above at runtime. If there's a chance they * might, we would have to emit bytecode to check and at that point * we're paying more in bytecode execution time than would make * things worthwhile. Trouble is we are very limited in * how much we can detect that at compile time. After decoding, * we need, first: * * (first <= end) * * The encoded indices (first <= TCL_INDEX END) and * (first == TCL_INDEX_BEFORE) always meets this condition, but * any other encoded first index has some list for which it fails. * * We also need, second: * * (last >= 0) * * The encoded indices (last >= TCL_INDEX_START) and * (last == TCL_INDEX_AFTER) always meet this condition but any * other encoded last index has some list for which it fails. * * Finally we need, third: * * (first <= last) * * Considered in combination with the constraints we already have, * we see that we can proceed when (first == TCL_INDEX_BEFORE) * or (last == TCL_INDEX_AFTER). These also permit simplification * of the prefix|replace|suffix construction. The other constraints, * though, interfere with getting a guarantee that first <= last. */ if ((first == TCL_INDEX_BEFORE) && (last >= TCL_INDEX_START)) { /* empty prefix */ tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 4); OP4( REVERSE, 2); if (last == TCL_INDEX_AFTER) { OP( POP); /* Pop original */ } else { OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END); OP1( STR_CONCAT1, 2); } return TCL_OK; } if ((last == TCL_INDEX_AFTER) && (first <= TCL_INDEX_END)) { OP44( STR_RANGE_IMM, 0, first-1); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 4); OP1( STR_CONCAT1, 2); return TCL_OK; } /* FLOW THROUGH TO genericReplace */ } else { /* * When we have no replacement string to worry about, we may * have more luck, because the forbidden empty string replacements * are harmless when they are replaced by another empty string. */ if ((first == TCL_INDEX_BEFORE) || (first == TCL_INDEX_START)) { /* empty prefix - build suffix only */ if ((last == TCL_INDEX_END) || (last == TCL_INDEX_AFTER)) { /* empty suffix too => empty result */ OP( POP); /* Pop original */ PUSH ( ""); return TCL_OK; } OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END); return TCL_OK; } else { if ((last == TCL_INDEX_END) || (last == TCL_INDEX_AFTER)) { /* empty suffix - build prefix only */ OP44( STR_RANGE_IMM, 0, first-1); return TCL_OK; } OP( DUP); OP44( STR_RANGE_IMM, 0, first-1); OP4( REVERSE, 2); OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END); OP1( STR_CONCAT1, 2); return TCL_OK; } } genericReplace: tokenPtr = TokenAfter(valueTokenPtr); CompileWord(envPtr, tokenPtr, interp, 2); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 3); if (parsePtr->numWords == 5) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 4); } else { PUSH( ""); } OP( STR_REPLACE); return TCL_OK; } int TclCompileStringTrimLCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command * created by Tcl_ParseCommand. */ |
︙ | ︙ |
Changes to generic/tclCompile.c.
︙ | ︙ | |||
125 126 127 128 129 130 131 | {"jumpTrue4", 5, -1, 1, {OPERAND_OFFSET4}}, /* Jump relative to (pc + op4) if stktop expr object is true */ {"jumpFalse1", 2, -1, 1, {OPERAND_OFFSET1}}, /* Jump relative to (pc + op1) if stktop expr object is false */ {"jumpFalse4", 5, -1, 1, {OPERAND_OFFSET4}}, /* Jump relative to (pc + op4) if stktop expr object is false */ | < < < < | 125 126 127 128 129 130 131 132 133 134 135 136 137 138 | {"jumpTrue4", 5, -1, 1, {OPERAND_OFFSET4}}, /* Jump relative to (pc + op4) if stktop expr object is true */ {"jumpFalse1", 2, -1, 1, {OPERAND_OFFSET1}}, /* Jump relative to (pc + op1) if stktop expr object is false */ {"jumpFalse4", 5, -1, 1, {OPERAND_OFFSET4}}, /* Jump relative to (pc + op4) if stktop expr object is false */ {"bitor", 1, -1, 0, {OPERAND_NONE}}, /* Bitwise or: push (stknext | stktop) */ {"bitxor", 1, -1, 0, {OPERAND_NONE}}, /* Bitwise xor push (stknext ^ stktop) */ {"bitand", 1, -1, 0, {OPERAND_NONE}}, /* Bitwise and: push (stknext & stktop) */ {"eq", 1, -1, 0, {OPERAND_NONE}}, |
︙ | ︙ | |||
169 170 171 172 173 174 175 | /* Unary plus: push +stktop */ {"uminus", 1, 0, 0, {OPERAND_NONE}}, /* Unary minus: push -stktop */ {"bitnot", 1, 0, 0, {OPERAND_NONE}}, /* Bitwise not: push ~stktop */ {"not", 1, 0, 0, {OPERAND_NONE}}, /* Logical not: push !stktop */ | < < < < < < < < < < < | 165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 | /* Unary plus: push +stktop */ {"uminus", 1, 0, 0, {OPERAND_NONE}}, /* Unary minus: push -stktop */ {"bitnot", 1, 0, 0, {OPERAND_NONE}}, /* Bitwise not: push ~stktop */ {"not", 1, 0, 0, {OPERAND_NONE}}, /* Logical not: push !stktop */ {"tryCvtToNumeric", 1, 0, 0, {OPERAND_NONE}}, /* Try converting stktop to first int then double if possible. */ {"break", 1, 0, 0, {OPERAND_NONE}}, /* Abort closest enclosing loop; if none, return TCL_BREAK code. */ {"continue", 1, 0, 0, {OPERAND_NONE}}, /* Skip to next iteration of closest enclosing loop; if none, return * TCL_CONTINUE code. */ {"beginCatch4", 5, 0, 1, {OPERAND_UINT4}}, /* Record start of catch with the operand's exception index. Push the * current stack depth onto a special catch stack. */ {"endCatch", 1, 0, 0, {OPERAND_NONE}}, /* End of last catch. Pop the bytecode interpreter's catch stack. */ {"pushResult", 1, +1, 0, {OPERAND_NONE}}, /* Push the interpreter's object result onto the stack. */ |
︙ | ︙ | |||
336 337 338 339 340 341 342 | * indicated by op4 to hold the iterator state. The local scalar * should not refer to a named variable as the value is not wholly * managed correctly. * Stack: ... dict => ... value key doneBool */ {"dictNext", 5, +3, 1, {OPERAND_LVT4}}, /* Get the next iteration from the iterator in op4's local scalar. * Stack: ... => ... value key doneBool */ | < < < | 321 322 323 324 325 326 327 328 329 330 331 332 333 334 | * indicated by op4 to hold the iterator state. The local scalar * should not refer to a named variable as the value is not wholly * managed correctly. * Stack: ... dict => ... value key doneBool */ {"dictNext", 5, +3, 1, {OPERAND_LVT4}}, /* Get the next iteration from the iterator in op4's local scalar. * Stack: ... => ... value key doneBool */ {"dictUpdateStart", 9, 0, 2, {OPERAND_LVT4, OPERAND_AUX4}}, /* Create the variables (described in the aux data referred to by the * second immediate argument) to mirror the state of the dictionary in * the variable referred to by the first immediate argument. The list * of keys (top of the stack, not popped) must be the same length as * the list of variables. * Stack: ... keyList => ... keyList */ |
︙ | ︙ | |||
1128 1129 1130 1131 1132 1133 1134 | if (hePtr) { ReleaseCmdWordData(Tcl_GetHashValue(hePtr)); Tcl_DeleteHashEntry(hePtr); } } | | | 1110 1111 1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 | if (hePtr) { ReleaseCmdWordData(Tcl_GetHashValue(hePtr)); Tcl_DeleteHashEntry(hePtr); } } if (codePtr->localCachePtr && (codePtr->localCachePtr->refCount-- <= 1)) { TclFreeLocalCache(interp, codePtr->localCachePtr); } TclHandleRelease(codePtr->interpHandle); ckfree(codePtr); } |
︙ | ︙ | |||
1424 1425 1426 1427 1428 1429 1430 | int numBytes, /* Number of bytes in source string. */ const CmdFrame *invoker, /* Location context invoking the bcc */ int word) /* Index of the word in that context getting * compiled */ { Interp *iPtr = (Interp *) interp; | | | 1406 1407 1408 1409 1410 1411 1412 1413 1414 1415 1416 1417 1418 1419 1420 | int numBytes, /* Number of bytes in source string. */ const CmdFrame *invoker, /* Location context invoking the bcc */ int word) /* Index of the word in that context getting * compiled */ { Interp *iPtr = (Interp *) interp; assert(tclInstructionTable[LAST_INST_OPCODE].name == NULL); envPtr->iPtr = iPtr; envPtr->source = stringPtr; envPtr->numSrcBytes = numBytes; envPtr->procPtr = iPtr->compiledProcPtr; iPtr->compiledProcPtr = NULL; envPtr->numCommands = 0; |
︙ | ︙ |
Changes to generic/tclCompile.h.
︙ | ︙ | |||
515 516 517 518 519 520 521 | #endif /* TCL_COMPILE_STATS */ } ByteCode; /* * Opcodes for the Tcl bytecode instructions. These must correspond to the * entries in the table of instruction descriptions, tclInstructionTable, in * tclCompile.c. Also, the order and number of the expression opcodes (e.g., | | > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < | | | | | | | | | | | | | | | | | | | | < < | | | | < < < < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < | | | | | < | | | | < | | < | | < | | | | | | | < | | < | < | | < | | | | | < | | | | | | | | < | | | | | | < | | | | | < | | | | < | | < | | < | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > > | 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 | #endif /* TCL_COMPILE_STATS */ } ByteCode; /* * Opcodes for the Tcl bytecode instructions. These must correspond to the * entries in the table of instruction descriptions, tclInstructionTable, in * tclCompile.c. Also, the order and number of the expression opcodes (e.g., * INST_BITOR) must match the entries in the array operatorStrings in * tclExecute.c. */ enum TclInstruction { /* Opcodes 0 to 9 */ INST_DONE = 0, INST_PUSH1, INST_PUSH4, INST_POP, INST_DUP, INST_STR_CONCAT1, INST_INVOKE_STK1, INST_INVOKE_STK4, INST_EVAL_STK, INST_EXPR_STK, /* Opcodes 10 to 23 */ INST_LOAD_SCALAR1, INST_LOAD_SCALAR4, INST_LOAD_SCALAR_STK, INST_LOAD_ARRAY1, INST_LOAD_ARRAY4, INST_LOAD_ARRAY_STK, INST_LOAD_STK, INST_STORE_SCALAR1, INST_STORE_SCALAR4, INST_STORE_SCALAR_STK, INST_STORE_ARRAY1, INST_STORE_ARRAY4, INST_STORE_ARRAY_STK, INST_STORE_STK, /* Opcodes 24 to 33 */ INST_INCR_SCALAR1, INST_INCR_SCALAR_STK, INST_INCR_ARRAY1, INST_INCR_ARRAY_STK, INST_INCR_STK, INST_INCR_SCALAR1_IMM, INST_INCR_SCALAR_STK_IMM, INST_INCR_ARRAY1_IMM, INST_INCR_ARRAY_STK_IMM, INST_INCR_STK_IMM, /* Opcodes 34 to 39 */ INST_JUMP1, INST_JUMP4, INST_JUMP_TRUE1, INST_JUMP_TRUE4, INST_JUMP_FALSE1, INST_JUMP_FALSE4, /* Opcodes 42 to 64 */ INST_BITOR, INST_BITXOR, INST_BITAND, INST_EQ, INST_NEQ, INST_LT, INST_GT, INST_LE, INST_GE, INST_LSHIFT, INST_RSHIFT, INST_ADD, INST_SUB, INST_MULT, INST_DIV, INST_MOD, INST_UPLUS, INST_UMINUS, INST_BITNOT, INST_LNOT, INST_TRY_CVT_TO_NUMERIC, /* Opcodes 65 to 66 */ INST_BREAK, INST_CONTINUE, /* Opcodes 69 to 72 */ INST_BEGIN_CATCH4, INST_END_CATCH, INST_PUSH_RESULT, INST_PUSH_RETURN_CODE, /* Opcodes 73 to 78 */ INST_STR_EQ, INST_STR_NEQ, INST_STR_CMP, INST_STR_LEN, INST_STR_INDEX, INST_STR_MATCH, /* Opcodes 79 to 81 */ INST_LIST, INST_LIST_INDEX, INST_LIST_LENGTH, /* Opcodes 82 to 87 */ INST_APPEND_SCALAR1, INST_APPEND_SCALAR4, INST_APPEND_ARRAY1, INST_APPEND_ARRAY4, INST_APPEND_ARRAY_STK, INST_APPEND_STK, /* Opcodes 88 to 93 */ INST_LAPPEND_SCALAR1, INST_LAPPEND_SCALAR4, INST_LAPPEND_ARRAY1, INST_LAPPEND_ARRAY4, INST_LAPPEND_ARRAY_STK, INST_LAPPEND_STK, /* TIP #22 - LINDEX operator with flat arg list */ INST_LIST_INDEX_MULTI, /* * TIP #33 - 'lset' command. Code gen also required a Forth-like * OVER operation. */ INST_OVER, INST_LSET_LIST, INST_LSET_FLAT, /* TIP#90 - 'return' command. */ INST_RETURN_IMM, /* TIP#123 - exponentiation operator. */ INST_EXPON, /* TIP #157 - {*}... (word expansion) language syntax support. */ INST_EXPAND_START, INST_EXPAND_STKTOP, INST_INVOKE_EXPANDED, /* * TIP #57 - 'lassign' command. Code generation requires immediate * LINDEX and LRANGE operators. */ INST_LIST_INDEX_IMM, INST_LIST_RANGE_IMM, INST_START_CMD, INST_LIST_IN, INST_LIST_NOT_IN, INST_PUSH_RETURN_OPTIONS, INST_RETURN_STK, /* * Dictionary (TIP#111) related commands. */ INST_DICT_GET, INST_DICT_SET, INST_DICT_UNSET, INST_DICT_INCR_IMM, INST_DICT_APPEND, INST_DICT_LAPPEND, INST_DICT_FIRST, INST_DICT_NEXT, INST_DICT_UPDATE_START, INST_DICT_UPDATE_END, /* * Instruction to support jumps defined by tables (instead of the classic * [switch] technique of chained comparisons). */ INST_JUMP_TABLE, /* * Instructions to support compilation of global, variable, upvar and * [namespace upvar]. */ INST_UPVAR, INST_NSUPVAR, INST_VARIABLE, /* Instruction to support compiling syntax error to bytecode */ INST_SYNTAX, /* Instruction to reverse N items on top of stack */ INST_REVERSE, /* regexp instruction */ INST_REGEXP, /* For [info exists] compilation */ INST_EXIST_SCALAR, INST_EXIST_ARRAY, INST_EXIST_ARRAY_STK, INST_EXIST_STK, /* For [subst] compilation */ INST_NOP, INST_RETURN_CODE_BRANCH, /* For [unset] compilation */ INST_UNSET_SCALAR, INST_UNSET_ARRAY, INST_UNSET_ARRAY_STK, INST_UNSET_STK, /* For [dict with], [dict exists], [dict create] and [dict merge] */ INST_DICT_EXPAND, INST_DICT_RECOMBINE_STK, INST_DICT_RECOMBINE_IMM, INST_DICT_EXISTS, INST_DICT_VERIFY, /* For [string map] and [regsub] compilation */ INST_STR_MAP, INST_STR_FIND, INST_STR_FIND_LAST, INST_STR_RANGE_IMM, INST_STR_RANGE, /* For operations to do with coroutines and other NRE-manipulators */ INST_YIELD, INST_COROUTINE_NAME, INST_TAILCALL, /* For compilation of basic information operations */ INST_NS_CURRENT, INST_INFO_LEVEL_NUM, INST_INFO_LEVEL_ARGS, INST_RESOLVE_COMMAND, /* For compilation relating to TclOO */ INST_TCLOO_SELF, INST_TCLOO_CLASS, INST_TCLOO_NS, INST_TCLOO_IS_OBJECT, /* For compilation of [array] subcommands */ INST_ARRAY_EXISTS_STK, INST_ARRAY_EXISTS_IMM, INST_ARRAY_MAKE_STK, INST_ARRAY_MAKE_IMM, INST_INVOKE_REPLACE, INST_LIST_CONCAT, INST_EXPAND_DROP, /* New foreach implementation */ INST_FOREACH_START, INST_FOREACH_STEP, INST_FOREACH_END, INST_LMAP_COLLECT, /* For compilation of [string trim] and related */ INST_STR_TRIM, INST_STR_TRIM_LEFT, INST_STR_TRIM_RIGHT, INST_CONCAT_STK, INST_STR_UPPER, INST_STR_LOWER, INST_STR_TITLE, INST_STR_REPLACE, INST_ORIGIN_COMMAND, INST_TCLOO_NEXT, INST_TCLOO_NEXT_CLASS, INST_YIELD_TO_INVOKE, INST_NUM_TYPE, INST_TRY_CVT_TO_BOOLEAN, INST_STR_CLASS, INST_LAPPEND_LIST, INST_LAPPEND_LIST_ARRAY, INST_LAPPEND_LIST_ARRAY_STK, INST_LAPPEND_LIST_STK, INST_CLOCK_READ, /* The last opcode */ LAST_INST_OPCODE }; /* * Table describing the Tcl bytecode instructions: their name (for displaying * code), total number of code bytes required (including operand bytes), and a * description of the type of each operand. These operand types include signed * and unsigned integers of length one and four bytes. The unsigned integers * are used for indexes or for, e.g., the count of objects to push in a "push" |
︙ | ︙ | |||
1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 | MODULE_SCOPE int TclFindCompiledLocal(const char *name, int nameChars, int create, CompileEnv *envPtr); MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr, JumpFixup *jumpFixupPtr, int jumpDist, int distThreshold); MODULE_SCOPE void TclFreeCompileEnv(CompileEnv *envPtr); MODULE_SCOPE void TclFreeJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE ByteCode * TclInitByteCode(CompileEnv *envPtr); MODULE_SCOPE ByteCode * TclInitByteCodeObj(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, CompileEnv *envPtr); MODULE_SCOPE void TclInitCompileEnv(Tcl_Interp *interp, CompileEnv *envPtr, const char *string, int numBytes, const CmdFrame *invoker, int word); MODULE_SCOPE void TclInitJumpFixupArray(JumpFixupArray *fixupArrayPtr); | > > | 1096 1097 1098 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 | MODULE_SCOPE int TclFindCompiledLocal(const char *name, int nameChars, int create, CompileEnv *envPtr); MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr, JumpFixup *jumpFixupPtr, int jumpDist, int distThreshold); MODULE_SCOPE void TclFreeCompileEnv(CompileEnv *envPtr); MODULE_SCOPE void TclFreeJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE int TclGetIndexFromToken(Tcl_Token *tokenPtr, int before, int after, int *indexPtr); MODULE_SCOPE ByteCode * TclInitByteCode(CompileEnv *envPtr); MODULE_SCOPE ByteCode * TclInitByteCodeObj(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, CompileEnv *envPtr); MODULE_SCOPE void TclInitCompileEnv(Tcl_Interp *interp, CompileEnv *envPtr, const char *string, int numBytes, const CmdFrame *invoker, int word); MODULE_SCOPE void TclInitJumpFixupArray(JumpFixupArray *fixupArrayPtr); |
︙ | ︙ |
Changes to generic/tclConfig.c.
︙ | ︙ | |||
213 214 215 216 217 218 219 | Tcl_Encoding venc = NULL; const char *value; if ((objc < 2) || (objc > 3)) { Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg?"); return TCL_ERROR; } | | | | 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 | Tcl_Encoding venc = NULL; const char *value; if ((objc < 2) || (objc > 3)) { Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], subcmdStrings, "subcommand", 0, &index) != TCL_OK) { return TCL_ERROR; } pDB = GetConfigDict(interp); if (Tcl_DictObjGet(interp, pDB, pkgName, &pkgDict) != TCL_OK || pkgDict == NULL) { /* |
︙ | ︙ |
Changes to generic/tclDecls.h.
︙ | ︙ | |||
112 113 114 115 116 117 118 | int length, const char *file, int line); /* 24 */ TCLAPI Tcl_Obj * Tcl_DbNewDoubleObj(double doubleValue, const char *file, int line); /* 25 */ TCLAPI Tcl_Obj * Tcl_DbNewListObj(int objc, Tcl_Obj *const *objv, const char *file, int line); | | < < | 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 | int length, const char *file, int line); /* 24 */ TCLAPI Tcl_Obj * Tcl_DbNewDoubleObj(double doubleValue, const char *file, int line); /* 25 */ TCLAPI Tcl_Obj * Tcl_DbNewListObj(int objc, Tcl_Obj *const *objv, const char *file, int line); /* Slot 26 is reserved */ /* 27 */ TCLAPI Tcl_Obj * Tcl_DbNewObj(const char *file, int line); /* 28 */ TCLAPI Tcl_Obj * Tcl_DbNewStringObj(const char *bytes, int length, const char *file, int line); /* 29 */ TCLAPI Tcl_Obj * Tcl_DuplicateObj(Tcl_Obj *objPtr); |
︙ | ︙ | |||
182 183 184 185 186 187 188 | int objc, Tcl_Obj *const objv[]); /* Slot 49 is reserved */ /* 50 */ TCLAPI Tcl_Obj * Tcl_NewByteArrayObj(const unsigned char *bytes, int length); /* 51 */ TCLAPI Tcl_Obj * Tcl_NewDoubleObj(double doubleValue); | | < | < | < | < | 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 | int objc, Tcl_Obj *const objv[]); /* Slot 49 is reserved */ /* 50 */ TCLAPI Tcl_Obj * Tcl_NewByteArrayObj(const unsigned char *bytes, int length); /* 51 */ TCLAPI Tcl_Obj * Tcl_NewDoubleObj(double doubleValue); /* Slot 52 is reserved */ /* 53 */ TCLAPI Tcl_Obj * Tcl_NewListObj(int objc, Tcl_Obj *const objv[]); /* Slot 54 is reserved */ /* 55 */ TCLAPI Tcl_Obj * Tcl_NewObj(void); /* 56 */ TCLAPI Tcl_Obj * Tcl_NewStringObj(const char *bytes, int length); /* Slot 57 is reserved */ /* 58 */ TCLAPI unsigned char * Tcl_SetByteArrayLength(Tcl_Obj *objPtr, int length); /* 59 */ TCLAPI void Tcl_SetByteArrayObj(Tcl_Obj *objPtr, const unsigned char *bytes, int length); /* 60 */ TCLAPI void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue); /* Slot 61 is reserved */ /* 62 */ TCLAPI void Tcl_SetListObj(Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[]); /* Slot 63 is reserved */ /* 64 */ TCLAPI void Tcl_SetObjLength(Tcl_Obj *objPtr, int length); /* 65 */ TCLAPI void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, int length); /* Slot 66 is reserved */ /* Slot 67 is reserved */ |
︙ | ︙ | |||
383 384 385 386 387 388 389 | /* 126 */ TCLAPI int Tcl_Eof(Tcl_Channel chan); /* 127 */ TCLAPI const char * Tcl_ErrnoId(void); /* 128 */ TCLAPI const char * Tcl_ErrnoMsg(int err); /* Slot 129 is reserved */ | | > > | 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 | /* 126 */ TCLAPI int Tcl_Eof(Tcl_Channel chan); /* 127 */ TCLAPI const char * Tcl_ErrnoId(void); /* 128 */ TCLAPI const char * Tcl_ErrnoMsg(int err); /* Slot 129 is reserved */ /* 130 */ TCLAPI int Tcl_EvalFile(Tcl_Interp *interp, const char *fileName); /* Slot 131 is reserved */ /* 132 */ TCLAPI void Tcl_EventuallyFree(ClientData clientData, Tcl_FreeProc *freeProc); /* 133 */ TCLAPI TCL_NORETURN void Tcl_Exit(int status); /* 134 */ |
︙ | ︙ | |||
739 740 741 742 743 744 745 | /* 264 */ TCLAPI void Tcl_WrongNumArgs(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], const char *message); /* 265 */ TCLAPI int Tcl_DumpActiveMemory(const char *fileName); /* 266 */ TCLAPI void Tcl_ValidateAllMemory(const char *file, int line); | | < < | < < | < < | < | 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 | /* 264 */ TCLAPI void Tcl_WrongNumArgs(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], const char *message); /* 265 */ TCLAPI int Tcl_DumpActiveMemory(const char *fileName); /* 266 */ TCLAPI void Tcl_ValidateAllMemory(const char *file, int line); /* Slot 267 is reserved */ /* Slot 268 is reserved */ /* 269 */ TCLAPI char * Tcl_HashStats(Tcl_HashTable *tablePtr); /* 270 */ TCLAPI const char * Tcl_ParseVar(Tcl_Interp *interp, const char *start, const char **termPtr); /* Slot 271 is reserved */ /* 272 */ TCLAPI const char * Tcl_PkgPresentEx(Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 273 */ TCLAPI int TclPkgProvide(Tcl_Interp *interp, const char *name, const char *version); /* Slot 274 is reserved */ /* Slot 275 is reserved */ /* Slot 276 is reserved */ /* 277 */ TCLAPI Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options); /* Slot 278 is reserved */ /* 279 */ TCLAPI void Tcl_GetVersion(int *major, int *minor, int *patchLevel, int *type); /* 280 */ TCLAPI void Tcl_InitMemory(Tcl_Interp *interp); /* 281 */ TCLAPI Tcl_Channel Tcl_StackChannel(Tcl_Interp *interp, |
︙ | ︙ | |||
949 950 951 952 953 954 955 | TCLAPI int Tcl_UniCharIsUpper(int ch); /* 351 */ TCLAPI int Tcl_UniCharIsWordChar(int ch); /* 352 */ TCLAPI int Tcl_UniCharLen(const Tcl_UniChar *uniStr); /* 353 */ TCLAPI int Tcl_UniCharNcmp(const Tcl_UniChar *ucs, | | > | 938 939 940 941 942 943 944 945 946 947 948 949 950 951 952 953 | TCLAPI int Tcl_UniCharIsUpper(int ch); /* 351 */ TCLAPI int Tcl_UniCharIsWordChar(int ch); /* 352 */ TCLAPI int Tcl_UniCharLen(const Tcl_UniChar *uniStr); /* 353 */ TCLAPI int Tcl_UniCharNcmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned long numChars); /* 354 */ TCLAPI char * Tcl_UniCharToUtfDString(const Tcl_UniChar *uniStr, int uniLength, Tcl_DString *dsPtr); /* 355 */ TCLAPI Tcl_UniChar * Tcl_UtfToUniCharDString(const char *src, int length, Tcl_DString *dsPtr); /* 356 */ |
︙ | ︙ | |||
996 997 998 999 1000 1001 1002 | /* 366 */ TCLAPI int Tcl_Chdir(const char *dirName); /* 367 */ TCLAPI int Tcl_Access(const char *path, int mode); /* 368 */ TCLAPI int Tcl_Stat(const char *path, struct stat *bufPtr); /* 369 */ | | > | | 986 987 988 989 990 991 992 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 | /* 366 */ TCLAPI int Tcl_Chdir(const char *dirName); /* 367 */ TCLAPI int Tcl_Access(const char *path, int mode); /* 368 */ TCLAPI int Tcl_Stat(const char *path, struct stat *bufPtr); /* 369 */ TCLAPI int Tcl_UtfNcmp(const char *s1, const char *s2, unsigned long n); /* 370 */ TCLAPI int Tcl_UtfNcasecmp(const char *s1, const char *s2, unsigned long n); /* 371 */ TCLAPI int Tcl_StringCaseMatch(const char *str, const char *pattern, int nocase); /* 372 */ TCLAPI int Tcl_UniCharIsControl(int ch); /* 373 */ TCLAPI int Tcl_UniCharIsGraph(int ch); |
︙ | ︙ | |||
1128 1129 1130 1131 1132 1133 1134 | TCLAPI void Tcl_SpliceChannel(Tcl_Channel channel); /* 417 */ TCLAPI void Tcl_ClearChannelHandlers(Tcl_Channel channel); /* 418 */ TCLAPI int Tcl_IsChannelExisting(const char *channelName); /* 419 */ TCLAPI int Tcl_UniCharNcasecmp(const Tcl_UniChar *ucs, | | > | 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 | TCLAPI void Tcl_SpliceChannel(Tcl_Channel channel); /* 417 */ TCLAPI void Tcl_ClearChannelHandlers(Tcl_Channel channel); /* 418 */ TCLAPI int Tcl_IsChannelExisting(const char *channelName); /* 419 */ TCLAPI int Tcl_UniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned long numChars); /* 420 */ TCLAPI int Tcl_UniCharCaseMatch(const Tcl_UniChar *uniStr, const Tcl_UniChar *uniPattern, int nocase); /* Slot 421 is reserved */ /* Slot 422 is reserved */ /* 423 */ TCLAPI void Tcl_InitCustomHashTable(Tcl_HashTable *tablePtr, |
︙ | ︙ | |||
1406 1407 1408 1409 1410 1411 1412 | /* 517 */ TCLAPI void Tcl_GetCommandFullName(Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 518 */ TCLAPI int Tcl_FSEvalFileEx(Tcl_Interp *interp, Tcl_Obj *fileName, const char *encodingName); /* 519 */ | | | 1398 1399 1400 1401 1402 1403 1404 1405 1406 1407 1408 1409 1410 1411 1412 | /* 517 */ TCLAPI void Tcl_GetCommandFullName(Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 518 */ TCLAPI int Tcl_FSEvalFileEx(Tcl_Interp *interp, Tcl_Obj *fileName, const char *encodingName); /* 519 */ TCLAPI Tcl_ExitProc * Tcl_SetExitProc(TCL_NORETURN Tcl_ExitProc *proc); /* 520 */ TCLAPI void Tcl_LimitAddHandler(Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, ClientData clientData, Tcl_LimitHandlerDeleteProc *deleteProc); /* 521 */ TCLAPI void Tcl_LimitRemoveHandler(Tcl_Interp *interp, int type, |
︙ | ︙ | |||
1743 1744 1745 1746 1747 1748 1749 | 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 */ | | | 1735 1736 1737 1738 1739 1740 1741 1742 1743 1744 1745 1746 1747 1748 1749 | 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_NORETURN 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 */ #if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ |
︙ | ︙ | |||
1783 1784 1785 1786 1787 1788 1789 | void (*tcl_DbDecrRefCount) (Tcl_Obj *objPtr, const char *file, int line); /* 19 */ void (*tcl_DbIncrRefCount) (Tcl_Obj *objPtr, const char *file, int line); /* 20 */ int (*tcl_DbIsShared) (Tcl_Obj *objPtr, const char *file, int line); /* 21 */ void (*reserved22)(void); Tcl_Obj * (*tcl_DbNewByteArrayObj) (const unsigned char *bytes, int length, const char *file, int line); /* 23 */ Tcl_Obj * (*tcl_DbNewDoubleObj) (double doubleValue, const char *file, int line); /* 24 */ Tcl_Obj * (*tcl_DbNewListObj) (int objc, Tcl_Obj *const *objv, const char *file, int line); /* 25 */ | | | 1775 1776 1777 1778 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 | void (*tcl_DbDecrRefCount) (Tcl_Obj *objPtr, const char *file, int line); /* 19 */ void (*tcl_DbIncrRefCount) (Tcl_Obj *objPtr, const char *file, int line); /* 20 */ int (*tcl_DbIsShared) (Tcl_Obj *objPtr, const char *file, int line); /* 21 */ void (*reserved22)(void); Tcl_Obj * (*tcl_DbNewByteArrayObj) (const unsigned char *bytes, int length, const char *file, int line); /* 23 */ Tcl_Obj * (*tcl_DbNewDoubleObj) (double doubleValue, const char *file, int line); /* 24 */ Tcl_Obj * (*tcl_DbNewListObj) (int objc, Tcl_Obj *const *objv, const char *file, int line); /* 25 */ void (*reserved26)(void); Tcl_Obj * (*tcl_DbNewObj) (const char *file, int line); /* 27 */ Tcl_Obj * (*tcl_DbNewStringObj) (const char *bytes, int length, const char *file, int line); /* 28 */ 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 */ |
︙ | ︙ | |||
1809 1810 1811 1812 1813 1814 1815 | int (*tcl_ListObjGetElements) (Tcl_Interp *interp, Tcl_Obj *listPtr, int *objcPtr, Tcl_Obj ***objvPtr); /* 45 */ int (*tcl_ListObjIndex) (Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj **objPtrPtr); /* 46 */ int (*tcl_ListObjLength) (Tcl_Interp *interp, Tcl_Obj *listPtr, int *lengthPtr); /* 47 */ int (*tcl_ListObjReplace) (Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, int objc, Tcl_Obj *const objv[]); /* 48 */ void (*reserved49)(void); Tcl_Obj * (*tcl_NewByteArrayObj) (const unsigned char *bytes, int length); /* 50 */ Tcl_Obj * (*tcl_NewDoubleObj) (double doubleValue); /* 51 */ | | | | | | 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 | int (*tcl_ListObjGetElements) (Tcl_Interp *interp, Tcl_Obj *listPtr, int *objcPtr, Tcl_Obj ***objvPtr); /* 45 */ int (*tcl_ListObjIndex) (Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj **objPtrPtr); /* 46 */ int (*tcl_ListObjLength) (Tcl_Interp *interp, Tcl_Obj *listPtr, int *lengthPtr); /* 47 */ int (*tcl_ListObjReplace) (Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, int objc, Tcl_Obj *const objv[]); /* 48 */ void (*reserved49)(void); Tcl_Obj * (*tcl_NewByteArrayObj) (const unsigned char *bytes, int length); /* 50 */ Tcl_Obj * (*tcl_NewDoubleObj) (double doubleValue); /* 51 */ void (*reserved52)(void); Tcl_Obj * (*tcl_NewListObj) (int objc, Tcl_Obj *const objv[]); /* 53 */ void (*reserved54)(void); Tcl_Obj * (*tcl_NewObj) (void); /* 55 */ Tcl_Obj * (*tcl_NewStringObj) (const char *bytes, int length); /* 56 */ void (*reserved57)(void); unsigned char * (*tcl_SetByteArrayLength) (Tcl_Obj *objPtr, int length); /* 58 */ void (*tcl_SetByteArrayObj) (Tcl_Obj *objPtr, const unsigned char *bytes, int length); /* 59 */ void (*tcl_SetDoubleObj) (Tcl_Obj *objPtr, double doubleValue); /* 60 */ void (*reserved61)(void); void (*tcl_SetListObj) (Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[]); /* 62 */ void (*reserved63)(void); void (*tcl_SetObjLength) (Tcl_Obj *objPtr, int length); /* 64 */ void (*tcl_SetStringObj) (Tcl_Obj *objPtr, const char *bytes, int length); /* 65 */ void (*reserved66)(void); void (*reserved67)(void); void (*tcl_AllowExceptions) (Tcl_Interp *interp); /* 68 */ void (*tcl_AppendElement) (Tcl_Interp *interp, const char *element); /* 69 */ void (*tcl_AppendResult) (Tcl_Interp *interp, ...); /* 70 */ |
︙ | ︙ | |||
1887 1888 1889 1890 1891 1892 1893 | 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 */ void (*reserved129)(void); | | | | 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 | 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 */ void (*reserved129)(void); int (*tcl_EvalFile) (Tcl_Interp *interp, const char *fileName); /* 130 */ void (*reserved131)(void); void (*tcl_EventuallyFree) (ClientData clientData, Tcl_FreeProc *freeProc); /* 132 */ TCL_NORETURN 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 */ |
︙ | ︙ | |||
2032 2033 2034 2035 2036 2037 2038 | void (*reserved260)(void); void (*reserved261)(void); 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 */ | | | | | | | 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 | void (*reserved260)(void); void (*reserved261)(void); ClientData (*tcl_VarTraceInfo2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData); /* 262 */ int (*tcl_Write) (Tcl_Channel chan, const char *s, int slen); /* 263 */ void (*tcl_WrongNumArgs) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], const char *message); /* 264 */ int (*tcl_DumpActiveMemory) (const char *fileName); /* 265 */ void (*tcl_ValidateAllMemory) (const char *file, int line); /* 266 */ void (*reserved267)(void); void (*reserved268)(void); char * (*tcl_HashStats) (Tcl_HashTable *tablePtr); /* 269 */ const char * (*tcl_ParseVar) (Tcl_Interp *interp, const char *start, const char **termPtr); /* 270 */ void (*reserved271)(void); const char * (*tcl_PkgPresentEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 272 */ int (*tclPkgProvide) (Tcl_Interp *interp, const char *name, const char *version); /* 273 */ void (*reserved274)(void); void (*reserved275)(void); void (*reserved276)(void); Tcl_Pid (*tcl_WaitPid) (Tcl_Pid pid, int *statPtr, int options); /* 277 */ void (*reserved278)(void); 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); void (*tcl_AppendObjToObj) (Tcl_Obj *objPtr, Tcl_Obj *appendObjPtr); /* 286 */ Tcl_Encoding (*tcl_CreateEncoding) (const Tcl_EncodingType *typePtr); /* 287 */ void (*tcl_CreateThreadExitHandler) (Tcl_ExitProc *proc, ClientData clientData); /* 288 */ void (*tcl_DeleteThreadExitHandler) (Tcl_ExitProc *proc, ClientData clientData); /* 289 */ void (*reserved290)(void); int (*tcl_EvalEx) (Tcl_Interp *interp, const char *script, int numBytes, int flags); /* 291 */ int (*tcl_EvalObjv) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); /* 292 */ int (*tcl_EvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 293 */ TCL_NORETURN void (*tcl_ExitThread) (int status); /* 294 */ 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 */ |
︙ | ︙ | |||
2118 2119 2120 2121 2122 2123 2124 | 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 */ | | | | | 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 | 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 */ void (*reserved357)(void); 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 */ int (*tcl_StringCaseMatch) (const char *str, const char *pattern, int nocase); /* 371 */ int (*tcl_UniCharIsControl) (int ch); /* 372 */ int (*tcl_UniCharIsGraph) (int ch); /* 373 */ int (*tcl_UniCharIsPrint) (int ch); /* 374 */ int (*tcl_UniCharIsPunct) (int ch); /* 375 */ int (*tcl_RegExpExecObj) (Tcl_Interp *interp, Tcl_RegExp regexp, Tcl_Obj *textObj, int offset, int nmatches, int flags); /* 376 */ void (*tcl_RegExpGetInfo) (Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr); /* 377 */ |
︙ | ︙ | |||
2184 2185 2186 2187 2188 2189 2190 | int (*tcl_JoinThread) (Tcl_ThreadId threadId, int *result); /* 412 */ int (*tcl_IsChannelShared) (Tcl_Channel channel); /* 413 */ int (*tcl_IsChannelRegistered) (Tcl_Interp *interp, Tcl_Channel channel); /* 414 */ void (*tcl_CutChannel) (Tcl_Channel channel); /* 415 */ void (*tcl_SpliceChannel) (Tcl_Channel channel); /* 416 */ void (*tcl_ClearChannelHandlers) (Tcl_Channel channel); /* 417 */ int (*tcl_IsChannelExisting) (const char *channelName); /* 418 */ | | | 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 2190 | int (*tcl_JoinThread) (Tcl_ThreadId threadId, int *result); /* 412 */ int (*tcl_IsChannelShared) (Tcl_Channel channel); /* 413 */ int (*tcl_IsChannelRegistered) (Tcl_Interp *interp, Tcl_Channel channel); /* 414 */ void (*tcl_CutChannel) (Tcl_Channel channel); /* 415 */ void (*tcl_SpliceChannel) (Tcl_Channel channel); /* 416 */ void (*tcl_ClearChannelHandlers) (Tcl_Channel channel); /* 417 */ int (*tcl_IsChannelExisting) (const char *channelName); /* 418 */ int (*tcl_UniCharNcasecmp) (const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsigned long numChars); /* 419 */ int (*tcl_UniCharCaseMatch) (const Tcl_UniChar *uniStr, const Tcl_UniChar *uniPattern, int nocase); /* 420 */ void (*reserved421)(void); void (*reserved422)(void); void (*tcl_InitCustomHashTable) (Tcl_HashTable *tablePtr, int keyType, const Tcl_HashKeyType *typePtr); /* 423 */ void (*tcl_InitObjHashTable) (Tcl_HashTable *tablePtr); /* 424 */ ClientData (*tcl_CommandTraceInfo) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *procPtr, ClientData prevClientData); /* 425 */ int (*tcl_TraceCommand) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, ClientData clientData); /* 426 */ |
︙ | ︙ | |||
2284 2285 2286 2287 2288 2289 2290 | Tcl_Namespace * (*tcl_GetCurrentNamespace) (Tcl_Interp *interp); /* 512 */ Tcl_Namespace * (*tcl_GetGlobalNamespace) (Tcl_Interp *interp); /* 513 */ Tcl_Namespace * (*tcl_FindNamespace) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 514 */ Tcl_Command (*tcl_FindCommand) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 515 */ Tcl_Command (*tcl_GetCommandFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 516 */ void (*tcl_GetCommandFullName) (Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 517 */ int (*tcl_FSEvalFileEx) (Tcl_Interp *interp, Tcl_Obj *fileName, const char *encodingName); /* 518 */ | | | 2276 2277 2278 2279 2280 2281 2282 2283 2284 2285 2286 2287 2288 2289 2290 | Tcl_Namespace * (*tcl_GetCurrentNamespace) (Tcl_Interp *interp); /* 512 */ Tcl_Namespace * (*tcl_GetGlobalNamespace) (Tcl_Interp *interp); /* 513 */ Tcl_Namespace * (*tcl_FindNamespace) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 514 */ Tcl_Command (*tcl_FindCommand) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 515 */ Tcl_Command (*tcl_GetCommandFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 516 */ void (*tcl_GetCommandFullName) (Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 517 */ int (*tcl_FSEvalFileEx) (Tcl_Interp *interp, Tcl_Obj *fileName, const char *encodingName); /* 518 */ Tcl_ExitProc * (*tcl_SetExitProc) (TCL_NORETURN Tcl_ExitProc *proc); /* 519 */ void (*tcl_LimitAddHandler) (Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, ClientData clientData, Tcl_LimitHandlerDeleteProc *deleteProc); /* 520 */ void (*tcl_LimitRemoveHandler) (Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, ClientData clientData); /* 521 */ int (*tcl_LimitReady) (Tcl_Interp *interp); /* 522 */ int (*tcl_LimitCheck) (Tcl_Interp *interp); /* 523 */ int (*tcl_LimitExceeded) (Tcl_Interp *interp); /* 524 */ void (*tcl_LimitSetCommands) (Tcl_Interp *interp, int commandLimit); /* 525 */ void (*tcl_LimitSetTime) (Tcl_Interp *interp, Tcl_Time *timeLimitPtr); /* 526 */ |
︙ | ︙ | |||
2474 2475 2476 2477 2478 2479 2480 | /* Slot 22 is reserved */ #define Tcl_DbNewByteArrayObj \ (tclStubsPtr->tcl_DbNewByteArrayObj) /* 23 */ #define Tcl_DbNewDoubleObj \ (tclStubsPtr->tcl_DbNewDoubleObj) /* 24 */ #define Tcl_DbNewListObj \ (tclStubsPtr->tcl_DbNewListObj) /* 25 */ | | < | 2466 2467 2468 2469 2470 2471 2472 2473 2474 2475 2476 2477 2478 2479 2480 | /* Slot 22 is reserved */ #define Tcl_DbNewByteArrayObj \ (tclStubsPtr->tcl_DbNewByteArrayObj) /* 23 */ #define Tcl_DbNewDoubleObj \ (tclStubsPtr->tcl_DbNewDoubleObj) /* 24 */ #define Tcl_DbNewListObj \ (tclStubsPtr->tcl_DbNewListObj) /* 25 */ /* Slot 26 is reserved */ #define Tcl_DbNewObj \ (tclStubsPtr->tcl_DbNewObj) /* 27 */ #define Tcl_DbNewStringObj \ (tclStubsPtr->tcl_DbNewStringObj) /* 28 */ #define Tcl_DuplicateObj \ (tclStubsPtr->tcl_DuplicateObj) /* 29 */ #define TclFreeObj \ |
︙ | ︙ | |||
2524 2525 2526 2527 2528 2529 2530 | #define Tcl_ListObjReplace \ (tclStubsPtr->tcl_ListObjReplace) /* 48 */ /* Slot 49 is reserved */ #define Tcl_NewByteArrayObj \ (tclStubsPtr->tcl_NewByteArrayObj) /* 50 */ #define Tcl_NewDoubleObj \ (tclStubsPtr->tcl_NewDoubleObj) /* 51 */ | < | < | < | < | | 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 | #define Tcl_ListObjReplace \ (tclStubsPtr->tcl_ListObjReplace) /* 48 */ /* Slot 49 is reserved */ #define Tcl_NewByteArrayObj \ (tclStubsPtr->tcl_NewByteArrayObj) /* 50 */ #define Tcl_NewDoubleObj \ (tclStubsPtr->tcl_NewDoubleObj) /* 51 */ /* Slot 52 is reserved */ #define Tcl_NewListObj \ (tclStubsPtr->tcl_NewListObj) /* 53 */ /* Slot 54 is reserved */ #define Tcl_NewObj \ (tclStubsPtr->tcl_NewObj) /* 55 */ #define Tcl_NewStringObj \ (tclStubsPtr->tcl_NewStringObj) /* 56 */ /* Slot 57 is reserved */ #define Tcl_SetByteArrayLength \ (tclStubsPtr->tcl_SetByteArrayLength) /* 58 */ #define Tcl_SetByteArrayObj \ (tclStubsPtr->tcl_SetByteArrayObj) /* 59 */ #define Tcl_SetDoubleObj \ (tclStubsPtr->tcl_SetDoubleObj) /* 60 */ /* Slot 61 is reserved */ #define Tcl_SetListObj \ (tclStubsPtr->tcl_SetListObj) /* 62 */ /* Slot 63 is reserved */ #define Tcl_SetObjLength \ (tclStubsPtr->tcl_SetObjLength) /* 64 */ #define Tcl_SetStringObj \ (tclStubsPtr->tcl_SetStringObj) /* 65 */ /* Slot 66 is reserved */ /* Slot 67 is reserved */ #define Tcl_AllowExceptions \ |
︙ | ︙ | |||
2674 2675 2676 2677 2678 2679 2680 | #define Tcl_Eof \ (tclStubsPtr->tcl_Eof) /* 126 */ #define Tcl_ErrnoId \ (tclStubsPtr->tcl_ErrnoId) /* 127 */ #define Tcl_ErrnoMsg \ (tclStubsPtr->tcl_ErrnoMsg) /* 128 */ /* Slot 129 is reserved */ | > | | 2661 2662 2663 2664 2665 2666 2667 2668 2669 2670 2671 2672 2673 2674 2675 2676 | #define Tcl_Eof \ (tclStubsPtr->tcl_Eof) /* 126 */ #define Tcl_ErrnoId \ (tclStubsPtr->tcl_ErrnoId) /* 127 */ #define Tcl_ErrnoMsg \ (tclStubsPtr->tcl_ErrnoMsg) /* 128 */ /* Slot 129 is reserved */ #define Tcl_EvalFile \ (tclStubsPtr->tcl_EvalFile) /* 130 */ /* Slot 131 is reserved */ #define Tcl_EventuallyFree \ (tclStubsPtr->tcl_EventuallyFree) /* 132 */ #define Tcl_Exit \ (tclStubsPtr->tcl_Exit) /* 133 */ #define Tcl_ExposeCommand \ (tclStubsPtr->tcl_ExposeCommand) /* 134 */ |
︙ | ︙ | |||
2936 2937 2938 2939 2940 2941 2942 | (tclStubsPtr->tcl_Write) /* 263 */ #define Tcl_WrongNumArgs \ (tclStubsPtr->tcl_WrongNumArgs) /* 264 */ #define Tcl_DumpActiveMemory \ (tclStubsPtr->tcl_DumpActiveMemory) /* 265 */ #define Tcl_ValidateAllMemory \ (tclStubsPtr->tcl_ValidateAllMemory) /* 266 */ | < | < | < | < | | 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 | (tclStubsPtr->tcl_Write) /* 263 */ #define Tcl_WrongNumArgs \ (tclStubsPtr->tcl_WrongNumArgs) /* 264 */ #define Tcl_DumpActiveMemory \ (tclStubsPtr->tcl_DumpActiveMemory) /* 265 */ #define Tcl_ValidateAllMemory \ (tclStubsPtr->tcl_ValidateAllMemory) /* 266 */ /* Slot 267 is reserved */ /* Slot 268 is reserved */ #define Tcl_HashStats \ (tclStubsPtr->tcl_HashStats) /* 269 */ #define Tcl_ParseVar \ (tclStubsPtr->tcl_ParseVar) /* 270 */ /* Slot 271 is reserved */ #define Tcl_PkgPresentEx \ (tclStubsPtr->tcl_PkgPresentEx) /* 272 */ #define TclPkgProvide \ (tclStubsPtr->tclPkgProvide) /* 273 */ /* Slot 274 is reserved */ /* Slot 275 is reserved */ /* Slot 276 is reserved */ #define Tcl_WaitPid \ (tclStubsPtr->tcl_WaitPid) /* 277 */ /* Slot 278 is reserved */ #define Tcl_GetVersion \ (tclStubsPtr->tcl_GetVersion) /* 279 */ #define Tcl_InitMemory \ (tclStubsPtr->tcl_InitMemory) /* 280 */ #define Tcl_StackChannel \ (tclStubsPtr->tcl_StackChannel) /* 281 */ #define Tcl_UnstackChannel \ |
︙ | ︙ | |||
3685 3686 3687 3688 3689 3690 3691 | #define Tcl_PkgProvide(interp, name, version) \ Tcl_PkgProvideEx(interp, name, version, NULL) #define Tcl_PkgRequire(interp, name, version, exact) \ Tcl_PkgRequireEx(interp, name, version, exact, NULL) #define Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr) \ Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, \ sizeof(char *), msg, flags, indexPtr) | < | | < | | 3669 3670 3671 3672 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 3688 | #define Tcl_PkgProvide(interp, name, version) \ Tcl_PkgProvideEx(interp, name, version, NULL) #define Tcl_PkgRequire(interp, name, version, exact) \ Tcl_PkgRequireEx(interp, name, version, exact, NULL) #define Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr) \ Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, \ sizeof(char *), msg, flags, indexPtr) #define Tcl_NewBooleanObj(boolValue) \ Tcl_NewWideIntObj((boolValue)!=0) #define Tcl_DbNewBooleanObj(boolValue, file, line) \ Tcl_DbNewWideIntObj((boolValue)!=0, file, line) #define Tcl_SetBooleanObj(objPtr, boolValue) \ Tcl_SetWideIntObj(objPtr, (boolValue)!=0) #define Tcl_SetVar(interp, varName, newValue, flags) \ Tcl_SetVar2(interp, varName, NULL, newValue, flags) #define Tcl_UnsetVar(interp, varName, flags) \ Tcl_UnsetVar2(interp, varName, NULL, flags) #define Tcl_GetVar(interp, varName, flags) \ Tcl_GetVar2(interp, varName, NULL, flags) #define Tcl_TraceVar(interp, varName, flags, proc, clientData) \ |
︙ | ︙ | |||
3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 3741 3742 | do { \ Tcl_ResetResult(interp); \ Tcl_SetObjResult(interp, *(statePtr)); \ Tcl_DecrRefCount(*(statePtr)); \ } while(0) #define Tcl_DiscardResult(statePtr) \ Tcl_DecrRefCount(*(statePtr)) #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) { \ if (__freeProc == TCL_DYNAMIC) { \ | > | 3711 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 | do { \ Tcl_ResetResult(interp); \ Tcl_SetObjResult(interp, *(statePtr)); \ Tcl_DecrRefCount(*(statePtr)); \ } while(0) #define Tcl_DiscardResult(statePtr) \ Tcl_DecrRefCount(*(statePtr)) #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) { \ if (__freeProc == TCL_DYNAMIC) { \ |
︙ | ︙ | |||
3752 3753 3754 3755 3756 3757 3758 | /* 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. */ | < < < < < < > > > > > > < | | | | < | 3735 3736 3737 3738 3739 3740 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 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 | /* 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 # 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; } # define Tcl_ExprLongObj TclExprLongObj static inline int TclExprLongObj(Tcl_Interp *interp, Tcl_Obj *obj, long *ptr){ int intValue; int result = tclStubsPtr->tcl_ExprLongObj(interp, obj, (long *)&intValue); if (result == TCL_OK) *ptr = (long)intValue; return result; } # endif #endif #define Tcl_NewLongObj(value) Tcl_NewWideIntObj((long)(value)) #define Tcl_NewIntObj(value) Tcl_NewWideIntObj((int)(value)) #define Tcl_DbNewLongObj(value, file, line) Tcl_DbNewWideIntObj((long)(value), file, line) #define Tcl_SetIntObj(objPtr, value) Tcl_SetWideIntObj(objPtr, (int)(value)) #define Tcl_SetLongObj(objPtr, value) Tcl_SetWideIntObj(objPtr, (long)(value)) /* * Deprecated Tcl procedures: */ #define Tcl_EvalObj(interp, objPtr) \ Tcl_EvalObjEx(interp, objPtr, 0) #define Tcl_GlobalEvalObj(interp, objPtr) \ Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL) #endif /* _TCLDECLS */ |
Changes to generic/tclDictObj.c.
︙ | ︙ | |||
137 138 139 140 141 142 143 | * dictionary. Used for doing traversal of the * entries in the order that they are * created. */ ChainEntry *entryChainTail; /* Other end of linked list of all entries in * the dictionary. Used for doing traversal of * the entries in the order that they are * created. */ | | | 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 | * dictionary. Used for doing traversal of the * entries in the order that they are * created. */ ChainEntry *entryChainTail; /* Other end of linked list of all entries in * the dictionary. Used for doing traversal of * the entries in the order that they are * created. */ unsigned int epoch; /* Epoch counter */ size_t refCount; /* Reference counter (see above) */ Tcl_Obj *chain; /* Linked list used for invalidating the * string representations of updated nested * dictionaries. */ } Dict; /* |
︙ | ︙ | |||
1161 1162 1163 1164 1165 1166 1167 | { ChainEntry *cPtr; /* * If the searh is done; we do no work. */ | | | 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 1174 1175 | { ChainEntry *cPtr; /* * If the searh is done; we do no work. */ if (!searchPtr->epoch) { *donePtr = 1; return; } /* * Bail out if the dictionary has had any elements added, modified or * removed. This *shouldn't* happen, but... |
︙ | ︙ | |||
1218 1219 1220 1221 1222 1223 1224 | void Tcl_DictObjDone( Tcl_DictSearch *searchPtr) /* Pointer to a hash search context. */ { Dict *dict; | | | 1218 1219 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 | void Tcl_DictObjDone( Tcl_DictSearch *searchPtr) /* Pointer to a hash search context. */ { Dict *dict; if (searchPtr->epoch) { searchPtr->epoch = 0; dict = (Dict *) searchPtr->dictionaryPtr; if (dict->refCount-- <= 1) { DeleteDict(dict); } } } |
︙ | ︙ | |||
2303 2304 2305 2306 2307 2308 2309 | Tcl_Obj *appendObjPtr = NULL; if (objc > 3) { /* Something to append */ if (objc == 4) { appendObjPtr = objv[3]; | | > > | | > | 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 | Tcl_Obj *appendObjPtr = NULL; if (objc > 3) { /* Something to append */ if (objc == 4) { appendObjPtr = objv[3]; } else { appendObjPtr = TclStringCat(interp, objc-3, objv+3, TCL_STRING_IN_PLACE); if (appendObjPtr == NULL) { return TCL_ERROR; } } } if (appendObjPtr == NULL) { /* => (objc == 3) => (valuePtr == NULL) */ TclNewObj(valuePtr); } else if (valuePtr == NULL) { |
︙ | ︙ |
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 265 266 267 268 269 270 271 272 273 274 275 276 277 278 279 | 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; /* * Print header lines describing the ByteCode. */ Tcl_AppendPrintfToObj(bufferObj, "ByteCode %p, refCt %" TCL_LL_MODIFIER "d, epoch %" TCL_LL_MODIFIER "d, interp %p (epoch %" TCL_LL_MODIFIER "d)\n", codePtr, (Tcl_WideUInt)codePtr->refCount, (Tcl_WideUInt)codePtr->compileEpoch, iPtr, (Tcl_WideUInt)iPtr->compileEpoch); Tcl_AppendToObj(bufferObj, " Source ", -1); PrintSourceToObj(bufferObj, codePtr->source, TclMin(codePtr->numSrcBytes, 55)); GetLocationInformation(codePtr->procPtr, &fileObj, &line); if (line > -1 && fileObj != NULL) { Tcl_AppendPrintfToObj(bufferObj, "\n File \"%s\" Line %d", Tcl_GetString(fileObj), line); |
︙ | ︙ | |||
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 323 | */ if (codePtr->procPtr != NULL) { Proc *procPtr = codePtr->procPtr; int numCompiledLocals = procPtr->numCompiledLocals; Tcl_AppendPrintfToObj(bufferObj, " Proc %p, refCt %" TCL_LL_MODIFIER "d, args %d, compiled locals %d\n", procPtr, (Tcl_WideUInt)procPtr->refCount, procPtr->numArgs, numCompiledLocals); if (numCompiledLocals > 0) { CompiledLocal *localPtr = procPtr->firstLocalPtr; for (i = 0; i < numCompiledLocals; i++) { Tcl_AppendPrintfToObj(bufferObj, " slot %d%s%s%s%s%s%s", i, |
︙ | ︙ | |||
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 836 837 | 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) { size_t len, inst = (size_t)objPtr->internalRep.wideValue; char *s, buf[TCL_INTEGER_SPACE + 5]; if (inst >= LAST_INST_OPCODE) { sprintf(buf, "inst_%" TCL_Z_MODIFIER "d", inst); s = buf; } else { s = (char *) tclInstructionTable[inst].name; } len = strlen(s); /* assert (len < UINT_MAX) */ objPtr->bytes = ckalloc(len + 1); memcpy(objPtr->bytes, s, len + 1); objPtr->length = len; } /* *---------------------------------------------------------------------- |
︙ | ︙ |
Changes to generic/tclEnsemble.c.
︙ | ︙ | |||
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_GetIndexFromObjStruct(interp, objv[0], ensembleCreateOptions, sizeof(char *), "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. |
︙ | ︙ | |||
1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 | /* * 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 | > | 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 | /* * 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 |
︙ | ︙ | |||
2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 | * None. * * Side effects: * Memory is (eventually) deallocated. * *---------------------------------------------------------------------- */ static void DeleteEnsembleConfig( ClientData clientData) { EnsembleConfig *ensemblePtr = clientData; Namespace *nsPtr = ensemblePtr->nsPtr; | > > > > > > > > > > > > > > > > > > > > < < | 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 2467 | * 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) { |
︙ | ︙ | |||
2436 2437 2438 2439 2440 2441 2442 | ensemblePtr->flags |= ENSEMBLE_DEAD; /* * Kill the pointer-containing fields. */ | < | < < < < < < < < < | 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 | 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) { |
︙ | ︙ | |||
2499 2500 2501 2502 2503 2504 2505 | static void BuildEnsembleConfig( EnsembleConfig *ensemblePtr) { Tcl_HashSearch search; /* Used for scanning the set of commands in * the namespace that backs up this * ensemble. */ | | < > > > > | > > > > > | > > > | > > > > > | | > | | | < | < | | | | > > > > > > > | < < < < < | < < | > < | < | < | < < < < < | | | < | < | < | < | | | | | | | > | | | | | < < < < < < | | | | > | | | | | | | | | | | | | | | | | | > | | < < < < | | 2540 2541 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 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 2661 2662 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 | static void BuildEnsembleConfig( EnsembleConfig *ensemblePtr) { 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 * the patterns in the export list. Note that we use an intermediate * hash table to make memory management easier, and because that makes * exact matching far easier too. * * Suggestion for future enhancement: compute the unique prefixes and * place them in the hash too, which should make for even faster * matching. */ hPtr = Tcl_FirstHashEntry(&ensemblePtr->nsPtr->cmdTable, &search); for (; hPtr!= NULL ; hPtr=Tcl_NextHashEntry(&search)) { char *nsCmdName = /* Name of command in namespace. */ Tcl_GetHashKey(&ensemblePtr->nsPtr->cmdTable, hPtr); size_t k; for (k=0 ; k<ensemblePtr->nsPtr->numExportPatterns ; k++) { if (Tcl_StringMatch(nsCmdName, ensemblePtr->nsPtr->exportArrayPtr[k])) { hPtr = Tcl_CreateHashEntry(hash, nsCmdName, &isNew); /* * Remember, hash entries have a full reference to the * 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/tclEnv.c.
︙ | ︙ | |||
126 127 128 129 130 131 132 133 134 135 136 137 138 139 | if (p2 == NULL) { /* * This condition seem to happen occasionally under some * versions of Solaris, or when encoding accidents swallow the * '='; ignore the entry. */ continue; } p2++; p2[-1] = '\0'; obj1 = Tcl_NewStringObj(p1, -1); obj2 = Tcl_NewStringObj(p2, -1); Tcl_DStringFree(&envString); | > | 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 | if (p2 == NULL) { /* * This condition seem to happen occasionally under some * versions of Solaris, or when encoding accidents swallow the * '='; ignore the entry. */ Tcl_DStringFree(&envString); continue; } p2++; p2[-1] = '\0'; obj1 = Tcl_NewStringObj(p1, -1); obj2 = Tcl_NewStringObj(p2, -1); Tcl_DStringFree(&envString); |
︙ | ︙ |
Changes to generic/tclEvent.c.
︙ | ︙ | |||
85 86 87 88 89 90 91 | /* * This variable contains the application wide exit handler. It will be called * by Tcl_Exit instead of the C-runtime exit if this variable is set to a * non-NULL value. */ | | | 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 | /* * This variable contains the application wide exit handler. It will be called * by Tcl_Exit instead of the C-runtime exit if this variable is set to a * non-NULL value. */ static TCL_NORETURN Tcl_ExitProc *appExitPtr = NULL; typedef struct ThreadSpecificData { ExitHandler *firstExitPtr; /* First in list of all exit handlers for this * thread. */ int inExit; /* True when this thread is exiting. This is * used as a hack to decide to close the * standard channels. */ |
︙ | ︙ | |||
853 854 855 856 857 858 859 | * Sets the application wide exit handler to the specified value. * *---------------------------------------------------------------------- */ Tcl_ExitProc * Tcl_SetExitProc( | | | 853 854 855 856 857 858 859 860 861 862 863 864 865 866 867 | * Sets the application wide exit handler to the specified value. * *---------------------------------------------------------------------- */ Tcl_ExitProc * Tcl_SetExitProc( TCL_NORETURN Tcl_ExitProc *proc) /* New exit handler for app or NULL */ { Tcl_ExitProc *prevExitProc; /* * Swap the old exit proc for the new one, saving the old one for our * return value. */ |
︙ | ︙ | |||
934 935 936 937 938 939 940 | */ TCL_NORETURN void Tcl_Exit( int status) /* Exit status for application; typically 0 * for normal return, 1 for error return. */ { | | | 934 935 936 937 938 939 940 941 942 943 944 945 946 947 948 | */ TCL_NORETURN void Tcl_Exit( int status) /* Exit status for application; typically 0 * for normal return, 1 for error return. */ { TCL_NORETURN Tcl_ExitProc *currentAppExitPtr; Tcl_MutexLock(&exitMutex); currentAppExitPtr = appExitPtr; Tcl_MutexUnlock(&exitMutex); if (currentAppExitPtr) { /* |
︙ | ︙ | |||
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(); } |
︙ | ︙ | |||
1499 1500 1501 1502 1503 1504 1505 | int flags = 0; /* Initialized to avoid compiler warning. */ static const char *const updateOptions[] = {"idletasks", NULL}; enum updateOptions {OPT_IDLETASKS}; if (objc == 1) { flags = TCL_ALL_EVENTS|TCL_DONT_WAIT; } else if (objc == 2) { | | | | 1498 1499 1500 1501 1502 1503 1504 1505 1506 1507 1508 1509 1510 1511 1512 1513 | int flags = 0; /* Initialized to avoid compiler warning. */ static const char *const updateOptions[] = {"idletasks", NULL}; enum updateOptions {OPT_IDLETASKS}; if (objc == 1) { flags = TCL_ALL_EVENTS|TCL_DONT_WAIT; } else if (objc == 2) { if (Tcl_GetIndexFromObj(interp, objv[1], updateOptions, "option", 0, &optionIndex) != TCL_OK) { return TCL_ERROR; } switch ((enum updateOptions) optionIndex) { case OPT_IDLETASKS: flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT; break; default: |
︙ | ︙ |
Changes to generic/tclExecute.c.
︙ | ︙ | |||
73 74 75 76 77 78 79 | * expression opcodes (e.g., INST_LOR) in tclCompile.h. * * Does not include the string for INST_EXPON (and beyond), as that is * disjoint for backward-compatibility reasons. */ static const char *const operatorStrings[] = { | | | 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 | * expression opcodes (e.g., INST_LOR) in tclCompile.h. * * Does not include the string for INST_EXPON (and beyond), as that is * disjoint for backward-compatibility reasons. */ static const char *const operatorStrings[] = { "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>", "+", "-", "*", "/", "%", "+", "-", "~", "!" }; /* * Mapping from Tcl result codes to strings; used for error and debugging * messages. */ |
︙ | ︙ | |||
97 98 99 100 101 102 103 | */ #ifdef TCL_COMPILE_STATS long tclObjsAlloced = 0; long tclObjsFreed = 0; long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; #endif /* TCL_COMPILE_STATS */ | < | 97 98 99 100 101 102 103 104 105 106 107 108 109 110 | */ #ifdef TCL_COMPILE_STATS long tclObjsAlloced = 0; long tclObjsFreed = 0; long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; #endif /* TCL_COMPILE_STATS */ /* * NR_TEBC * Helpers for NR - non-recursive calls to TEBC * Minimal data required to fully reconstruct the execution state. */ |
︙ | ︙ | |||
264 265 266 267 268 269 270 | 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) { \ | | | | | | 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 | 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 |
︙ | ︙ | |||
437 438 439 440 441 442 443 | * 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); */ | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 | * 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 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: * * MODULE_SCOPE int Overflowing(inttype_t a, inttype_t b, inttype_t sum); |
︙ | ︙ | |||
515 516 517 518 519 520 521 | #define IsErroringNaNType(type) 0 #endif /* * Auxiliary tables used to compute powers of small integers. */ | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 479 480 481 482 483 484 485 486 487 488 489 490 491 492 | #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) */ |
︙ | ︙ | |||
652 653 654 655 656 657 658 | (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); | < | 582 583 584 585 586 587 588 589 590 591 592 593 594 595 | (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) |
︙ | ︙ | |||
683 684 685 686 687 688 689 | 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); | < < | 612 613 614 615 616 617 618 619 620 621 622 623 624 625 | 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, |
︙ | ︙ | |||
847 848 849 850 851 852 853 | * [sizeof(Tcl_Obj*)] */ { ExecEnv *eePtr = ckalloc(sizeof(ExecEnv)); ExecStack *esPtr = ckalloc(sizeof(ExecStack) + (size_t) (size-1) * sizeof(Tcl_Obj *)); eePtr->execStackPtr = esPtr; | | | | 774 775 776 777 778 779 780 781 782 783 784 785 786 787 788 789 790 | * [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; |
︙ | ︙ | |||
1272 1273 1274 1275 1276 1277 1278 | void * TclStackAlloc( Tcl_Interp *interp, int numBytes) { Interp *iPtr = (Interp *) interp; | | | | 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 1217 1218 | void * TclStackAlloc( Tcl_Interp *interp, int numBytes) { Interp *iPtr = (Interp *) interp; int numWords; if (iPtr == NULL || iPtr->execEnvPtr == NULL) { return (void *) ckalloc(numBytes); } numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *); return (void *) StackAllocWords(interp, numWords); } void * TclStackRealloc( Tcl_Interp *interp, void *ptr, |
︙ | ︙ | |||
1816 1817 1818 1819 1820 1821 1822 | */ TclGetIntFromObj(interp, incrPtr, &type1); Tcl_AddErrorInfo(interp, "\n (reading increment)"); return TCL_ERROR; } | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < | 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 | */ 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; |
︙ | ︙ | |||
2623 2624 2625 2626 2627 2628 2629 | TRACE(("%u => OK\n", opnd)); NEXT_INST_F(5, 0, 0); } case INST_STR_CONCAT1: opnd = TclGetUInt1AtPtr(pc+1); | | | | | 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 | TRACE(("%u => OK\n", opnd)); NEXT_INST_F(5, 0, 0); } case INST_STR_CONCAT1: opnd = TclGetUInt1AtPtr(pc+1); objResultPtr = TclStringCat(interp, opnd, &OBJ_AT_DEPTH(opnd-1), TCL_STRING_IN_PLACE); if (objResultPtr == NULL) { TRACE_ERROR(interp); goto gotError; } TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); NEXT_INST_V(2, opnd, 1); |
︙ | ︙ | |||
2841 2842 2843 2844 2845 2846 2847 | DECACHE_STACK_INFO(); pc += pcAdjustment; TEBC_YIELD(); return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NOERR | TCL_EVAL_SOURCE_IN_FRAME, NULL); | < < < < < < < < < < | 2735 2736 2737 2738 2739 2740 2741 2742 2743 2744 2745 2746 2747 2748 | DECACHE_STACK_INFO(); pc += pcAdjustment; TEBC_YIELD(); return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NOERR | TCL_EVAL_SOURCE_IN_FRAME, NULL); case INST_INVOKE_REPLACE: objc = TclGetUInt4AtPtr(pc+1); opnd = TclGetUInt1AtPtr(pc+5); objPtr = POP_OBJECT(); objv = &OBJ_AT_DEPTH(objc-1); cleanup = objc; #ifdef TCL_COMPILE_DEBUG |
︙ | ︙ | |||
3490 3491 3492 3493 3494 3495 3496 | * common execution code. */ /*TODO: Consider more untangling here; merge with LOAD and STORE ? */ { Tcl_Obj *incrPtr; | < < | 3374 3375 3376 3377 3378 3379 3380 3381 3382 3383 3384 3385 3386 3387 3388 | * 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: |
︙ | ︙ | |||
3591 3592 3593 3594 3595 3596 3597 | if (TclIsVarDirectModifyable(varPtr)) { ClientData ptr; int type; objPtr = varPtr->value.objPtr; if (GetNumberFromObj(NULL, objPtr, &ptr, &type) == TCL_OK) { | | | | | | < | < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | 3473 3474 3475 3476 3477 3478 3479 3480 3481 3482 3483 3484 3485 3486 3487 3488 3489 3490 3491 3492 3493 3494 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 3553 | 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; } |
︙ | ︙ | |||
3969 3970 3971 3972 3973 3974 3975 | TRACE_APPEND(("OK\n")); NEXT_INST_V(2, cleanup, 0); errorInUnset: CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; | < < < < < < < < < < < < < < < < < < < < < < < | 3816 3817 3818 3819 3820 3821 3822 3823 3824 3825 3826 3827 3828 3829 | TRACE_APPEND(("OK\n")); NEXT_INST_V(2, cleanup, 0); errorInUnset: CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; } /* * End of INST_UNSET instructions. * ----------------------------------------------------------------- * Start of INST_ARRAY instructions. */ |
︙ | ︙ | |||
4317 4318 4319 4320 4321 4322 4323 | NEXT_INST_F(jumpOffset, 1, 0); } else { TRACE_APPEND(("not found in table\n")); NEXT_INST_F(5, 1, 0); } } | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 4141 4142 4143 4144 4145 4146 4147 4148 4149 4150 4151 4152 4153 4154 | NEXT_INST_F(jumpOffset, 1, 0); } else { TRACE_APPEND(("not found in table\n")); NEXT_INST_F(5, 1, 0); } } /* * ----------------------------------------------------------------- * Start of general introspector instructions. */ case INST_NS_CURRENT: { Namespace *currNsPtr = (Namespace *) TclGetCurrentNamespace(interp); |
︙ | ︙ | |||
4390 4391 4392 4393 4394 4395 4396 | Tcl_GetCommandFullName(interp, (Tcl_Command) corPtr->cmdPtr, objResultPtr); } TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); } case INST_INFO_LEVEL_NUM: | | | 4170 4171 4172 4173 4174 4175 4176 4177 4178 4179 4180 4181 4182 4183 4184 | 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; |
︙ | ︙ | |||
4759 4760 4761 4762 4763 4764 4765 | case INST_LIST_LENGTH: TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS))); if (TclListObjLength(interp, OBJ_AT_TOS, &length) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } | | | 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 4552 4553 | 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))); |
︙ | ︙ | |||
4816 4817 4818 4819 4820 4821 4822 | */ if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } | < < | < < < < | < | 4596 4597 4598 4599 4600 4601 4602 4603 4604 4605 4606 4607 4608 4609 4610 4611 4612 | */ if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } /* Decode end-offset index values. */ index = TclIndexDecode(opnd, objc - 1); pcAdjustment = 5; lindexFastPath: if (index >= 0 && index < objc) { objResultPtr = objv[index]; } else { TclNewObj(objResultPtr); |
︙ | ︙ | |||
4973 4974 4975 4976 4977 4978 4979 | #ifndef TCL_COMPILE_DEBUG if (*(pc+9) == INST_POP) { NEXT_INST_F(10, 1, 0); } #endif | > > > > > > > > | < > > > > > | < < < < | < | > > | | | | | < < | | | < > > > > | | > | | | < < | > > > | > > > | | > > < > | 4746 4747 4748 4749 4750 4751 4752 4753 4754 4755 4756 4757 4758 4759 4760 4761 4762 4763 4764 4765 4766 4767 4768 4769 4770 4771 4772 4773 4774 4775 4776 4777 4778 4779 4780 4781 4782 4783 4784 4785 4786 4787 4788 4789 4790 4791 4792 4793 4794 4795 4796 4797 4798 4799 4800 4801 4802 4803 4804 4805 4806 4807 4808 4809 4810 4811 4812 4813 4814 4815 4816 4817 | #ifndef TCL_COMPILE_DEBUG if (*(pc+9) == INST_POP) { NEXT_INST_F(10, 1, 0); } #endif /* Every range of an empty list is an empty list */ if (objc == 0) { TRACE_APPEND(("\n")); NEXT_INST_F(9, 0, 0); } /* Decode index value operands. */ /* assert ( toIdx != TCL_INDEX_AFTER); * * Extra safety for legacy bytecodes: */ if (toIdx == TCL_INDEX_AFTER) { toIdx = TCL_INDEX_END; } if ((toIdx == TCL_INDEX_BEFORE) || (fromIdx == TCL_INDEX_AFTER)) { goto emptyList; } toIdx = TclIndexDecode(toIdx, objc - 1); if (toIdx < 0) { goto emptyList; } else if (toIdx >= objc) { toIdx = objc - 1; } assert ( toIdx >= 0 && toIdx < objc); /* assert ( fromIdx != TCL_INDEX_BEFORE ); * * Extra safety for legacy bytecodes: */ if (fromIdx == TCL_INDEX_BEFORE) { fromIdx = TCL_INDEX_START; } fromIdx = TclIndexDecode(fromIdx, objc - 1); if (fromIdx < 0) { fromIdx = 0; } if (fromIdx <= toIdx) { /* Construct the subsquence list */ /* unshared optimization */ if (Tcl_IsShared(valuePtr)) { objResultPtr = Tcl_NewListObj(toIdx-fromIdx+1, objv+fromIdx); } else { if (toIdx != objc - 1) { Tcl_ListObjReplace(NULL, valuePtr, toIdx + 1, LIST_MAX, 0, NULL); } Tcl_ListObjReplace(NULL, valuePtr, 0, fromIdx, 0, NULL); TRACE_APPEND(("%.30s\n", O2S(valuePtr))); NEXT_INST_F(9, 0, 0); } } else { emptyList: TclNewObj(objResultPtr); } TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr))); NEXT_INST_F(9, 1, 1); case INST_LIST_IN: |
︙ | ︙ | |||
5230 5231 5232 5233 5234 5235 5236 | 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); | | | 5020 5021 5022 5023 5024 5025 5026 5027 5028 5029 5030 5031 5032 5033 5034 | 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)) { |
︙ | ︙ | |||
5359 5360 5361 5362 5363 5364 5365 5366 | case INST_STR_RANGE_IMM: valuePtr = OBJ_AT_TOS; fromIdx = TclGetInt4AtPtr(pc+1); toIdx = TclGetInt4AtPtr(pc+5); length = Tcl_GetCharLength(valuePtr); TRACE(("\"%.20s\" %d %d => ", O2S(valuePtr), fromIdx, toIdx)); /* | > > > > > > > > < > > > > > > | | < < | | < < | > | | > > > > > | > > > > > > > > > > > > | | | | < < | | | > > > > > | | | < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 5149 5150 5151 5152 5153 5154 5155 5156 5157 5158 5159 5160 5161 5162 5163 5164 5165 5166 5167 5168 5169 5170 5171 5172 5173 5174 5175 5176 5177 5178 5179 5180 5181 5182 5183 5184 5185 5186 5187 5188 5189 5190 5191 5192 5193 5194 5195 5196 5197 5198 5199 5200 5201 5202 5203 5204 5205 5206 5207 5208 5209 5210 5211 5212 5213 5214 5215 5216 5217 5218 5219 5220 5221 5222 5223 5224 5225 5226 5227 5228 5229 5230 5231 5232 5233 5234 5235 5236 5237 5238 5239 5240 5241 5242 5243 5244 5245 5246 5247 5248 5249 5250 5251 5252 5253 5254 5255 5256 5257 5258 5259 5260 5261 5262 5263 5264 5265 5266 5267 5268 5269 | case INST_STR_RANGE_IMM: valuePtr = OBJ_AT_TOS; fromIdx = TclGetInt4AtPtr(pc+1); toIdx = TclGetInt4AtPtr(pc+5); length = Tcl_GetCharLength(valuePtr); TRACE(("\"%.20s\" %d %d => ", O2S(valuePtr), fromIdx, toIdx)); /* Every range of an empty value is an empty value */ if (length == 0) { TRACE_APPEND(("\n")); NEXT_INST_F(9, 0, 0); } /* Decode index operands. */ /* assert ( toIdx != TCL_INDEX_BEFORE ); assert ( toIdx != TCL_INDEX_AFTER); * * Extra safety for legacy bytecodes: */ if (toIdx == TCL_INDEX_BEFORE) { goto emptyRange; } if (toIdx == TCL_INDEX_AFTER) { toIdx = TCL_INDEX_END; } toIdx = TclIndexDecode(toIdx, length - 1); if (toIdx < 0) { goto emptyRange; } else if (toIdx >= length) { toIdx = length - 1; } assert ( toIdx >= 0 && toIdx < length ); /* assert ( fromIdx != TCL_INDEX_BEFORE ); assert ( fromIdx != TCL_INDEX_AFTER); * * Extra safety for legacy bytecodes: */ if (fromIdx == TCL_INDEX_BEFORE) { fromIdx = TCL_INDEX_START; } if (fromIdx == TCL_INDEX_AFTER) { goto emptyRange; } fromIdx = TclIndexDecode(fromIdx, length - 1); if (fromIdx < 0) { fromIdx = 0; } if (fromIdx <= toIdx) { objResultPtr = Tcl_GetRange(valuePtr, fromIdx, toIdx); } else { emptyRange: TclNewObj(objResultPtr); } TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_F(9, 1, 1); { Tcl_UniChar *ustring1, *ustring2, *ustring3, *end, *p; int length3, endIdx; Tcl_Obj *value3Ptr; case INST_STR_REPLACE: value3Ptr = POP_OBJECT(); valuePtr = OBJ_AT_DEPTH(2); endIdx = Tcl_GetCharLength(valuePtr) - 1; TRACE(("\"%.20s\" %s %s \"%.20s\" => ", O2S(valuePtr), O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(value3Ptr))); if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, endIdx, &fromIdx) != TCL_OK || TclGetIntForIndexM(interp, OBJ_AT_TOS, endIdx, &toIdx) != TCL_OK) { TclDecrRefCount(value3Ptr); TRACE_ERROR(interp); goto gotError; } TclDecrRefCount(OBJ_AT_TOS); (void) POP_OBJECT(); TclDecrRefCount(OBJ_AT_TOS); (void) POP_OBJECT(); if ((toIdx < 0) || (fromIdx > endIdx) || (toIdx < fromIdx)) { TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr))); TclDecrRefCount(value3Ptr); NEXT_INST_F(1, 0, 0); } if (fromIdx < 0) { fromIdx = 0; } if (toIdx > endIdx) { toIdx = endIdx; } if (fromIdx == 0 && toIdx == endIdx) { TclDecrRefCount(OBJ_AT_TOS); OBJ_AT_TOS = value3Ptr; TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr))); NEXT_INST_F(1, 0, 0); } objResultPtr = TclStringReplace(interp, valuePtr, fromIdx, toIdx - fromIdx + 1, value3Ptr, TCL_STRING_IN_PLACE); if (objResultPtr == value3Ptr) { /* See [Bug 82e7f67325] */ TclDecrRefCount(OBJ_AT_TOS); OBJ_AT_TOS = value3Ptr; TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr))); NEXT_INST_F(1, 0, 0); } |
︙ | ︙ | |||
5581 5582 5583 5584 5585 5586 5587 | } doneStringMap: TRACE_WITH_OBJ(("%.20s %.20s %.20s => ", O2S(value2Ptr), O2S(value3Ptr), O2S(valuePtr)), objResultPtr); NEXT_INST_V(1, 3, 1); case INST_STR_FIND: | | | | | 5328 5329 5330 5331 5332 5333 5334 5335 5336 5337 5338 5339 5340 5341 5342 5343 5344 5345 5346 5347 5348 5349 5350 5351 5352 5353 5354 | } doneStringMap: TRACE_WITH_OBJ(("%.20s %.20s %.20s => ", O2S(value2Ptr), O2S(value3Ptr), O2S(valuePtr)), objResultPtr); NEXT_INST_V(1, 3, 1); case INST_STR_FIND: match = TclStringFirst(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))); |
︙ | ︙ | |||
5683 5684 5685 5686 5687 5688 5689 | trim1 = 0; goto createTrimmedString; case INST_STR_TRIM: valuePtr = OBJ_UNDER_TOS; /* String */ value2Ptr = OBJ_AT_TOS; /* TrimSet */ string2 = TclGetStringFromObj(value2Ptr, &length2); string1 = TclGetStringFromObj(valuePtr, &length); | | < < < < < | 5430 5431 5432 5433 5434 5435 5436 5437 5438 5439 5440 5441 5442 5443 5444 | trim1 = 0; goto createTrimmedString; case INST_STR_TRIM: valuePtr = OBJ_UNDER_TOS; /* String */ value2Ptr = OBJ_AT_TOS; /* TrimSet */ string2 = TclGetStringFromObj(value2Ptr, &length2); string1 = TclGetStringFromObj(valuePtr, &length); trim1 = TclTrim(string1, length, string2, length2, &trim2); createTrimmedString: /* * Careful here; trim set often contains non-ASCII characters so we * take care when printing. [Bug 971cb4f1db] */ #ifdef TCL_COMPILE_DEBUG |
︙ | ︙ | |||
5766 5767 5768 5769 5770 5771 5772 | * ----------------------------------------------------------------- * Start of numeric operator instructions. */ { ClientData ptr1, ptr2; int type1, type2; | | | | > < < < < < < < < < | | | | 5508 5509 5510 5511 5512 5513 5514 5515 5516 5517 5518 5519 5520 5521 5522 5523 5524 5525 5526 5527 5528 5529 5530 5531 5532 5533 5534 5535 5536 5537 5538 5539 5540 5541 5542 5543 5544 5545 | * ----------------------------------------------------------------- * 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 LLONG_MIN and LLONG_MAX */ /* [string is integer] is -UINT_MAX to UINT_MAX range */ /* [string is wideinteger] is -ULLONG_MAX to ULLONG_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 LLONG_MIN to LLONG_MAX range */ /* [string is wideinteger] is -ULLONG_MAX to ULLONG_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: |
︙ | ︙ | |||
5832 5833 5834 5835 5836 5837 5838 | iResult = (*pc == INST_NEQ); goto foundResult; } if (valuePtr == value2Ptr) { compare = MP_EQ; goto convertComparison; } | | | | | | 5566 5567 5568 5569 5570 5571 5572 5573 5574 5575 5576 5577 5578 5579 5580 5581 5582 5583 | 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. */ |
︙ | ︙ | |||
5911 5912 5913 5914 5915 5916 5917 | goto gotError; } /* * Check for common, simple case. */ | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | < < < < < < < < < | 5645 5646 5647 5648 5649 5650 5651 5652 5653 5654 5655 5656 5657 5658 5659 5660 5661 5662 5663 5664 5665 5666 5667 5668 5669 5670 5671 5672 5673 5674 5675 5676 5677 5678 5679 5680 5681 5682 5683 5684 5685 5686 5687 5688 5689 5690 5691 5692 5693 5694 5695 5696 5697 5698 5699 5700 5701 5702 5703 5704 5705 5706 5707 5708 5709 5710 5711 5712 5713 5714 5715 5716 5717 5718 5719 5720 5721 5722 5723 5724 5725 5726 5727 5728 5729 5730 5731 5732 5733 5734 5735 5736 5737 5738 5739 5740 5741 5742 5743 5744 5745 5746 5747 5748 5749 5750 5751 5752 5753 5754 5755 5756 5757 5758 5759 5760 5761 5762 5763 5764 5765 5766 5767 5768 5769 5770 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 5809 5810 5811 5812 5813 5814 5815 5816 | 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 > 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. |
︙ | ︙ | |||
6160 6161 6162 6163 6164 6165 6166 | #endif /* * Handle (long,long) arithmetic as best we can without going out to * an external function. */ | | < < | | < < < < < < > > > > > > > > > | < | | | | | | | | | | | | | | | | | | | 5885 5886 5887 5888 5889 5890 5891 5892 5893 5894 5895 5896 5897 5898 5899 5900 5901 5902 5903 5904 5905 5906 5907 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 | #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 Tcl_WideInt. */ 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(Tcl_WideInt) >= 2*sizeof(int)) && (w1 <= INT_MAX) && (w1 >= INT_MIN) && (w2 <= INT_MAX) && (w2 >= INT_MIN)) || ((sizeof(Tcl_WideInt) >= 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. */ } |
︙ | ︙ | |||
6303 6304 6305 6306 6307 6308 6309 | 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; } | | | | | | 6028 6029 6030 6031 6032 6033 6034 6035 6036 6037 6038 6039 6040 6041 6042 6043 6044 6045 6046 6047 6048 6049 | 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); |
︙ | ︙ | |||
6340 6341 6342 6343 6344 6345 6346 | goto gotError; } switch (type1) { case TCL_NUMBER_NAN: /* -NaN => NaN */ TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); | | | | | | | 6065 6066 6067 6068 6069 6070 6071 6072 6073 6074 6075 6076 6077 6078 6079 6080 6081 6082 6083 6084 6085 6086 6087 | 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) { |
︙ | ︙ | |||
6487 6488 6489 6490 6491 6492 6493 6494 6495 | CACHE_STACK_INFO(); */ result = TCL_CONTINUE; cleanup = 0; TRACE(("=> CONTINUE!\n")); goto processExceptionReturn; { ForeachInfo *infoPtr; | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | > | 6212 6213 6214 6215 6216 6217 6218 6219 6220 6221 6222 6223 6224 6225 6226 6227 6228 6229 6230 6231 6232 | CACHE_STACK_INFO(); */ result = TCL_CONTINUE; cleanup = 0; TRACE(("=> CONTINUE!\n")); goto processExceptionReturn; { ForeachInfo *infoPtr; Tcl_Obj *listPtr, **elements, *tmpPtr; ForeachVarList *varListPtr; int numLists, listLen, numVars; int listTmpDepth; size_t iterNum, iterMax, iterTmp; int varIndex, valIndex, j; long i; case INST_FOREACH_START: /* * Initialize the data for the looping construct, pushing the * corresponding Tcl_Objs to the stack. |
︙ | ︙ | |||
6706 6707 6708 6709 6710 6711 6712 | * Store the iterNum and iterMax in a single Tcl_Obj; we keep a * nul-string obj with the pointer stored in the ptrValue so that the * thing is properly garbage collected. THIS OBJ MAKES NO SENSE, but * it will never leave this scope and is read-only. */ TclNewObj(tmpPtr); | | | | 6269 6270 6271 6272 6273 6274 6275 6276 6277 6278 6279 6280 6281 6282 6283 6284 | * Store the iterNum and iterMax in a single Tcl_Obj; we keep a * nul-string obj with the pointer stored in the ptrValue so that the * thing is properly garbage collected. THIS OBJ MAKES NO SENSE, but * it will never leave this scope and is read-only. */ TclNewObj(tmpPtr); tmpPtr->internalRep.twoPtrValue.ptr1 = NULL; tmpPtr->internalRep.twoPtrValue.ptr2 = (void *)iterMax; PUSH_OBJECT(tmpPtr); /* iterCounts object */ /* * Store a pointer to the ForeachInfo struct; same dirty trick * as above */ |
︙ | ︙ | |||
6739 6740 6741 6742 6743 6744 6745 | tmpPtr = OBJ_AT_TOS; infoPtr = tmpPtr->internalRep.twoPtrValue.ptr1; numLists = infoPtr->numLists; TRACE(("=> ")); tmpPtr = OBJ_AT_DEPTH(1); | | | | | 6302 6303 6304 6305 6306 6307 6308 6309 6310 6311 6312 6313 6314 6315 6316 6317 6318 6319 6320 6321 6322 6323 6324 6325 6326 6327 6328 6329 | tmpPtr = OBJ_AT_TOS; infoPtr = tmpPtr->internalRep.twoPtrValue.ptr1; numLists = infoPtr->numLists; TRACE(("=> ")); tmpPtr = OBJ_AT_DEPTH(1); iterNum = (size_t)tmpPtr->internalRep.twoPtrValue.ptr1; iterMax = (size_t)tmpPtr->internalRep.twoPtrValue.ptr2; /* * If some list still has a remaining list element iterate one more * time. Assign to var the next element from its value list. */ if (iterNum < iterMax) { /* * Set the variables and jump back to run the body */ tmpPtr->internalRep.twoPtrValue.ptr1 =(void *)(iterNum + 1); listTmpDepth = numLists + 1; for (i = 0; i < numLists; i++) { varListPtr = infoPtr->varLists[i]; numVars = varListPtr->numVars; |
︙ | ︙ | |||
6880 6881 6882 6883 6884 6885 6886 | TclNewObj(objPtr); Tcl_IncrRefCount(objPtr); iPtr->objResultPtr = objPtr; NEXT_INST_F(1, 0, -1); case INST_PUSH_RETURN_CODE: | | | 6443 6444 6445 6446 6447 6448 6449 6450 6451 6452 6453 6454 6455 6456 6457 | 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(); |
︙ | ︙ | |||
7546 7547 7548 7549 7550 7551 7552 | case 3: /* seconds */ Tcl_GetTime(&now); wval = (Tcl_WideInt) now.sec; break; default: Tcl_Panic("clockRead instruction with unknown clock#"); } | < | 7109 7110 7111 7112 7113 7114 7115 7116 7117 7118 7119 7120 7121 7122 | 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); |
︙ | ︙ | |||
7978 7979 7980 7981 7982 7983 7984 | 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. */ { | < < < < < < < < | | 7540 7541 7542 7543 7544 7545 7546 7547 7548 7549 7550 7551 7552 7553 7554 7555 7556 7557 7558 | 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); \ |
︙ | ︙ | |||
8012 8013 8014 8015 8016 8017 8018 | Tcl_SetDoubleObj(valuePtr, (d)); \ return NULL; \ } int type1, type2; ClientData ptr1, ptr2; double d1, d2, dResult; | < | | | | | < > > > > > > > > | 7566 7567 7568 7569 7570 7571 7572 7573 7574 7575 7576 7577 7578 7579 7580 7581 7582 7583 7584 7585 7586 7587 7588 7589 7590 7591 7592 7593 7594 7595 7596 7597 7598 7599 7600 7601 7602 7603 7604 7605 7606 7607 7608 7609 7610 7611 7612 7613 7614 7615 7616 | 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 (w1 == 0) { /* * 0 % (non-zero) always yields remainder of 0. */ return constants[0]; } if (type2 != TCL_NUMBER_BIG) { Tcl_WideInt wQuotient, wRemainder; Tcl_GetWideIntFromObj(NULL, value2Ptr, &w2); wQuotient = w1 / w2; /* * Force Tcl's integer division rules. |
︙ | ︙ | |||
8085 8086 8087 8088 8089 8090 8091 | /* * Arguments are same sign; remainder is first operand. */ mp_clear(&big2); return NULL; } | < | 7645 7646 7647 7648 7649 7650 7651 7652 7653 7654 7655 7656 7657 7658 | /* * 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)) { /* |
︙ | ︙ | |||
8112 8113 8114 8115 8116 8117 8118 | case INST_LSHIFT: case INST_RSHIFT: { /* * Reject negative shift argument. */ switch (type2) { | < < < < < | | | | | | | < < < < < | | | < | < | | 7671 7672 7673 7674 7675 7676 7677 7678 7679 7680 7681 7682 7683 7684 7685 7686 7687 7688 7689 7690 7691 7692 7693 7694 7695 7696 7697 7698 7699 7700 7701 7702 7703 7704 7705 7706 7707 7708 7709 7710 7711 7712 7713 7714 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 7794 7795 7796 7797 7798 7799 7800 7801 7802 7803 7804 7805 7806 7807 | 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_isneg(&big2); 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) > 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_isneg(&big1)); 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); } else { mp_init(&bigRemainder); mp_div_2d(&big1, shift, &bigResult, &bigRemainder); if (mp_isneg(&bigRemainder)) { /* * Convert to Tcl's integer division rules. */ mp_sub_d(&bigResult, 1, &bigResult); } mp_clear(&bigRemainder); |
︙ | ︙ | |||
8273 8274 8275 8276 8277 8278 8279 | Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); /* * Count how many positive arguments we have. If only one of the * arguments is negative, store it in 'Second'. */ | | | | | 7820 7821 7822 7823 7824 7825 7826 7827 7828 7829 7830 7831 7832 7833 7834 7835 7836 7837 7838 7839 7840 7841 | Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); /* * Count how many positive arguments we have. If only one of the * arguments is negative, store it in 'Second'. */ if (!mp_isneg(&big1)) { numPos = 1 + !mp_isneg(&big2); First = &big1; Second = &big2; } else { First = &big2; Second = &big1; numPos = (!mp_isneg(First)); } mp_init(&bigResult); switch (opcode) { case INST_BITAND: switch (numPos) { case 2: |
︙ | ︙ | |||
8403 8404 8405 8406 8407 8408 8409 | } mp_clear(&big1); mp_clear(&big2); BIG_RESULT(&bigResult); } | < < | | | | | | | | | | | | < < < < < < | | | | | | | | | | | | | < < < < | | < | < < < < | | < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < | | | | | | 7950 7951 7952 7953 7954 7955 7956 7957 7958 7959 7960 7961 7962 7963 7964 7965 7966 7967 7968 7969 7970 7971 7972 7973 7974 7975 7976 7977 7978 7979 7980 7981 7982 7983 7984 7985 7986 7987 7988 7989 7990 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 8032 8033 8034 8035 8036 8037 8038 8039 8040 8041 8042 8043 8044 8045 8046 8047 8048 8049 8050 8051 8052 8053 8054 8055 8056 8057 8058 8059 8060 8061 8062 8063 8064 8065 8066 8067 8068 8069 8070 8071 8072 8073 8074 8075 8076 8077 8078 8079 8080 8081 8082 8083 8084 8085 8086 8087 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 | } 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_isneg(&big2); 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 */ |
︙ | ︙ | |||
8769 8770 8771 8772 8773 8774 8775 | /* * 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 | | | | | < | 8225 8226 8227 8228 8229 8230 8231 8232 8233 8234 8235 8236 8237 8238 8239 8240 8241 8242 8243 8244 8245 8246 8247 8248 8249 8250 8251 8252 8253 8254 8255 8256 8257 8258 8259 8260 8261 8262 8263 8264 8265 | /* * 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)); |
︙ | ︙ | |||
8876 8877 8878 8879 8880 8881 8882 | 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; | < < < < | < | 8331 8332 8333 8334 8335 8336 8337 8338 8339 8340 8341 8342 8343 8344 8345 8346 8347 8348 8349 8350 8351 8352 8353 8354 8355 8356 8357 8358 8359 8360 8361 8362 8363 8364 8365 8366 8367 8368 8369 8370 8371 8372 8373 8374 8375 8376 8377 8378 8379 | 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) { |
︙ | ︙ | |||
9018 9019 9020 9021 9022 9023 9024 | mp_int big; Tcl_Obj *objResultPtr; (void) GetNumberFromObj(NULL, valuePtr, &ptr, &type); switch (opcode) { case INST_BITNOT: | < < < < < < < < < < < < | 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 | 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 /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
9091 9092 9093 9094 9095 9096 9097 | 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; | < < < | | < < < < < < | < > | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < | | < < < | | 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 8580 8581 8582 8583 8584 8585 8586 8587 8588 8589 8590 8591 8592 8593 8594 8595 8596 8597 8598 8599 8600 8601 8602 8603 8604 8605 8606 8607 8608 8609 8610 8611 8612 8613 8614 8615 8616 8617 8618 8619 8620 8621 8622 8623 8624 8625 8626 8627 8628 8629 8630 8631 8632 8633 8634 8635 8636 8637 8638 8639 8640 8641 8642 8643 8644 8645 8646 8647 8648 8649 8650 8651 8652 8653 8654 8655 8656 8657 8658 8659 8660 8661 8662 | 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. * * Need this to get comparsions like * expr 20000000000000003 < 20000000000000004.0 * right. Converting the first argument to double will yield two * double values that are equivalent within double precision. * Converting the double to an integer gets done exactly, then * integer comparison can tell the difference. */ if (d2 < (double)LLONG_MIN) { return MP_GT; } if (d2 > (double)LLONG_MAX) { return MP_LT; } w2 = (Tcl_WideInt) d2; goto wideCompare; case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); if (mp_isneg(&big2)) { 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)LLONG_MAX) && (d1 > (double)LLONG_MIN)) { if (mp_isneg(&big2)) { compare = MP_GT; } else { compare = MP_LT; } mp_clear(&big2); return compare; } if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) && modf(d1, &tmp) != 0.0) { d2 = TclBignumToDouble(&big2); mp_clear(&big2); goto doubleCompare; } Tcl_InitBignumFromDouble(NULL, d1, &big1); goto bigCompare; } 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; mp_clear(&big1); return compare; } if ((d2 < (double)LLONG_MAX) && (d2 > (double)LLONG_MIN)) { compare = mp_cmp_d(&big1, 0); mp_clear(&big1); return compare; } if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) && modf(d2, &tmp) != 0.0) { d1 = TclBignumToDouble(&big1); |
︙ | ︙ | |||
9332 9333 9334 9335 9336 9337 9338 | PrintByteCodeInfo( register ByteCode *codePtr) /* The bytecode whose summary is printed to * stdout. */ { Proc *procPtr = codePtr->procPtr; Interp *iPtr = (Interp *) *codePtr->interpHandle; | | | | < | 8702 8703 8704 8705 8706 8707 8708 8709 8710 8711 8712 8713 8714 8715 8716 8717 8718 | 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_Z_MODIFIER "u, epoch %" TCL_Z_MODIFIER "u, interp 0x%p (epoch %" TCL_Z_MODIFIER "u)\n", codePtr, (size_t)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, codePtr->numAuxDataItems, codePtr->maxStackDepth, |
︙ | ︙ | |||
9361 9362 9363 9364 9365 9366 9367 | (unsigned long) (codePtr->numLitObjects * sizeof(Tcl_Obj *)), (unsigned long) (codePtr->numExceptRanges*sizeof(ExceptionRange)), (unsigned long) (codePtr->numAuxDataItems * sizeof(AuxData)), codePtr->numCmdLocBytes); #endif /* TCL_COMPILE_STATS */ if (procPtr != NULL) { fprintf(stdout, | | | 8730 8731 8732 8733 8734 8735 8736 8737 8738 8739 8740 8741 8742 8743 8744 | (unsigned long) (codePtr->numLitObjects * sizeof(Tcl_Obj *)), (unsigned long) (codePtr->numExceptRanges*sizeof(ExceptionRange)), (unsigned long) (codePtr->numAuxDataItems * sizeof(AuxData)), codePtr->numCmdLocBytes); #endif /* TCL_COMPILE_STATS */ if (procPtr != NULL) { fprintf(stdout, " Proc 0x%p, refCt %zd, args %d, compiled locals %d\n", procPtr, procPtr->refCount, procPtr->numArgs, procPtr->numCompiledLocals); } } #endif /* TCL_COMPILE_DEBUG */ /* |
︙ | ︙ | |||
9413 9414 9415 9416 9417 9418 9419 | unsigned char opCode = *pc; if (((unsigned long) pc < codeStart) || ((unsigned long) pc > codeEnd)) { fprintf(stderr, "\nBad instruction pc 0x%p in TclNRExecuteByteCode\n", pc); Tcl_Panic("TclNRExecuteByteCode execution failure: bad pc"); } | | | 8782 8783 8784 8785 8786 8787 8788 8789 8790 8791 8792 8793 8794 8795 8796 | unsigned char opCode = *pc; if (((unsigned long) pc < codeStart) || ((unsigned long) pc > codeEnd)) { fprintf(stderr, "\nBad instruction pc 0x%p in TclNRExecuteByteCode\n", pc); Tcl_Panic("TclNRExecuteByteCode execution failure: bad pc"); } if ((unsigned) opCode >= LAST_INST_OPCODE) { fprintf(stderr, "\nBad opcode %d at pc %u in TclNRExecuteByteCode\n", (unsigned) opCode, relativePc); Tcl_Panic("TclNRExecuteByteCode execution failure: bad opcode"); } if (checkStack && ((stackTop < 0) || (stackTop > stackUpperBound))) { int numChars; |
︙ | ︙ | |||
9476 9477 9478 9479 9480 9481 9482 | int type; const unsigned char opcode = *pc; const char *description, *operator = "unknown"; if (opcode == INST_EXPON) { operator = "**"; } else if (opcode <= INST_LNOT) { | | | 8845 8846 8847 8848 8849 8850 8851 8852 8853 8854 8855 8856 8857 8858 8859 | int type; const unsigned char opcode = *pc; const char *description, *operator = "unknown"; if (opcode == INST_EXPON) { operator = "**"; } else if (opcode <= INST_LNOT) { operator = operatorStrings[opcode - INST_BITOR]; } if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) { description = "non-numeric string"; } else if (type == TCL_NUMBER_NAN) { description = "non-numeric floating-point value"; } else if (type == TCL_NUMBER_DOUBLE) { |
︙ | ︙ | |||
10337 10338 10339 10340 10341 10342 10343 | } /* * Instruction counts. */ Tcl_AppendPrintfToObj(objPtr, "\nInstruction counts:\n"); | | | 9706 9707 9708 9709 9710 9711 9712 9713 9714 9715 9716 9717 9718 9719 9720 | } /* * Instruction counts. */ Tcl_AppendPrintfToObj(objPtr, "\nInstruction counts:\n"); for (i = 0; i < LAST_INST_OPCODE; i++) { Tcl_AppendPrintfToObj(objPtr, "%20s %8ld ", tclInstructionTable[i].name, statsPtr->instructionCount[i]); if (statsPtr->instructionCount[i]) { Tcl_AppendPrintfToObj(objPtr, "%6.1f%%\n", Percent(statsPtr->instructionCount[i], numInstructions)); } else { Tcl_AppendPrintfToObj(objPtr, "0\n"); |
︙ | ︙ |
Changes to generic/tclFCmd.c.
︙ | ︙ | |||
824 825 826 827 828 829 830 | }; force = 0; for (i = 0; i < objc; i++) { if (TclGetString(objv[i])[0] != '-') { break; } | | | | 824 825 826 827 828 829 830 831 832 833 834 835 836 837 838 839 | }; force = 0; for (i = 0; i < objc; i++) { if (TclGetString(objv[i])[0] != '-') { break; } if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", TCL_EXACT, &idx) != TCL_OK) { return -1; } if (idx == 0 /* -force */) { force = 1; } else { /* -- */ i++; break; |
︙ | ︙ | |||
1074 1075 1076 1077 1078 1079 1080 | Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad option \"%s\", there are no file attributes in this" " filesystem", TclGetString(objv[0]))); Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", NULL); goto end; } | | | | 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 1089 | Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad option \"%s\", there are no file attributes in this" " filesystem", TclGetString(objv[0]))); Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", NULL); goto end; } if (Tcl_GetIndexFromObj(interp, objv[0], attributeStrings, "option", INDEX_TEMP_TABLE, &index) != TCL_OK) { goto end; } if (Tcl_FSFileAttrsGet(interp, index, filePtr, &objPtr) != TCL_OK) { goto end; } Tcl_SetObjResult(interp, objPtr); |
︙ | ︙ | |||
1099 1100 1101 1102 1103 1104 1105 | "bad option \"%s\", there are no file attributes in this" " filesystem", TclGetString(objv[0]))); Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", NULL); goto end; } for (i = 0; i < objc ; i += 2) { | | | < | 1099 1100 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 | "bad option \"%s\", there are no file attributes in this" " filesystem", TclGetString(objv[0]))); Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", NULL); goto end; } for (i = 0; i < objc ; i += 2) { if (Tcl_GetIndexFromObj(interp, objv[i], attributeStrings, "option", INDEX_TEMP_TABLE, &index) != TCL_OK) { goto end; } if (i + 1 == objc) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "value for \"%s\" missing", TclGetString(objv[i]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FATTR", "NOVALUE", NULL); |
︙ | ︙ |
Changes to generic/tclFileName.c.
︙ | ︙ | |||
1877 1878 1879 1880 1881 1882 1883 | &driveNameLen, &driveName) == TCL_PATH_ABSOLUTE) { pathPrefix = driveName; tail += driveNameLen; } } /* | | | 1877 1878 1879 1880 1881 1882 1883 1884 1885 1886 1887 1888 1889 1890 1891 | &driveNameLen, &driveName) == TCL_PATH_ABSOLUTE) { pathPrefix = driveName; tail += driveNameLen; } } /* * To process a [glob] invocation, this function may be called multiple * times. Each time, the previously discovered filenames are in the * interpreter result. We stash that away here so the result is free for * error messsages. */ savedResultObj = Tcl_GetObjResult(interp); Tcl_IncrRefCount(savedResultObj); |
︙ | ︙ |
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 != 0; } return code; } /* * Local Variables: * mode: c |
︙ | ︙ |
Changes to generic/tclHash.c.
︙ | ︙ | |||
24 25 26 27 28 29 30 | * The following macro takes a preliminary integer hash value and produces an * index into a hash tables bucket list. The idea is to make it so that * preliminary values that are arbitrarily similar will end up in different * buckets. The hash function was taken from a random-number generator. */ #define RANDOM_INDEX(tablePtr, i) \ | | | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | * The following macro takes a preliminary integer hash value and produces an * index into a hash tables bucket list. The idea is to make it so that * preliminary values that are arbitrarily similar will end up in different * buckets. The hash function was taken from a random-number generator. */ #define RANDOM_INDEX(tablePtr, i) \ ((((i)*1103515245UL) >> (tablePtr)->downShift) & (tablePtr)->mask) /* * Prototypes for the array hash key methods. */ static Tcl_HashEntry * AllocArrayEntry(Tcl_HashTable *tablePtr, void *keyPtr); static int CompareArrayKeys(void *keyPtr, Tcl_HashEntry *hPtr); |
︙ | ︙ | |||
198 199 200 201 202 203 204 | return CreateHashEntry(tablePtr, key, NULL); } /* *---------------------------------------------------------------------- * | | | 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 | return CreateHashEntry(tablePtr, key, NULL); } /* *---------------------------------------------------------------------- * * CreateHashEntry -- * * Given a hash table with string keys, and a string key, find the entry * with a matching key. If there is no matching entry, then create a new * entry that does match. * * Results: * The return value is a pointer to the matching entry. If this is a |
︙ | ︙ | |||
226 227 228 229 230 231 232 | const char *key, /* Key to use to find or create matching * entry. */ int *newPtr) /* Store info here telling whether a new entry * was created. */ { register Tcl_HashEntry *hPtr; const Tcl_HashKeyType *typePtr; | > | | 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 | const char *key, /* Key to use to find or create matching * entry. */ int *newPtr) /* Store info here telling whether a new entry * was created. */ { register Tcl_HashEntry *hPtr; const Tcl_HashKeyType *typePtr; unsigned int hash; unsigned int index; if (tablePtr->keyType == TCL_STRING_KEYS) { typePtr = &tclStringHashKeyType; } else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) { typePtr = &tclOneWordHashKeyType; } else if (tablePtr->keyType == TCL_CUSTOM_TYPE_KEYS || tablePtr->keyType == TCL_CUSTOM_PTR_KEYS) { |
︙ | ︙ | |||
345 346 347 348 349 350 351 | Tcl_DeleteHashEntry( Tcl_HashEntry *entryPtr) { register Tcl_HashEntry *prevPtr; const Tcl_HashKeyType *typePtr; Tcl_HashTable *tablePtr; Tcl_HashEntry **bucketPtr; | | | 346 347 348 349 350 351 352 353 354 355 356 357 358 359 360 | Tcl_DeleteHashEntry( Tcl_HashEntry *entryPtr) { register Tcl_HashEntry *prevPtr; const Tcl_HashKeyType *typePtr; Tcl_HashTable *tablePtr; Tcl_HashEntry **bucketPtr; unsigned int index; tablePtr = entryPtr->tablePtr; if (tablePtr->keyType == TCL_STRING_KEYS) { typePtr = &tclStringHashKeyType; } else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) { typePtr = &tclOneWordHashKeyType; |
︙ | ︙ | |||
752 753 754 755 756 757 758 | static Tcl_HashEntry * AllocStringEntry( Tcl_HashTable *tablePtr, /* Hash table. */ void *keyPtr) /* Key to store in the hash table entry. */ { const char *string = (const char *) keyPtr; Tcl_HashEntry *hPtr; | | | 753 754 755 756 757 758 759 760 761 762 763 764 765 766 767 | static Tcl_HashEntry * AllocStringEntry( Tcl_HashTable *tablePtr, /* Hash table. */ void *keyPtr) /* Key to store in the hash table entry. */ { const char *string = (const char *) keyPtr; Tcl_HashEntry *hPtr; size_t size, allocsize; allocsize = size = strlen(string) + 1; if (size < sizeof(hPtr->key)) { allocsize = sizeof(hPtr->key); } hPtr = ckalloc(TclOffset(Tcl_HashEntry, key) + allocsize); memcpy(hPtr->key.string, string, size); |
︙ | ︙ | |||
937 938 939 940 941 942 943 | *---------------------------------------------------------------------- */ static void RebuildTable( register Tcl_HashTable *tablePtr) /* Table to enlarge. */ { | | | > > > > > > < < < | 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 | *---------------------------------------------------------------------- */ static void RebuildTable( register Tcl_HashTable *tablePtr) /* Table to enlarge. */ { size_t count, index, oldSize = tablePtr->numBuckets; Tcl_HashEntry **oldBuckets = tablePtr->buckets; register Tcl_HashEntry **oldChainPtr, **newChainPtr; register Tcl_HashEntry *hPtr; const Tcl_HashKeyType *typePtr; /* Avoid outgrowing capability of the memory allocators */ if (oldSize > UINT_MAX / (4 * sizeof(Tcl_HashEntry *))) { tablePtr->rebuildSize = INT_MAX; return; } if (tablePtr->keyType == TCL_STRING_KEYS) { typePtr = &tclStringHashKeyType; } else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) { typePtr = &tclOneWordHashKeyType; } else if (tablePtr->keyType == TCL_CUSTOM_TYPE_KEYS || tablePtr->keyType == TCL_CUSTOM_PTR_KEYS) { typePtr = tablePtr->typePtr; } else { typePtr = &tclArrayHashKeyType; } /* * Allocate and initialize the new bucket array, and set up hashing * constants for new array size. */ tablePtr->numBuckets *= 4; if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) { |
︙ | ︙ |
Changes to generic/tclIO.c.
︙ | ︙ | |||
717 718 719 720 721 722 723 724 725 | void Tcl_SetStdChannel( Tcl_Channel channel, int type) /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); switch (type) { case TCL_STDIN: | > | | | | 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 | void Tcl_SetStdChannel( Tcl_Channel channel, int type) /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); int init = channel ? 1 : -1; switch (type) { case TCL_STDIN: tsdPtr->stdinInitialized = init; tsdPtr->stdinChannel = channel; break; case TCL_STDOUT: tsdPtr->stdoutInitialized = init; tsdPtr->stdoutChannel = channel; break; case TCL_STDERR: tsdPtr->stderrInitialized = init; tsdPtr->stderrChannel = channel; break; } } /* *---------------------------------------------------------------------- |
︙ | ︙ | |||
764 765 766 767 768 769 770 771 | * If the channels were not created yet, create them now and store them in * the static variables. */ switch (type) { case TCL_STDIN: if (!tsdPtr->stdinInitialized) { tsdPtr->stdinChannel = TclpGetDefaultStdChannel(TCL_STDIN); | > < > > < > > < > | 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 | * If the channels were not created yet, create them now and store them in * the static variables. */ switch (type) { case TCL_STDIN: if (!tsdPtr->stdinInitialized) { tsdPtr->stdinInitialized = -1; tsdPtr->stdinChannel = TclpGetDefaultStdChannel(TCL_STDIN); /* * Artificially bump the refcount to ensure that the channel is * only closed on exit. * * NOTE: Must only do this if stdinChannel is not NULL. It can be * NULL in situations where Tcl is unable to connect to the * standard input. */ if (tsdPtr->stdinChannel != NULL) { tsdPtr->stdinInitialized = 1; Tcl_RegisterChannel(NULL, tsdPtr->stdinChannel); } } channel = tsdPtr->stdinChannel; break; case TCL_STDOUT: if (!tsdPtr->stdoutInitialized) { tsdPtr->stdoutInitialized = -1; tsdPtr->stdoutChannel = TclpGetDefaultStdChannel(TCL_STDOUT); if (tsdPtr->stdoutChannel != NULL) { tsdPtr->stdoutInitialized = 1; Tcl_RegisterChannel(NULL, tsdPtr->stdoutChannel); } } channel = tsdPtr->stdoutChannel; break; case TCL_STDERR: if (!tsdPtr->stderrInitialized) { tsdPtr->stderrInitialized = -1; tsdPtr->stderrChannel = TclpGetDefaultStdChannel(TCL_STDERR); if (tsdPtr->stderrChannel != NULL) { tsdPtr->stderrInitialized = 1; Tcl_RegisterChannel(NULL, tsdPtr->stderrChannel); } } channel = tsdPtr->stderrChannel; break; } return channel; |
︙ | ︙ | |||
1064 1065 1066 1067 1068 1069 1070 | static void CheckForStdChannelsBeingClosed( Tcl_Channel chan) { ChannelState *statePtr = ((Channel *) chan)->state; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); | | | | | 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 | static void CheckForStdChannelsBeingClosed( Tcl_Channel chan) { ChannelState *statePtr = ((Channel *) chan)->state; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (tsdPtr->stdinInitialized == 1 && tsdPtr->stdinChannel != NULL && statePtr == ((Channel *)tsdPtr->stdinChannel)->state) { if (statePtr->refCount < 2) { statePtr->refCount = 0; tsdPtr->stdinChannel = NULL; return; } } else if (tsdPtr->stdoutInitialized == 1 && tsdPtr->stdoutChannel != NULL && statePtr == ((Channel *)tsdPtr->stdoutChannel)->state) { if (statePtr->refCount < 2) { statePtr->refCount = 0; tsdPtr->stdoutChannel = NULL; return; } } else if (tsdPtr->stderrInitialized == 1 && tsdPtr->stderrChannel != NULL && statePtr == ((Channel *)tsdPtr->stderrChannel)->state) { if (statePtr->refCount < 2) { statePtr->refCount = 0; tsdPtr->stderrChannel = NULL; return; } |
︙ | ︙ | |||
8924 8925 8926 8927 8928 8929 8930 | static const char *const modeOptions[] = {"readable", "writable", NULL}; static const int maskArray[] = {TCL_READABLE, TCL_WRITABLE}; if ((objc != 3) && (objc != 4)) { Tcl_WrongNumArgs(interp, 1, objv, "channelId event ?script?"); return TCL_ERROR; } | | | | 8928 8929 8930 8931 8932 8933 8934 8935 8936 8937 8938 8939 8940 8941 8942 8943 | static const char *const modeOptions[] = {"readable", "writable", NULL}; static const int maskArray[] = {TCL_READABLE, TCL_WRITABLE}; if ((objc != 3) && (objc != 4)) { Tcl_WrongNumArgs(interp, 1, objv, "channelId event ?script?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[2], modeOptions, "event name", 0, &modeIndex) != TCL_OK) { return TCL_ERROR; } mask = maskArray[modeIndex]; chanName = TclGetString(objv[1]); chan = Tcl_GetChannel(interp, chanName, NULL); if (chan == NULL) { |
︙ | ︙ |
Changes to generic/tclIORTrans.c.
︙ | ︙ | |||
611 612 613 614 615 616 617 | TclGetString(cmdObj), TclGetString(resObj))); Tcl_DecrRefCount(resObj); goto error; } methods = 0; while (listc > 0) { | | | | 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 626 | TclGetString(cmdObj), TclGetString(resObj))); Tcl_DecrRefCount(resObj); goto error; } methods = 0; while (listc > 0) { if (Tcl_GetIndexFromObj(interp, listv[listc-1], methodNames, "method", TCL_EXACT, &methIndex) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s initialize\" returned %s", TclGetString(cmdObj), Tcl_GetString(Tcl_GetObjResult(interp)))); Tcl_DecrRefCount(resObj); goto error; } |
︙ | ︙ |
Changes to generic/tclIOSock.c.
︙ | ︙ | |||
218 219 220 221 222 223 224 | /* * We found some problems when using AI_ADDRCONFIG, e.g. on systems that * have no networking besides the loopback interface and want to resolve * localhost. See [Bugs 3385024, 3382419, 3382431]. As the advantage of * using AI_ADDRCONFIG is probably low even in situations where it works, * we'll leave it out for now. After all, it is just an optimisation. * | | | 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 | /* * We found some problems when using AI_ADDRCONFIG, e.g. on systems that * have no networking besides the loopback interface and want to resolve * localhost. See [Bugs 3385024, 3382419, 3382431]. As the advantage of * using AI_ADDRCONFIG is probably low even in situations where it works, * we'll leave it out for now. After all, it is just an optimisation. * * Missing on NetBSD. * Causes failure when used on AIX 5.1 and HP-UX */ #if defined(AI_ADDRCONFIG) && !defined(_AIX) && !defined(__hpux) hints.ai_flags |= AI_ADDRCONFIG; #endif /* AI_ADDRCONFIG && !_AIX && !__hpux */ #endif /* 0 */ |
︙ | ︙ |
Changes to generic/tclIOUtil.c.
︙ | ︙ | |||
407 408 409 410 411 412 413 414 415 416 417 418 419 420 | return NULL; } Tcl_DStringInit(cwdPtr); TclDStringAppendObj(cwdPtr, cwd); Tcl_DecrRefCount(cwd); return Tcl_DStringValue(cwdPtr); } /* * Now move on to the basic filesystem implementation. */ static void FsThrExitProc( | > > > > > > > > > > > > > > > | 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 | return NULL; } 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; Tcl_Obj *pathPtr = Tcl_NewStringObj(fileName,-1); Tcl_IncrRefCount(pathPtr); ret = Tcl_FSEvalFile(interp, pathPtr); Tcl_DecrRefCount(pathPtr); return ret; } /* * Now move on to the basic filesystem implementation. */ static void FsThrExitProc( |
︙ | ︙ | |||
811 812 813 814 815 816 817 | 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 -- * |
︙ | ︙ | |||
2488 2489 2490 2491 2492 2493 2494 | /* * It's a constant attribute table, so use T_GIFO. */ Tcl_Obj *tmpObj = Tcl_NewStringObj(attributeName, -1); int result; | | | | 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 | /* * It's a constant attribute table, so use T_GIFO. */ Tcl_Obj *tmpObj = Tcl_NewStringObj(attributeName, -1); int result; result = Tcl_GetIndexFromObj(NULL, tmpObj, attrTable, NULL, TCL_EXACT, indexPtr); TclDecrRefCount(tmpObj); if (listObj != NULL) { TclDecrRefCount(listObj); } return result; } else if (listObj != NULL) { /* |
︙ | ︙ |
Changes to generic/tclIndexObj.c.
︙ | ︙ | |||
522 523 524 525 526 527 528 | if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "?options? table string"); return TCL_ERROR; } for (i = 1; i < (objc - 2); i++) { | | | | 522 523 524 525 526 527 528 529 530 531 532 533 534 535 536 537 | if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "?options? table string"); return TCL_ERROR; } for (i = 1; i < (objc - 2); i++) { if (Tcl_GetIndexFromObj(interp, objv[i], matchOptions, "option", 0, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum matchOptions) index) { case PRFMATCH_EXACT: flags |= TCL_EXACT; break; case PRFMATCH_MESSAGE: |
︙ | ︙ | |||
592 593 594 595 596 597 598 | } if (Tcl_IsShared(errorPtr)) { errorPtr = Tcl_DuplicateObj(errorPtr); } Tcl_ListObjAppendElement(interp, errorPtr, Tcl_NewStringObj("-code", 5)); | | | 592 593 594 595 596 597 598 599 600 601 602 603 604 605 606 | } if (Tcl_IsShared(errorPtr)) { errorPtr = Tcl_DuplicateObj(errorPtr); } Tcl_ListObjAppendElement(interp, errorPtr, Tcl_NewStringObj("-code", 5)); Tcl_ListObjAppendElement(interp, errorPtr, Tcl_NewIntObj(result)); return Tcl_SetReturnOptions(interp, errorPtr); } result = Tcl_ListObjIndex(interp, tablePtr, index, &resultPtr); if (result != TCL_OK) { return result; |
︙ | ︙ | |||
1365 1366 1367 1368 1369 1370 1371 | "ok", "error", "return", "break", "continue", NULL }; if ((value->typePtr != &indexType) && TclGetIntFromObj(NULL, value, codePtr) == TCL_OK) { return TCL_OK; } | | | | 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 | "ok", "error", "return", "break", "continue", NULL }; if ((value->typePtr != &indexType) && TclGetIntFromObj(NULL, value, codePtr) == TCL_OK) { return TCL_OK; } if (Tcl_GetIndexFromObj(NULL, value, returnCodes, NULL, TCL_EXACT, codePtr) == TCL_OK) { return TCL_OK; } /* * Value is not a legal completion 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) } # Removed in 9.0: #declare 8 { # int TclCopyChannelOld(Tcl_Interp *interp, Tcl_Channel inChan, # Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr) #} # TclCreatePipeline unofficially exported for use by BLT. |
︙ | ︙ | |||
70 71 72 73 74 75 76 | } declare 11 { void TclDeleteCompiledLocalVars(Interp *iPtr, CallFrame *framePtr) } declare 12 { void TclDeleteVars(Interp *iPtr, TclVarHashTable *tablePtr) } | | | | 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 | } 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 { |
︙ | ︙ | |||
111 112 113 114 115 116 117 | 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 { | | | | 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 | 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) } |
︙ | ︙ | |||
144 145 146 147 148 149 150 | declare 31 { const char *TclGetExtension(const char *name) } declare 32 { int TclGetFrame(Tcl_Interp *interp, const char *str, CallFrame **framePtrPtr) } | | | | 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 | 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 { |
︙ | ︙ | |||
182 183 184 185 186 187 188 | } declare 41 { Tcl_Command TclGetOriginalCommand(Tcl_Command command) } declare 42 { const char *TclpGetUserHome(const char *name, Tcl_DString *bufferPtr) } | | | 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 | } declare 41 { Tcl_Command TclGetOriginalCommand(Tcl_Command command) } declare 42 { const 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) } |
︙ | ︙ | |||
217 218 219 220 221 222 223 | declare 50 { void TclInitCompiledLocals(Tcl_Interp *interp, CallFrame *framePtr, Namespace *nsPtr) } declare 51 { int TclInterpInit(Tcl_Interp *interp) } | | | 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 | 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) |
︙ | ︙ | |||
270 271 272 273 274 275 276 | 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) } | | | 270 271 272 273 274 275 276 277 278 279 280 281 282 283 284 | 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) #} |
︙ | ︙ | |||
354 355 356 357 358 359 360 | # declare 86 { # int TclParseQuotes(Tcl_Interp *interp, char *str, int termChar, # int flags, char **termPtr, ParseValue *pvPtr) # } # declare 87 { # void TclPlatformInit(Tcl_Interp *interp) # } | > | | | < > | | 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 | # declare 86 { # int TclParseQuotes(Tcl_Interp *interp, char *str, int termChar, # int flags, char **termPtr, ParseValue *pvPtr) # } # declare 87 { # void TclPlatformInit(Tcl_Interp *interp) # } # Removed in 9.0: #declare 88 { # 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) } # Removed in 8.1 (only available if compiled with TCL_COMPILE_DEBUG): # declare 90 { # void TclPrintByteCodeObj(Tcl_Interp *interp, Tcl_Obj *objPtr) # } declare 91 { void TclProcCleanupProc(Proc *procPtr) } declare 92 { 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) |
︙ | ︙ | |||
416 417 418 419 420 421 422 | declare 102 { void TclSetupEnv(Tcl_Interp *interp) } declare 103 { int TclSockGetPort(Tcl_Interp *interp, const char *str, const char *proto, int *portPtr) } | | | 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 | declare 102 { void TclSetupEnv(Tcl_Interp *interp) } declare 103 { int TclSockGetPort(Tcl_Interp *interp, const char *str, const char *proto, int *portPtr) } # Removed in 9.0: #declare 104 { # int TclSockMinimumBuffersOld(int sock, int size) #} # Replaced by Tcl_FSStat in 8.4: #declare 105 { # int TclStat(const char *path, Tcl_StatBuf *buf) #} |
︙ | ︙ | |||
698 699 700 701 702 703 704 | #} # REMOVED - use public Tcl_GetStartupScript() #declare 168 { # Tcl_Obj *TclGetStartupScriptPath(void) #} # variant of Tcl_UtfNCmp that takes n as bytes, not chars declare 169 { | | | 699 700 701 702 703 704 705 706 707 708 709 710 711 712 713 | #} # REMOVED - use public Tcl_GetStartupScript() #declare 168 { # 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 { int TclCheckInterpTraces(Tcl_Interp *interp, const char *command, int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]) } declare 171 { |
︙ | ︙ | |||
1062 1063 1064 1065 1066 1067 1068 | ################################ # Windows specific functions declare 0 win { void TclWinConvertError(DWORD errCode) } | | | | | | > | | < > | | | 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 | ################################ # Windows specific functions declare 0 win { void TclWinConvertError(DWORD errCode) } # Removed in 9.0: #declare 1 win { # void TclWinConvertWSAError(DWORD errCode) #} # Removed in 9.0: #declare 2 win { # struct servent *TclWinGetServByName(const char *nm, # const char *proto) #} # Removed in 9.0: #declare 3 win { # int TclWinGetSockOpt(SOCKET s, int level, int optname, # char *optval, int *optlen) #} declare 4 win { HINSTANCE TclWinGetTclInstance(void) } # new for 8.4.20+/8.5.12+ Cygwin only declare 5 win { int TclUnixWaitForFile(int fd, int mask, int timeout) } # Removed in 8.1: # declare 5 win { # HINSTANCE TclWinLoadLibrary(char *name) # } # Removed in 9.0: #declare 6 win { # unsigned short TclWinNToHS(unsigned short ns) #} # Removed in 9.0: #declare 7 win { # int TclWinSetSockOpt(SOCKET s, int level, int optname, # const char *optval, int optlen) #} declare 8 win { int TclpGetPid(Tcl_Pid pid) } # Removed in 9.0: #declare 9 win { # int TclWinGetPlatformId(void) #} # Removed in 9.0: #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 { |
︙ | ︙ | |||
1156 1157 1158 1159 1160 1161 1162 | } declare 19 win { TclFile TclpOpenFile(const char *fname, int mode) } declare 20 win { void TclWinAddProcess(HANDLE hProcess, DWORD id) } | | | 1158 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 | } declare 19 win { TclFile TclpOpenFile(const char *fname, int mode) } declare 20 win { void TclWinAddProcess(HANDLE hProcess, DWORD id) } # Removed in 9.0: #declare 21 win { # char *TclpInetNtoa(struct in_addr addr) #} # removed permanently for 8.4 #declare 21 win { # void TclpAsyncMark(Tcl_AsyncHandler async) #} |
︙ | ︙ | |||
1180 1181 1182 1183 1184 1185 1186 | declare 24 win { char *TclWinNoBackslash(char *path) } # replaced by generic TclGetPlatform #declare 25 win { # TclPlatformType *TclWinGetPlatform(void) #} | > | | < > > | | < > | 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 | declare 24 win { char *TclWinNoBackslash(char *path) } # replaced by generic TclGetPlatform #declare 25 win { # TclPlatformType *TclWinGetPlatform(void) #} # Removed in 9.0: #declare 26 win { # void TclWinSetInterfaces(int wide) #} # Added in Tcl 8.3.3 / 8.4 declare 27 win { void TclWinFlushDirtyChannels(void) } # Added in 8.4.2 # Removed in 9.0: #declare 28 win { # void TclWinResetInterfaces(void) #} ################################ # Unix specific functions # Pipe channel functions declare 0 unix { |
︙ | ︙ | |||
1241 1242 1243 1244 1245 1246 1247 | declare 9 unix { TclFile TclpCreateTempFile(const char *contents) } # Added in 8.4: | | > > > | 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 | declare 9 unix { TclFile TclpCreateTempFile(const char *contents) } # Added in 8.4: # Removed in 9.0: #declare 10 unix { # Tcl_DirEntry *TclpReaddir(DIR *dir) #} # Removed in 9.0: #declare 11 unix { # struct tm *TclpLocaltime_unix(const time_t *clock) #} # Removed in 9.0: #declare 12 unix { # struct tm *TclpGmtime_unix(const time_t *clock) #} # Removed in 9.0: #declare 13 unix { # char *TclpInetNtoa(struct in_addr addr) #} # Added in 8.5: declare 14 unix { |
︙ | ︙ |
Changes to generic/tclInt.h.
︙ | ︙ | |||
34 35 36 37 38 39 40 41 42 43 44 45 46 47 | */ #include "tclPort.h" #include <stdio.h> #include <ctype.h> #ifdef NO_STDLIB_H # include "../compat/stdlib.h" #else # include <stdlib.h> #endif #ifdef NO_STRING_H #include "../compat/string.h" | > | 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | */ #include "tclPort.h" #include <stdio.h> #include <ctype.h> #include <stdarg.h> #ifdef NO_STDLIB_H # include "../compat/stdlib.h" #else # include <stdlib.h> #endif #ifdef NO_STRING_H #include "../compat/string.h" |
︙ | ︙ | |||
173 174 175 176 177 178 179 | * This flag bit should not interfere with TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY, or TCL_LEAVE_ERR_MSG; it signals that the variable * lookup is performed for upvar (or similar) purposes, with slightly * different rules: * - Bug #696893 - variable is either proc-local or in the current * namespace; never follow the second (global) resolution path * - Bug #631741 - do not use special namespace or interp resolvers | < < < | 174 175 176 177 178 179 180 181 182 183 184 185 186 187 | * This flag bit should not interfere with TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY, or TCL_LEAVE_ERR_MSG; it signals that the variable * lookup is performed for upvar (or similar) purposes, with slightly * different rules: * - Bug #696893 - variable is either proc-local or in the current * namespace; never follow the second (global) resolution path * - Bug #631741 - do not use special namespace or interp resolvers */ #define TCL_AVOID_RESOLVERS 0x40000 /* *---------------------------------------------------------------- * Data structures related to namespaces. |
︙ | ︙ | |||
249 250 251 252 253 254 255 | #else Tcl_HashTable *childTablePtr; /* Contains any child namespaces. Indexed by * strings; values have type (Namespace *). If * NULL, there are no children. */ #endif size_t nsId; /* Unique id for the namespace. */ | | | 247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 | #else Tcl_HashTable *childTablePtr; /* Contains any child namespaces. Indexed by * strings; values have type (Namespace *). If * NULL, there are no children. */ #endif size_t nsId; /* Unique id for the namespace. */ 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. */ |
︙ | ︙ | |||
409 410 411 412 413 414 415 | * 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 { | | | 407 408 409 410 411 412 413 414 415 416 417 418 419 420 421 | * 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.) */ size_t epoch; /* The epoch at which this ensemble's table of * exported commands is valid. */ |
︙ | ︙ | |||
1479 1480 1481 1482 1483 1484 1485 | * 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 | | | 1477 1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 | * 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 { |
︙ | ︙ | |||
2186 2187 2188 2189 2190 2191 2192 | * 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, | | | 2184 2185 2186 2187 2188 2189 2190 2191 2192 2193 2194 2195 2196 2197 2198 | * 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 |
︙ | ︙ | |||
2327 2328 2329 2330 2331 2332 2333 | 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 | | | 2325 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 | 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 *))) |
︙ | ︙ | |||
2380 2381 2382 2383 2384 2385 2386 | * TclNRLmapCmd and their compilations. */ #define TCL_EACH_KEEP_NONE 0 /* Discard iteration result like [foreach] */ #define TCL_EACH_COLLECT 1 /* Collect iteration result like [lmap] */ /* | | > | > > > > > > > | > > > > > > > > < | | > > | | > > < < < < < < < < < < < < | < < < < | | | 2378 2379 2380 2381 2382 2383 2384 2385 2386 2387 2388 2389 2390 2391 2392 2393 2394 2395 2396 2397 2398 2399 2400 2401 2402 2403 2404 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 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 2460 2461 2462 | * TclNRLmapCmd and their compilations. */ #define TCL_EACH_KEEP_NONE 0 /* Discard iteration result like [foreach] */ #define TCL_EACH_COLLECT 1 /* Collect iteration result like [lmap] */ /* * Macros providing a faster path to booleans and integers: * Tcl_GetBooleanFromObj, Tcl_GetLongFromObj, Tcl_GetIntFromObj * and TclGetIntForIndex. * * WARNING: these macros eval their args more than once. */ #define TclGetBooleanFromObj(interp, objPtr, boolPtr) \ (((objPtr)->typePtr == &tclIntType \ || (objPtr)->typePtr == &tclBooleanType) \ ? (*(boolPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK) \ : Tcl_GetBooleanFromObj((interp), (objPtr), (boolPtr))) #ifdef TCL_WIDE_INT_IS_LONG #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) = (int)(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) = (int)(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 |
︙ | ︙ | |||
2646 2647 2648 2649 2650 2651 2652 | 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 tclArraySearchType; MODULE_SCOPE const Tcl_ObjType tclEnsembleCmdType; | < < < | 2647 2648 2649 2650 2651 2652 2653 2654 2655 2656 2657 2658 2659 2660 | 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 tclArraySearchType; 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. */ |
︙ | ︙ | |||
2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 | MODULE_SCOPE Tcl_ObjCmdProc TclNREvalObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRCatchObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRExprObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRForObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRForeachCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRIfObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRLmapCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSourceObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSubstObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSwitchObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRTryObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRUplevelObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRWhileObjCmd; | > | 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 | MODULE_SCOPE Tcl_ObjCmdProc TclNREvalObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRCatchObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRExprObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRForObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRForeachCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRIfObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRLmapCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRPackageObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSourceObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSubstObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRSwitchObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRTryObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRUplevelObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRWhileObjCmd; |
︙ | ︙ | |||
2824 2825 2826 2827 2828 2829 2830 2831 2832 2833 2834 2835 2836 2837 2838 | 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, | > > | > > > > > > > > > > > > > | | 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 2853 2854 2855 2856 2857 2858 2859 2860 2861 2862 2863 2864 2865 2866 | 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 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; |
︙ | ︙ | |||
2861 2862 2863 2864 2865 2866 2867 2868 2869 2870 2871 2872 2873 2874 | 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); | > > | 2875 2876 2877 2878 2879 2880 2881 2882 2883 2884 2885 2886 2887 2888 2889 2890 | 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); |
︙ | ︙ | |||
2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 | 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, | > > > > > > > > > | 2903 2904 2905 2906 2907 2908 2909 2910 2911 2912 2913 2914 2915 2916 2917 2918 2919 2920 2921 2922 2923 2924 2925 | 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, |
︙ | ︙ | |||
3044 3045 3046 3047 3048 3049 3050 | 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); | < | 3069 3070 3071 3072 3073 3074 3075 3076 3077 3078 3079 3080 3081 3082 | 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); |
︙ | ︙ | |||
3075 3076 3077 3078 3079 3080 3081 | Tcl_Obj *newValue, Tcl_Encoding encoding); MODULE_SCOPE void TclSignalExitThread(Tcl_ThreadId id, int result); MODULE_SCOPE void TclSpellFix(Tcl_Interp *interp, Tcl_Obj *const *objv, int objc, size_t subIdx, Tcl_Obj *bad, Tcl_Obj *fix); MODULE_SCOPE void * TclStackRealloc(Tcl_Interp *interp, void *ptr, int numBytes); | < < < < < < < < < < > > > | 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 | Tcl_Obj *newValue, Tcl_Encoding encoding); MODULE_SCOPE void TclSignalExitThread(Tcl_ThreadId id, int result); MODULE_SCOPE void TclSpellFix(Tcl_Interp *interp, Tcl_Obj *const *objv, int objc, size_t subIdx, Tcl_Obj *bad, Tcl_Obj *fix); MODULE_SCOPE void * TclStackRealloc(Tcl_Interp *interp, void *ptr, int numBytes); MODULE_SCOPE int TclStringMatch(const char *str, int strLen, const char *pattern, int ptnLen, int flags); MODULE_SCOPE int TclStringMatchObj(Tcl_Obj *stringObj, Tcl_Obj *patternObj, int flags); MODULE_SCOPE void TclSubstCompile(Tcl_Interp *interp, const char *bytes, int numBytes, int flags, int line, struct CompileEnv *envPtr); MODULE_SCOPE int TclSubstOptions(Tcl_Interp *interp, int numOpts, Tcl_Obj *const opts[], int *flagPtr); MODULE_SCOPE void TclSubstParse(Tcl_Interp *interp, const char *bytes, int numBytes, int flags, Tcl_Parse *parsePtr, Tcl_InterpState *statePtr); MODULE_SCOPE int TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, int count, int *tokensLeftPtr, int line, int *clNextOuter, const char *outerScript); MODULE_SCOPE int TclTrim(const char *bytes, int numBytes, const char *trim, int numTrim, int *trimRight); 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); |
︙ | ︙ | |||
3887 3888 3889 3890 3891 3892 3893 3894 3895 3896 3897 3898 3899 3900 | Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileAssembleCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); /* * Functions defined in generic/tclVar.c and currently exported only for use * by the bytecode compiler and engine. Some of these could later be placed in * the public interface. */ MODULE_SCOPE Var * TclObjLookupVarEx(Tcl_Interp * interp, | > > > > > > > > > > > > > > > > > > > > > > > | 3904 3905 3906 3907 3908 3909 3910 3911 3912 3913 3914 3915 3916 3917 3918 3919 3920 3921 3922 3923 3924 3925 3926 3927 3928 3929 3930 3931 3932 3933 3934 3935 3936 3937 3938 3939 3940 | Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileAssembleCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); /* * Routines that provide the [string] ensemble functionality. Possible * candidates for public interface. */ MODULE_SCOPE Tcl_Obj * TclStringCat(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); MODULE_SCOPE int TclStringFirst(Tcl_Obj *needle, Tcl_Obj *haystack, int start); MODULE_SCOPE int TclStringLast(Tcl_Obj *needle, Tcl_Obj *haystack, int last); MODULE_SCOPE Tcl_Obj * TclStringRepeat(Tcl_Interp *interp, Tcl_Obj *objPtr, int count, int flags); MODULE_SCOPE Tcl_Obj * TclStringReplace(Tcl_Interp *interp, Tcl_Obj *objPtr, int first, int count, Tcl_Obj *insertPtr, int flags); MODULE_SCOPE Tcl_Obj * TclStringReverse(Tcl_Obj *objPtr, int flags); /* Flag values for the [string] ensemble functions. */ #define TCL_STRING_MATCH_NOCASE TCL_MATCH_NOCASE /* (1<<0) in tcl.h */ #define TCL_STRING_IN_PLACE (1<<1) /* * Functions defined in generic/tclVar.c and currently exported only for use * by the bytecode compiler and engine. Some of these could later be placed in * the public interface. */ MODULE_SCOPE Var * TclObjLookupVarEx(Tcl_Interp * interp, |
︙ | ︙ | |||
3942 3943 3944 3945 3946 3947 3948 3949 3950 3951 3952 3953 3954 3955 | MODULE_SCOPE int TclCompareObjKeys(void *keyPtr, Tcl_HashEntry *hPtr); MODULE_SCOPE void TclFreeObjEntry(Tcl_HashEntry *hPtr); MODULE_SCOPE TCL_HASH_TYPE TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr); MODULE_SCOPE int TclFullFinalizationRequested(void); /* *---------------------------------------------------------------- * Macros used by the Tcl core to create and release Tcl objects. * TclNewObj(objPtr) creates a new object denoting an empty string. * TclDecrRefCount(objPtr) decrements the object's reference count, and frees * the object if its reference count is zero. These macros are inline versions * of Tcl_NewObj() and Tcl_DecrRefCount(). Notice that the names differ in not | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 4005 4006 4007 4008 4009 4010 4011 4012 4013 4014 4015 4016 4017 4018 4019 4020 4021 4022 4023 4024 4025 4026 4027 4028 4029 4030 4031 4032 4033 4034 | MODULE_SCOPE int TclCompareObjKeys(void *keyPtr, Tcl_HashEntry *hPtr); MODULE_SCOPE void TclFreeObjEntry(Tcl_HashEntry *hPtr); MODULE_SCOPE TCL_HASH_TYPE TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr); MODULE_SCOPE int TclFullFinalizationRequested(void); /* * TIP #462. */ /* * The following enum values give the status of a spawned process. */ typedef enum TclProcessWaitStatus { TCL_PROCESS_ERROR = -1, /* Error waiting for process to exit */ TCL_PROCESS_UNCHANGED = 0, /* No change since the last call. */ TCL_PROCESS_EXITED = 1, /* Process has exited. */ TCL_PROCESS_SIGNALED = 2, /* Child killed because of a signal. */ TCL_PROCESS_STOPPED = 3, /* Child suspended because of a signal. */ TCL_PROCESS_UNKNOWN_STATUS = 4 /* Child wait status didn't make sense. */ } TclProcessWaitStatus; MODULE_SCOPE Tcl_Command TclInitProcessCmd(Tcl_Interp *interp); MODULE_SCOPE void TclProcessCreated(Tcl_Pid pid); MODULE_SCOPE TclProcessWaitStatus TclProcessWait(Tcl_Pid pid, int options, int *codePtr, Tcl_Obj **msgObjPtr, Tcl_Obj **errorObjPtr); /* * Utility routines for encoding index values as integers. Used by both * some of the command compilers and by [lsort] and [lsearch]. */ MODULE_SCOPE int TclIndexEncode(Tcl_Interp *interp, Tcl_Obj *objPtr, int before, int after, int *indexPtr); MODULE_SCOPE int TclIndexDecode(int encoded, int endValue); /* Constants used in index value encoding routines. */ #define TCL_INDEX_END (-2) #define TCL_INDEX_BEFORE (-1) #define TCL_INDEX_START (0) #define TCL_INDEX_AFTER (INT_MAX) /* *---------------------------------------------------------------- * Macros used by the Tcl core to create and release Tcl objects. * TclNewObj(objPtr) creates a new object denoting an empty string. * TclDecrRefCount(objPtr) decrements the object's reference count, and frees * the object if its reference count is zero. These macros are inline versions * of Tcl_NewObj() and Tcl_DecrRefCount(). Notice that the names differ in not |
︙ | ︙ | |||
4331 4332 4333 4334 4335 4336 4337 | * 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) \ | | | 4410 4411 4412 4413 4414 4415 4416 4417 4418 4419 4420 4421 4422 4423 4424 | * 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 |
︙ | ︙ | |||
4396 4397 4398 4399 4400 4401 4402 | # define TclUniCharNcmp(cs,ct,n) memcmp((cs),(ct),(n)*sizeof(Tcl_UniChar)) #else /* !WORDS_BIGENDIAN */ # define TclUniCharNcmp Tcl_UniCharNcmp #endif /* WORDS_BIGENDIAN */ /* *---------------------------------------------------------------- | | | 4475 4476 4477 4478 4479 4480 4481 4482 4483 4484 4485 4486 4487 4488 4489 | # define TclUniCharNcmp(cs,ct,n) memcmp((cs),(ct),(n)*sizeof(Tcl_UniChar)) #else /* !WORDS_BIGENDIAN */ # define TclUniCharNcmp Tcl_UniCharNcmp #endif /* WORDS_BIGENDIAN */ /* *---------------------------------------------------------------- * Macro used by the Tcl core to increment a namespace's export epoch * counter. The ANSI C "prototype" for this macro is: * * MODULE_SCOPE void TclInvalidateNsCmdLookup(Namespace *nsPtr); *---------------------------------------------------------------- */ #define TclInvalidateNsCmdLookup(nsPtr) \ |
︙ | ︙ | |||
4456 4457 4458 4459 4460 4461 4462 | /* *---------------------------------------------------------------- * 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: * | < | | | < < < < < < < < < < < | | | | 4535 4536 4537 4538 4539 4540 4541 4542 4543 4544 4545 4546 4547 4548 4549 4550 4551 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 | /* *---------------------------------------------------------------- * 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, size_t 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(); \ |
︙ | ︙ | |||
4537 4538 4539 4540 4541 4542 4543 | (objPtr)->refCount = 0; \ TclInitStringRep((objPtr), (s), (len)); \ (objPtr)->typePtr = NULL; \ TCL_DTRACE_OBJ_CREATE(objPtr); \ } while (0) #else /* TCL_MEM_DEBUG */ | | | | 4604 4605 4606 4607 4608 4609 4610 4611 4612 4613 4614 4615 4616 4617 4618 4619 | (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.
︙ | ︙ | |||
79 80 81 82 83 84 85 | const char *listStr, int listLength, const char **elementPtr, const char **nextPtr, int *sizePtr, int *bracePtr); /* 23 */ TCLAPI Proc * TclFindProc(Interp *iPtr, const char *procName); /* 24 */ | | | 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 | const char *listStr, int listLength, const char **elementPtr, const char **nextPtr, int *sizePtr, int *bracePtr); /* 23 */ TCLAPI Proc * TclFindProc(Interp *iPtr, const char *procName); /* 24 */ TCLAPI int TclFormatInt(char *buffer, Tcl_WideInt n); /* 25 */ TCLAPI void TclFreePackageInfo(Interp *iPtr); /* Slot 26 is reserved */ /* Slot 27 is reserved */ /* 28 */ TCLAPI Tcl_Channel TclpGetDefaultStdChannel(int type); /* Slot 29 is reserved */ |
︙ | ︙ | |||
195 196 197 198 199 200 201 | TCLAPI 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 */ | | < < < | 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 | TCLAPI 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 */ /* Slot 88 is reserved */ /* 89 */ TCLAPI int TclPreventAliasLoop(Tcl_Interp *interp, Tcl_Interp *cmdInterp, Tcl_Command cmd); /* Slot 90 is reserved */ /* 91 */ TCLAPI void TclProcCleanupProc(Proc *procPtr); /* 92 */ |
︙ | ︙ | |||
361 362 363 364 365 366 367 | TCLAPI int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj *valuePtr); /* Slot 167 is reserved */ /* Slot 168 is reserved */ /* 169 */ TCLAPI int TclpUtfNcmp2(const char *s1, const char *s2, | | | 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 | TCLAPI int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj *valuePtr); /* Slot 167 is reserved */ /* Slot 168 is reserved */ /* 169 */ TCLAPI int TclpUtfNcmp2(const char *s1, const char *s2, unsigned long n); /* 170 */ TCLAPI int TclCheckInterpTraces(Tcl_Interp *interp, const char *command, int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 171 */ TCLAPI int TclCheckExecutionTraces(Tcl_Interp *interp, |
︙ | ︙ | |||
596 597 598 599 600 601 602 | 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 */ | | | 593 594 595 596 597 598 599 600 601 602 603 604 605 606 607 | 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 */ |
︙ | ︙ | |||
660 661 662 663 664 665 666 | 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); | | | 657 658 659 660 661 662 663 664 665 666 667 668 669 670 671 | 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); void (*reserved88)(void); 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); |
︙ | ︙ | |||
741 742 743 744 745 746 747 | void (*tclChannelEventScriptInvoker) (ClientData clientData, int flags); /* 162 */ const void * (*tclGetInstructionTable) (void); /* 163 */ void (*tclExpandCodeArray) (void *envPtr); /* 164 */ void (*tclpSetInitialEncodings) (void); /* 165 */ int (*tclListObjSetElement) (Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj *valuePtr); /* 166 */ void (*reserved167)(void); void (*reserved168)(void); | | | 738 739 740 741 742 743 744 745 746 747 748 749 750 751 752 | void (*tclChannelEventScriptInvoker) (ClientData clientData, int flags); /* 162 */ const void * (*tclGetInstructionTable) (void); /* 163 */ void (*tclExpandCodeArray) (void *envPtr); /* 164 */ void (*tclpSetInitialEncodings) (void); /* 165 */ int (*tclListObjSetElement) (Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj *valuePtr); /* 166 */ void (*reserved167)(void); void (*reserved168)(void); 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 */ |
︙ | ︙ | |||
974 975 976 977 978 979 980 | (tclIntStubsPtr->tclpRealloc) /* 81 */ /* Slot 82 is reserved */ /* Slot 83 is reserved */ /* Slot 84 is reserved */ /* Slot 85 is reserved */ /* Slot 86 is reserved */ /* Slot 87 is reserved */ | | < | 971 972 973 974 975 976 977 978 979 980 981 982 983 984 985 | (tclIntStubsPtr->tclpRealloc) /* 81 */ /* Slot 82 is reserved */ /* Slot 83 is reserved */ /* Slot 84 is reserved */ /* Slot 85 is reserved */ /* Slot 86 is reserved */ /* Slot 87 is reserved */ /* Slot 88 is reserved */ #define TclPreventAliasLoop \ (tclIntStubsPtr->tclPreventAliasLoop) /* 89 */ /* Slot 90 is reserved */ #define TclProcCleanupProc \ (tclIntStubsPtr->tclProcCleanupProc) /* 91 */ #define TclProcCompileProc \ (tclIntStubsPtr->tclProcCompileProc) /* 92 */ |
︙ | ︙ |
Changes to generic/tclIntPlatDecls.h.
︙ | ︙ | |||
94 95 96 97 98 99 100 | TCLAPI HINSTANCE TclWinGetTclInstance(void); /* 5 */ TCLAPI int TclUnixWaitForFile(int fd, int mask, int timeout); /* Slot 6 is reserved */ /* Slot 7 is reserved */ /* 8 */ TCLAPI int TclpGetPid(Tcl_Pid pid); | | < | 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 | TCLAPI HINSTANCE TclWinGetTclInstance(void); /* 5 */ TCLAPI int TclUnixWaitForFile(int fd, int mask, int timeout); /* Slot 6 is reserved */ /* Slot 7 is reserved */ /* 8 */ TCLAPI int TclpGetPid(Tcl_Pid pid); /* Slot 9 is reserved */ /* Slot 10 is reserved */ /* 11 */ TCLAPI void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan); /* 12 */ TCLAPI int TclpCloseFile(TclFile file); /* 13 */ |
︙ | ︙ | |||
132 133 134 135 136 137 138 | /* Slot 21 is reserved */ /* 22 */ TCLAPI TclFile TclpCreateTempFile(const char *contents); /* Slot 23 is reserved */ /* 24 */ TCLAPI char * TclWinNoBackslash(char *path); /* Slot 25 is reserved */ | | < | < | 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 | /* Slot 21 is reserved */ /* 22 */ TCLAPI TclFile TclpCreateTempFile(const char *contents); /* Slot 23 is reserved */ /* 24 */ TCLAPI char * TclWinNoBackslash(char *path); /* Slot 25 is reserved */ /* Slot 26 is reserved */ /* 27 */ TCLAPI void TclWinFlushDirtyChannels(void); /* Slot 28 is reserved */ /* 29 */ TCLAPI int TclWinCPUID(int index, int *regs); /* 30 */ TCLAPI int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); #endif /* WIN */ |
︙ | ︙ | |||
263 264 265 266 267 268 269 | void (*reserved2)(void); void (*reserved3)(void); HINSTANCE (*tclWinGetTclInstance) (void); /* 4 */ int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 5 */ void (*reserved6)(void); void (*reserved7)(void); int (*tclpGetPid) (Tcl_Pid pid); /* 8 */ | | | | | 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 | void (*reserved2)(void); void (*reserved3)(void); HINSTANCE (*tclWinGetTclInstance) (void); /* 4 */ int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 5 */ void (*reserved6)(void); void (*reserved7)(void); int (*tclpGetPid) (Tcl_Pid pid); /* 8 */ void (*reserved9)(void); void (*reserved10)(void); void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 11 */ int (*tclpCloseFile) (TclFile file); /* 12 */ Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 13 */ int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 14 */ int (*tclpCreateProcess) (Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 15 */ int (*tclpIsAtty) (int fd); /* 16 */ int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 17 */ TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 18 */ TclFile (*tclpOpenFile) (const char *fname, int mode); /* 19 */ void (*tclWinAddProcess) (HANDLE hProcess, DWORD id); /* 20 */ void (*reserved21)(void); TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */ void (*reserved23)(void); char * (*tclWinNoBackslash) (char *path); /* 24 */ void (*reserved25)(void); void (*reserved26)(void); void (*tclWinFlushDirtyChannels) (void); /* 27 */ void (*reserved28)(void); int (*tclWinCPUID) (int index, int *regs); /* 29 */ int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */ int (*tclpCloseFile) (TclFile file); /* 1 */ Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */ |
︙ | ︙ | |||
392 393 394 395 396 397 398 | (tclIntPlatStubsPtr->tclWinGetTclInstance) /* 4 */ #define TclUnixWaitForFile \ (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 5 */ /* Slot 6 is reserved */ /* Slot 7 is reserved */ #define TclpGetPid \ (tclIntPlatStubsPtr->tclpGetPid) /* 8 */ | | < | 389 390 391 392 393 394 395 396 397 398 399 400 401 402 403 | (tclIntPlatStubsPtr->tclWinGetTclInstance) /* 4 */ #define TclUnixWaitForFile \ (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 5 */ /* Slot 6 is reserved */ /* Slot 7 is reserved */ #define TclpGetPid \ (tclIntPlatStubsPtr->tclpGetPid) /* 8 */ /* Slot 9 is reserved */ /* Slot 10 is reserved */ #define TclGetAndDetachPids \ (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 11 */ #define TclpCloseFile \ (tclIntPlatStubsPtr->tclpCloseFile) /* 12 */ #define TclpCreateCommandChannel \ (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 13 */ |
︙ | ︙ | |||
422 423 424 425 426 427 428 | /* Slot 21 is reserved */ #define TclpCreateTempFile \ (tclIntPlatStubsPtr->tclpCreateTempFile) /* 22 */ /* Slot 23 is reserved */ #define TclWinNoBackslash \ (tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */ /* Slot 25 is reserved */ | | < | < | 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 | /* Slot 21 is reserved */ #define TclpCreateTempFile \ (tclIntPlatStubsPtr->tclpCreateTempFile) /* 22 */ /* Slot 23 is reserved */ #define TclWinNoBackslash \ (tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */ /* Slot 25 is reserved */ /* Slot 26 is reserved */ #define TclWinFlushDirtyChannels \ (tclIntPlatStubsPtr->tclWinFlushDirtyChannels) /* 27 */ /* Slot 28 is reserved */ #define TclWinCPUID \ (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ #define TclUnixOpenTemporaryFile \ (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ #define TclGetAndDetachPids \ |
︙ | ︙ | |||
488 489 490 491 492 493 494 | (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ #endif /* MACOSX */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ | | | 482 483 484 485 486 487 488 489 490 491 492 493 494 | (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ #endif /* MACOSX */ #endif /* defined(USE_TCL_STUBS) */ /* !END!: Do not edit above this line. */ #if !defined(_WIN32) # undef TclpGetPid # define TclpGetPid(pid) ((unsigned long) (pid)) #endif #endif /* _TCLINTPLATDECLS */ |
Changes to generic/tclInterp.c.
︙ | ︙ | |||
62 63 64 65 66 67 68 | * the structure, which will be extended to * accomodate the remaining objects in the * prefix. */ } Alias; /* * | | | 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 | * the structure, which will be extended to * accomodate the remaining objects in the * prefix. */ } Alias; /* * * Slave: * * Used by the "interp" command to record and find information about slave * interpreters. Maps from a command name in the master to information about a * slave interpreter, e.g. what aliases are defined in it. */ typedef struct { |
︙ | ︙ | |||
108 109 110 111 112 113 114 | struct Target *nextPtr; /* Next in list of target records, or NULL if * at the end of the list of targets. */ struct Target *prevPtr; /* Previous in list of target records, or NULL * if at the start of the list of targets. */ } Target; /* | | | 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 | struct Target *nextPtr; /* Next in list of target records, or NULL if * at the end of the list of targets. */ struct Target *prevPtr; /* Previous in list of target records, or NULL * if at the start of the list of targets. */ } Target; /* * Master: * * This record is used for two purposes: First, slaveTable (a hashtable) maps * from names of commands to slave interpreters. This hashtable is used to * store information about slave interpreters of this interpreter, to map over * all slaves, etc. The second purpose is to store information about all * aliases in slaves (or siblings) which direct to target commands in this * interpreter (using the targetsPtr doubly-linked list). |
︙ | ︙ | |||
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.
︙ | ︙ | |||
642 643 644 645 646 647 648 | static int SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static Tcl_ObjType invalidRealType = { "invalidReal", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ NULL, /* updateStringProc */ | | | 642 643 644 645 646 647 648 649 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 */ 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 79 80 | #endif /* *---------------------------------------------------------------------- * * NewListIntRep -- * * Creates a 'List' structure with space for 'objc' elements. 'objc' must * be > 0. If 'objv' is not NULL, The list is initialized with first * 'objc' values in that array. Otherwise the list is initialized to have * 0 elements, with space to add 'objc' more. Flag value 'p' indicates * how to behave on failure. * * Value * * A new 'List' structure with refCount 0. If some failure * prevents this NULL is returned if 'p' is 0 , and 'Tcl_Panic' * is called if it is not. * * Effect * * The refCount of each value in 'objv' is incremented as it is added * to the list. * *---------------------------------------------------------------------- */ static List * NewListIntRep( int objc, |
︙ | ︙ | |||
128 129 130 131 132 133 134 | } return listRepPtr; } /* *---------------------------------------------------------------------- * | | < < < < < < < | < < < < < | 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 | } return listRepPtr; } /* *---------------------------------------------------------------------- * * AttemptNewList -- * * Like NewListIntRep, but additionally sets an error message on failure. * *---------------------------------------------------------------------- */ static List * AttemptNewList( Tcl_Interp *interp, |
︙ | ︙ | |||
175 176 177 178 179 180 181 | } /* *---------------------------------------------------------------------- * * Tcl_NewListObj -- * | < | < < > < < > < | | | | | > | | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_NewListObj -- * * Creates a new list object and adds values to it. When TCL_MEM_DEBUG is * defined, 'Tcl_DbNewListObj' is called instead. * * Value * * A new list 'Tcl_Obj' to which is appended values from 'objv', or if * 'objc' is less than or equal to zero, a list 'Tcl_Obj' having no * elements. The string representation of the new 'Tcl_Obj' is set to * NULL. The refCount of the list is 0. * * Effect * * The refCount of each elements in 'objv' is incremented as it is added * to the list. * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG #undef Tcl_NewListObj |
︙ | ︙ | |||
242 243 244 245 246 247 248 | return listPtr; } #endif /* if TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * | | < < < | | | | | < < < < < < < < < < < | 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 | return listPtr; } #endif /* if TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * * Tcl_DbNewListObj -- * * Like 'Tcl_NewListObj', but it calls Tcl_DbCkalloc directly with the * file name and line number from its caller. This simplifies debugging * since the [memory active] command will report the correct file * name and line number when reporting objects that haven't been freed. * * When TCL_MEM_DEBUG is not defined, 'Tcl_NewListObj' is called instead. * *---------------------------------------------------------------------- */ #ifdef TCL_MEM_DEBUG Tcl_Obj * |
︙ | ︙ | |||
324 325 326 327 328 329 330 | #endif /* TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * * Tcl_SetListObj -- * | | < < < | < < < < < < < < | 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 | #endif /* TCL_MEM_DEBUG */ /* *---------------------------------------------------------------------- * * Tcl_SetListObj -- * * Like 'Tcl_NewListObj', but operates on an existing 'Tcl_Obj'instead of * creating a new one. * *---------------------------------------------------------------------- */ void Tcl_SetListObj( Tcl_Obj *objPtr, /* Object whose internal rep to init. */ |
︙ | ︙ | |||
380 381 382 383 384 385 386 | } /* *---------------------------------------------------------------------- * * TclListObjCopy -- * | | | | | < > | | | > | < > > | 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 | } /* *---------------------------------------------------------------------- * * TclListObjCopy -- * * Creates a new 'Tcl_Obj' which is a pure copy of a list value. This * provides for the C level a counterpart of the [lrange $list 0 end] * command, while using internals details to be as efficient as possible. * * Value * * The address of the new 'Tcl_Obj' which shares its internal * representation with 'listPtr', and whose refCount is 0. If 'listPtr' * is not actually a list, the value is NULL, and an error message is left * in 'interp' if it is not NULL. * * Effect * * 'listPtr' is converted to a list if it isn't one already. * *---------------------------------------------------------------------- */ Tcl_Obj * TclListObjCopy( Tcl_Interp *interp, /* Used to report errors if not NULL. */ |
︙ | ︙ | |||
421 422 423 424 425 426 427 | } /* *---------------------------------------------------------------------- * * Tcl_ListObjGetElements -- * | | < | > | > | | < < < | | | | | | > > > > > | < > | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_ListObjGetElements -- * * Retreive the elements in a list 'Tcl_Obj'. * * Value * * TCL_OK * * A count of list elements is stored, 'objcPtr', And a pointer to the * array of elements in the list is stored in 'objvPtr'. * * The elements accessible via 'objvPtr' should be treated as readonly * and the refCount for each object is _not_ incremented; the caller * must do that if it holds on to a reference. Furthermore, the * pointer and length returned by this function may change as soon as * any function is called on the list object. Be careful about * retaining the pointer in a local data structure. * * TCL_ERROR * * 'listPtr' is not a valid list. An error message is left in the * interpreter's result if 'interp' is not NULL. * * Effect * * 'listPtr' is converted to a list object if it isn't one already. * *---------------------------------------------------------------------- */ int Tcl_ListObjGetElements( Tcl_Interp *interp, /* Used to report errors if not NULL. */ |
︙ | ︙ | |||
482 483 484 485 486 487 488 | } /* *---------------------------------------------------------------------- * * Tcl_ListObjAppendList -- * | | < | > | > > > | > > | | > | | | | > | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_ListObjAppendList -- * * Appends the elements of elemListPtr to those of listPtr. * * Value * * TCL_OK * * Success. * * TCL_ERROR * * 'listPtr' or 'elemListPtr' are not valid lists. An error * message is left in the interpreter's result if 'interp' is not NULL. * * Effect * * The reference count of each element of 'elemListPtr' as it is added to * 'listPtr'. 'listPtr' and 'elemListPtr' are converted to 'tclListType' * if they are not already. Appending the new elements may cause the * array of element pointers in 'listObj' to grow. If any objects are * appended to 'listPtr'. Any preexisting string representation of * 'listPtr' is invalidated. * *---------------------------------------------------------------------- */ int Tcl_ListObjAppendList( Tcl_Interp *interp, /* Used to report errors if not NULL. */ |
︙ | ︙ | |||
534 535 536 537 538 539 540 | } /* *---------------------------------------------------------------------- * * Tcl_ListObjAppendElement -- * | | < < < | > | > > > > > | | | < | > > | < | | | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_ListObjAppendElement -- * * Like 'Tcl_ListObjAppendList', but Appends a single value to a list. * * Value * * TCL_OK * * 'objPtr' is appended to the elements of 'listPtr'. * * TCL_ERROR * * listPtr does not refer to a list object and the object can not be * converted to one. An error message will be left in the * interpreter's result if interp is not NULL. * * Effect * * If 'listPtr' is not already of type 'tclListType', it is converted. * The 'refCount' of 'objPtr' is incremented as it is added to 'listPtr'. * Appending the new element may cause the the array of element pointers * in 'listObj' to grow. Any preexisting string representation of * 'listPtr' is invalidated. * *---------------------------------------------------------------------- */ int Tcl_ListObjAppendElement( Tcl_Interp *interp, /* Used to report errors if not NULL. */ |
︙ | ︙ | |||
702 703 704 705 706 707 708 | } /* *---------------------------------------------------------------------- * * Tcl_ListObjIndex -- * | | | < < < | > | > | > | | | > > > | | | > | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_ListObjIndex -- * * Retrieve a pointer to the element of 'listPtr' at 'index'. The index * of the first element is 0. * * Value * * TCL_OK * * A pointer to the element at 'index' is stored in 'objPtrPtr'. If * 'index' is out of range, NULL is stored in 'objPtrPtr'. This * object should be treated as readonly and its 'refCount' is _not_ * incremented. The caller must do that if it holds on to the * reference. * * TCL_ERROR * * 'listPtr' is not a valid list. An an error message is left in the * interpreter's result if 'interp' is not NULL. * * Effect * * If 'listPtr' is not already of type 'tclListType', it is converted. * *---------------------------------------------------------------------- */ int Tcl_ListObjIndex( Tcl_Interp *interp, /* Used to report errors if not NULL. */ |
︙ | ︙ | |||
760 761 762 763 764 765 766 | } /* *---------------------------------------------------------------------- * * Tcl_ListObjLength -- * | | < < | > | > | > | < > | < | > | 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 | } /* *---------------------------------------------------------------------- * * Tcl_ListObjLength -- * * Retrieve the number of elements in a list. * * Value * * TCL_OK * * A count of list elements is stored at the address provided by * 'intPtr'. If 'listPtr' is not already of type 'tclListPtr', it is * converted. * * TCL_ERROR * * 'listPtr' is not a valid list. An error message will be left in * the interpreter's result if 'interp' is not NULL. * *---------------------------------------------------------------------- */ int Tcl_ListObjLength( Tcl_Interp *interp, /* Used to report errors if not NULL. */ |
︙ | ︙ | |||
808 809 810 811 812 813 814 | } /* *---------------------------------------------------------------------- * * Tcl_ListObjReplace -- * | < < | < | | | < > | | < > > > > | | < < < | > | | | < > > > > | < > | | | 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 | } /* *---------------------------------------------------------------------- * * Tcl_ListObjReplace -- * * Replace values in a list. * * If 'first' is zero or negative, it refers to the first element. If * 'first' outside the range of elements in the list, no elements are * deleted. * * If 'count' is zero or negative no elements are deleted, and any new * elements are inserted at the beginning of the list. * * Value * * TCL_OK * * The first 'objc' values of 'objv' replaced 'count' elements in 'listPtr' * starting at 'first'. If 'objc' 0, no new elements are added. * * TCL_ERROR * * 'listPtr' is not a valid list. An error message is left in the * interpreter's result if 'interp' is not NULL. * * Effect * * If 'listPtr' is not of type 'tclListType', it is converted if possible. * * The 'refCount' of each element appended to the list is incremented. * Similarly, the 'refCount' for each replaced element is decremented. * * If 'listPtr' is modified, any previous string representation is * invalidated. * *---------------------------------------------------------------------- */ int Tcl_ListObjReplace( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ |
︙ | ︙ | |||
1090 1091 1092 1093 1094 1095 1096 | } /* *---------------------------------------------------------------------- * * TclLindexList -- * | | | | | | | > > | | < < < < < | 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 | } /* *---------------------------------------------------------------------- * * TclLindexList -- * * Implements the 'lindex' command when objc==3. * * Implemented entirely as a wrapper around 'TclLindexFlat'. Reconfigures * the argument format into required form while taking care to manage * shimmering so as to tend to keep the most useful intreps * and/or avoid the most expensive conversions. * * Value * * A pointer to the specified element, with its 'refCount' incremented, or * NULL if an error occurred. * * Notes * *---------------------------------------------------------------------- */ Tcl_Obj * TclLindexList( Tcl_Interp *interp, /* Tcl interpreter. */ |
︙ | ︙ | |||
1157 1158 1159 1160 1161 1162 1163 | * argPtr designates something that is neither an index nor a * well-formed list. Report the error via TclLindexFlat. */ return TclLindexFlat(interp, listPtr, 1, &argPtr); } | < < | < < < | | < | | | | | < < < < > > | < < < < | | > | 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 | * argPtr designates something that is neither an index nor a * well-formed list. Report the error via TclLindexFlat. */ return TclLindexFlat(interp, listPtr, 1, &argPtr); } { int indexCount = -1; /* Size of the array of list indices. */ Tcl_Obj **indices = NULL; /* Array of list indices. */ TclListObjGetElements(NULL, indexListCopy, &indexCount, &indices); listPtr = TclLindexFlat(interp, listPtr, indexCount, indices); } Tcl_DecrRefCount(indexListCopy); return listPtr; } /* *---------------------------------------------------------------------- * * TclLindexFlat -- * * The core of the 'lindex' command, with all index * arguments presented as a flat list. * * Value * * A pointer to the object extracted, with its 'refCount' incremented, or * NULL if an error occurred. Thus, the calling code will usually do * something like: * * Tcl_SetObjResult(interp, result); * Tcl_DecrRefCount(result); * * *---------------------------------------------------------------------- */ Tcl_Obj * TclLindexFlat( Tcl_Interp *interp, /* Tcl interpreter. */ |
︙ | ︙ | |||
1271 1272 1273 1274 1275 1276 1277 | } /* *---------------------------------------------------------------------- * * TclLsetList -- * | | | < < | | < < > | < < < < | 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 1252 1253 1254 1255 1256 1257 1258 1259 1260 1261 1262 1263 | } /* *---------------------------------------------------------------------- * * TclLsetList -- * * The core of [lset] when objc == 4. Objv[2] may be either a * scalar index or a list of indices. * * Implemented entirely as a wrapper around 'TclLindexFlat', as described * for 'TclLindexList'. * * Value * * The new list, with the 'refCount' of 'valuPtr' incremented, or NULL if * there was an error. * *---------------------------------------------------------------------- */ Tcl_Obj * TclLsetList( Tcl_Interp *interp, /* Tcl interpreter. */ |
︙ | ︙ | |||
1349 1350 1351 1352 1353 1354 1355 | /* *---------------------------------------------------------------------- * * TclLsetFlat -- * * Core engine of the 'lset' command. * | | < < > | < > | < | | > > | > > | | | | > > > | > | | < | | < < | | | | 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 | /* *---------------------------------------------------------------------- * * TclLsetFlat -- * * Core engine of the 'lset' command. * * Value * * The resulting list * * The 'refCount' of 'valuePtr' is incremented. If 'listPtr' was not * duplicated, its 'refCount' is incremented. The reference count of * an unduplicated object is therefore 2 (one for the returned pointer * and one for the variable that holds it). The reference count of a * duplicate object is 1, reflecting that result is the only active * reference. The caller is expected to store the result in the * variable and decrement its reference count. (INST_STORE_* does * exactly this.) * * NULL * * An error occurred. If 'listPtr' was duplicated, the reference * count on the duplicate is decremented so that it is 0, causing any * memory allocated by this function to be freed. * * * Effect * * On entry, the reference count of 'listPtr' does not reflect any * references held on the stack. The first action of this function is to * determine whether 'listPtr' is shared and to create a duplicate * unshared copy if it is. The reference count of the duplicate is * incremented. At this point, the reference count is 1 in either case so * that the object is considered unshared. * * The unshared list is altered directly to produce the result. * 'TclLsetFlat' maintains a linked list of 'Tcl_Obj' values whose string * 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 * |
︙ | ︙ | |||
1593 1594 1595 1596 1597 1598 1599 | } /* *---------------------------------------------------------------------- * * TclListObjSetElement -- * | | > > > | > | > > > > > | | > > > > | | | | | > | > | | | < < < | 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 | } /* *---------------------------------------------------------------------- * * TclListObjSetElement -- * * Set a single element of a list to a specified value. * * It is the caller's responsibility to invalidate the string * representation of the 'listPtr'. * * Value * * TCL_OK * * Success. * * TCL_ERROR * * 'listPtr' does not refer to a list object and cannot be converted * to one. An error message will be left in the interpreter result if * interp is not NULL. * * TCL_ERROR * * An index designates an element outside the range [0..listLength-1], * where 'listLength' is the count of elements in the list object * designated by 'listPtr'. An error message is left in the * interpreter result. * * Effect * * If 'listPtr' designates a shared object, 'Tcl_Panic' is called. If * 'listPtr' is not already of type 'tclListType', it is converted and the * internal representation is unshared. The 'refCount' of the element at * 'index' is decremented and replaced in the list with the 'valuePtr', * whose 'refCount' in turn is incremented. * * *---------------------------------------------------------------------- */ int TclListObjSetElement( Tcl_Interp *interp, /* Tcl interpreter; used for error reporting |
︙ | ︙ | |||
1730 1731 1732 1733 1734 1735 1736 | } /* *---------------------------------------------------------------------- * * FreeListInternalRep -- * | | | | < < | | | | 1707 1708 1709 1710 1711 1712 1713 1714 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 | } /* *---------------------------------------------------------------------- * * FreeListInternalRep -- * * Deallocate the storage associated with the internal representation of a * a list object. * * Effect * * The storage for the internal 'List' pointer of 'listPtr' is freed, the * 'internalRep.twoPtrValue.ptr1' of 'listPtr' is set to NULL, and the 'refCount' * of each element of the list is decremented. * *---------------------------------------------------------------------- */ static void FreeListInternalRep( Tcl_Obj *listPtr) /* List object with internal rep to free. */ |
︙ | ︙ | |||
1768 1769 1770 1771 1772 1773 1774 | } /* *---------------------------------------------------------------------- * * DupListInternalRep -- * | | | < < | | | > | > | | | > | < > > | 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 | } /* *---------------------------------------------------------------------- * * DupListInternalRep -- * * Initialize the internal representation of a list 'Tcl_Obj' to share the * internal representation of an existing list object. * * Effect * * The 'refCount' 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 -- * * Convert any object to a list. * * Value * * TCL_OK * * Success. The internal representation of 'objPtr' is set, and the type * of 'objPtr' is 'tclListType'. * * TCL_ERROR * * An error occured during conversion. An error message is left in the * interpreter's result if 'interp' is not NULL. * * *---------------------------------------------------------------------- */ static int SetListFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ |
︙ | ︙ | |||
1929 1930 1931 1932 1933 1934 1935 | } /* *---------------------------------------------------------------------- * * UpdateStringOfList -- * | | > | | | < < | | | < | 1906 1907 1908 1909 1910 1911 1912 1913 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 | } /* *---------------------------------------------------------------------- * * UpdateStringOfList -- * * Update the string representation for a list object. * * Any previously-exising string representation is not invalidated, so * storage is lost if this has not been taken care of. * * Effect * * The string representation of 'listPtr' is set to the resulting string. * This string will be empty if the list has no elements. It is assumed * that the list internal representation is not NULL. * *---------------------------------------------------------------------- */ static void UpdateStringOfList( Tcl_Obj *listPtr) /* List object with string rep to update. */ |
︙ | ︙ |
Changes to generic/tclLiteral.c.
︙ | ︙ | |||
401 402 403 404 405 406 407 | 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; | | < | | 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 | 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; size_t localHash, 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 = TclGetString(newObjPtr); length = 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--; |
︙ | ︙ | |||
478 479 480 481 482 483 484 | } objIndex = envPtr->literalArrayNext; envPtr->literalArrayNext++; lPtr = &envPtr->literalArrayPtr[objIndex]; lPtr->objPtr = objPtr; Tcl_IncrRefCount(objPtr); | | | 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 | } 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; |
︙ | ︙ |
Changes to generic/tclLoad.c.
︙ | ︙ | |||
459 460 461 462 463 464 465 466 467 468 469 470 471 472 | Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "ENTRYPOINT", NULL); code = TCL_ERROR; goto done; } code = pkgPtr->initProc(target); } /* * Test for whether the initialization failed. If so, transfer the error * from the target interpreter to the originating one. */ if (code != TCL_OK) { Interp *iPtr = (Interp *) target; | > | | 459 460 461 462 463 464 465 466 467 468 469 470 471 472 473 474 475 476 477 478 479 480 481 | Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "ENTRYPOINT", NULL); code = TCL_ERROR; goto done; } code = pkgPtr->initProc(target); } /* * Test for whether the initialization failed. If so, transfer the error * from the target interpreter to the originating one. */ if (code != TCL_OK) { Interp *iPtr = (Interp *) target; if (iPtr->legacyResult && *(iPtr->legacyResult) && !iPtr->legacyFreeProc) { /* * A call to Tcl_InitStubs() determined the caller extension and * this interp are incompatible in their stubs mechanisms, and * recorded the error in the oldest legacy place we have to do so. */ Tcl_SetObjResult(target, Tcl_NewStringObj(iPtr->legacyResult, -1)); iPtr->legacyResult = NULL; |
︙ | ︙ |
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 */ |
︙ | ︙ | |||
364 365 366 367 368 369 370 | } else { appName = path; } Tcl_SetVar2Ex(interp, "argv0", NULL, appName, TCL_GLOBAL_ONLY); argc--; argv++; | | | | 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 | } else { appName = path; } Tcl_SetVar2Ex(interp, "argv0", NULL, appName, TCL_GLOBAL_ONLY); argc--; argv++; Tcl_SetVar2Ex(interp, "argc", NULL, Tcl_NewIntObj(argc), TCL_GLOBAL_ONLY); argvPtr = Tcl_NewListObj(0, NULL); while (argc--) { Tcl_ListObjAppendElement(NULL, argvPtr, NewNativeObj(*argv++, -1)); } Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY); /* * Set the "tcl_interactive" variable. */ is.tty = isatty(0); Tcl_SetVar2Ex(interp, "tcl_interactive", NULL, Tcl_NewIntObj(!path && is.tty), TCL_GLOBAL_ONLY); /* * Invoke application-specific initialization. */ Tcl_Preserve(interp); if (appInitProc(interp) != TCL_OK) { |
︙ | ︙ |
Changes to generic/tclNamesp.c.
︙ | ︙ | |||
385 386 387 388 389 390 391 | if (framePtr->varTablePtr != NULL) { TclDeleteVars(iPtr, framePtr->varTablePtr); ckfree(framePtr->varTablePtr); framePtr->varTablePtr = NULL; } if (framePtr->numCompiledLocals > 0) { TclDeleteCompiledLocalVars(iPtr, framePtr); | | | 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 | 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 |
︙ | ︙ | |||
905 906 907 908 909 910 911 912 913 914 915 916 917 918 | 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 | > > > > > | 905 906 907 908 909 910 911 912 913 914 915 916 917 918 919 920 921 922 923 | 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 |
︙ | ︙ | |||
1037 1038 1039 1040 1041 1042 1043 | if (nsPtr->childTablePtr != NULL) { Tcl_DeleteHashTable(nsPtr->childTablePtr); ckfree(nsPtr->childTablePtr); } #endif Tcl_DeleteHashTable(&nsPtr->cmdTable); | < < < < < < < < | < > | 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 | 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 -- * |
︙ | ︙ | |||
2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 | 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 | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 2412 2413 2414 2415 2416 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 | 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 |
︙ | ︙ | |||
2629 2630 2631 2632 2633 2634 2635 | } } } } else { Namespace *nsPtr[2]; register int search; | | | 2655 2656 2657 2658 2659 2660 2661 2662 2663 2664 2665 2666 2667 2668 2669 | } } } } 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 | */ 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)); /* Corresponding TclOODecrRefCount in KillFoudation */ AddRef(fPtr->objectCls->thisPtr); /* This is why it is unnecessary in this routine to replace the * incremented reference count of fPtr->objectCls that was swallowed by * fakeObject. */ fPtr->objectCls->superclasses.num = 0; ckfree(fPtr->objectCls->superclasses.list); fPtr->objectCls->superclasses.list = NULL; /* special initialization for the primordial objects */ fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT; fPtr->objectCls->flags |= ROOT_OBJECT; fPtr->classCls = AllocClass(interp, AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL)); /* Corresponding TclOODecrRefCount in KillFoudation */ AddRef(fPtr->classCls->thisPtr); /* * Increment reference counts for each reference because these * relationships can be dynamically changed. * * Corresponding TclOODecrRefCount for all incremented refcounts is in * KillFoundation. */ /* Rewire bootstrapped objects. */ fPtr->objectCls->thisPtr->selfCls = fPtr->classCls; AddRef(fPtr->classCls->thisPtr); TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls); fPtr->classCls->thisPtr->selfCls = fPtr->classCls; AddRef(fPtr->classCls->thisPtr); TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls); fPtr->classCls->thisPtr->flags |= ROOT_CLASS; fPtr->classCls->flags |= ROOT_CLASS; /* Standard initialization for new Objects */ 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); | < < > > > | > > > > > > < | < | < > > > > > < | < > > > > > > > | | | | | < < < | | < < < < < < < > > < < < < | < < < < < < < < < < < | < < < | 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 | 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); TclOODecrRefCount(fPtr->objectCls->thisPtr); TclOODecrRefCount(fPtr->classCls->thisPtr); 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; size_t 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%" TCL_LL_MODIFIER "u", (Tcl_WideUInt)++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 * have to get rid of the error message from Tcl_CreateNamespace, * since that's something that should not be exposed to the user. */ Tcl_ResetResult(interp); } configNamespace: ((Namespace *)oPtr->namespacePtr)->refCount++; /* * Make the namespace know about the helper commands. This grants access * to the [self] and [next] commands. */ if (fPtr->helpersNs != NULL) { TclSetNsPath((Namespace *) oPtr->namespacePtr, 1, &fPtr->helpersNs); } TclOOSetupVariableResolver(oPtr->namespacePtr); /* * Suppress use of compiled versions of the commands in this object's * namespace and its children; causes wrong behaviour without expensive * recompilation. [Bug 2037727] */ ((Namespace *) oPtr->namespacePtr)->flags |= NS_SUPPRESS_COMPILATION; /* * 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; } /* * ---------------------------------------------------------------------- * | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | < < < < < < | > | < | | > > > | > | > | | | > > > | > > > > | > | < < > | | > | > > > | > > > > > | > > > > | | | > | < > | > | < > > > > > | > > | < | | > > | | | > | | > < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 | 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 -- * * Delete all descendants of a particular class. * * ---------------------------------------------------------------------- */ 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; /* * Squelch classes that this class has been mixed into. */ if (clsPtr->mixinSubs.num > 0) { while (clsPtr->mixinSubs.num > 0) { mixinSubclassPtr = clsPtr->mixinSubs.list[clsPtr->mixinSubs.num-1]; /* This condition also covers the case where mixinSubclassPtr == * clsPtr */ if (!Deleted(mixinSubclassPtr->thisPtr)) { Tcl_DeleteCommandFromToken(interp, mixinSubclassPtr->thisPtr->command); } TclOORemoveFromMixinSubs(mixinSubclassPtr, clsPtr); } } if (clsPtr->mixinSubs.size > 0) { ckfree(clsPtr->mixinSubs.list); clsPtr->mixinSubs.size = 0; } /* * Squelch subclasses of this class. */ if (clsPtr->subclasses.num > 0) { while (clsPtr->subclasses.num > 0) { subclassPtr = clsPtr->subclasses.list[clsPtr->subclasses.num-1]; if (!Deleted(subclassPtr->thisPtr) && !IsRoot(subclassPtr)) { Tcl_DeleteCommandFromToken(interp, subclassPtr->thisPtr->command); } TclOORemoveFromSubclasses(subclassPtr, clsPtr); } } if (clsPtr->subclasses.size > 0) { ckfree(clsPtr->subclasses.list); clsPtr->subclasses.list = NULL; clsPtr->subclasses.size = 0; } /* * Squelch instances of this class (includes objects we're mixed into). */ if (clsPtr->instances.num > 0) { while (clsPtr->instances.num > 0) { instancePtr = clsPtr->instances.list[clsPtr->instances.num-1]; /* * This condition also covers the case where instancePtr == oPtr */ if (!Deleted(instancePtr) && !IsRoot(instancePtr)) { Tcl_DeleteCommandFromToken(interp, instancePtr->command); } TclOORemoveFromInstances(instancePtr, clsPtr); } } if (clsPtr->instances.size > 0) { ckfree(clsPtr->instances.list); clsPtr->instances.list = NULL; clsPtr->instances.size = 0; } } /* * ---------------------------------------------------------------------- * * ReleaseClassContents -- * * Tear down the special class data structure, including deleting all * dependent classes and objects. * * ---------------------------------------------------------------------- */ 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; |
︙ | ︙ | |||
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 | if (clsPtr->filters.num) { Tcl_Obj *filterObj; FOREACH(filterObj, clsPtr->filters) { TclDecrRefCount(filterObj); } ckfree(clsPtr->filters.list); clsPtr->filters.num = 0; } /* * Squelch our metadata. */ if (clsPtr->metadataPtr != NULL) { Tcl_ObjectMetadataType *metadataTypePtr; ClientData value; FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) { metadataTypePtr->deleteProc(value); } Tcl_DeleteHashTable(clsPtr->metadataPtr); ckfree(clsPtr->metadataPtr); clsPtr->metadataPtr = NULL; } } /* * ---------------------------------------------------------------------- * * ObjectNamespaceDeleted -- * | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | if (clsPtr->filters.num) { Tcl_Obj *filterObj; FOREACH(filterObj, clsPtr->filters) { TclDecrRefCount(filterObj); } ckfree(clsPtr->filters.list); clsPtr->filters.list = NULL; clsPtr->filters.num = 0; } /* * Squelch our metadata. */ if (clsPtr->metadataPtr != NULL) { Tcl_ObjectMetadataType *metadataTypePtr; ClientData value; FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) { metadataTypePtr->deleteProc(value); } Tcl_DeleteHashTable(clsPtr->metadataPtr); ckfree(clsPtr->metadataPtr); clsPtr->metadataPtr = NULL; } if (clsPtr->mixins.num) { FOREACH(tmpClsPtr, clsPtr->mixins) { TclOORemoveFromMixinSubs(clsPtr, tmpClsPtr); TclOODecrRefCount(tmpClsPtr->thisPtr); } ckfree(clsPtr->mixins.list); clsPtr->mixins.list = NULL; clsPtr->mixins.num = 0; } if (clsPtr->superclasses.num > 0) { FOREACH(tmpClsPtr, clsPtr->superclasses) { TclOORemoveFromSubclasses(clsPtr, tmpClsPtr); TclOODecrRefCount(tmpClsPtr->thisPtr); } ckfree(clsPtr->superclasses.list); clsPtr->superclasses.num = 0; clsPtr->superclasses.list = NULL; } 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 -- * |
︙ | ︙ | |||
1161 1162 1163 1164 1165 1166 1167 1168 | static void ObjectNamespaceDeleted( ClientData clientData) /* Pointer to the class whose namespace is * being deleted. */ { Object *oPtr = clientData; FOREACH_HASH_DECLS; | > | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | > > > > > > > > > > > > > > | | | | | < > < < | 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 | 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); if (oPtr->mixins.num > 0) { FOREACH(mixinPtr, oPtr->mixins) { TclOORemoveFromInstances(oPtr, mixinPtr); TclOODecrRefCount(mixinPtr->thisPtr); } ckfree(oPtr->mixins.list); } FOREACH(filterObj, oPtr->filters) { TclDecrRefCount(filterObj); } if (i) { |
︙ | ︙ | |||
1240 1241 1242 1243 1244 1245 1246 | } Tcl_DeleteHashTable(oPtr->metadataPtr); ckfree(oPtr->metadataPtr); oPtr->metadataPtr = NULL; } /* | | < | < | < | < < < < < < < < | < < < < < < < | < | | | < < < < < < < < < < < < | < < | > | < < | < < | < < | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > | | | > > > | < < < < < < < < < < < < < < < < < < > | | | | | > > | < < < < < < < < < < | 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 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 | } 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. */ TclNsDecrRefCount((Namespace *)oPtr->namespacePtr); oPtr->namespacePtr = NULL; TclOODecrRefCount(oPtr->selfCls->thisPtr); 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) { if (oPtr->classPtr != NULL) { 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; 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; FOREACH(subclsPtr, superPtr->subclasses) { if (subPtr == subclsPtr) { RemoveItem(Class, superPtr->subclasses, i); TclOODecrRefCount(subPtr->thisPtr); res++; } } return res; } /* * ---------------------------------------------------------------------- * * TclOOAddToSubclasses -- * |
︙ | ︙ | |||
1443 1444 1445 1446 1447 1448 1449 | { if (Deleted(superPtr->thisPtr)) { return; } if (superPtr->subclasses.num >= superPtr->subclasses.size) { superPtr->subclasses.size += ALLOC_CHUNK; if (superPtr->subclasses.size == ALLOC_CHUNK) { | | > | | | | > > > | < < < < < < < < < < | 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 | { 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; FOREACH(subclsPtr, superPtr->mixinSubs) { if (subPtr == subclsPtr) { RemoveItem(Class, superPtr->mixinSubs, i); TclOODecrRefCount(subPtr->thisPtr); res++; break; } } return res; } /* * ---------------------------------------------------------------------- * * TclOOAddToMixinSubs -- * |
︙ | ︙ | |||
1521 1522 1523 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 | 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 -- * | > | | | | | < < < < < < < < < < < < < < < < < < < | > > > > > > > > > > > > > > < < > | > < < < | < < < < < < | < < | < < < < < < < < < < < < < < < < < < < < < < < < < < | | | < < < < < | | < < < | > | < > < < < < < < < < < < < < < < | 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 | 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 |
︙ | ︙ | |||
1755 1756 1757 1758 1759 1760 1761 | 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; | < < < < < | < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | < < | > > > > > | > > > > > | 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 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 1853 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 | 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; AddRef(classPtr->thisPtr); 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 -- |
︙ | ︙ | |||
1950 1951 1952 1953 1954 1955 1956 | } } /* * Copy the object's mixin references to the new object. */ | > | | | | > > > > > | 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 1939 1940 1941 1942 1943 1944 1945 1946 1947 1948 1949 1950 | } } /* * Copy the object's mixin references to the new object. */ if (o2Ptr->mixins.num != 0) { FOREACH(mixinPtr, o2Ptr->mixins) { if (mixinPtr && mixinPtr != o2Ptr->selfCls) { TclOORemoveFromInstances(o2Ptr, mixinPtr); } TclOODecrRefCount(mixinPtr->thisPtr); } ckfree(o2Ptr->mixins.list); } DUPLICATE(o2Ptr->mixins, oPtr->mixins, Class *); FOREACH(mixinPtr, o2Ptr->mixins) { if (mixinPtr && mixinPtr != o2Ptr->selfCls) { TclOOAddToInstances(o2Ptr, mixinPtr); } /* For the reference just created in DUPLICATE */ AddRef(mixinPtr->thisPtr); } /* * Copy the object's filter list to the new object. */ DUPLICATE(o2Ptr->filters, oPtr->filters, Tcl_Obj *); |
︙ | ︙ | |||
1989 1990 1991 1992 1993 1994 1995 | * 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); | < | 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 | * 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; |
︙ | ︙ | |||
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 | /* * Ensure that the new class's superclass structure is the same as the * old class's. */ FOREACH(superPtr, cls2Ptr->superclasses) { TclOORemoveFromSubclasses(cls2Ptr, superPtr); } if (cls2Ptr->superclasses.num) { cls2Ptr->superclasses.list = ckrealloc(cls2Ptr->superclasses.list, sizeof(Class *) * clsPtr->superclasses.num); } else { cls2Ptr->superclasses.list = ckalloc(sizeof(Class *) * clsPtr->superclasses.num); } memcpy(cls2Ptr->superclasses.list, clsPtr->superclasses.list, sizeof(Class *) * clsPtr->superclasses.num); cls2Ptr->superclasses.num = clsPtr->superclasses.num; FOREACH(superPtr, cls2Ptr->superclasses) { TclOOAddToSubclasses(cls2Ptr, superPtr); } /* * Duplicate the source class's filters. */ DUPLICATE(cls2Ptr->filters, clsPtr->filters, Tcl_Obj *); | > > > > > > | 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 | /* * Ensure that the new class's superclass structure is the same as the * old class's. */ FOREACH(superPtr, cls2Ptr->superclasses) { TclOORemoveFromSubclasses(cls2Ptr, superPtr); TclOODecrRefCount(superPtr->thisPtr); } if (cls2Ptr->superclasses.num) { cls2Ptr->superclasses.list = ckrealloc(cls2Ptr->superclasses.list, sizeof(Class *) * clsPtr->superclasses.num); } else { cls2Ptr->superclasses.list = ckalloc(sizeof(Class *) * clsPtr->superclasses.num); } memcpy(cls2Ptr->superclasses.list, clsPtr->superclasses.list, sizeof(Class *) * clsPtr->superclasses.num); cls2Ptr->superclasses.num = clsPtr->superclasses.num; FOREACH(superPtr, cls2Ptr->superclasses) { TclOOAddToSubclasses(cls2Ptr, superPtr); /* For the new item in cls2Ptr->superclasses that memcpy just * created */ AddRef(superPtr->thisPtr); } /* * Duplicate the source class's filters. */ DUPLICATE(cls2Ptr->filters, clsPtr->filters, Tcl_Obj *); |
︙ | ︙ | |||
2076 2077 2078 2079 2080 2081 2082 | } /* * Duplicate the source class's mixins (which cannot be circular * references to the duplicate). */ | > | | > | < > > | 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 | } /* * Duplicate the source class's mixins (which cannot be circular * references to the duplicate). */ if (cls2Ptr->mixins.num != 0) { FOREACH(mixinPtr, cls2Ptr->mixins) { TclOORemoveFromMixinSubs(cls2Ptr, mixinPtr); TclOODecrRefCount(mixinPtr->thisPtr); } ckfree(clsPtr->mixins.list); } DUPLICATE(cls2Ptr->mixins, clsPtr->mixins, Class *); FOREACH(mixinPtr, cls2Ptr->mixins) { TclOOAddToMixinSubs(cls2Ptr, mixinPtr); /* For the copy just created in DUPLICATE */ AddRef(mixinPtr->thisPtr); } /* * Duplicate the source class's methods, constructor and destructor. */ FOREACH_HASH(keyPtr, mPtr, &clsPtr->classMethods) { |
︙ | ︙ | |||
2430 2431 2432 2433 2434 2435 2436 | } /* * ---------------------------------------------------------------------- * * PublicObjectCmd, PrivateObjectCmd, TclOOInvokeObject -- * | | | 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 2426 2427 2428 2429 | } /* * ---------------------------------------------------------------------- * * PublicObjectCmd, PrivateObjectCmd, TclOOInvokeObject -- * * Main entry point for object invocations. The Public* and Private* * wrapper functions (implementations of both object instance commands * and [my]) are just thin wrappers round the main TclOOObjectCmdCore * function. Note that the core is function is NRE-aware. * * ---------------------------------------------------------------------- */ |
︙ | ︙ | |||
2515 2516 2517 2518 2519 2520 2521 | } /* * ---------------------------------------------------------------------- * * TclOOObjectCmdCore, FinalizeObjectCall -- * | | | | | 2500 2501 2502 2503 2504 2505 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 | } /* * ---------------------------------------------------------------------- * * TclOOObjectCmdCore, FinalizeObjectCall -- * * Main function for object invocations. Does call chain creation, * management and invocation. The function FinalizeObjectCall exists to * clean up after the non-recursive processing of TclOOObjectCmdCore. * * ---------------------------------------------------------------------- */ int TclOOObjectCmdCore( Object *oPtr, /* The object being invoked. */ Tcl_Interp *interp, /* The interpreter containing the object. */ int objc, /* How many arguments are being passed in. */ Tcl_Obj *const *objv, /* The array of arguments. */ int flags, /* Whether this is an invocation through the * public or the private command interface. */ Class *startCls) /* Where to start in the call chain, or NULL * if we are to start at the front with * filters and the object's methods (which is * the normal case). */ { CallContext *contextPtr; |
︙ | ︙ | |||
2717 2718 2719 2720 2721 2722 2723 | } /* * Advance to the next method implementation in the chain in the method * call context while we process the body. However, need to adjust the * argument-skip control because we're guaranteed to have a single prefix * arg (i.e., 'next') and not the variable amount that can happen because | | | 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 | } /* * Advance to the next method implementation in the chain in the method * call context while we process the body. However, need to adjust the * argument-skip control because we're guaranteed to have a single prefix * arg (i.e., 'next') and not the variable amount that can happen because * method invocations (i.e., '$obj meth' and 'my meth'), constructors * (i.e., '$cls new' and '$cls create obj') and destructors (no args at * all) come through the same code. */ contextPtr->index++; contextPtr->skip = skip; |
︙ | ︙ | |||
2786 2787 2788 2789 2790 2791 2792 | } /* * Advance to the next method implementation in the chain in the method * call context while we process the body. However, need to adjust the * argument-skip control because we're guaranteed to have a single prefix * arg (i.e., 'next') and not the variable amount that can happen because | | | 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 | } /* * Advance to the next method implementation in the chain in the method * call context while we process the body. However, need to adjust the * argument-skip control because we're guaranteed to have a single prefix * arg (i.e., 'next') and not the variable amount that can happen because * method invocations (i.e., '$obj meth' and 'my meth'), constructors * (i.e., '$cls new' and '$cls create obj') and destructors (no args at * all) come through the same code. */ TclNRAddCallback(interp, FinalizeNext, contextPtr, INT2PTR(contextPtr->index), INT2PTR(contextPtr->skip), NULL); contextPtr->index++; |
︙ | ︙ | |||
3001 3002 3003 3004 3005 3006 3007 | return (Tcl_Class) ((Object *)object)->classPtr; } int Tcl_ObjectDeleted( Tcl_Object object) { | | | 2986 2987 2988 2989 2990 2991 2992 2993 2994 2995 2996 2997 2998 2999 3000 | 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.
︙ | ︙ | |||
981 982 983 984 985 986 987 | */ if (objc > 2) { Tcl_WrongNumArgs(interp, 1, objv, "subcommand"); return TCL_ERROR; } else if (objc == 1) { index = SELF_OBJECT; | | | | 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 | */ if (objc > 2) { Tcl_WrongNumArgs(interp, 1, objv, "subcommand"); return TCL_ERROR; } else if (objc == 1) { index = SELF_OBJECT; } else if (Tcl_GetIndexFromObj(interp, objv[1], subcmds, "subcommand", 0, &index) != TCL_OK) { return TCL_ERROR; } switch ((enum SelfCmds) index) { case SELF_OBJECT: Tcl_SetObjResult(interp, TclOOObjectName(interp, contextPtr->oPtr)); return TCL_OK; |
︙ | ︙ | |||
1151 1152 1153 1154 1155 1156 1157 | result[0] = TclOOObjectName(interp, declarerPtr); result[1] = mPtr->namePtr; Tcl_SetObjResult(interp, Tcl_NewListObj(2, result)); return TCL_OK; } case SELF_CALL: result[0] = TclOORenderCallChain(interp, contextPtr->callPtr); | | | 1151 1152 1153 1154 1155 1156 1157 1158 1159 1160 1161 1162 1163 1164 1165 | result[0] = TclOOObjectName(interp, declarerPtr); result[1] = mPtr->namePtr; Tcl_SetObjResult(interp, Tcl_NewListObj(2, result)); return TCL_OK; } case SELF_CALL: result[0] = TclOORenderCallChain(interp, contextPtr->callPtr); result[1] = Tcl_NewIntObj(contextPtr->index); Tcl_SetObjResult(interp, Tcl_NewListObj(2, result)); return TCL_OK; } return TCL_ERROR; } /* |
︙ | ︙ | |||
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 -- |
︙ | ︙ | |||
229 230 231 232 233 234 235 | /* * ---------------------------------------------------------------------- * * TclOOInvokeContext -- * * Invokes a single step along a method call-chain context. Note that the | | | 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 | /* * ---------------------------------------------------------------------- * * TclOOInvokeContext -- * * Invokes a single step along a method call-chain context. Note that the * invocation of a step along the chain can cause further steps along the * chain to be invoked. Note that this function is written to be as light * in stack usage as possible. * * ---------------------------------------------------------------------- */ int |
︙ | ︙ | |||
826 827 828 829 830 831 832 | for (i=cbPtr->filterLength ; i<callPtr->numChain ; i++) { if (callPtr->chain[i].mPtr == mPtr && callPtr->chain[i].isFilter == (doneFilters != NULL)) { /* * Call chain semantics states that methods come as *late* in the * call chain as possible. This is done by copying down the * following methods. Note that this does not change the number of | | | 831 832 833 834 835 836 837 838 839 840 841 842 843 844 845 | for (i=cbPtr->filterLength ; i<callPtr->numChain ; i++) { if (callPtr->chain[i].mPtr == mPtr && callPtr->chain[i].isFilter == (doneFilters != NULL)) { /* * Call chain semantics states that methods come as *late* in the * call chain as possible. This is done by copying down the * following methods. Note that this does not change the number of * method invocations in the call chain; it just rearranges them. */ Class *declCls = callPtr->chain[i].filterDeclarer; for (; i+1<callPtr->numChain ; i++) { callPtr->chain[i] = callPtr->chain[i+1]; } |
︙ | ︙ | |||
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 |
︙ | ︙ | |||
931 932 933 934 935 936 937 | /* * ---------------------------------------------------------------------- * * TclOOGetCallContext -- * * Responsible for constructing the call context, an ordered list of all | | | 937 938 939 940 941 942 943 944 945 946 947 948 949 950 951 | /* * ---------------------------------------------------------------------- * * TclOOGetCallContext -- * * Responsible for constructing the call context, an ordered list of all * method implementations to be called as part of a method invocation. * This method is central to the whole operation of the OO system. * * ---------------------------------------------------------------------- */ CallContext * TclOOGetCallContext( |
︙ | ︙ | |||
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; } |
︙ | ︙ | |||
1513 1514 1515 1516 1517 1518 1519 | Tcl_IncrRefCount(methodLiteral); objectLiteral = Tcl_NewStringObj("object", -1); Tcl_IncrRefCount(objectLiteral); /* * Do the actual construction of the descriptions. They consist of a list * of triples that describe the details of how a method is understood. For | | | 1524 1525 1526 1527 1528 1529 1530 1531 1532 1533 1534 1535 1536 1537 1538 | Tcl_IncrRefCount(methodLiteral); objectLiteral = Tcl_NewStringObj("object", -1); Tcl_IncrRefCount(objectLiteral); /* * Do the actual construction of the descriptions. They consist of a list * of triples that describe the details of how a method is understood. For * each triple, the first word is the type of invocation ("method" is * normal, "unknown" is special because it adds the method name as an * extra argument when handled by some method types, and "filter" is * special because it's a filter method). The second word is the name of * the method in question (which differs for "unknown" and "filter" types) * and the third word is the full name of the class that declares the * method (or "object" if it is declared on the instance). */ |
︙ | ︙ |
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 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 | 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); TclOODecrRefCount(mixinPtr->thisPtr); } ckfree(oPtr->mixins.list); oPtr->mixins.num = 0; } RecomputeClassCacheFlag(oPtr); } else { if (oPtr->mixins.num != 0) { FOREACH(mixinPtr, oPtr->mixins) { if (mixinPtr && mixinPtr != oPtr->selfCls) { TclOORemoveFromInstances(oPtr, mixinPtr); } TclOODecrRefCount(mixinPtr->thisPtr); } oPtr->mixins.list = ckrealloc(oPtr->mixins.list, sizeof(Class *) * numMixins); } else { oPtr->mixins.list = ckalloc(sizeof(Class *) * numMixins); 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); /* For the new copy created by memcpy */ AddRef(mixinPtr->thisPtr); } } } oPtr->epoch++; } /* * ---------------------------------------------------------------------- * * TclOOClassSetMixins -- * * Install a list of mixin classes into a class. * * ---------------------------------------------------------------------- */ void TclOOClassSetMixins( Tcl_Interp *interp, Class *classPtr, int numMixins, Class *const *mixins) { Class *mixinPtr; int i; if (numMixins == 0) { if (classPtr->mixins.num != 0) { FOREACH(mixinPtr, classPtr->mixins) { TclOORemoveFromMixinSubs(classPtr, mixinPtr); TclOODecrRefCount(mixinPtr->thisPtr); } ckfree(classPtr->mixins.list); classPtr->mixins.num = 0; } } else { if (classPtr->mixins.num != 0) { FOREACH(mixinPtr, classPtr->mixins) { TclOORemoveFromMixinSubs(classPtr, mixinPtr); TclOODecrRefCount(mixinPtr->thisPtr); } classPtr->mixins.list = ckrealloc(classPtr->mixins.list, sizeof(Class *) * numMixins); } 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); /* For the new copy created by memcpy */ AddRef(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. * * ---------------------------------------------------------------------- */ | > | 506 507 508 509 510 511 512 513 514 515 516 517 518 519 520 | 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 | > | 585 586 587 588 589 590 591 592 593 594 595 596 597 598 599 | 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. * * ---------------------------------------------------------------------- */ | > | 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 | 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; } | > | > > | 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 | 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. * * ---------------------------------------------------------------------- */ | > | 726 727 728 729 730 731 732 733 734 735 736 737 738 739 740 | 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( | > | 769 770 771 772 773 774 775 776 777 778 779 780 781 782 783 | 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. * * ---------------------------------------------------------------------- */ | > | 808 809 810 811 812 813 814 815 816 817 818 819 820 821 822 | (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. * * ---------------------------------------------------------------------- | > | 872 873 874 875 876 877 878 879 880 881 882 883 884 885 886 | 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); } | | > | 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 | 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); } | | > | 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 1019 1020 1021 1022 1023 1024 1025 1026 1027 1028 1029 | 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); } | | > | 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 | 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 1105 1106 1107 1108 1109 1110 1111 1112 | return TCL_OK; } /* * ---------------------------------------------------------------------- * * TclOODefineClassObjCmd -- * Implementation of the "class" subcommand of the "oo::objdefine" * command. * * ---------------------------------------------------------------------- */ int TclOODefineClassObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { Object *oPtr; Class *clsPtr; | > < | 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 | return TCL_OK; } /* * ---------------------------------------------------------------------- * * TclOODefineClassObjCmd -- * * Implementation of the "class" subcommand of the "oo::objdefine" * command. * * ---------------------------------------------------------------------- */ int TclOODefineClassObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { Object *oPtr; Class *clsPtr; /* * Parse the context to get the object to operate on. */ oPtr = (Object *) TclOOGetDefineCmdContext(interp); if (oPtr == NULL) { |
︙ | ︙ | |||
1143 1144 1145 1146 1147 1148 1149 | } clsPtr = GetClassInOuterContext(interp, objv[1], "the class of an object must be a class"); if (clsPtr == NULL) { return TCL_ERROR; } | < < < < < < < < < < < < < < > > < < | > | 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 | } clsPtr = GetClassInOuterContext(interp, objv[1], "the class of an object must be a class"); if (clsPtr == NULL) { return TCL_ERROR; } /* * Set the object's class. */ if (oPtr->selfCls != clsPtr) { TclOORemoveFromInstances(oPtr, oPtr->selfCls); TclOODecrRefCount(oPtr->selfCls->thisPtr); oPtr->selfCls = clsPtr; AddRef(oPtr->selfCls->thisPtr); 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 | > | 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 | 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 | > | 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 1331 1332 1333 1334 | 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 | > | 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 | 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 | > | 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 1492 1493 1494 | 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 | > | 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 | 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 | > | 1599 1600 1601 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 | return TCL_OK; } /* * ---------------------------------------------------------------------- * * TclOODefineMixinObjCmd -- * * Implementation of the "mixin" subcommand of the "oo::define" and * "oo::objdefine" commands. * * ---------------------------------------------------------------------- */ int |
︙ | ︙ | |||
1644 1645 1646 1647 1648 1649 1650 1651 1652 1653 1654 1655 1656 1657 | return TCL_ERROR; } /* * ---------------------------------------------------------------------- * * TclOODefineRenameMethodObjCmd -- * Implementation of the "renamemethod" subcommand of the "oo::define" * and "oo::objdefine" commands. * * ---------------------------------------------------------------------- */ int | > | 1663 1664 1665 1666 1667 1668 1669 1670 1671 1672 1673 1674 1675 1676 1677 | 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 | > | 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 1731 1732 1733 1734 | 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 | > | 1815 1816 1817 1818 1819 1820 1821 1822 1823 1824 1825 1826 1827 1828 1829 | 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 | > | 1870 1871 1872 1873 1874 1875 1876 1877 1878 1879 1880 1881 1882 1883 1884 | } } /* * ---------------------------------------------------------------------- * * 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 | > | 1914 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 | 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 | > | 1994 1995 1996 1997 1998 1999 2000 2001 2002 2003 2004 2005 2006 2007 2008 | 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 | 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; | > | 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 2088 2089 2090 | 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; |
︙ | ︙ | |||
2074 2075 2076 2077 2078 2079 2080 2081 2082 2083 2084 2085 2086 2087 | return TCL_ERROR; } /* * ---------------------------------------------------------------------- * * ClassSuperGet, ClassSuperSet -- * Implementation of the "superclass" slot accessors of the "oo::define" * command. * * ---------------------------------------------------------------------- */ static int | > | 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 | 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 *)); | < < > > > > > > > > > > > > > > > > > | 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 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 | * * 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; 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); TclOODecrRefCount(superPtr->thisPtr); } ckfree(oPtr->classPtr->superclasses.list); } oPtr->classPtr->superclasses.list = superclasses; oPtr->classPtr->superclasses.num = superc; FOREACH(superPtr, oPtr->classPtr->superclasses) { TclOOAddToSubclasses(oPtr->classPtr, superPtr); } 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 | > | 2411 2412 2413 2414 2415 2416 2417 2418 2419 2420 2421 2422 2423 2424 2425 | 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 | > | 2479 2480 2481 2482 2483 2484 2485 2486 2487 2488 2489 2490 2491 2492 2493 | return TCL_OK; } /* * ---------------------------------------------------------------------- * * ObjectMixinGet, ObjectMixinSet -- * * Implementation of the "mixin" slot accessors of the "oo::objdefine" * command. * * ---------------------------------------------------------------------- */ static int |
︙ | ︙ | |||
2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 | return TCL_OK; } /* * ---------------------------------------------------------------------- * * ObjectVarsGet, ObjectVarsSet -- * Implementation of the "variable" slot accessors of the "oo::objdefine" * command. * * ---------------------------------------------------------------------- */ static int | > | 2565 2566 2567 2568 2569 2570 2571 2572 2573 2574 2575 2576 2577 2578 2579 | return TCL_OK; } /* * ---------------------------------------------------------------------- * * ObjectVarsGet, ObjectVarsSet -- * * Implementation of the "variable" slot accessors of the "oo::objdefine" * command. * * ---------------------------------------------------------------------- */ static int |
︙ | ︙ |
Changes to generic/tclOOInt.h.
︙ | ︙ | |||
145 146 147 148 149 150 151 | * Now, the definition of what an object actually is. */ typedef struct Object { struct Foundation *fPtr; /* The basis for the object system. Putting * this here allows the avoidance of quite a * lot of hash lookups on the critical path | | | | | | | | 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 | * Now, the definition of what an object actually is. */ typedef struct Object { struct Foundation *fPtr; /* The basis for the object system. Putting * this here allows the avoidance of quite a * lot of hash lookups on the critical path * for object invocation and creation. */ Tcl_Namespace *namespacePtr;/* This object's namespace. */ Tcl_Command command; /* Reference to this object's public * command. */ Tcl_Command myCommand; /* Reference to this object's internal * command. */ struct Class *selfCls; /* This object's class. */ Tcl_HashTable *methodsPtr; /* Object-local Tcl_Obj (method name) to * Method* mapping. */ LIST_STATIC(struct Class *) mixins; /* Classes mixed into this object. */ LIST_STATIC(Tcl_Obj *) filters; /* List of filter names. */ struct Class *classPtr; /* This is non-NULL for all classes, and NULL * for everything else. It points to the class * structure. */ int refCount; /* Number of strong references to this object. * Note that there may be many more weak * references; this mechanism exists to * avoid Tcl_Preserve. */ int flags; size_t creationEpoch; /* Unique value to make comparisons of objects * easier. */ size_t epoch; /* Per-object epoch, incremented when the way * an object should resolve call chains is * changed. */ |
︙ | ︙ | |||
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 |
︙ | ︙ | |||
319 320 321 322 323 324 325 | * destructor. */ Tcl_Obj *clonedName; /* Shared object containing the name of a * "<cloned>" pseudo-constructor. */ Tcl_Obj *defineName; /* Fully qualified name of oo::define. */ } Foundation; /* | | | | 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 | * destructor. */ Tcl_Obj *clonedName; /* Shared object containing the name of a * "<cloned>" pseudo-constructor. */ Tcl_Obj *defineName; /* Fully qualified name of oo::define. */ } Foundation; /* * A call context structure is built when a method is called. It contains the * chain of method implementations that are to be invoked by a particular * call, and the process of calling walks the chain, with the [next] command * proceeding to the next entry in the chain. */ #define CALL_CHAIN_STATIC_SIZE 4 struct MInvoke { Method *mPtr; /* Reference to the method implementation * record. */ int isFilter; /* Whether this is a filter invocation. */ Class *filterDeclarer; /* What class decided to add the filter; if * NULL, it was added by the object. */ }; typedef struct CallChain { size_t objectCreationEpoch; /* The object's creation epoch. Note that the * object reference is not stored in the call |
︙ | ︙ | |||
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 | */ 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); 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 | /* * 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. */ | | < < < < < < < < < < < < < < < < | 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 | /* * 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. */ const Tcl_ObjType tclBooleanType = { "boolean", /* 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 */ }; const Tcl_ObjType tclBignumType = { "bignum", /* name */ FreeBignum, /* freeIntRepProc */ DupBignum, /* dupIntRepProc */ UpdateStringOfBignum, /* updateStringProc */ NULL /* setFromAnyProc */ }; |
︙ | ︙ | |||
391 392 393 394 395 396 397 | Tcl_MutexLock(&tableMutex); typeTableInitialized = 1; Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS); Tcl_MutexUnlock(&tableMutex); Tcl_RegisterObjType(&tclByteArrayType); Tcl_RegisterObjType(&tclDoubleType); | < < < < < < < < < | 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 | Tcl_MutexLock(&tableMutex); typeTableInitialized = 1; Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS); Tcl_MutexUnlock(&tableMutex); Tcl_RegisterObjType(&tclByteArrayType); Tcl_RegisterObjType(&tclDoubleType); Tcl_RegisterObjType(&tclStringType); Tcl_RegisterObjType(&tclListType); Tcl_RegisterObjType(&tclDictType); Tcl_RegisterObjType(&tclByteCodeType); Tcl_RegisterObjType(&tclCmdNameType); Tcl_RegisterObjType(&tclRegexpType); Tcl_RegisterObjType(&tclProcBodyType); #ifdef TCL_COMPILE_STATS Tcl_MutexLock(&tclObjMutex); tclObjsAlloced = 0; tclObjsFreed = 0; { int i; |
︙ | ︙ | |||
1744 1745 1746 1747 1748 1749 1750 | int 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 { | | | < < < < | 1715 1716 1717 1718 1719 1720 1721 1722 1723 1724 1725 1726 1727 1728 1729 1730 | int 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 || objPtr->typePtr == &tclBooleanType) { *boolPtr = (objPtr->internalRep.wideValue != 0); return TCL_OK; } if (objPtr->typePtr == &tclDoubleType) { /* * Caution: Don't be tempted to check directly for the "double" * Tcl_ObjType and then compare the intrep to 0.0. This isn't * reliable because a "double" Tcl_ObjType can hold the NaN value. |
︙ | ︙ | |||
1773 1774 1775 1776 1777 1778 1779 | *boolPtr = (d != 0.0); return TCL_OK; } if (objPtr->typePtr == &tclBignumType) { *boolPtr = 1; return TCL_OK; } | < < < < < < | | < < < < < < < | 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 | *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; } /* *---------------------------------------------------------------------- * * TclSetBooleanFromAny -- * * Attempt to generate a boolean internal form for the Tcl object * "objPtr". * * Results: * The return value is a standard Tcl result. 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, an integer 1 or 0 is stored as "objPtr"s internal * representation and the type of "objPtr" is set to boolean or int. * *---------------------------------------------------------------------- */ int TclSetBooleanFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ register Tcl_Obj *objPtr) /* The object to convert. */ { /* * 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) { if ((Tcl_WideUInt)objPtr->internalRep.wideValue < 2) { 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; |
︙ | ︙ | |||
1964 1965 1966 1967 1968 1969 1970 | * Free the old internalRep before setting the new one. We do this as late * as possible to allow the conversion code, in particular * Tcl_GetStringFromObj, to use that old internalRep. */ goodBoolean: TclFreeIntRep(objPtr); | | | | 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 1933 1934 1935 1936 1937 1938 | * Free the old internalRep before setting the new one. We do this as late * as possible to allow the conversion code, in particular * Tcl_GetStringFromObj, to use that old internalRep. */ goodBoolean: TclFreeIntRep(objPtr); objPtr->internalRep.wideValue = newBool; objPtr->typePtr = &tclBooleanType; return TCL_OK; numericBoolean: TclFreeIntRep(objPtr); objPtr->internalRep.wideValue = newBool; objPtr->typePtr = &tclIntType; return TCL_OK; } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
2151 2152 2153 2154 2155 2156 2157 | } return TCL_ERROR; } *dblPtr = (double) objPtr->internalRep.doubleValue; return TCL_OK; } if (objPtr->typePtr == &tclIntType) { | | < < < < < < | 2105 2106 2107 2108 2109 2110 2111 2112 2113 2114 2115 2116 2117 2118 2119 2120 2121 2122 2123 2124 2125 2126 2127 2128 | } 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; } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
2206 2207 2208 2209 2210 2211 2212 | /* *---------------------------------------------------------------------- * * UpdateStringOfDouble -- * * Update the string representation for a double-precision floating point | < | | 2154 2155 2156 2157 2158 2159 2160 2161 2162 2163 2164 2165 2166 2167 2168 | /* *---------------------------------------------------------------------- * * UpdateStringOfDouble -- * * Update the string representation for a double-precision floating point * object. Note: This function does not free an * existing old string rep so storage will be lost if this has not * already been done. * * Results: * None. * * Side effects: |
︙ | ︙ | |||
2239 2240 2241 2242 2243 2244 2245 | memcpy(objPtr->bytes, buffer, (unsigned) len + 1); objPtr->length = len; } /* *---------------------------------------------------------------------- * | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < | > | | > > > | | | | | > > | | | 2186 2187 2188 2189 2190 2191 2192 2193 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 | memcpy(objPtr->bytes, buffer, (unsigned) len + 1); objPtr->length = len; } /* *---------------------------------------------------------------------- * * Tcl_GetIntFromObj -- * * Retrieve the integer value of 'objPtr'. * * Value * * TCL_OK * * Success. * * TCL_ERROR * * An error occurred during conversion or the integral value can not * be represented as an integer (it might be too large). An error * message is left in the interpreter's result if 'interp' is not * NULL. * * Effect * * 'objPtr' is converted to an integer if necessary if it is not one * already. The conversion frees any previously-existing internal * representation. * *---------------------------------------------------------------------- */ int Tcl_GetIntFromObj( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ |
︙ | ︙ | |||
2395 2396 2397 2398 2399 2400 2401 | */ static int SetIntFromAny( Tcl_Interp *interp, /* Tcl interpreter */ Tcl_Obj *objPtr) /* Pointer to the object to convert */ { | < | | | 2261 2262 2263 2264 2265 2266 2267 2268 2269 2270 2271 2272 2273 2274 2275 2276 | */ 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 -- * |
︙ | ︙ | |||
2426 2427 2428 2429 2430 2431 2432 | static void UpdateStringOfInt( register Tcl_Obj *objPtr) /* Int object whose string rep to update. */ { char buffer[TCL_INTEGER_SPACE]; register int len; | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 2291 2292 2293 2294 2295 2296 2297 2298 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 | 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; } /* *---------------------------------------------------------------------- * * Tcl_GetLongFromObj -- * * Attempt to return an long integer from the Tcl object "objPtr". If the |
︙ | ︙ | |||
2616 2617 2618 2619 2620 2621 2622 2623 | 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) { | > | < > | | 2326 2327 2328 2329 2330 2331 2332 2333 2334 2335 2336 2337 2338 2339 2340 2341 2342 2343 2344 2345 2346 | 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 { #ifdef TCL_WIDE_INT_IS_LONG 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. */ |
︙ | ︙ | |||
2694 2695 2696 2697 2698 2699 2700 | } return TCL_ERROR; } } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL, TCL_PARSE_INTEGER_ONLY)==TCL_OK); return TCL_ERROR; } | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 2405 2406 2407 2408 2409 2410 2411 2412 2413 2414 2415 2416 2417 2418 | } 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 |
︙ | ︙ | |||
2786 2787 2788 2789 2790 2791 2792 | register Tcl_WideInt wideValue) /* Wide integer used to initialize the new * object. */ { register Tcl_Obj *objPtr; TclNewObj(objPtr); | | | 2454 2455 2456 2457 2458 2459 2460 2461 2462 2463 2464 2465 2466 2467 2468 | 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 */ /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
2838 2839 2840 2841 2842 2843 2844 | * function; used for debugging. */ int line) /* Line number in the source file; used for * debugging. */ { register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); | | | 2506 2507 2508 2509 2510 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 | * 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( |
︙ | ︙ | |||
2887 2888 2889 2890 2891 2892 2893 | /* Wide integer used to initialize the * object's value. */ { if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetWideIntObj"); } | < < < < < | < < < < < < < | 2555 2556 2557 2558 2559 2560 2561 2562 2563 2564 2565 2566 2567 2568 2569 | /* 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 -- * |
︙ | ︙ | |||
2931 2932 2933 2934 2935 2936 2937 | 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 { | < | < < < < < | 2587 2588 2589 2590 2591 2592 2593 2594 2595 2596 2597 2598 2599 2600 2601 2602 | 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))); |
︙ | ︙ | |||
2991 2992 2993 2994 2995 2996 2997 | } return TCL_ERROR; } } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL, TCL_PARSE_INTEGER_ONLY)==TCL_OK); return TCL_ERROR; } | < < < < < < < < < < < < < < < < < < < < < < < < < < < | 2641 2642 2643 2644 2645 2646 2647 2648 2649 2650 2651 2652 2653 2654 | } 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. |
︙ | ︙ | |||
3260 3261 3262 3263 3264 3265 3266 | if (objPtr->bytes == NULL) { TclInitStringRep(objPtr, &tclEmptyString, 0); } } return TCL_OK; } if (objPtr->typePtr == &tclIntType) { | < < < < < < | 2883 2884 2885 2886 2887 2888 2889 2890 2891 2892 2893 2894 2895 2896 2897 2898 2899 2900 | 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); } |
︙ | ︙ | |||
3379 3380 3381 3382 3383 3384 3385 | 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 | < < < < < < < < < < < < < < < < < < < < < < < < < | | | | | | < | 2996 2997 2998 2999 3000 3001 3002 3003 3004 3005 3006 3007 3008 3009 3010 3011 3012 3013 3014 3015 3016 3017 3018 3019 3020 3021 3022 3023 3024 3025 3026 3027 3028 3029 3030 3031 3032 3033 | 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); } /* *---------------------------------------------------------------------- |
︙ | ︙ | |||
3510 3511 3512 3513 3514 3515 3516 | } else { *typePtr = TCL_NUMBER_DOUBLE; } *clientDataPtr = &objPtr->internalRep.doubleValue; return TCL_OK; } if (objPtr->typePtr == &tclIntType) { | < < < < < < < | 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 | } 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/tclOptimize.c.
︙ | ︙ | |||
283 284 285 286 287 288 289 | case INST_JUMP_FALSE1: case INST_JUMP_FALSE4: case INST_INCR_SCALAR1: case INST_INCR_ARRAY1: case INST_INCR_ARRAY_STK: case INST_INCR_SCALAR_STK: case INST_INCR_STK: | < < | 283 284 285 286 287 288 289 290 291 292 293 294 295 296 | case INST_JUMP_FALSE1: case INST_JUMP_FALSE4: case INST_INCR_SCALAR1: case INST_INCR_ARRAY1: case INST_INCR_ARRAY_STK: case INST_INCR_SCALAR_STK: case INST_INCR_STK: case INST_EQ: case INST_NEQ: case INST_LT: case INST_LE: case INST_GT: case INST_GE: case INST_MOD: |
︙ | ︙ |
Changes to generic/tclPanic.c.
︙ | ︙ | |||
22 23 24 25 26 27 28 | * The panicProc variable contains a pointer to an application specific panic * procedure. */ #if defined(__CYGWIN__) static TCL_NORETURN Tcl_PanicProc *panicProc = tclWinDebugPanic; #else | | | | > > > > > > > | | | < > > > > | 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 | * The panicProc variable contains a pointer to an application specific panic * procedure. */ #if defined(__CYGWIN__) static TCL_NORETURN Tcl_PanicProc *panicProc = tclWinDebugPanic; #else static TCL_NORETURN Tcl_PanicProc *panicProc = NULL; #endif /* *---------------------------------------------------------------------- * * Tcl_SetPanicProc -- * * Replace the default panic behavior with the specified function. * * Results: * None. * * Side effects: * Sets the panicProc variable. * *---------------------------------------------------------------------- */ void Tcl_SetPanicProc( TCL_NORETURN Tcl_PanicProc *proc) { #if defined(_WIN32) /* tclWinDebugPanic only installs if there is no panicProc yet. */ if ((proc != tclWinDebugPanic) || (panicProc == NULL)) #elif defined(__CYGWIN__) if (proc == NULL) panicProc = tclWinDebugPanic; else #endif panicProc = proc; } /* *---------------------------------------------------------------------- * * Tcl_Panic -- * * Print an error message and kill the process. * * Results: * None. * * Side effects: * The process dies, entering the debugger if possible. * *---------------------------------------------------------------------- */ /* ARGSUSED */ /* * The following comment is here so that Coverity's static analizer knows that * a Tcl_Panic() call can never return and avoids lots of false positives. */ /* coverity[+kill] */ void Tcl_Panic( const char *format, ...) { va_list argList; char *arg1, *arg2, *arg3; /* Additional arguments (variable in number) * to pass to fprintf. */ char *arg4, *arg5, *arg6, *arg7, *arg8; va_start(argList, format); arg1 = va_arg(argList, char *); arg2 = va_arg(argList, char *); arg3 = va_arg(argList, char *); arg4 = va_arg(argList, char *); arg5 = va_arg(argList, char *); arg6 = va_arg(argList, char *); arg7 = va_arg(argList, char *); arg8 = va_arg(argList, char *); va_end (argList); if (panicProc != NULL) { panicProc(format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8); #ifdef _WIN32 } else if (IsDebuggerPresent()) { tclWinDebugPanic(format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8); #endif |
︙ | ︙ | |||
120 121 122 123 124 125 126 | #if defined(_WIN32) ExitProcess(1); #else abort(); #endif } } | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 | #if defined(_WIN32) ExitProcess(1); #else abort(); #endif } } /* * Local Variables: * mode: c * c-basic-offset: 4 * fill-column: 78 * End: */ |
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/tclPipe.c.
︙ | ︙ | |||
217 218 219 220 221 222 223 | */ void Tcl_ReapDetachedProcs(void) { register Detached *detPtr; Detached *nextPtr, *prevPtr; | | < | > | | 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 237 | */ void Tcl_ReapDetachedProcs(void) { register Detached *detPtr; Detached *nextPtr, *prevPtr; int status, code; Tcl_MutexLock(&pipeMutex); for (detPtr = detList, prevPtr = NULL; detPtr != NULL; ) { status = TclProcessWait(detPtr->pid, WNOHANG, &code, NULL, NULL); if (status == TCL_PROCESS_UNCHANGED || (status == TCL_PROCESS_ERROR && code != ECHILD)) { prevPtr = detPtr; detPtr = detPtr->nextPtr; continue; } nextPtr = detPtr->nextPtr; if (prevPtr == NULL) { detList = detPtr->nextPtr; |
︙ | ︙ | |||
273 274 275 276 277 278 279 | Tcl_Pid *pidPtr, /* Array of process ids of children. */ Tcl_Channel errorChan) /* Channel for file containing stderr output * from pipeline. NULL means there isn't any * stderr output. */ { int result = TCL_OK; int i, abnormalExit, anyErrorInfo; | < | > | < < < < < < | < | < < < < < < < < | < < < | < > > < < | < | < | < < < < < < < < < < | < | < < < < < < | < > > | 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 | Tcl_Pid *pidPtr, /* Array of process ids of children. */ Tcl_Channel errorChan) /* Channel for file containing stderr output * from pipeline. NULL means there isn't any * stderr output. */ { int result = TCL_OK; int i, abnormalExit, anyErrorInfo; TclProcessWaitStatus waitStatus; int code; Tcl_Obj *msg, *error; abnormalExit = 0; for (i = 0; i < numPids; i++) { waitStatus = TclProcessWait(pidPtr[i], 0, &code, &msg, &error); if (waitStatus == TCL_PROCESS_ERROR) { result = TCL_ERROR; if (interp != NULL) { Tcl_SetObjErrorCode(interp, error); Tcl_SetObjResult(interp, msg); } Tcl_DecrRefCount(error); Tcl_DecrRefCount(msg); continue; } /* * Create error messages for unusual process exits. An extra newline * gets appended to each error message, but it gets removed below (in * the same fashion that an extra newline in the command's output is * removed). */ if (waitStatus != TCL_PROCESS_EXITED || code != 0) { result = TCL_ERROR; if (waitStatus == TCL_PROCESS_EXITED) { if (interp != NULL) { Tcl_SetObjErrorCode(interp, error); } abnormalExit = 1; } else if (interp != NULL) { Tcl_SetObjErrorCode(interp, error); Tcl_SetObjResult(interp, msg); } Tcl_DecrRefCount(error); Tcl_DecrRefCount(msg); } } /* * Read the standard error file. If there's anything there, then return an * error and add the file's contents to the result string. */ |
︙ | ︙ | |||
932 933 934 935 936 937 938 939 940 941 942 943 944 945 | if (result != TCL_OK) { goto error; } Tcl_DStringFree(&execBuffer); pidPtr[numPids] = pid; numPids++; /* * Close off our copies of file descriptors that were set up for this * child, then set up the input for the next child. */ if ((curInFile != NULL) && (curInFile != inputFile)) { | > | 895 896 897 898 899 900 901 902 903 904 905 906 907 908 909 | if (result != TCL_OK) { goto error; } Tcl_DStringFree(&execBuffer); pidPtr[numPids] = pid; numPids++; TclProcessCreated(pid); /* * Close off our copies of file descriptors that were set up for this * child, then set up the input for the next child. */ if ((curInFile != NULL) && (curInFile != inputFile)) { |
︙ | ︙ |
Changes to generic/tclPkg.c.
︙ | ︙ | |||
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 | * (malloc'ed). NULL means the package doesn't * exist in this interpreter yet. */ PkgAvail *availPtr; /* First in list of all available versions of * this package. */ const void *clientData; /* Client data. */ } Package; /* * Prototypes for functions defined in this file: */ static int CheckVersionAndConvert(Tcl_Interp *interp, const char *string, char **internal, int *stable); static int CompareVersions(char *v1i, char *v2i, int *isMajorPtr); static int CheckRequirement(Tcl_Interp *interp, const char *string); static int CheckAllRequirements(Tcl_Interp *interp, int reqc, Tcl_Obj *const reqv[]); static int RequirementSatisfied(char *havei, const char *req); static int SomeRequirementSatisfied(char *havei, int reqc, Tcl_Obj *const reqv[]); static void AddRequirementsToResult(Tcl_Interp *interp, int reqc, Tcl_Obj *const reqv[]); static void AddRequirementsToDString(Tcl_DString *dstring, int reqc, Tcl_Obj *const reqv[]); static Package * FindPackage(Tcl_Interp *interp, const char *name); | > > > > > > > > > > > > | > > > > | | > > | 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 | * (malloc'ed). NULL means the package doesn't * exist in this interpreter yet. */ PkgAvail *availPtr; /* First in list of all available versions of * this package. */ const void *clientData; /* Client data. */ } Package; typedef struct Require { void * clientDataPtr; const char *name; Package *pkgPtr; char *versionToProvide; } Require; typedef struct RequireProcArgs { const char *name; void *clientDataPtr; } RequireProcArgs; /* * Prototypes for functions defined in this file: */ static int CheckVersionAndConvert(Tcl_Interp *interp, const char *string, char **internal, int *stable); static int CompareVersions(char *v1i, char *v2i, int *isMajorPtr); static int CheckRequirement(Tcl_Interp *interp, const char *string); static int CheckAllRequirements(Tcl_Interp *interp, int reqc, Tcl_Obj *const reqv[]); static int RequirementSatisfied(char *havei, const char *req); static int SomeRequirementSatisfied(char *havei, int reqc, Tcl_Obj *const reqv[]); static void AddRequirementsToResult(Tcl_Interp *interp, int reqc, Tcl_Obj *const reqv[]); static void AddRequirementsToDString(Tcl_DString *dstring, int reqc, Tcl_Obj *const reqv[]); static Package * FindPackage(Tcl_Interp *interp, const char *name); static int PkgRequireCore(ClientData data[], Tcl_Interp *interp, int result); static int PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result); static int PkgRequireCoreCleanup(ClientData data[], Tcl_Interp *interp, int result); static int PkgRequireCoreStep1(ClientData data[], Tcl_Interp *interp, int result); static int PkgRequireCoreStep2(ClientData data[], Tcl_Interp *interp, int result); static int TclNRPkgRequireProc(ClientData clientData, Tcl_Interp *interp, int reqc, Tcl_Obj *const reqv[]); static int SelectPackage(ClientData data[], Tcl_Interp *interp, int result); static int SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result); static int TclNRPackageObjCmdCleanup(ClientData data[], Tcl_Interp *interp, int result); /* * Helper macros. */ #define DupBlock(v,s,len) \ ((v) = ckalloc(len), memcpy((v),(s),(len))) |
︙ | ︙ | |||
335 336 337 338 339 340 341 | } /* * Translate between old and new API, and defer to the new function. */ if (version == NULL) { | | > > > | > | | > | > | | > | < < | > > > | > > > > | | < < > | | < | > | > > > > > | > > > > > > > > > | | < < < | < < | < < < | < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < | < < < < < | < < | < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < | < < < < < < < < < | < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | | | | > > | | > | | > > > > > > | > > > > > > > | | | | | | | | | | | > > > > | | | > > > > > > > | | < | | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | } /* * Translate between old and new API, and defer to the new function. */ if (version == NULL) { if (Tcl_PkgRequireProc(interp, name, 0, NULL, clientDataPtr) == TCL_OK) { result = Tcl_GetStringResult(interp); Tcl_ResetResult(interp); } } else { if (exact && TCL_OK != CheckVersionAndConvert(interp, version, NULL, NULL)) { return NULL; } ov = Tcl_NewStringObj(version, -1); if (exact) { Tcl_AppendStringsToObj(ov, "-", version, NULL); } Tcl_IncrRefCount(ov); if (Tcl_PkgRequireProc(interp, name, 1, &ov, clientDataPtr) == TCL_OK) { result = Tcl_GetStringResult(interp); Tcl_ResetResult(interp); } TclDecrRefCount(ov); } return result; } int Tcl_PkgRequireProc( Tcl_Interp *interp, /* Interpreter in which package is now * available. */ const char *name, /* Name of desired package. */ int reqc, /* Requirements constraining the desired * version. */ Tcl_Obj *const reqv[], /* 0 means to use the latest version * available. */ void *clientDataPtr) { RequireProcArgs args; args.name = name; args.clientDataPtr = clientDataPtr; return Tcl_NRCallObjProc(interp, TclNRPkgRequireProc, (void *)&args, reqc, reqv); } static int TclNRPkgRequireProc( ClientData clientData, Tcl_Interp *interp, int reqc, Tcl_Obj *const reqv[]) { RequireProcArgs *args = clientData; Tcl_NRAddCallback(interp, PkgRequireCore, (void *)args->name, INT2PTR(reqc), (void *)reqv, args->clientDataPtr); return TCL_OK; } static int PkgRequireCore(ClientData data[], Tcl_Interp *interp, int result) { const char *name = data[0]; int reqc = PTR2INT(data[1]); Tcl_Obj *const *reqv = data[2]; int code = CheckAllRequirements(interp, reqc, reqv); Require *reqPtr; if (code != TCL_OK) { return code; } reqPtr = ckalloc(sizeof(Require)); Tcl_NRAddCallback(interp, PkgRequireCoreCleanup, reqPtr, NULL, NULL, NULL); reqPtr->clientDataPtr = data[3]; reqPtr->name = name; reqPtr->pkgPtr = FindPackage(interp, name); if (reqPtr->pkgPtr->version == NULL) { Tcl_NRAddCallback(interp, SelectPackage, reqPtr, INT2PTR(reqc), (void *)reqv, PkgRequireCoreStep1); } else { Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); } return TCL_OK; } static int PkgRequireCoreStep1(ClientData data[], Tcl_Interp *interp, int result) { Tcl_DString command; char *script; Require *reqPtr = data[0]; int reqc = PTR2INT(data[1]); Tcl_Obj **const reqv = data[2]; const char *name = reqPtr->name /* Name of desired package. */; if (reqPtr->pkgPtr->version == NULL) { /* * The package is not in the database. If there is a "package unknown" * command, invoke it. */ script = ((Interp *) interp)->packageUnknown; if (script == NULL) { Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); } else { Tcl_DStringInit(&command); Tcl_DStringAppend(&command, script, -1); Tcl_DStringAppendElement(&command, name); AddRequirementsToDString(&command, reqc, reqv); Tcl_NRAddCallback(interp, PkgRequireCoreStep2, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); Tcl_NREvalObj(interp, Tcl_NewStringObj(Tcl_DStringValue(&command), Tcl_DStringLength(&command)), TCL_EVAL_GLOBAL ); Tcl_DStringFree(&command); } return TCL_OK; } else { Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); } return TCL_OK; } static int PkgRequireCoreStep2(ClientData data[], Tcl_Interp *interp, int result) { Require *reqPtr = data[0]; int reqc = PTR2INT(data[1]); Tcl_Obj **const reqv = data[2]; const char *name = reqPtr->name /* Name of desired package. */; if ((result != TCL_OK) && (result != TCL_ERROR)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad return code: %d", result)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); result = TCL_ERROR; } if (result == TCL_ERROR) { Tcl_AddErrorInfo(interp, "\n (\"package unknown\" script)"); return result; } Tcl_ResetResult(interp); /* pkgPtr may now be invalid, so refresh it. */ reqPtr->pkgPtr = FindPackage(interp, name); Tcl_NRAddCallback(interp, SelectPackage, reqPtr, INT2PTR(reqc), (void *)reqv, PkgRequireCoreFinal); return TCL_OK; } static int PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result) { Require *reqPtr = data[0]; int reqc = PTR2INT(data[1]), satisfies; Tcl_Obj **const reqv = data[2]; char *pkgVersionI; void *clientDataPtr = reqPtr->clientDataPtr; const char *name = reqPtr->name /* Name of desired package. */; if (reqPtr->pkgPtr->version == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't find package %s", name)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", NULL); AddRequirementsToResult(interp, reqc, reqv); return TCL_ERROR; } /* * Ensure that the provided version meets the current requirements. */ if (reqc != 0) { CheckVersionAndConvert(interp, reqPtr->pkgPtr->version, &pkgVersionI, NULL); satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv); ckfree(pkgVersionI); if (!satisfies) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "version conflict for package \"%s\": have %s, need", name, reqPtr->pkgPtr->version)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", NULL); AddRequirementsToResult(interp, reqc, reqv); return TCL_ERROR; } } if (clientDataPtr) { const void **ptr = (const void **) clientDataPtr; *ptr = reqPtr->pkgPtr->clientData; } Tcl_SetObjResult(interp, Tcl_NewStringObj(reqPtr->pkgPtr->version, -1)); return TCL_OK; } static int PkgRequireCoreCleanup(ClientData data[], Tcl_Interp *interp, int result) { ckfree(data[0]); return result; } static int SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { PkgAvail *availPtr, *bestPtr, *bestStablePtr; char *availVersion, *bestVersion, *bestStableVersion; /* Internal rep. of versions */ int availStable, satisfies; Require *reqPtr = data[0]; int reqc = PTR2INT(data[1]); Tcl_Obj **const reqv = data[2]; const char *name = reqPtr->name; Package *pkgPtr = reqPtr->pkgPtr; Interp *iPtr = (Interp *) interp; /* * Check whether we're already attempting to load some version of this * package (circular dependency detection). */ if (pkgPtr->clientData != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "circular package dependency:" " attempt to provide %s %s requires %s", name, (char *) pkgPtr->clientData, name)); AddRequirementsToResult(interp, reqc, reqv); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", NULL); return TCL_ERROR; } /* * The package isn't yet present. Search the list of available * versions and invoke the script for the best available version. We * 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. */ if ((iPtr->packagePrefer == PKG_PREFER_STABLE) && (bestStablePtr != NULL)) { bestPtr = bestStablePtr; } if (bestPtr == NULL) { Tcl_NRAddCallback(interp, data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL); } else { /* * We found an ifneeded script for the package. Be careful while * executing it: this could cause reentrancy, so (a) protect the * script itself from deletion and (b) don't assume that bestPtr * will still exist when the script completes. */ char *versionToProvide = bestPtr->version; PkgFiles *pkgFiles; PkgName *pkgName; Tcl_Preserve(versionToProvide); pkgPtr->clientData = versionToProvide; pkgFiles = TclInitPkgFiles(interp); /* Push "ifneeded" package name in "tclPkgFiles" assocdata. */ pkgName = ckalloc(sizeof(PkgName) + strlen(name)); pkgName->nextPtr = pkgFiles->names; strcpy(pkgName->name, name); pkgFiles->names = pkgName; if (bestPtr->pkgIndex) { TclPkgFileSeen(interp, bestPtr->pkgIndex); } reqPtr->versionToProvide = versionToProvide; Tcl_NRAddCallback(interp, SelectPackageFinal, reqPtr, INT2PTR(reqc), (void *)reqv, data[3]); Tcl_NREvalObj(interp, Tcl_NewStringObj(bestPtr->script, -1), TCL_EVAL_GLOBAL); } return TCL_OK; } static int SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) { Require *reqPtr = data[0]; int reqc = PTR2INT(data[1]); Tcl_Obj **const reqv = data[2]; const char *name = reqPtr->name; char *versionToProvide = reqPtr->versionToProvide; /* Pop the "ifneeded" package name from "tclPkgFiles" assocdata*/ PkgFiles *pkgFiles = Tcl_GetAssocData(interp, "tclPkgFiles", NULL); PkgName *pkgName = pkgFiles->names; pkgFiles->names = pkgName->nextPtr; ckfree(pkgName); reqPtr->pkgPtr = FindPackage(interp, name); if (result == TCL_OK) { Tcl_ResetResult(interp); if (reqPtr->pkgPtr->version == NULL) { result = TCL_ERROR; Tcl_SetObjResult(interp, Tcl_ObjPrintf( "attempt to provide package %s %s failed:" " no version of package %s provided", name, versionToProvide, name)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED", NULL); } else { char *pvi, *vi; if (CheckVersionAndConvert(interp, reqPtr->pkgPtr->version, &pvi, NULL) != TCL_OK) { result = TCL_ERROR; } else if (CheckVersionAndConvert(interp, versionToProvide, &vi, NULL) != TCL_OK) { ckfree(pvi); result = TCL_ERROR; } else { int res = CompareVersions(pvi, vi, NULL); ckfree(pvi); ckfree(vi); if (res != 0) { result = TCL_ERROR; Tcl_SetObjResult(interp, Tcl_ObjPrintf( "attempt to provide package %s %s failed:" " package %s %s provided instead", name, versionToProvide, name, reqPtr->pkgPtr->version)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "WRONGPROVIDE", NULL); } } } } else if (result != TCL_ERROR) { Tcl_Obj *codePtr = Tcl_NewIntObj(result); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "attempt to provide package %s %s failed:" " bad return code: %s", name, versionToProvide, TclGetString(codePtr))); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL); TclDecrRefCount(codePtr); result = TCL_ERROR; } if (result == TCL_ERROR) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (\"package ifneeded %s %s\" script)", name, versionToProvide)); } Tcl_Release(versionToProvide); if (result != TCL_OK) { /* * Take a non-TCL_OK code from the script as an indication the * package wasn't loaded properly, so the package system * should not remember an improper load. * * This is consistent with our returning NULL. If we're not * willing to tell our caller we got a particular version, we * shouldn't store that version for telling future callers * either. */ if (reqPtr->pkgPtr->version != NULL) { ckfree(reqPtr->pkgPtr->version); reqPtr->pkgPtr->version = NULL; } reqPtr->pkgPtr->clientData = NULL; return result; } Tcl_NRAddCallback(interp, data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL); return TCL_OK; } /* *---------------------------------------------------------------------- * * Tcl_PkgPresentEx -- * |
︙ | ︙ | |||
789 790 791 792 793 794 795 796 797 798 | * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ /* ARGSUSED */ int | > > > > > > > > > | | > | 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 | * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ int Tcl_PackageObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { return Tcl_NRCallObjProc(interp, TclNRPackageObjCmd, NULL, objc, objv); } /* ARGSUSED */ int TclNRPackageObjCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { static const char *const pkgOptions[] = { "files", "forget", "ifneeded", "names", "prefer", "present", "provide", "require", "unknown", "vcompare", "versions", "vsatisfies", NULL }; enum pkgOptions { PKG_FILES, PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, PKG_PREFER, PKG_PRESENT, PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE, PKG_VERSIONS, PKG_VSATISFIES }; Interp *iPtr = (Interp *) interp; int optionIndex, exact, i, newobjc, satisfies; PkgAvail *availPtr, *prevPtr; Package *pkgPtr; Tcl_HashEntry *hPtr; Tcl_HashSearch search; Tcl_HashTable *tablePtr; const char *version; const char *argv2, *argv3, *argv4; char *iva = NULL, *ivb = NULL; Tcl_Obj *objvListPtr, **newObjvPtr; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], pkgOptions, "option", 0, |
︙ | ︙ | |||
876 877 878 879 880 881 882 883 884 885 886 887 888 889 | 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; } | > | 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 | 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; } |
︙ | ︙ | |||
929 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 | 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)); | > | | 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 | 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; |
︙ | ︙ | |||
1061 1062 1063 1064 1065 1066 1067 | } version = NULL; argv2 = TclGetString(objv[2]); if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { Tcl_Obj *ov; | < > > | | > | > > | > > > > > > > > > > | > > > > > > | 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 | } version = NULL; argv2 = TclGetString(objv[2]); if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) { Tcl_Obj *ov; if (objc != 5) { goto requireSyntax; } version = TclGetString(objv[4]); if (CheckVersionAndConvert(interp, version, NULL, NULL) != TCL_OK) { return TCL_ERROR; } /* * Create a new-style requirement for the exact version. */ ov = Tcl_NewStringObj(version, -1); Tcl_AppendStringsToObj(ov, "-", version, NULL); version = NULL; argv3 = TclGetString(objv[3]); Tcl_IncrRefCount(objv[3]); objvListPtr = Tcl_NewListObj(0, NULL); Tcl_IncrRefCount(objvListPtr); Tcl_ListObjAppendElement(interp, objvListPtr, ov); Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[3], objvListPtr, NULL, NULL); Tcl_NRAddCallback(interp, PkgRequireCore, (void *)argv3, INT2PTR(newobjc), newObjvPtr, NULL); return TCL_OK; } else { int i, newobjc = objc-3; Tcl_Obj *const *newobjv = objv + 3; if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) { return TCL_ERROR; } objvListPtr = Tcl_NewListObj(0, NULL); Tcl_IncrRefCount(objvListPtr); Tcl_IncrRefCount(objv[2]); for (i = 0; i < newobjc; i++) { /* * Tcl_Obj structures may have come from another interpreter, * so duplicate them. */ Tcl_ListObjAppendElement(interp, objvListPtr, Tcl_DuplicateObj(newobjv[i])); } Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[2], objvListPtr, NULL, NULL); Tcl_NRAddCallback(interp, PkgRequireCore, (void *)argv2, INT2PTR(newobjc), newObjvPtr, NULL); return TCL_OK; } break; case PKG_UNKNOWN: { int length; if (objc == 2) { if (iPtr->packageUnknown != NULL) { |
︙ | ︙ | |||
1231 1232 1233 1234 1235 1236 1237 1238 1239 1240 1241 1242 1243 1244 | break; } default: Tcl_Panic("Tcl_PackageObjCmd: bad option index to pkgOptions"); } return TCL_OK; } /* *---------------------------------------------------------------------- * * FindPackage -- * * This function finds the Package record for a particular package in a | > > > > > > > | 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 1390 1391 1392 1393 1394 1395 1396 1397 | break; } default: Tcl_Panic("Tcl_PackageObjCmd: bad option index to pkgOptions"); } return TCL_OK; } static int TclNRPackageObjCmdCleanup(ClientData data[], Tcl_Interp *interp, int result) { TclDecrRefCount((Tcl_Obj *)data[0]); TclDecrRefCount((Tcl_Obj *)data[1]); return result; } /* *---------------------------------------------------------------------- * * FindPackage -- * * This function finds the Package record for a particular package in a |
︙ | ︙ | |||
1312 1313 1314 1315 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 | 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) { | > | 1465 1466 1467 1468 1469 1470 1471 1472 1473 1474 1475 1476 1477 1478 1479 | 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. */ |
︙ | ︙ | |||
389 390 391 392 393 394 395 | Namespace *nsPtr, /* Namespace containing this proc. */ const char *procName, /* Unqualified name of this proc. */ Tcl_Obj *argsPtr, /* Description of arguments. */ Tcl_Obj *bodyPtr, /* Command body. */ Proc **procPtrPtr) /* Returns: pointer to proc data. */ { Interp *iPtr = (Interp *) interp; | < | | > | | 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 | Namespace *nsPtr, /* Namespace containing this proc. */ const char *procName, /* Unqualified name of this proc. */ Tcl_Obj *argsPtr, /* Description of arguments. */ Tcl_Obj *bodyPtr, /* Command body. */ Proc **procPtrPtr) /* Returns: pointer to proc data. */ { Interp *iPtr = (Interp *) interp; register Proc *procPtr; int i, result, numArgs, plen; const char *bytes, *argname, *argnamei; char argnamelast; register CompiledLocal *localPtr = NULL; Tcl_Obj *defPtr, *errorObj, **argArray; int precompiled = 0; if (bodyPtr->typePtr == &tclProcBodyType) { /* * Because the body is a TclProProcBody, the actual body is already * compiled, and it is not shared with anyone else, so it's OK not to * unshare it (as a matter of fact, it is bad to unshare it, because |
︙ | ︙ | |||
432 433 434 435 436 437 438 439 440 441 442 443 444 445 | * means that the same code can not be shared by two procedures that * have a different number of arguments, even if their bodies are * identical. Note that we don't use Tcl_DuplicateObj since we would * not want any bytecode internal representation. */ if (Tcl_IsShared(bodyPtr)) { Tcl_Obj *sharedBodyPtr = bodyPtr; bytes = TclGetStringFromObj(bodyPtr, &length); bodyPtr = Tcl_NewStringObj(bytes, length); /* * TIP #280. | > | 408 409 410 411 412 413 414 415 416 417 418 419 420 421 422 | * means that the same code can not be shared by two procedures that * have a different number of arguments, even if their bodies are * identical. Note that we don't use Tcl_DuplicateObj since we would * not want any bytecode internal representation. */ if (Tcl_IsShared(bodyPtr)) { int length; Tcl_Obj *sharedBodyPtr = bodyPtr; bytes = TclGetStringFromObj(bodyPtr, &length); bodyPtr = Tcl_NewStringObj(bytes, length); /* * TIP #280. |
︙ | ︙ | |||
469 470 471 472 473 474 475 | } /* * Break up the argument list into argument specifiers, then process each * argument specifier. If the body is precompiled, processing is limited * to checking that the parsed argument is consistent with the one stored * in the Proc. | < < < | | 446 447 448 449 450 451 452 453 454 455 456 457 458 459 460 461 462 | } /* * Break up the argument list into argument specifiers, then process each * argument specifier. If the body is precompiled, processing is limited * to checking that the parsed argument is consistent with the one stored * in the Proc. */ result = Tcl_ListObjGetElements(interp , argsPtr ,&numArgs ,&argArray); if (result != TCL_OK) { goto procError; } if (precompiled) { if (numArgs > procPtr->numArgs) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( |
︙ | ︙ | |||
498 499 500 501 502 503 504 | procPtr->numArgs = numArgs; procPtr->numCompiledLocals = numArgs; } for (i = 0; i < numArgs; i++) { int fieldCount, nameLength; size_t valueLength; | | | < | | | > > | < | > | | > > | | < < < < < | | < | < | | > | < > | < | | | > > | < < > | | | < | < < < < < < | 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 | procPtr->numArgs = numArgs; procPtr->numCompiledLocals = numArgs; } for (i = 0; i < numArgs; i++) { int fieldCount, nameLength; size_t valueLength; Tcl_Obj **fieldValues; /* * Now divide the specifier up into name and default. */ result = Tcl_ListObjGetElements(interp, argArray[i], &fieldCount, &fieldValues); if (result != TCL_OK) { goto procError; } if (fieldCount > 2) { errorObj = Tcl_NewStringObj( "too many fields in argument specifier \"", -1); Tcl_AppendObjToObj(errorObj, argArray[i]); Tcl_AppendToObj(errorObj, "\"", -1); Tcl_SetObjResult(interp, errorObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } if ((fieldCount == 0) || (fieldValues[0]->length == 0)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "argument with no name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } nameLength = Tcl_NumUtfChars(Tcl_GetString(fieldValues[0]), fieldValues[0]->length); if (fieldCount == 2) { valueLength = Tcl_NumUtfChars(Tcl_GetString(fieldValues[1]), fieldValues[1]->length); } else { valueLength = 0; } /* * Check that the formal parameter name is a scalar. */ argname = Tcl_GetStringFromObj(fieldValues[0], &plen); argnamei = argname; argnamelast = argname[plen-1]; while (plen--) { if (argnamei[0] == '(') { if (argnamelast == ')') { /* We have an array element. */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "formal parameter \"%s\" is an array element", Tcl_GetString(fieldValues[0]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } } else if ((argnamei[0] == ':') && (argnamei[1] == ':')) { errorObj = Tcl_NewStringObj("formal parameter \"", -1); Tcl_AppendObjToObj(errorObj, fieldValues[0]); Tcl_AppendToObj(errorObj, "\" is not a simple name", -1); Tcl_SetObjResult(interp, errorObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "FORMALARGUMENTFORMAT", NULL); goto procError; } argnamei = Tcl_UtfNext(argnamei); } if (precompiled) { /* * Compare the parsed argument with the stored one. Note that the * only flag value that makes sense at this point is VAR_ARGUMENT * (its value was kept the same as pre VarReform to simplify * tbcload's processing of older byetcodes). * * The only other flag vlaue that is important to retrieve from * precompiled procs is VAR_TEMPORARY (also unchanged). It is * needed later when retrieving the variable names. */ if ((localPtr->nameLength != nameLength) || (Tcl_UtfNcmp(localPtr->name, argname, nameLength)) || (localPtr->frameIndex != i) || !(localPtr->flags & VAR_ARGUMENT) || (localPtr->defValuePtr == NULL && fieldCount == 2) || (localPtr->defValuePtr != NULL && fieldCount != 2)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "procedure \"%s\": formal parameter %d is " "inconsistent with precompiled body", procName, i)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "BYTECODELIES", NULL); goto procError; } /* * Compare the default value if any. */ if (localPtr->defValuePtr != NULL) { const char *tmpPtr = TclGetString(localPtr->defValuePtr); size_t tmpLength = localPtr->defValuePtr->length; if ((valueLength != tmpLength) || Tcl_UtfNcmp(Tcl_GetString(fieldValues[1]), tmpPtr, tmpLength)) { errorObj = Tcl_ObjPrintf( "procedure \"%s\": formal parameter \"" ,procName); Tcl_AppendObjToObj(errorObj, fieldValues[0]); Tcl_AppendToObj(errorObj, "\" has " "default value inconsistent with precompiled body", -1); Tcl_SetObjResult(interp, errorObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", "BYTECODELIES", NULL); goto procError; } } if ((i == numArgs - 1) && (localPtr->nameLength == 4) && (localPtr->name[0] == 'a') && (strcmp(localPtr->name, "args") == 0)) { localPtr->flags |= VAR_IS_ARGS; } localPtr = localPtr->nextPtr; } else { /* * Allocate an entry in the runtime procedure frame's array of * local variables for the argument. */ localPtr = ckalloc(TclOffset(CompiledLocal, name) + fieldValues[0]->length +1); if (procPtr->firstLocalPtr == NULL) { procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; } else { procPtr->lastLocalPtr->nextPtr = localPtr; procPtr->lastLocalPtr = localPtr; } localPtr->nextPtr = NULL; localPtr->nameLength = Tcl_NumUtfChars(argname, fieldValues[0]->length); localPtr->frameIndex = i; localPtr->flags = VAR_ARGUMENT; localPtr->resolveInfo = NULL; if (fieldCount == 2) { localPtr->defValuePtr = fieldValues[1]; Tcl_IncrRefCount(localPtr->defValuePtr); } else { localPtr->defValuePtr = NULL; } memcpy(localPtr->name, argname, fieldValues[0]->length + 1); if ((i == numArgs - 1) && (localPtr->nameLength == 4) && (localPtr->name[0] == 'a') && (strcmp(localPtr->name, "args") == 0)) { localPtr->flags |= VAR_IS_ARGS; } } } *procPtrPtr = procPtr; return TCL_OK; procError: if (precompiled) { procPtr->refCount--; } else { Tcl_DecrRefCount(bodyPtr); while (procPtr->firstLocalPtr != NULL) { localPtr = procPtr->firstLocalPtr; procPtr->firstLocalPtr = localPtr->nextPtr; defPtr = localPtr->defValuePtr; if (defPtr != NULL) { Tcl_DecrRefCount(defPtr); } ckfree(localPtr); } ckfree(procPtr); } return TCL_ERROR; } /* *---------------------------------------------------------------------- * * TclGetFrame -- |
︙ | ︙ | |||
822 823 824 825 826 827 828 | 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. |
︙ | ︙ | |||
2408 2409 2410 2411 2412 2413 2414 | 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; | | | 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 2383 2384 2385 2386 | 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 |
︙ | ︙ |
Added generic/tclProcess.c.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | /* * tclProcess.c -- * * This file implements the "tcl::process" ensemble for subprocess * management as defined by TIP #462. * * Copyright (c) 2017 Frederic Bonnet. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" /* * Autopurge flag. Process-global because of the way Tcl manages child * processes (see tclPipe.c). */ static int autopurge = 1; /* Autopurge flag. */ /* * Hash tables that keeps track of all child process statuses. Keys are the * child process ids and resolved pids, values are (ProcessInfo *). */ typedef struct ProcessInfo { Tcl_Pid pid; /* Process id. */ int resolvedPid; /* Resolved process id. */ int purge; /* Purge eventualy. */ TclProcessWaitStatus status;/* Process status. */ int code; /* Error code, exit status or signal number. */ Tcl_Obj *msg; /* Error message. */ Tcl_Obj *error; /* Error code. */ } ProcessInfo; static Tcl_HashTable infoTablePerPid; static Tcl_HashTable infoTablePerResolvedPid; static int infoTablesInitialized = 0; /* 0 means not yet initialized. */ TCL_DECLARE_MUTEX(infoTablesMutex) /* * Prototypes for functions defined later in this file: */ static void InitProcessInfo(ProcessInfo *info, Tcl_Pid pid, int resolvedPid); static void FreeProcessInfo(ProcessInfo *info); static int RefreshProcessInfo(ProcessInfo *info, int options); static TclProcessWaitStatus WaitProcessStatus(Tcl_Pid pid, int resolvedPid, int options, int *codePtr, Tcl_Obj **msgPtr, Tcl_Obj **errorObjPtr); static Tcl_Obj * BuildProcessStatusObj(ProcessInfo *info); static int ProcessListObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int ProcessStatusObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int ProcessPurgeObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int ProcessAutopurgeObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* *---------------------------------------------------------------------- * * InitProcessInfo -- * * Initializes the ProcessInfo structure. * * Results: * None. * * Side effects: * Memory written. * *---------------------------------------------------------------------- */ void InitProcessInfo( ProcessInfo *info, /* Structure to initialize. */ Tcl_Pid pid, /* Process id. */ int resolvedPid) /* Resolved process id. */ { info->pid = pid; info->resolvedPid = resolvedPid; info->purge = 0; info->status = TCL_PROCESS_UNCHANGED; info->code = 0; info->msg = NULL; info->error = NULL; } /* *---------------------------------------------------------------------- * * FreeProcessInfo -- * * Free the ProcessInfo structure. * * Results: * None. * * Side effects: * Memory deallocated, Tcl_Obj refcount decreased. * *---------------------------------------------------------------------- */ void FreeProcessInfo( ProcessInfo *info) /* Structure to free. */ { /* * Free stored Tcl_Objs. */ if (info->msg) { Tcl_DecrRefCount(info->msg); } if (info->error) { Tcl_DecrRefCount(info->error); } /* * Free allocated structure. */ ckfree(info); } /* *---------------------------------------------------------------------- * * RefreshProcessInfo -- * * Refresh process info. * * Results: * Nonzero if state changed, else zero. * * Side effects: * May call WaitProcessStatus, which can block if WNOHANG option is set. * *---------------------------------------------------------------------- */ int RefreshProcessInfo( ProcessInfo *info, /* Structure to refresh. */ int options /* Options passed to WaitProcessStatus. */ ) { if (info->status == TCL_PROCESS_UNCHANGED) { /* * Refresh & store status. */ info->status = WaitProcessStatus(info->pid, info->resolvedPid, options, &info->code, &info->msg, &info->error); if (info->msg) Tcl_IncrRefCount(info->msg); if (info->error) Tcl_IncrRefCount(info->error); return (info->status != TCL_PROCESS_UNCHANGED); } else { /* * No change. */ return 0; } } /* *---------------------------------------------------------------------- * * WaitProcessStatus -- * * Wait for process status to change. * * Results: * TclProcessWaitStatus enum value. * * Side effects: * May call WaitProcessStatus, which can block if WNOHANG option is set. * *---------------------------------------------------------------------- */ TclProcessWaitStatus WaitProcessStatus( Tcl_Pid pid, /* Process id. */ int resolvedPid, /* Resolved process id. */ int options, /* Options passed to Tcl_WaitPid. */ int *codePtr, /* If non-NULL, will receive either: * - 0 for normal exit. * - errno in case of error. * - non-zero exit code for abormal exit. * - signal number if killed or suspended. * - Tcl_WaitPid status in all other cases. */ Tcl_Obj **msgObjPtr, /* If non-NULL, will receive error message. */ Tcl_Obj **errorObjPtr) /* If non-NULL, will receive error code. */ { int waitStatus; Tcl_Obj *errorStrings[5]; const char *msg; pid = Tcl_WaitPid(pid, &waitStatus, options); if (pid == 0) { /* * No change. */ return TCL_PROCESS_UNCHANGED; } /* * Get process status. */ if (pid == (Tcl_Pid) -1) { /* * POSIX errName msg */ msg = Tcl_ErrnoMsg(errno); if (errno == ECHILD) { /* * This changeup in message suggested by Mark Diekhans to * remind people that ECHILD errors can occur on some * systems if SIGCHLD isn't in its default state. */ msg = "child process lost (is SIGCHLD ignored or trapped?)"; } if (codePtr) *codePtr = errno; if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf( "error waiting for process to exit: %s", msg); if (errorObjPtr) { errorStrings[0] = Tcl_NewStringObj("POSIX", -1); errorStrings[1] = Tcl_NewStringObj(Tcl_ErrnoId(), -1); errorStrings[2] = Tcl_NewStringObj(msg, -1); *errorObjPtr = Tcl_NewListObj(3, errorStrings); } return TCL_PROCESS_ERROR; } else if (WIFEXITED(waitStatus)) { if (codePtr) *codePtr = WEXITSTATUS(waitStatus); if (!WEXITSTATUS(waitStatus)) { /* * Normal exit. */ if (msgObjPtr) *msgObjPtr = NULL; if (errorObjPtr) *errorObjPtr = NULL; } else { /* * CHILDSTATUS pid code * * Child exited with a non-zero exit status. */ if (msgObjPtr) *msgObjPtr = Tcl_NewStringObj( "child process exited abnormally", -1); if (errorObjPtr) { errorStrings[0] = Tcl_NewStringObj("CHILDSTATUS", -1); errorStrings[1] = Tcl_NewIntObj(resolvedPid); errorStrings[2] = Tcl_NewIntObj(WEXITSTATUS(waitStatus)); *errorObjPtr = Tcl_NewListObj(3, errorStrings); } } return TCL_PROCESS_EXITED; } else if (WIFSIGNALED(waitStatus)) { /* * CHILDKILLED pid sigName msg * * Child killed because of a signal. */ msg = Tcl_SignalMsg(WTERMSIG(waitStatus)); if (codePtr) *codePtr = WTERMSIG(waitStatus); if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf( "child killed: %s", msg); if (errorObjPtr) { errorStrings[0] = Tcl_NewStringObj("CHILDKILLED", -1); errorStrings[1] = Tcl_NewIntObj(resolvedPid); errorStrings[2] = Tcl_NewStringObj(Tcl_SignalId(WTERMSIG(waitStatus)), -1); errorStrings[3] = Tcl_NewStringObj(msg, -1); *errorObjPtr = Tcl_NewListObj(4, errorStrings); } return TCL_PROCESS_SIGNALED; } else if (WIFSTOPPED(waitStatus)) { /* * CHILDSUSP pid sigName msg * * Child suspended because of a signal. */ msg = Tcl_SignalMsg(WSTOPSIG(waitStatus)); if (codePtr) *codePtr = WSTOPSIG(waitStatus); if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf( "child suspended: %s", msg); if (errorObjPtr) { errorStrings[0] = Tcl_NewStringObj("CHILDSUSP", -1); errorStrings[1] = Tcl_NewIntObj(resolvedPid); errorStrings[2] = Tcl_NewStringObj(Tcl_SignalId(WSTOPSIG(waitStatus)), -1); errorStrings[3] = Tcl_NewStringObj(msg, -1); *errorObjPtr = Tcl_NewListObj(4, errorStrings); } return TCL_PROCESS_STOPPED; } else { /* * TCL OPERATION EXEC ODDWAITRESULT * * Child wait status didn't make sense. */ if (codePtr) *codePtr = waitStatus; if (msgObjPtr) *msgObjPtr = Tcl_NewStringObj( "child wait status didn't make sense\n", -1); if (errorObjPtr) { errorStrings[0] = Tcl_NewStringObj("TCL", -1); errorStrings[1] = Tcl_NewStringObj("OPERATION", -1); errorStrings[2] = Tcl_NewStringObj("EXEC", -1); errorStrings[3] = Tcl_NewStringObj("ODDWAITRESULT", -1); errorStrings[4] = Tcl_NewIntObj(resolvedPid); *errorObjPtr = Tcl_NewListObj(5, errorStrings); } return TCL_PROCESS_UNKNOWN_STATUS; } } /* *---------------------------------------------------------------------- * * BuildProcessStatusObj -- * * Build a list object with process status. The first element is always * a standard Tcl return value, which can be either TCL_OK or TCL_ERROR. * In the latter case, the second element is the error message and the * third element is a Tcl error code (see tclvars). * * Results: * A list object. * * Side effects: * Tcl_Objs are created. * *---------------------------------------------------------------------- */ Tcl_Obj * BuildProcessStatusObj( ProcessInfo *info) { Tcl_Obj *resultObjs[3]; if (info->status == TCL_PROCESS_UNCHANGED) { /* * Process still running, return empty obj. */ return Tcl_NewObj(); } if (info->status == TCL_PROCESS_EXITED && info->code == 0) { /* * Normal exit, return TCL_OK. */ return Tcl_NewIntObj(TCL_OK); } /* * Abnormal exit, return {TCL_ERROR msg error} */ resultObjs[0] = Tcl_NewIntObj(TCL_ERROR); resultObjs[1] = info->msg; resultObjs[2] = info->error; return Tcl_NewListObj(3, resultObjs); } /*---------------------------------------------------------------------- * * ProcessListObjCmd -- * * This function implements the 'tcl::process list' Tcl command. * Refer to the user documentation for details on what it does. * * Results: * Returns a standard Tcl result. * * Side effects: * Access to the internal structures is protected by infoTablesMutex. * *---------------------------------------------------------------------- */ static int ProcessListObjCmd( ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Obj *list; Tcl_HashEntry *entry; Tcl_HashSearch search; ProcessInfo *info; if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, NULL); return TCL_ERROR; } /* * Return the list of all chid process ids. */ list = Tcl_NewListObj(0, NULL); Tcl_MutexLock(&infoTablesMutex); for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); entry != NULL; entry = Tcl_NextHashEntry(&search)) { info = (ProcessInfo *) Tcl_GetHashValue(entry); Tcl_ListObjAppendElement(interp, list, Tcl_NewIntObj(info->resolvedPid)); } Tcl_MutexUnlock(&infoTablesMutex); Tcl_SetObjResult(interp, list); return TCL_OK; } /*---------------------------------------------------------------------- * * ProcessStatusObjCmd -- * * This function implements the 'tcl::process status' Tcl command. * Refer to the user documentation for details on what it does. * * Results: * Returns a standard Tcl result. * * Side effects: * Access to the internal structures is protected by infoTablesMutex. * Calls RefreshProcessInfo, which can block if -wait switch is given. * *---------------------------------------------------------------------- */ static int ProcessStatusObjCmd( ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Obj *dict; int index, options = WNOHANG; Tcl_HashEntry *entry; Tcl_HashSearch search; ProcessInfo *info; int numPids; Tcl_Obj **pidObjs; int result; int i; int pid; Tcl_Obj *const *savedobjv = objv; static const char *const switches[] = { "-wait", "--", NULL }; enum switches { STATUS_WAIT, STATUS_LAST }; while (objc > 1) { if (TclGetString(objv[1])[0] != '-') { break; } if (Tcl_GetIndexFromObj(interp, objv[1], switches, "switches", 0, &index) != TCL_OK) { return TCL_ERROR; } ++objv; --objc; if (STATUS_WAIT == (enum switches) index) { options = 0; } else { break; } } if (objc != 1 && objc != 2) { Tcl_WrongNumArgs(interp, 1, savedobjv, "?switches? ?pids?"); return TCL_ERROR; } if (objc == 1) { /* * Return a dict with all child process statuses. */ dict = Tcl_NewDictObj(); Tcl_MutexLock(&infoTablesMutex); for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); entry != NULL; entry = Tcl_NextHashEntry(&search)) { info = (ProcessInfo *) Tcl_GetHashValue(entry); RefreshProcessInfo(info, options); if (info->purge && autopurge) { /* * Purge entry. */ Tcl_DeleteHashEntry(entry); entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); Tcl_DeleteHashEntry(entry); FreeProcessInfo(info); } else { /* * Add to result. */ Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid), BuildProcessStatusObj(info)); } } Tcl_MutexUnlock(&infoTablesMutex); } else { /* * Only return statuses of provided processes. */ result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs); if (result != TCL_OK) { return result; } dict = Tcl_NewDictObj(); Tcl_MutexLock(&infoTablesMutex); for (i = 0; i < numPids; i++) { result = Tcl_GetIntFromObj(interp, pidObjs[i], (int *) &pid); if (result != TCL_OK) { Tcl_MutexUnlock(&infoTablesMutex); Tcl_DecrRefCount(dict); return result; } entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(pid)); if (!entry) { /* * Skip unknown process. */ continue; } info = (ProcessInfo *) Tcl_GetHashValue(entry); RefreshProcessInfo(info, options); if (info->purge && autopurge) { /* * Purge entry. */ Tcl_DeleteHashEntry(entry); entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); Tcl_DeleteHashEntry(entry); FreeProcessInfo(info); } else { /* * Add to result. */ Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid), BuildProcessStatusObj(info)); } } Tcl_MutexUnlock(&infoTablesMutex); } Tcl_SetObjResult(interp, dict); return TCL_OK; } /*---------------------------------------------------------------------- * * ProcessPurgeObjCmd -- * * This function implements the 'tcl::process purge' Tcl command. * Refer to the user documentation for details on what it does. * * Results: * Returns a standard Tcl result. * * Side effects: * Frees all ProcessInfo structures with their purge flag set. * *---------------------------------------------------------------------- */ static int ProcessPurgeObjCmd( ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_HashEntry *entry; Tcl_HashSearch search; ProcessInfo *info; int numPids; Tcl_Obj **pidObjs; int result; int i; int pid; if (objc != 1 && objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "?pids?"); return TCL_ERROR; } /* * First reap detached procs so that their purge flag is up-to-date. */ Tcl_ReapDetachedProcs(); if (objc == 1) { /* * Purge all terminated processes. */ Tcl_MutexLock(&infoTablesMutex); for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); entry != NULL; entry = Tcl_NextHashEntry(&search)) { info = (ProcessInfo *) Tcl_GetHashValue(entry); if (info->purge) { Tcl_DeleteHashEntry(entry); entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); Tcl_DeleteHashEntry(entry); FreeProcessInfo(info); } } Tcl_MutexUnlock(&infoTablesMutex); } else { /* * Purge only provided processes. */ result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs); if (result != TCL_OK) { return result; } Tcl_MutexLock(&infoTablesMutex); for (i = 0; i < numPids; i++) { result = Tcl_GetIntFromObj(interp, pidObjs[i], (int *) &pid); if (result != TCL_OK) { Tcl_MutexUnlock(&infoTablesMutex); return result; } entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(pid)); if (!entry) { /* * Skip unknown process. */ continue; } info = (ProcessInfo *) Tcl_GetHashValue(entry); if (info->purge) { Tcl_DeleteHashEntry(entry); entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); Tcl_DeleteHashEntry(entry); FreeProcessInfo(info); } } Tcl_MutexUnlock(&infoTablesMutex); } return TCL_OK; } /*---------------------------------------------------------------------- * * ProcessAutopurgeObjCmd -- * * This function implements the 'tcl::process autopurge' Tcl command. * Refer to the user documentation for details on what it does. * * Results: * Returns a standard Tcl result. * * Side effects: * Alters detached process handling by Tcl_ReapDetachedProcs(). * *---------------------------------------------------------------------- */ static int ProcessAutopurgeObjCmd( ClientData clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { if (objc != 1 && objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "?flag?"); return TCL_ERROR; } if (objc == 2) { /* * Set given value. */ int flag; int result = Tcl_GetBooleanFromObj(interp, objv[1], &flag); if (result != TCL_OK) { return result; } autopurge = !!flag; } /* * Return current value. */ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(autopurge)); return TCL_OK; } /* *---------------------------------------------------------------------- * * TclInitProcessCmd -- * * This procedure creates the "tcl::process" Tcl command. See the user * documentation for details on what it does. * * Results: * A standard Tcl result. * * Side effects: * See the user documentation. * *---------------------------------------------------------------------- */ Tcl_Command TclInitProcessCmd( Tcl_Interp *interp) /* Current interpreter. */ { static const EnsembleImplMap processImplMap[] = { {"list", ProcessListObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1}, {"status", ProcessStatusObjCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 1}, {"purge", ProcessPurgeObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, {"autopurge", ProcessAutopurgeObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, {NULL, NULL, NULL, NULL, NULL, 0} }; Tcl_Command processCmd; if (infoTablesInitialized == 0) { Tcl_MutexLock(&infoTablesMutex); if (infoTablesInitialized == 0) { Tcl_InitHashTable(&infoTablePerPid, TCL_ONE_WORD_KEYS); Tcl_InitHashTable(&infoTablePerResolvedPid, TCL_ONE_WORD_KEYS); infoTablesInitialized = 1; } Tcl_MutexUnlock(&infoTablesMutex); } processCmd = TclMakeEnsemble(interp, "::tcl::process", processImplMap); Tcl_Export(interp, Tcl_FindNamespace(interp, "::tcl", NULL, 0), "process", 0); return processCmd; } /* *---------------------------------------------------------------------- * * TclProcessCreated -- * * Called when a child process has been created by Tcl. * * Results: * None. * * Side effects: * Internal structures are updated with a new ProcessInfo. * *---------------------------------------------------------------------- */ void TclProcessCreated( Tcl_Pid pid) /* Process id. */ { int resolvedPid; Tcl_HashEntry *entry, *entry2; int isNew; ProcessInfo *info; /* * Get resolved pid first. */ resolvedPid = TclpGetPid(pid); Tcl_MutexLock(&infoTablesMutex); /* * Create entry in pid table. */ entry = Tcl_CreateHashEntry(&infoTablePerPid, pid, &isNew); if (!isNew) { /* * Pid was reused, free old info and reuse structure. */ info = (ProcessInfo *) Tcl_GetHashValue(entry); entry2 = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(resolvedPid)); if (entry2) Tcl_DeleteHashEntry(entry2); FreeProcessInfo(info); } /* * Allocate and initialize info structure. */ info = (ProcessInfo *) ckalloc(sizeof(ProcessInfo)); InitProcessInfo(info, pid, resolvedPid); /* * Add entry to tables. */ Tcl_SetHashValue(entry, info); entry = Tcl_CreateHashEntry(&infoTablePerResolvedPid, INT2PTR(resolvedPid), &isNew); Tcl_SetHashValue(entry, info); Tcl_MutexUnlock(&infoTablesMutex); } /* *---------------------------------------------------------------------- * * TclProcessWait -- * * Wait for process status to change. * * Results: * TclProcessWaitStatus enum value. * * Side effects: * Completed process info structures are purged immediately (autopurge on) * or eventually (autopurge off). * *---------------------------------------------------------------------- */ TclProcessWaitStatus TclProcessWait( Tcl_Pid pid, /* Process id. */ int options, /* Options passed to WaitProcessStatus. */ int *codePtr, /* If non-NULL, will receive either: * - 0 for normal exit. * - errno in case of error. * - non-zero exit code for abormal exit. * - signal number if killed or suspended. * - Tcl_WaitPid status in all other cases. */ Tcl_Obj **msgObjPtr, /* If non-NULL, will receive error message. */ Tcl_Obj **errorObjPtr) /* If non-NULL, will receive error code. */ { Tcl_HashEntry *entry; ProcessInfo *info; TclProcessWaitStatus result; /* * First search for pid in table. */ entry = Tcl_FindHashEntry(&infoTablePerPid, pid); if (!entry) { /* * Unknown process, just call WaitProcessStatus and return. */ result = WaitProcessStatus(pid, TclpGetPid(pid), options, codePtr, msgObjPtr, errorObjPtr); if (msgObjPtr && *msgObjPtr) Tcl_IncrRefCount(*msgObjPtr); if (errorObjPtr && *errorObjPtr) Tcl_IncrRefCount(*errorObjPtr); return result; } info = (ProcessInfo *) Tcl_GetHashValue(entry); if (info->purge) { /* * Process has completed but TclProcessWait has already been called, * so report no change. */ return TCL_PROCESS_UNCHANGED; } RefreshProcessInfo(info, options); if (info->status == TCL_PROCESS_UNCHANGED) { /* * No change, stop there. */ return TCL_PROCESS_UNCHANGED; } /* * Set return values. */ result = info->status; if (codePtr) *codePtr = info->code; if (msgObjPtr) *msgObjPtr = info->msg; if (errorObjPtr) *errorObjPtr = info->error; if (msgObjPtr && *msgObjPtr) Tcl_IncrRefCount(*msgObjPtr); if (errorObjPtr && *errorObjPtr) Tcl_IncrRefCount(*errorObjPtr); if (autopurge) { /* * Purge now. */ Tcl_DeleteHashEntry(entry); entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(info->resolvedPid)); Tcl_DeleteHashEntry(entry); FreeProcessInfo(info); } else { /* * Eventually purge. Subsequent calls will return * TCL_PROCESS_UNCHANGED. */ info->purge = 1; } return result; } |
Changes to generic/tclResult.c.
︙ | ︙ | |||
302 303 304 305 306 307 308 | return iPtr->objResultPtr; } /* *---------------------------------------------------------------------- * | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 302 303 304 305 306 307 308 309 310 311 312 313 314 315 | return iPtr->objResultPtr; } /* *---------------------------------------------------------------------- * * Tcl_AppendResult -- * * Append a variable number of strings onto the interpreter's result. * * Results: * None. * |
︙ | ︙ | |||
360 361 362 363 364 365 366 367 368 | */ void Tcl_AppendResult( Tcl_Interp *interp, ...) { va_list argList; va_start(argList, interp); | > > | > > > > > > > > > > > > | 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 | */ void Tcl_AppendResult( Tcl_Interp *interp, ...) { va_list argList; Tcl_Obj *objPtr; va_start(argList, interp); objPtr = Tcl_GetObjResult(interp); if (Tcl_IsShared(objPtr)) { objPtr = Tcl_DuplicateObj(objPtr); } while (1) { const char *bytes = va_arg(argList, char *); if (bytes == NULL) { break; } Tcl_AppendToObj(objPtr, bytes, -1); } Tcl_SetObjResult(interp, objPtr); va_end(argList); } /* *---------------------------------------------------------------------- * * Tcl_AppendElement -- |
︙ | ︙ | |||
541 542 543 544 545 546 547 | TclFreeIntRep(objResultPtr); } } /* *---------------------------------------------------------------------- * | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 520 521 522 523 524 525 526 527 528 529 530 531 532 533 | TclFreeIntRep(objResultPtr); } } /* *---------------------------------------------------------------------- * * Tcl_SetErrorCode -- * * This function is called to record machine-readable information about * an error that is about to be returned. * * Results: * None. |
︙ | ︙ | |||
604 605 606 607 608 609 610 611 612 613 614 615 616 617 | */ void Tcl_SetErrorCode( Tcl_Interp *interp, ...) { va_list argList; /* * Scan through the arguments one at a time, appending them to the * errorCode field as list elements. */ va_start(argList, interp); | > > | > > > > > > > > > > > > > > | 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 | */ void Tcl_SetErrorCode( Tcl_Interp *interp, ...) { va_list argList; Tcl_Obj *errorObj; /* * Scan through the arguments one at a time, appending them to the * errorCode field as list elements. */ va_start(argList, interp); errorObj = Tcl_NewObj(); /* * Scan through the arguments one at a time, appending them to the * errorCode field as list elements. */ while (1) { char *elem = va_arg(argList, char *); if (elem == NULL) { break; } Tcl_ListObjAppendElement(NULL, errorObj, Tcl_NewStringObj(elem, -1)); } Tcl_SetObjErrorCode(interp, errorObj); va_end(argList); } /* *---------------------------------------------------------------------- * * Tcl_SetObjErrorCode -- |
︙ | ︙ |
Changes to generic/tclScan.c.
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 | /* * tclScan.c -- * * This file contains the implementation of the "scan" command. * * Copyright (c) 1998 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" /* * Flag values used by Tcl_ScanObjCmd. */ #define SCAN_NOSKIP 0x1 /* Don't skip blanks. */ #define SCAN_SUPPRESS 0x2 /* Suppress assignment. */ | > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 | /* * tclScan.c -- * * This file contains the implementation of the "scan" command. * * Copyright (c) 1998 by Scriptics Corporation. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tommath.h" /* * Flag values used by Tcl_ScanObjCmd. */ #define SCAN_NOSKIP 0x1 /* Don't skip blanks. */ #define SCAN_SUPPRESS 0x2 /* Suppress assignment. */ |
︙ | ︙ | |||
411 412 413 414 415 416 417 | case 'g': case 'G': case 'i': case 'o': case 'x': case 'X': case 'b': | < < < < < < < | 412 413 414 415 416 417 418 419 420 421 422 423 424 425 426 | case 'g': case 'G': case 'i': case 'o': case 'x': case 'X': case 'b': case 'u': break; /* * Bracket terms need special checking */ case '[': if (flags & (SCAN_LONGER|SCAN_BIG)) { goto invalidFieldSize; |
︙ | ︙ | |||
881 882 883 884 885 886 887 | break; } case 'c': /* * Scan a single Unicode character. */ | | > > > > > > > > | | 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 | break; } case 'c': /* * 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); CLANG_ASSERT(objs); objs[objIndex++] = objPtr; } break; case 'i': |
︙ | ︙ | |||
920 921 922 923 924 925 926 | string = end; if (flags & SCAN_SUPPRESS) { Tcl_DecrRefCount(objPtr); break; } if (flags & SCAN_LONGER) { if (Tcl_GetWideIntFromObj(NULL, objPtr, &wideValue) != TCL_OK) { | | | | | > > > > > > > > > > > | | 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 | string = end; if (flags & SCAN_SUPPRESS) { Tcl_DecrRefCount(objPtr); break; } if (flags & SCAN_LONGER) { if (Tcl_GetWideIntFromObj(NULL, objPtr, &wideValue) != TCL_OK) { wideValue = LLONG_MAX; if (TclGetString(objPtr)[0] == '-') { wideValue = LLONG_MIN; } } 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 (flags & SCAN_UNSIGNED) { mp_int big; if ((Tcl_GetBignumFromObj(interp, objPtr, &big) != TCL_OK) || mp_isneg(&big)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "unsigned bignum scans are invalid", -1)); Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADUNSIGNED",NULL); return TCL_ERROR; } } } else { 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.
︙ | ︙ | |||
1204 1205 1206 1207 1208 1209 1210 | octalSignificandWide <<= shift; } else { mp_mul_2d(&octalSignificandBig, shift, &octalSignificandBig); } } if (!octalSignificandOverflow) { | | < < < < < < < < < < < < < < | | | | | 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 | 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) { | | < < < < < < < < < < < < < < | | | | | 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 | &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); } |
︙ | ︙ | |||
3992 3993 3994 3995 3996 3997 3998 | * endPtr to point to the terminating '\0' byte of the string. Sets *sign * to 1 if a minus sign should be printed with the number, or 0 if a plus * sign (or no sign) should appear. * * This function is a service routine that produces the string of digits for * floating-point-to-decimal conversion. It can do a number of things * according to the 'flags' argument. Valid values for 'flags' include: | | | < | | 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 3993 3994 | * endPtr to point to the terminating '\0' byte of the string. Sets *sign * to 1 if a minus sign should be printed with the number, or 0 if a plus * sign (or no sign) should appear. * * This function is a service routine that produces the string of digits for * floating-point-to-decimal conversion. It can do a number of things * according to the 'flags' argument. Valid values for 'flags' include: * TCL_DD_SHORTEST - This is the default for floating point conversion. * It constructs the shortest string of * digits that will reconvert to the given number when scanned. * For floating point numbers that are exactly between two * decimal numbers, it resolves using the 'round to even' rule. * With this value, the 'ndigits' parameter is ignored. * TCL_DD_STEELE - This value is not recommended and may be removed in * the future. It follows the conversion algorithm outlined in * "How to Print Floating-Point Numbers Accurately" by Guy * L. Steele, Jr. and Jon L. White [Proc. ACM SIGPLAN '90, * pp. 112-126]. This rule has the effect of rendering 1e23 as * 9.9999999999999999e22 - which is a 'better' approximation in * the sense that it will reconvert correctly even if a * subsequent input conversion is 'round up' or 'round down' * rather than 'round to nearest', but is surprising otherwise. * TCL_DD_E_FORMAT - This value is used to prepare numbers for %e format * conversion. It constructs a string of at most 'ndigits' digits, * choosing the one that is closest to the given number (and * resolving ties with 'round to even'). It is allowed to return * fewer than 'ndigits' if the number converts exactly; if the * TCL_DD_E_FORMAT|TCL_DD_SHORTEN_FLAG is supplied instead, it * also returns fewer digits if the shorter string will still * reconvert without loss to the given input number. In any case, * strings of trailing zeroes are suppressed. |
︙ | ︙ | |||
4658 4659 4660 4661 4662 4663 4664 | TclCeil( const mp_int *a) /* Integer to convert. */ { double r = 0.0; mp_int b; mp_init(&b); | | | 4629 4630 4631 4632 4633 4634 4635 4636 4637 4638 4639 4640 4641 4642 4643 | TclCeil( const mp_int *a) /* Integer to convert. */ { double r = 0.0; mp_int b; mp_init(&b); if (mp_isneg(a)) { mp_neg(a, &b); r = -TclFloor(&b); } else { int bits = mp_count_bits(a); if (bits > DBL_MAX_EXP*log2FLT_RADIX) { r = HUGE_VAL; |
︙ | ︙ | |||
4715 4716 4717 4718 4719 4720 4721 | TclFloor( const mp_int *a) /* Integer to convert. */ { double r = 0.0; mp_int b; mp_init(&b); | | | 4686 4687 4688 4689 4690 4691 4692 4693 4694 4695 4696 4697 4698 4699 4700 | TclFloor( const mp_int *a) /* Integer to convert. */ { double r = 0.0; mp_int b; mp_init(&b); if (mp_isneg(a)) { mp_neg(a, &b); r = -TclCeil(&b); } else { int bits = mp_count_bits(a); if (bits > DBL_MAX_EXP*log2FLT_RADIX) { r = DBL_MAX; |
︙ | ︙ |
Changes to generic/tclStringObj.c.
︙ | ︙ | |||
34 35 36 37 38 39 40 41 42 43 44 45 46 47 | * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tommath.h" #include "tclStringRep.h" /* * Prototypes for functions defined later in this file: */ static void AppendPrintfToObjVA(Tcl_Obj *objPtr, const char *format, va_list argList); static void AppendUnicodeToUnicodeRep(Tcl_Obj *objPtr, | > | 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 | * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ #include "tclInt.h" #include "tommath.h" #include "tclStringRep.h" #include "assert.h" /* * Prototypes for functions defined later in this file: */ static void AppendPrintfToObjVA(Tcl_Obj *objPtr, const char *format, va_list argList); static void AppendUnicodeToUnicodeRep(Tcl_Obj *objPtr, |
︙ | ︙ | |||
136 137 138 139 140 141 142 | char *ptr = NULL; size_t attempt; if (objPtr->bytes == &tclEmptyString) { objPtr->bytes = NULL; } if (flag == 0 || stringPtr->allocated > 0) { | > | < | 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 | char *ptr = NULL; size_t attempt; if (objPtr->bytes == &tclEmptyString) { objPtr->bytes = NULL; } if (flag == 0 || stringPtr->allocated > 0) { if (needed <= STRING_MAXCHARS / 2) { attempt = 2 * needed; ptr = attemptckrealloc(objPtr->bytes, attempt + 1); } if (ptr == NULL) { /* * Take care computing the amount of modest growth to avoid * overflow into invalid argument values for attempt. */ |
︙ | ︙ | |||
186 187 188 189 190 191 192 | size_t attempt; if (stringPtr->maxChars > 0) { /* * Subsequent appends - apply the growth algorithm. */ | > | < | 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 | size_t attempt; if (stringPtr->maxChars > 0) { /* * Subsequent appends - apply the growth algorithm. */ if (needed <= STRING_MAXCHARS / 2) { attempt = 2 * needed; ptr = stringAttemptRealloc(stringPtr, attempt); } if (ptr == NULL) { /* * Take care computing the amount of modest growth to avoid * overflow into invalid argument values for attempt. */ |
︙ | ︙ | |||
414 415 416 417 418 419 420 | if ((objPtr->bytes) && (objPtr->length < 2)) { /* 0 bytes -> 0 chars; 1 byte -> 1 char */ return objPtr->length; } /* | | | > > > | > > | 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 | 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; |
︙ | ︙ | |||
472 473 474 475 476 477 478 | * from. */ int index) /* Get the index'th Unicode character. */ { String *stringPtr; /* * Optimize the case where we're really dealing with a bytearray object | < | | 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 | * from. */ int index) /* Get the index'th Unicode character. */ { String *stringPtr; /* * Optimize the case where we're really dealing with a bytearray object * we don't need to convert to a string to perform the indexing operation. */ if (TclIsPureByteArray(objPtr)) { unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, NULL); return (Tcl_UniChar) bytes[index]; } |
︙ | ︙ | |||
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. |
︙ | ︙ | |||
606 607 608 609 610 611 612 | int last) /* Last index of the range. */ { Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */ String *stringPtr; /* * Optimize the case where we're really dealing with a bytearray object | < | | 611 612 613 614 615 616 617 618 619 620 621 622 623 624 625 | int last) /* Last index of the range. */ { Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */ String *stringPtr; /* * Optimize the case where we're really dealing with a bytearray object * we don't need to convert to a string to perform the substring operation. */ if (TclIsPureByteArray(objPtr)) { unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, NULL); return Tcl_NewByteArrayObj(bytes+first, last-first+1); } |
︙ | ︙ | |||
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 -- | > > > > > > > > > > > | 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 | 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 -- |
︙ | ︙ | |||
1205 1206 1207 1208 1209 1210 1211 | if (appendObjPtr->bytes == &tclEmptyString) { return; } /* * Handle append of one bytearray object to another as a special case. | | > | < | 1220 1221 1222 1223 1224 1225 1226 1227 1228 1229 1230 1231 1232 1233 1234 1235 1236 | if (appendObjPtr->bytes == &tclEmptyString) { return; } /* * Handle append of one bytearray object to another as a special case. * Note that we only do this when the objects are pure so that the * bytearray faithfully represent the true value; Otherwise * appending the byte arrays together could lose information; */ if ((TclIsPureByteArray(objPtr) || objPtr->bytes == &tclEmptyString) && TclIsPureByteArray(appendObjPtr)) { /* * You might expect the code here to be |
︙ | ︙ | |||
1552 1553 1554 1555 1556 1557 1558 | objPtr->bytes[newLength] = 0; objPtr->length = newLength; } /* *---------------------------------------------------------------------- * | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 1567 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 | objPtr->bytes[newLength] = 0; objPtr->length = newLength; } /* *---------------------------------------------------------------------- * * Tcl_AppendStringsToObj -- * * This function appends one or more null-terminated strings to an * object. * * Results: * None. |
︙ | ︙ | |||
1612 1613 1614 1615 1616 1617 1618 | Tcl_AppendStringsToObj( Tcl_Obj *objPtr, ...) { va_list argList; va_start(argList, objPtr); | > | > > > > > > > > > > | 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 | Tcl_AppendStringsToObj( Tcl_Obj *objPtr, ...) { va_list argList; va_start(argList, objPtr); if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_AppendStringsToObj"); } while (1) { const char *bytes = va_arg(argList, char *); if (bytes == NULL) { break; } Tcl_AppendToObj(objPtr, bytes, -1); } va_end(argList); } /* *---------------------------------------------------------------------- * * Tcl_AppendFormatToObj -- |
︙ | ︙ | |||
1866 1867 1868 1869 1870 1871 1872 | } else { useWide = 1; #endif } } else if (ch == 'I') { if ((format[1] == '6') && (format[2] == '4')) { format += (step + 2); | | | | | | < < | < < < < < < < < | 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 | } 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') || (ch == 'q') || (ch == 'j') || (ch == 'L')) { format += step; step = TclUtfToUniChar(format, &ch); useBig = 1; } format += step; span = format; /* * Step 6. The actual conversion character. |
︙ | ︙ | |||
1936 1937 1938 1939 1940 1941 1942 | segment = Tcl_NewStringObj(buf, length); Tcl_IncrRefCount(segment); allocSegment = 1; break; } case 'u': | < < < < < > | > > > > > > > > > > > | | > | > > > > | < < < < < > | 1915 1916 1917 1918 1919 1920 1921 1922 1923 1924 1925 1926 1927 1928 1929 1930 1931 1932 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 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 1987 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 | segment = Tcl_NewStringObj(buf, length); Tcl_IncrRefCount(segment); allocSegment = 1; break; } case 'u': case 'd': case 'o': case 'p': case 'x': case 'X': case 'b': { short s = 0; /* Silence compiler warning; only defined and * used when useShort is true. */ long l; Tcl_WideInt w; mp_int big; int toAppend, isNegative = 0; #ifndef TCL_WIDE_INT_IS_LONG if (ch == 'p') { useWide = 1; } #endif if (useBig) { int cmpResult; if (Tcl_GetBignumFromObj(interp, segment, &big) != TCL_OK) { goto error; } cmpResult = mp_cmp_d(&big, 0); isNegative = (cmpResult == MP_LT); if (cmpResult == MP_EQ) gotHash = 0; if (ch == 'u') { if (isNegative) { msg = "unsigned bignum format is invalid"; errCode = "BADUNSIGNED"; goto errorMsg; } else { ch = 'd'; } } #ifndef TCL_WIDE_INT_IS_LONG } else if (useWide) { if (TclGetWideIntFromObj(NULL, segment, &w) != TCL_OK) { Tcl_Obj *objPtr; if (Tcl_GetBignumFromObj(interp,segment,&big) != TCL_OK) { goto error; } mp_mod_2d(&big, (int) CHAR_BIT*sizeof(Tcl_WideInt), &big); objPtr = Tcl_NewBignumObj(&big); Tcl_IncrRefCount(objPtr); TclGetWideIntFromObj(NULL, objPtr, &w); Tcl_DecrRefCount(objPtr); } isNegative = (w < (Tcl_WideInt) 0); if (w == (Tcl_WideInt) 0) gotHash = 0; #endif } else if (TclGetLongFromObj(NULL, segment, &l) != TCL_OK) { if (TclGetWideIntFromObj(NULL, segment, &w) != TCL_OK) { Tcl_Obj *objPtr; if (Tcl_GetBignumFromObj(interp,segment,&big) != TCL_OK) { goto error; } mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big); objPtr = Tcl_NewBignumObj(&big); Tcl_IncrRefCount(objPtr); TclGetLongFromObj(NULL, objPtr, &l); Tcl_DecrRefCount(objPtr); } else { l = Tcl_WideAsLong(w); } if (useShort) { s = (short) l; isNegative = (s < (short) 0); if (s == (short) 0) gotHash = 0; } else { isNegative = (l < (long) 0); if (l == (long) 0) gotHash = 0; } } else if (useShort) { s = (short) l; isNegative = (s < (short) 0); if (s == (short) 0) gotHash = 0; } else { isNegative = (l < (long) 0); if (l == (long) 0) gotHash = 0; } segment = Tcl_NewObj(); allocSegment = 1; segmentLimit = INT_MAX; Tcl_IncrRefCount(segment); if ((isNegative || gotPlus || gotSpace) && (useBig || ch=='d')) { Tcl_AppendToObj(segment, (isNegative ? "-" : gotPlus ? "+" : " "), 1); segmentLimit -= 1; } if (gotHash || (ch == 'p')) { switch (ch) { case 'o': Tcl_AppendToObj(segment, "0o", 2); segmentLimit -= 2; break; case 'p': case 'x': case 'X': Tcl_AppendToObj(segment, "0x", 2); segmentLimit -= 2; break; case 'b': Tcl_AppendToObj(segment, "0b", 2); segmentLimit -= 2; break; |
︙ | ︙ | |||
2176 2177 2178 2179 2180 2181 2182 | } } /* * Need to be sure zero becomes "0", not "". */ | | | 2163 2164 2165 2166 2167 2168 2169 2170 2171 2172 2173 2174 2175 2176 2177 | } } /* * Need to be sure zero becomes "0", not "". */ if (numDigits == 0) { numDigits = 1; } pure = Tcl_NewObj(); Tcl_SetObjLength(pure, (int) numDigits); bytes = TclGetString(pure); toAppend = length = (int) numDigits; while (numDigits--) { |
︙ | ︙ | |||
2243 2244 2245 2246 2247 2248 2249 2250 2251 2252 2253 2254 2255 2256 | break; } } break; } case 'e': case 'E': case 'f': case 'g': case 'G': { #define MAX_FLOAT_SIZE 320 char spec[2*TCL_INTEGER_SPACE + 9], *p = spec; | > > | 2230 2231 2232 2233 2234 2235 2236 2237 2238 2239 2240 2241 2242 2243 2244 2245 | break; } } break; } case 'a': case 'A': case 'e': case 'E': case 'f': case 'g': case 'G': { #define MAX_FLOAT_SIZE 320 char spec[2*TCL_INTEGER_SPACE + 9], *p = spec; |
︙ | ︙ | |||
2310 2311 2312 2313 2314 2315 2316 2317 2318 2319 2320 2321 2322 2323 | goto errorMsg; } bytes = TclGetString(segment); if (!Tcl_AttemptSetObjLength(segment, sprintf(bytes, spec, d))) { msg = overflow; errCode = "OVERFLOW"; goto errorMsg; } break; } default: if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad field specifier \"%c\"", ch)); | > > > > > > | 2299 2300 2301 2302 2303 2304 2305 2306 2307 2308 2309 2310 2311 2312 2313 2314 2315 2316 2317 2318 | goto errorMsg; } bytes = TclGetString(segment); if (!Tcl_AttemptSetObjLength(segment, sprintf(bytes, spec, d))) { msg = overflow; errCode = "OVERFLOW"; goto errorMsg; } if (ch == 'A') { char *p = TclGetString(segment) + 1; *p = 'x'; p = strchr(p, 'P'); if (p) *p = 'p'; } break; } default: if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad field specifier \"%c\"", ch)); |
︙ | ︙ | |||
2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 | Tcl_ListObjAppendElement(NULL, list, Tcl_NewLongObj( va_arg(argList, long))); break; case 2: Tcl_ListObjAppendElement(NULL, list, Tcl_NewWideIntObj( va_arg(argList, Tcl_WideInt))); break; } break; case 'e': case 'E': case 'f': case 'g': case 'G': Tcl_ListObjAppendElement(NULL, list, Tcl_NewDoubleObj( | > > > > > > > > > > | > < | 2511 2512 2513 2514 2515 2516 2517 2518 2519 2520 2521 2522 2523 2524 2525 2526 2527 2528 2529 2530 2531 2532 2533 2534 2535 2536 2537 2538 2539 2540 2541 2542 2543 2544 2545 2546 2547 2548 2549 2550 2551 2552 2553 2554 2555 2556 2557 2558 2559 2560 2561 2562 2563 | Tcl_ListObjAppendElement(NULL, list, Tcl_NewLongObj( va_arg(argList, long))); break; case 2: Tcl_ListObjAppendElement(NULL, list, Tcl_NewWideIntObj( va_arg(argList, Tcl_WideInt))); break; case 3: Tcl_ListObjAppendElement(NULL, list, Tcl_NewBignumObj( va_arg(argList, mp_int *))); break; } break; case 'a': case 'A': case 'e': case 'E': case 'f': case 'g': case 'G': if (size > 0) { Tcl_ListObjAppendElement(NULL, list, Tcl_NewDoubleObj( (double)va_arg(argList, long double))); } else { Tcl_ListObjAppendElement(NULL, list, Tcl_NewDoubleObj( va_arg(argList, double))); } seekingConversion = 0; break; case '*': lastNum = (int) va_arg(argList, int); Tcl_ListObjAppendElement(NULL, list, Tcl_NewIntObj(lastNum)); p++; break; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': { char *end; lastNum = (int) strtoul(p, &end, 10); p = end; break; } case '.': gotPrecision = 1; p++; break; case 'l': ++size; p++; break; case 't': case 'z': if (sizeof(size_t) == sizeof(Tcl_WideInt)) { |
︙ | ︙ | |||
2571 2572 2573 2574 2575 2576 2577 2578 2579 2580 2581 2582 2583 2584 | size = 2; } else if (p[1]=='3' && p[2]=='2') { p += 2; } else if (sizeof(size_t) == sizeof(Tcl_WideInt)) { size = 2; } p++; break; case 'h': size = -1; default: p++; } } while (seekingConversion); | > > > > | 2576 2577 2578 2579 2580 2581 2582 2583 2584 2585 2586 2587 2588 2589 2590 2591 2592 2593 | size = 2; } else if (p[1]=='3' && p[2]=='2') { p += 2; } else if (sizeof(size_t) == sizeof(Tcl_WideInt)) { size = 2; } p++; break; case 'L': size = 3; p++; break; case 'h': size = -1; default: p++; } } while (seekingConversion); |
︙ | ︙ | |||
2685 2686 2687 2688 2689 2690 2691 | *--------------------------------------------------------------------------- * * TclStringRepeat -- * * Performs the [string repeat] function. * * Results: | > | < | < > | > | 2694 2695 2696 2697 2698 2699 2700 2701 2702 2703 2704 2705 2706 2707 2708 2709 2710 2711 2712 2713 2714 2715 2716 2717 2718 2719 2720 2721 2722 2723 2724 2725 | *--------------------------------------------------------------------------- * * TclStringRepeat -- * * Performs the [string repeat] function. * * Results: * A (Tcl_Obj *) pointing to the result value, or NULL in case of an * error. * * Side effects: * On error, when interp is not NULL, error information is left in it. * *--------------------------------------------------------------------------- */ Tcl_Obj * TclStringRepeat( Tcl_Interp *interp, Tcl_Obj *objPtr, int count, int flags) { Tcl_Obj *objResultPtr; int inPlace = flags & TCL_STRING_IN_PLACE; int length = 0, unichar = 0, done = 1; int binary = TclIsPureByteArray(objPtr); /* assert (count >= 2) */ /* * Analyze to determine what representation result should be. |
︙ | ︙ | |||
2736 2737 2738 2739 2740 2741 2742 | } else { /* Result will be concat of string reps. Pre-size it. */ Tcl_GetStringFromObj(objPtr, &length); } if (length == 0) { /* Any repeats of empty is empty. */ | < | | | | | | | | | | | < | > | < | < > | < < > > | < > > | < < < | | | | | | | < | 2746 2747 2748 2749 2750 2751 2752 2753 2754 2755 2756 2757 2758 2759 2760 2761 2762 2763 2764 2765 2766 2767 2768 2769 2770 2771 2772 2773 2774 2775 2776 2777 2778 2779 2780 2781 2782 2783 2784 2785 2786 2787 2788 2789 2790 2791 2792 2793 2794 2795 2796 2797 2798 2799 2800 2801 2802 2803 2804 2805 2806 2807 2808 2809 2810 2811 2812 2813 2814 2815 2816 2817 2818 2819 2820 2821 2822 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 2853 2854 2855 2856 2857 2858 2859 2860 2861 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 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 | } else { /* Result will be concat of string reps. Pre-size it. */ Tcl_GetStringFromObj(objPtr, &length); } if (length == 0) { /* Any repeats of empty is empty. */ return objPtr; } if (count > INT_MAX/length) { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "max size for a Tcl value (%d bytes) exceeded", INT_MAX)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); } return NULL; } if (binary) { /* Efficiently produce a pure byte array result */ objResultPtr = (!inPlace || Tcl_IsShared(objPtr)) ? Tcl_DuplicateObj(objPtr) : objPtr; Tcl_SetByteArrayLength(objResultPtr, count*length); /* PANIC? */ Tcl_SetByteArrayLength(objResultPtr, length); while (count - done > done) { Tcl_AppendObjToObj(objResultPtr, objResultPtr); done *= 2; } TclAppendBytesToByteArray(objResultPtr, Tcl_GetByteArrayFromObj(objResultPtr, NULL), (count - done) * length); } else if (unichar) { /* Efficiently produce a pure Tcl_UniChar array result */ if (!inPlace || Tcl_IsShared(objPtr)) { objResultPtr = Tcl_NewUnicodeObj(Tcl_GetUnicode(objPtr), length); } else { TclInvalidateStringRep(objPtr); objResultPtr = objPtr; } if (0 == Tcl_AttemptSetObjLength(objResultPtr, count*length)) { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "string size overflow: unable to alloc %" TCL_Z_MODIFIER "u bytes", STRING_SIZE(count*length))); Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); } return NULL; } Tcl_SetObjLength(objResultPtr, length); while (count - done > done) { Tcl_AppendObjToObj(objResultPtr, objResultPtr); done *= 2; } Tcl_AppendUnicodeToObj(objResultPtr, Tcl_GetUnicode(objResultPtr), (count - done) * length); } else { /* Efficiently concatenate string reps */ if (!inPlace || Tcl_IsShared(objPtr)) { objResultPtr = Tcl_NewStringObj(Tcl_GetString(objPtr), length); } else { TclFreeIntRep(objPtr); objResultPtr = objPtr; } if (0 == Tcl_AttemptSetObjLength(objResultPtr, count*length)) { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "string size overflow: unable to alloc %u bytes", count*length)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); } return NULL; } Tcl_SetObjLength(objResultPtr, length); while (count - done > done) { Tcl_AppendObjToObj(objResultPtr, objResultPtr); done *= 2; } Tcl_AppendToObj(objResultPtr, Tcl_GetString(objResultPtr), (count - done) * length); } return objResultPtr; } /* *--------------------------------------------------------------------------- * * TclStringCat -- * * Performs the [string cat] function. * * Results: * A (Tcl_Obj *) pointing to the result value, or NULL in case of an * error. * * Side effects: * On error, when interp is not NULL, error information is left in it. * *--------------------------------------------------------------------------- */ Tcl_Obj * TclStringCat( Tcl_Interp *interp, int objc, Tcl_Obj * const objv[], int flags) { Tcl_Obj *objResultPtr, * const *ov; int oc, length = 0, binary = 1; int allowUniChar = 1, requestUniChar = 0; int first = objc - 1; /* Index of first value possibly not empty */ int last = 0; /* Index of last value possibly not empty */ int inPlace = flags & TCL_STRING_IN_PLACE; /* assert ( objc >= 0 ) */ if (objc <= 1) { /* Only one or no objects; return first or empty */ return objc ? objv[0] : Tcl_NewObj(); } /* assert ( objc >= 2 ) */ /* * Analyze to determine what representation result should be. * GOALS: Avoid shimmering & string rep generation. * Produce pure bytearray when possible. * Error on overflow. */ ov = objv, oc = objc; do { Tcl_Obj *objPtr = *ov++; if (TclIsPureByteArray(objPtr)) { allowUniChar = 0; } else if (objPtr->bytes) { /* Value has a string rep. */ if (objPtr->length) { /* * Non-empty string rep. Not a pure bytearray, so we * won't create a pure bytearray */ binary = 0; if ((objPtr->typePtr) && (objPtr->typePtr != &tclStringType)) { /* Prevent shimmer of non-string types. */ allowUniChar = 0; } } } else { /* assert (objPtr->typePtr != NULL) -- stork! */ binary = 0; if (objPtr->typePtr == &tclStringType) { /* Have a pure Unicode value; ask to preserve it */ requestUniChar = 1; } else { /* Have another type; prevent shimmer */ allowUniChar = 0; } } } while (--oc && (binary || allowUniChar)); if (binary) { /* Result will be pure byte array. Pre-size it */ ov = objv; oc = objc; |
︙ | ︙ | |||
3031 3032 3033 3034 3035 3036 3037 | --oc; } } if (last <= first /*|| length == 0 */) { /* Only one non-empty value or zero length; return first */ /* NOTE: (length == 0) implies (last <= first) */ | | < | 3036 3037 3038 3039 3040 3041 3042 3043 3044 3045 3046 3047 3048 3049 3050 | --oc; } } if (last <= first /*|| length == 0 */) { /* Only one non-empty value or zero length; return first */ /* NOTE: (length == 0) implies (last <= first) */ return objv[first]; } objv += first; objc = (last - first + 1); if (binary) { /* Efficiently produce a pure byte array result */ unsigned char *dst; |
︙ | ︙ | |||
3082 3083 3084 3085 3086 3087 3088 | /* Ugly interface! Force resize of the unicode array. */ Tcl_GetUnicodeFromObj(objResultPtr, &start); Tcl_InvalidateStringRep(objResultPtr); if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "concatenation failed: unable to alloc %" | | | | | | | | 3086 3087 3088 3089 3090 3091 3092 3093 3094 3095 3096 3097 3098 3099 3100 3101 3102 3103 3104 3105 3106 3107 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 | /* Ugly interface! Force resize of the unicode array. */ Tcl_GetUnicodeFromObj(objResultPtr, &start); Tcl_InvalidateStringRep(objResultPtr); if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "concatenation failed: unable to alloc %" TCL_Z_MODIFIER "u bytes", STRING_SIZE(length))); Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); } return NULL; } dst = Tcl_GetUnicode(objResultPtr) + start; } else { Tcl_UniChar ch = 0; /* Ugly interface! No scheme to init array size. */ objResultPtr = Tcl_NewUnicodeObj(&ch, 0); /* PANIC? */ if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { Tcl_DecrRefCount(objResultPtr); if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "concatenation failed: unable to alloc %" TCL_Z_MODIFIER "u bytes", STRING_SIZE(length))); Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); } return NULL; } dst = Tcl_GetUnicode(objResultPtr); } while (objc--) { Tcl_Obj *objPtr = *objv++; if ((objPtr->bytes == NULL) || (objPtr->length)) { |
︙ | ︙ | |||
3134 3135 3136 3137 3138 3139 3140 | if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "concatenation failed: unable to alloc %u bytes", length)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); } | | | | < | | | > > > < | < | | < > > > > > > | < > > > > < < | | > | > | | | < | < < < < < < < > | < | < > | < | | < | 3138 3139 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 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 3197 3198 3199 3200 3201 3202 3203 3204 3205 3206 3207 3208 3209 3210 3211 3212 3213 3214 3215 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 3230 3231 3232 3233 3234 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 3250 3251 3252 3253 3254 3255 3256 3257 3258 3259 3260 3261 3262 3263 3264 3265 3266 3267 3268 3269 3270 3271 3272 3273 3274 3275 3276 3277 3278 3279 3280 3281 3282 3283 3284 | if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "concatenation failed: unable to alloc %u bytes", length)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); } return NULL; } dst = Tcl_GetString(objResultPtr) + start; /* assert ( length > start ) */ TclFreeIntRep(objResultPtr); } else { objResultPtr = Tcl_NewObj(); /* PANIC? */ if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { Tcl_DecrRefCount(objResultPtr); if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "concatenation failed: unable to alloc %u bytes", length)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); } return NULL; } dst = Tcl_GetString(objResultPtr); } while (objc--) { Tcl_Obj *objPtr = *objv++; if ((objPtr->bytes == NULL) || (objPtr->length)) { int more; char *src = Tcl_GetStringFromObj(objPtr, &more); memcpy(dst, src, (size_t) more); dst += more; } } } return objResultPtr; overflow: if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "max size for a Tcl value (%d bytes) exceeded", INT_MAX)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); } return NULL; } /* *--------------------------------------------------------------------------- * * TclStringFirst -- * * Implements the [string first] operation. * * Results: * If needle is found as a substring of haystack, the index of the * first instance of such a find is returned. If needle is not present * as a substring of haystack, -1 is returned. * * Side effects: * needle and haystack may have their Tcl_ObjType changed. * *--------------------------------------------------------------------------- */ int TclStringFirst( Tcl_Obj *needle, Tcl_Obj *haystack, int start) { int lh, ln = Tcl_GetCharLength(needle); if (start < 0) { start = 0; } if (ln == 0) { /* We don't find empty substrings. Bizarre! * Whenever this routine is turned into a proper substring * finder, change to `return start` after limits imposed. */ return -1; } if (TclIsPureByteArray(needle) && TclIsPureByteArray(haystack)) { unsigned char *end, *try, *bh; unsigned char *bn = Tcl_GetByteArrayFromObj(needle, &ln); /* Find bytes in bytes */ bh = Tcl_GetByteArrayFromObj(haystack, &lh); end = bh + lh; try = bh + start; while (try + ln <= end) { /* * Look for the leading byte of the needle in the haystack * starting at try and stopping when there's not enough room * for the needle left. */ try = memchr(try, bn[0], (end + 1 - ln) - try); if (try == NULL) { /* Leading byte not found -> needle cannot be found. */ return -1; } /* Leading byte found, check rest of needle. */ if (0 == memcmp(try+1, bn+1, ln-1)) { /* Checks! Return the successful index. */ return (try - bh); } /* Rest of needle match failed; Iterate to continue search. */ try++; } return -1; } /* * TODO: It might be nice to support some cases where it is not * necessary to shimmer to &tclStringType to compute the result, * and instead operate just on the objPtr->bytes values directly. * However, we also do not want the answer to change based on the * code pathway, or if it does we want that to be for some values * we explicitly decline to support. Getting there will involve * locking down in practice more firmly just what encodings produce * what supported results for the objPtr->bytes values. For now, * do only the well-defined Tcl_UniChar array search. */ { Tcl_UniChar *try, *end, *uh; Tcl_UniChar *un = Tcl_GetUnicodeFromObj(needle, &ln); uh = Tcl_GetUnicodeFromObj(haystack, &lh); end = uh + lh; for (try = uh + start; try + ln <= end; try++) { if ((*try == *un) && (0 == memcmp(try + 1, un + 1, (ln-1) * sizeof(Tcl_UniChar)))) { return (try - uh); } } return -1; } } /* *--------------------------------------------------------------------------- |
︙ | ︙ | |||
3305 3306 3307 3308 3309 3310 3311 | int lh, ln = Tcl_GetCharLength(needle); if (ln == 0) { /* * We don't find empty substrings. Bizarre! * * TODO: When we one day make this a true substring | | > > > > | > | < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < | < < | | | | | 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 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 3351 3352 3353 3354 3355 3356 3357 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 3373 3374 3375 3376 | int lh, ln = Tcl_GetCharLength(needle); if (ln == 0) { /* * We don't find empty substrings. Bizarre! * * TODO: When we one day make this a true substring * finder, change this to "return last", after limitation. */ return -1; } lh = Tcl_GetCharLength(haystack); if (last >= lh) { last = lh - 1; } if (last < ln - 1) { return -1; } if (TclIsPureByteArray(needle) && TclIsPureByteArray(haystack)) { unsigned char *try, *bh = Tcl_GetByteArrayFromObj(haystack, &lh); unsigned char *bn = Tcl_GetByteArrayFromObj(needle, &ln); try = bh + last + 1 - ln; while (try >= bh) { if ((*try == bn[0]) && (0 == memcmp(try+1, bn+1, ln-1))) { return (try - bh); } try--; } return -1; } { Tcl_UniChar *try, *uh = Tcl_GetUnicodeFromObj(haystack, &lh); Tcl_UniChar *un = Tcl_GetUnicodeFromObj(needle, &ln); try = uh + last + 1 - ln; while (try >= uh) { if ((*try == un[0]) && (0 == memcmp(try+1, un+1, (ln-1)*sizeof(Tcl_UniChar)))) { return (try - uh); } try--; } return -1; } } /* *--------------------------------------------------------------------------- * * TclStringReverse -- * * Implements the [string reverse] operation. * * Results: * A Tcl value which is the [string reverse] of the argument supplied. * When sharing rules permit and the caller requests, the returned value * might be the argument with modifications done in place. * * Side effects: * May allocate a new Tcl_Obj. * *--------------------------------------------------------------------------- */ |
︙ | ︙ | |||
3419 3420 3421 3422 3423 3424 3425 | while (--src >= from) { *to++ = *src; } } } Tcl_Obj * | | | > > | | < | 3393 3394 3395 3396 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 3431 3432 3433 3434 3435 3436 3437 3438 3439 3440 | while (--src >= from) { *to++ = *src; } } } Tcl_Obj * TclStringReverse( Tcl_Obj *objPtr, int flags) { String *stringPtr; Tcl_UniChar ch = 0; int inPlace = flags & TCL_STRING_IN_PLACE; if (TclIsPureByteArray(objPtr)) { int numBytes; unsigned char *from = Tcl_GetByteArrayFromObj(objPtr, &numBytes); if (!inPlace || Tcl_IsShared(objPtr)) { objPtr = Tcl_NewByteArrayObj(NULL, numBytes); } ReverseBytes(Tcl_GetByteArrayFromObj(objPtr, NULL), from, numBytes); return objPtr; } SetStringFromAny(NULL, objPtr); stringPtr = GET_STRING(objPtr); if (stringPtr->hasUnicode) { Tcl_UniChar *from = Tcl_GetUnicode(objPtr); Tcl_UniChar *src = from + stringPtr->numChars; if (!inPlace || Tcl_IsShared(objPtr)) { Tcl_UniChar *to; /* * Create a non-empty, pure unicode value, so we can coax * Tcl_SetObjLength into growing the unicode rep buffer. */ objPtr = Tcl_NewUnicodeObj(&ch, 1); Tcl_SetObjLength(objPtr, stringPtr->numChars); to = Tcl_GetUnicode(objPtr); while (--src >= from) { *to++ = *src; } } else { |
︙ | ︙ | |||
3473 3474 3475 3476 3477 3478 3479 | } if (objPtr->bytes) { int numChars = stringPtr->numChars; int numBytes = objPtr->length; char *to, *from = objPtr->bytes; | | | 3448 3449 3450 3451 3452 3453 3454 3455 3456 3457 3458 3459 3460 3461 3462 | } if (objPtr->bytes) { int numChars = stringPtr->numChars; int numBytes = objPtr->length; char *to, *from = objPtr->bytes; if (!inPlace || Tcl_IsShared(objPtr)) { objPtr = Tcl_NewObj(); Tcl_SetObjLength(objPtr, numBytes); } to = objPtr->bytes; if (numChars < numBytes) { /* |
︙ | ︙ | |||
3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 | return objPtr; } /* *--------------------------------------------------------------------------- * * FillUnicodeRep -- * * Populate the Unicode internal rep with the Unicode form of its string * rep. The object must alread have a "String" internal rep. * * Results: * None. | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 3495 3496 3497 3498 3499 3500 3501 3502 3503 3504 3505 3506 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 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 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 3585 3586 3587 3588 3589 3590 3591 3592 3593 3594 3595 3596 3597 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 3629 3630 3631 3632 3633 3634 3635 3636 3637 3638 3639 3640 3641 3642 3643 3644 3645 3646 3647 3648 3649 3650 3651 3652 | return objPtr; } /* *--------------------------------------------------------------------------- * * TclStringReplace -- * * Implements the inner engine of the [string replace] command. * * The result is a concatenation of a prefix from objPtr, characters * 0 through first-1, the insertPtr string value, and a suffix from * objPtr, characters from first + count to the end. The effect is * as if the inner substring of characters first through first+count-1 * are removed and replaced with insertPtr. * If insertPtr is NULL, it is treated as an empty string. * When passed the flag TCL_STRING_IN_PLACE, this routine will try * to do the work within objPtr, so long as no sharing forbids it. * Without that request, or as needed, a new Tcl value will be allocated * to be the result. * * Results: * A Tcl value that is the result of the substring replacement. * May return NULL in case of an error. When NULL is returned and * interp is non-NULL, error information is left in interp * *--------------------------------------------------------------------------- */ Tcl_Obj * TclStringReplace( Tcl_Interp *interp, /* For error reporting, may be NULL */ Tcl_Obj *objPtr, /* String to act upon */ int first, /* First index to replace */ int count, /* How many chars to replace */ Tcl_Obj *insertPtr, /* Replacement string, may be NULL */ int flags) /* TCL_STRING_IN_PLACE => attempt in-place */ { int inPlace = flags & TCL_STRING_IN_PLACE; Tcl_Obj *result; /* Caller is expected to pass sensible arguments */ assert ( count >= 0 ) ; assert ( first >= 0 ) ; /* Replace nothing with nothing */ if ((insertPtr == NULL) && (count == 0)) { if (inPlace) { return objPtr; } else { return Tcl_DuplicateObj(objPtr); } } /* * The caller very likely had to call Tcl_GetCharLength() or similar * to be able to process index values. This means it is like that * objPtr is either a proper "bytearray" or a "string" or else it has * a known and short string rep. */ if (TclIsPureByteArray(objPtr)) { int numBytes; unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &numBytes); if (insertPtr == NULL) { /* Replace something with nothing. */ assert ( first <= numBytes ) ; assert ( count <= numBytes ) ; assert ( first + count <= numBytes ) ; result = Tcl_NewByteArrayObj(NULL, numBytes - count);/* PANIC? */ TclAppendBytesToByteArray(result, bytes, first); TclAppendBytesToByteArray(result, bytes + first + count, numBytes - count - first); return result; } /* Replace everything */ if ((first == 0) && (count == numBytes)) { return insertPtr; } if (TclIsPureByteArray(insertPtr)) { int newBytes; unsigned char *iBytes = Tcl_GetByteArrayFromObj(insertPtr, &newBytes); if (count == newBytes && inPlace && !Tcl_IsShared(objPtr)) { /* * Removal count and replacement count are equal. * Other conditions permit. Do in-place splice. */ memcpy(bytes + first, iBytes, count); Tcl_InvalidateStringRep(objPtr); return objPtr; } if (newBytes > INT_MAX - (numBytes - count)) { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "max size for a Tcl value (%d bytes) exceeded", INT_MAX)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); } return NULL; } result = Tcl_NewByteArrayObj(NULL, numBytes - count + newBytes); /* PANIC? */ TclAppendBytesToByteArray(result, bytes, first); TclAppendBytesToByteArray(result, iBytes, newBytes); TclAppendBytesToByteArray(result, bytes + first + count, numBytes - count - first); return result; } /* Flow through to try other approaches below */ } /* * TODO: Figure out how not to generate a Tcl_UniChar array rep * when it can be determined objPtr->bytes points to a string of * all single-byte characters so we can index it directly. */ /* The traditional implementation... */ { int numChars; Tcl_UniChar *ustring = Tcl_GetUnicodeFromObj(objPtr, &numChars); /* TODO: Is there an in-place option worth pursuing here? */ result = Tcl_NewUnicodeObj(ustring, first); if (insertPtr) { Tcl_AppendObjToObj(result, insertPtr); } if (first + count < numChars) { Tcl_AppendUnicodeToObj(result, ustring + first + count, numChars - first - count); } return result; } } /* *--------------------------------------------------------------------------- * * FillUnicodeRep -- * * Populate the Unicode internal rep with the Unicode form of its string * rep. The object must alread have a "String" internal rep. * * Results: * None. |
︙ | ︙ | |||
3554 3555 3556 3557 3558 3559 3560 | Tcl_Obj *objPtr, const char *bytes, size_t numBytes, size_t numAppendChars) { String *stringPtr = GET_STRING(objPtr); size_t needed, numOrigChars = 0; | | | 3673 3674 3675 3676 3677 3678 3679 3680 3681 3682 3683 3684 3685 3686 3687 | Tcl_Obj *objPtr, const char *bytes, size_t numBytes, size_t numAppendChars) { String *stringPtr = GET_STRING(objPtr); size_t needed, numOrigChars = 0; Tcl_UniChar *dst, unichar = 0; if (stringPtr->hasUnicode) { numOrigChars = stringPtr->numChars; } if (numAppendChars == (size_t)-1) { TclNumUtfChars(numAppendChars, bytes, numBytes); } |
︙ | ︙ | |||
3577 3578 3579 3580 3581 3582 3583 | stringPtr->hasUnicode = 1; if (bytes) { stringPtr->numChars = needed; } else { numAppendChars = 0; } for (dst=stringPtr->unicode + numOrigChars; numAppendChars-- > 0; dst++) { | | > | 3696 3697 3698 3699 3700 3701 3702 3703 3704 3705 3706 3707 3708 3709 3710 3711 | stringPtr->hasUnicode = 1; if (bytes) { stringPtr->numChars = needed; } else { numAppendChars = 0; } for (dst=stringPtr->unicode + numOrigChars; numAppendChars-- > 0; dst++) { bytes += TclUtfToUniChar(bytes, &unichar); *dst = unichar; } *dst = 0; } /* *---------------------------------------------------------------------- * |
︙ | ︙ |
Changes to generic/tclStubInit.c.
︙ | ︙ | |||
33 34 35 36 37 38 39 40 41 42 43 44 45 46 | #undef Tcl_Alloc #undef Tcl_Free #undef Tcl_Realloc #undef Tcl_NewByteArrayObj #undef Tcl_NewDoubleObj #undef Tcl_NewListObj #undef Tcl_NewLongObj #undef Tcl_NewObj #undef Tcl_NewStringObj #undef Tcl_DumpActiveMemory #undef Tcl_ValidateAllMemory #undef TclpGetPid #undef TclPkgProvide #undef Tcl_SetIntObj | > | 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 | #undef Tcl_Alloc #undef Tcl_Free #undef Tcl_Realloc #undef Tcl_NewByteArrayObj #undef Tcl_NewDoubleObj #undef Tcl_NewListObj #undef Tcl_NewLongObj #undef Tcl_DbNewLongObj #undef Tcl_NewObj #undef Tcl_NewStringObj #undef Tcl_DumpActiveMemory #undef Tcl_ValidateAllMemory #undef TclpGetPid #undef TclPkgProvide #undef Tcl_SetIntObj |
︙ | ︙ | |||
71 72 73 74 75 76 77 | #ifdef _WIN32 # define TclUnixWaitForFile 0 # define TclUnixCopyFile 0 # define TclUnixOpenTemporaryFile 0 # define TclpIsAtty 0 #elif defined(__CYGWIN__) # define TclpIsAtty TclPlatIsAtty | | < < | | < > | > > < < < < < < < < < | | 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 | #ifdef _WIN32 # define TclUnixWaitForFile 0 # define TclUnixCopyFile 0 # define TclUnixOpenTemporaryFile 0 # define TclpIsAtty 0 #elif defined(__CYGWIN__) # define TclpIsAtty TclPlatIsAtty static void doNothing(void) { /* dummy implementation, no need to do anything */ } # 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; } #define TclWinNoBackslash winNoBackslash static char * TclWinNoBackslash(char *path) { |
︙ | ︙ | |||
121 122 123 124 125 126 127 | int TclpGetPid(Tcl_Pid pid) { return (int) (size_t) pid; } | < < < < < < | | | | > > | > > > > | > | > > > | > > | > > > > | | 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 | 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 |
︙ | ︙ | |||
324 325 326 327 328 329 330 | TclpRealloc, /* 81 */ 0, /* 82 */ 0, /* 83 */ 0, /* 84 */ 0, /* 85 */ 0, /* 86 */ 0, /* 87 */ | | | 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 | TclpRealloc, /* 81 */ 0, /* 82 */ 0, /* 83 */ 0, /* 84 */ 0, /* 85 */ 0, /* 86 */ 0, /* 87 */ 0, /* 88 */ TclPreventAliasLoop, /* 89 */ 0, /* 90 */ TclProcCleanupProc, /* 91 */ TclProcCompileProc, /* 92 */ TclProcDeleteProc, /* 93 */ 0, /* 94 */ 0, /* 95 */ |
︙ | ︙ | |||
541 542 543 544 545 546 547 | 0, /* 2 */ 0, /* 3 */ TclWinGetTclInstance, /* 4 */ TclUnixWaitForFile, /* 5 */ 0, /* 6 */ 0, /* 7 */ TclpGetPid, /* 8 */ | | | | | 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 | 0, /* 2 */ 0, /* 3 */ TclWinGetTclInstance, /* 4 */ TclUnixWaitForFile, /* 5 */ 0, /* 6 */ 0, /* 7 */ TclpGetPid, /* 8 */ 0, /* 9 */ 0, /* 10 */ TclGetAndDetachPids, /* 11 */ TclpCloseFile, /* 12 */ TclpCreateCommandChannel, /* 13 */ TclpCreatePipe, /* 14 */ TclpCreateProcess, /* 15 */ TclpIsAtty, /* 16 */ TclUnixCopyFile, /* 17 */ TclpMakeFile, /* 18 */ TclpOpenFile, /* 19 */ TclWinAddProcess, /* 20 */ 0, /* 21 */ TclpCreateTempFile, /* 22 */ 0, /* 23 */ TclWinNoBackslash, /* 24 */ 0, /* 25 */ 0, /* 26 */ TclWinFlushDirtyChannels, /* 27 */ 0, /* 28 */ TclWinCPUID, /* 29 */ TclUnixOpenTemporaryFile, /* 30 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ TclGetAndDetachPids, /* 0 */ TclpCloseFile, /* 1 */ TclpCreateCommandChannel, /* 2 */ |
︙ | ︙ | |||
742 743 744 745 746 747 748 | Tcl_DbDecrRefCount, /* 19 */ Tcl_DbIncrRefCount, /* 20 */ Tcl_DbIsShared, /* 21 */ 0, /* 22 */ Tcl_DbNewByteArrayObj, /* 23 */ Tcl_DbNewDoubleObj, /* 24 */ Tcl_DbNewListObj, /* 25 */ | | | 744 745 746 747 748 749 750 751 752 753 754 755 756 757 758 | Tcl_DbDecrRefCount, /* 19 */ Tcl_DbIncrRefCount, /* 20 */ Tcl_DbIsShared, /* 21 */ 0, /* 22 */ Tcl_DbNewByteArrayObj, /* 23 */ Tcl_DbNewDoubleObj, /* 24 */ Tcl_DbNewListObj, /* 25 */ 0, /* 26 */ Tcl_DbNewObj, /* 27 */ Tcl_DbNewStringObj, /* 28 */ Tcl_DuplicateObj, /* 29 */ TclFreeObj, /* 30 */ Tcl_GetBoolean, /* 31 */ Tcl_GetBooleanFromObj, /* 32 */ Tcl_GetByteArrayFromObj, /* 33 */ |
︙ | ︙ | |||
768 769 770 771 772 773 774 | Tcl_ListObjGetElements, /* 45 */ Tcl_ListObjIndex, /* 46 */ Tcl_ListObjLength, /* 47 */ Tcl_ListObjReplace, /* 48 */ 0, /* 49 */ Tcl_NewByteArrayObj, /* 50 */ Tcl_NewDoubleObj, /* 51 */ | | | | | | 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 | Tcl_ListObjGetElements, /* 45 */ Tcl_ListObjIndex, /* 46 */ Tcl_ListObjLength, /* 47 */ Tcl_ListObjReplace, /* 48 */ 0, /* 49 */ Tcl_NewByteArrayObj, /* 50 */ Tcl_NewDoubleObj, /* 51 */ 0, /* 52 */ Tcl_NewListObj, /* 53 */ 0, /* 54 */ Tcl_NewObj, /* 55 */ Tcl_NewStringObj, /* 56 */ 0, /* 57 */ Tcl_SetByteArrayLength, /* 58 */ Tcl_SetByteArrayObj, /* 59 */ Tcl_SetDoubleObj, /* 60 */ 0, /* 61 */ Tcl_SetListObj, /* 62 */ 0, /* 63 */ Tcl_SetObjLength, /* 64 */ Tcl_SetStringObj, /* 65 */ 0, /* 66 */ 0, /* 67 */ Tcl_AllowExceptions, /* 68 */ Tcl_AppendElement, /* 69 */ Tcl_AppendResult, /* 70 */ |
︙ | ︙ | |||
846 847 848 849 850 851 852 | Tcl_DStringResult, /* 123 */ Tcl_DStringSetLength, /* 124 */ Tcl_DStringStartSublist, /* 125 */ Tcl_Eof, /* 126 */ Tcl_ErrnoId, /* 127 */ Tcl_ErrnoMsg, /* 128 */ 0, /* 129 */ | | | 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 | Tcl_DStringResult, /* 123 */ Tcl_DStringSetLength, /* 124 */ Tcl_DStringStartSublist, /* 125 */ Tcl_Eof, /* 126 */ Tcl_ErrnoId, /* 127 */ Tcl_ErrnoMsg, /* 128 */ 0, /* 129 */ Tcl_EvalFile, /* 130 */ 0, /* 131 */ Tcl_EventuallyFree, /* 132 */ Tcl_Exit, /* 133 */ Tcl_ExposeCommand, /* 134 */ Tcl_ExprBoolean, /* 135 */ Tcl_ExprBooleanObj, /* 136 */ Tcl_ExprDouble, /* 137 */ |
︙ | ︙ | |||
991 992 993 994 995 996 997 | 0, /* 260 */ 0, /* 261 */ Tcl_VarTraceInfo2, /* 262 */ Tcl_Write, /* 263 */ Tcl_WrongNumArgs, /* 264 */ Tcl_DumpActiveMemory, /* 265 */ Tcl_ValidateAllMemory, /* 266 */ | | | | | | 993 994 995 996 997 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 1013 1014 1015 1016 1017 1018 | 0, /* 260 */ 0, /* 261 */ Tcl_VarTraceInfo2, /* 262 */ Tcl_Write, /* 263 */ Tcl_WrongNumArgs, /* 264 */ Tcl_DumpActiveMemory, /* 265 */ Tcl_ValidateAllMemory, /* 266 */ 0, /* 267 */ 0, /* 268 */ Tcl_HashStats, /* 269 */ Tcl_ParseVar, /* 270 */ 0, /* 271 */ Tcl_PkgPresentEx, /* 272 */ TclPkgProvide, /* 273 */ 0, /* 274 */ 0, /* 275 */ 0, /* 276 */ Tcl_WaitPid, /* 277 */ 0, /* 278 */ Tcl_GetVersion, /* 279 */ Tcl_InitMemory, /* 280 */ Tcl_StackChannel, /* 281 */ Tcl_UnstackChannel, /* 282 */ Tcl_GetStackedChannel, /* 283 */ Tcl_SetMainLoop, /* 284 */ 0, /* 285 */ |
︙ | ︙ |
Changes to generic/tclTest.c.
︙ | ︙ | |||
411 412 413 414 415 416 417 418 419 420 421 422 423 424 | 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, |
︙ | ︙ | |||
676 677 678 679 680 681 682 683 684 685 686 687 688 689 | (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", | > > > > | 682 683 684 685 686 687 688 689 690 691 692 693 694 695 696 697 698 699 | (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", |
︙ | ︙ | |||
5191 5192 5193 5194 5195 5196 5197 | TestmainthreadCmd( ClientData dummy, /* Not used. */ register Tcl_Interp *interp,/* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { if (argc == 1) { | | | 5201 5202 5203 5204 5205 5206 5207 5208 5209 5210 5211 5212 5213 5214 5215 | TestmainthreadCmd( ClientData dummy, /* Not used. */ register Tcl_Interp *interp,/* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { if (argc == 1) { Tcl_Obj *idObj = Tcl_NewWideIntObj((Tcl_WideInt)(size_t)Tcl_GetCurrentThread()); Tcl_SetObjResult(interp, idObj); return TCL_OK; } else { Tcl_AppendResult(interp, "wrong # args", NULL); return TCL_ERROR; } |
︙ | ︙ | |||
5588 5589 5590 5591 5592 5593 5594 | if ((cmdName[0] == 'm') && (strncmp(cmdName, "mthread", len) == 0)) { if (argc != 3) { Tcl_AppendResult(interp, "channel name required", NULL); return TCL_ERROR; } | > | < | 5598 5599 5600 5601 5602 5603 5604 5605 5606 5607 5608 5609 5610 5611 5612 5613 | if ((cmdName[0] == 'm') && (strncmp(cmdName, "mthread", len) == 0)) { if (argc != 3) { Tcl_AppendResult(interp, "channel name required", NULL); return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewWideIntObj( (Tcl_WideInt) (size_t) Tcl_GetChannelThread(chan))); return TCL_OK; } if ((cmdName[0] == 'n') && (strncmp(cmdName, "name", len) == 0)) { if (argc != 3) { Tcl_AppendResult(interp, "channel name required", NULL); return TCL_ERROR; |
︙ | ︙ | |||
6715 6716 6717 6718 6719 6720 6721 6722 6723 6724 6725 6726 6727 6728 | (void) Tcl_GetIntFromObj(interp, objv[2], &len); } len = Tcl_NumUtfChars(Tcl_GetString(objv[1]), len); Tcl_SetObjResult(interp, Tcl_NewLongObj(len)); } return TCL_OK; } #if defined(HAVE_CPUID) || defined(_WIN32) /* *---------------------------------------------------------------------- * * TestcpuidCmd -- * | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 6725 6726 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 | (void) Tcl_GetIntFromObj(interp, objv[2], &len); } len = Tcl_NumUtfChars(Tcl_GetString(objv[1]), len); Tcl_SetObjResult(interp, Tcl_NewLongObj(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.
︙ | ︙ | |||
1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 | 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]); | > > > | 1085 1086 1087 1088 1089 1090 1091 1092 1093 1094 1095 1096 1097 1098 1099 1100 1101 | 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]); |
︙ | ︙ | |||
1112 1113 1114 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 | 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; | > > > > > | 1115 1116 1117 1118 1119 1120 1121 1122 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 | 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/tclThreadTest.c.
︙ | ︙ | |||
244 245 246 247 248 249 250 | ListUpdateInner(tsdPtr); Tcl_CreateThreadExitHandler(ThreadExitProc, NULL); Tcl_MutexUnlock(&threadMutex); } switch ((enum options)option) { case THREAD_CANCEL: { | | | | 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 | ListUpdateInner(tsdPtr); Tcl_CreateThreadExitHandler(ThreadExitProc, NULL); Tcl_MutexUnlock(&threadMutex); } switch ((enum options)option) { case THREAD_CANCEL: { Tcl_WideInt id; const char *result; int flags, arg; if ((objc < 3) || (objc > 5)) { Tcl_WrongNumArgs(interp, 2, objv, "?-unwind? id ?result?"); return TCL_ERROR; } flags = 0; arg = 2; if ((objc == 4) || (objc == 5)) { if (strcmp("-unwind", Tcl_GetString(objv[arg])) == 0) { flags = TCL_CANCEL_UNWIND; arg++; } } if (Tcl_GetWideIntFromObj(interp, objv[arg], &id) != TCL_OK) { return TCL_ERROR; } arg++; if (arg < objc) { result = Tcl_GetString(objv[arg]); } else { result = NULL; |
︙ | ︙ |
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_GetIndexFromObjStruct(NULL, objv[1], afterSubCmds, sizeof(char *), "", 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/tclTomMath.decls.
︙ | ︙ | |||
217 218 219 220 221 222 223 | declare 62 { int TclBN_mp_set_int(mp_int *a, unsigned long i) } declare 63 { int TclBN_mp_cnt_lsb(const mp_int *a) } | > > | | | | 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 | declare 62 { int TclBN_mp_set_int(mp_int *a, unsigned long i) } declare 63 { int TclBN_mp_cnt_lsb(const mp_int *a) } # Formerly internal API to allow initialisation of bignums without knowing the # typedefs of how a bignum works internally. # Removed in 9.0 #declare 64 { # void TclBNInitBignumFromLong(mp_int *bignum, long initVal) #} # Removed in 9.0 #declare 65 { # void TclBNInitBignumFromWideInt(mp_int *bignum, Tcl_WideInt initVal) #} # Removed in 9.0 #declare 66 { # void TclBNInitBignumFromWideUInt(mp_int *bignum, Tcl_WideUInt initVal) #} # Added in libtommath 1.0 declare 67 { int TclBN_mp_expt_d_ex(const mp_int *a, mp_digit b, mp_int *c, int fast) |
︙ | ︙ |
Changes to generic/tclTomMath.h.
︙ | ︙ | |||
21 22 23 24 25 26 27 28 29 | #endif #ifdef __cplusplus extern "C" { #endif /* detect 64-bit mode if possible */ | > > > > > | | | 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 | #endif #ifdef __cplusplus extern "C" { #endif /* MS Visual C++ doesn't have a 128bit type for words, so fall back to 32bit MPI's (where words are 64bit) */ #if defined(_MSC_VER) || defined(__LLP64__) # define MP_32BIT #endif /* detect 64-bit mode if possible */ #if defined(NEVER) # if !(defined(MP_32BIT) || defined(MP_16BIT) || defined(MP_8BIT) || defined(_MSC_VER)) # define MP_64BIT # endif #endif /* some default configurations. * * A "mp_digit" must be able to hold DIGIT_BIT + 1 bits |
︙ | ︙ | |||
69 70 71 72 73 74 75 | # endif #elif defined(MP_64BIT) /* for GCC only on supported platforms */ #ifndef MP_DIGIT_DECLARED typedef uint64_t mp_digit; #define MP_DIGIT_DECLARED #endif | | < < < < < | 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 | # endif #elif defined(MP_64BIT) /* for GCC only on supported platforms */ #ifndef MP_DIGIT_DECLARED typedef uint64_t mp_digit; #define MP_DIGIT_DECLARED #endif # if defined(__GNUC__) typedef unsigned long mp_word __attribute__((mode(TI))); # else /* it seems you have a problem * but we assume you can somewhere define your own uint128_t */ #ifndef MP_WORD_DECLARED typedef uint128_t mp_word; #define MP_WORD_DECLARED |
︙ | ︙ | |||
120 121 122 123 124 125 126 | #else typedef mp_digit mp_min_u32; #endif /* use arc4random on platforms that support it */ #if defined(__FreeBSD__) || defined(__OpenBSD__) || defined(__NetBSD__) || defined(__DragonFly__) # define MP_GEN_RANDOM() arc4random() | | | 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 | #else typedef mp_digit mp_min_u32; #endif /* use arc4random on platforms that support it */ #if defined(__FreeBSD__) || defined(__OpenBSD__) || defined(__NetBSD__) || defined(__DragonFly__) # define MP_GEN_RANDOM() arc4random() # define MP_GEN_RANDOM_MAX 0xffffffffu #endif /* use rand() as fall-back if there's no better rand function */ #ifndef MP_GEN_RANDOM # define MP_GEN_RANDOM() rand() # define MP_GEN_RANDOM_MAX RAND_MAX #endif |
︙ | ︙ | |||
177 178 179 180 181 182 183 | # define MP_PREC 32 /* default digits of precision */ # else # define MP_PREC 8 /* default digits of precision */ # endif #endif /* size of comba arrays, should be at least 2 * 2**(BITS_PER_WORD - BITS_PER_DIGIT*2) */ | | | 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 | # define MP_PREC 32 /* default digits of precision */ # else # define MP_PREC 8 /* default digits of precision */ # endif #endif /* size of comba arrays, should be at least 2 * 2**(BITS_PER_WORD - BITS_PER_DIGIT*2) */ #define MP_WARRAY (1u << (((sizeof(mp_word) * CHAR_BIT) - (2 * DIGIT_BIT)) + 1)) /* the infamous mp_int structure */ #ifndef MP_INT_DECLARED #define MP_INT_DECLARED typedef struct mp_int mp_int; #endif struct mp_int { |
︙ | ︙ | |||
267 268 269 270 271 272 273 | */ /* set a platform dependent unsigned long value */ /* int mp_set_long(mp_int *a, unsigned long b); */ | | | | | | 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 | */ /* set a platform dependent unsigned long value */ /* int mp_set_long(mp_int *a, unsigned long b); */ /* set a platform dependent Tcl_WideUInt value */ /* int mp_set_long_long(mp_int *a, Tcl_WideUInt b); */ /* get a 32-bit value */ /* unsigned long mp_get_int(const mp_int *a); */ /* get a platform dependent unsigned long value */ /* unsigned long mp_get_long(const mp_int *a); */ /* get a platform dependent Tcl_WideUInt value */ /* Tcl_WideUInt mp_get_long_long(const mp_int *a); */ /* initialize and set a digit */ /* int mp_init_set(mp_int *a, mp_digit b); */ |
︙ | ︙ | |||
549 550 551 552 553 554 555 | /* special sqrt algo */ /* int mp_sqrt(const mp_int *arg, mp_int *ret); */ /* special sqrt (mod prime) */ /* | | | | | | | | | | 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 | /* special sqrt algo */ /* int mp_sqrt(const mp_int *arg, mp_int *ret); */ /* special sqrt (mod prime) */ /* int mp_sqrtmod_prime(const mp_int *n, const mp_int *prime, mp_int *ret); */ /* is number a square? */ /* int mp_is_square(const mp_int *arg, int *ret); */ /* computes the jacobi c = (a | n) (or Legendre if b is prime) */ /* int mp_jacobi(const mp_int *a, const mp_int *n, int *c); */ /* used to setup the Barrett reduction for a given modulus b */ /* int mp_reduce_setup(mp_int *a, const mp_int *b); */ /* Barrett Reduction, computes a (mod b) with a precomputed value c * * Assumes that 0 < x <= m*m, note if 0 > x > -(m*m) then you can merely * compute the reduction as -1 * mp_reduce(mp_abs(x)) [pseudo code]. */ /* int mp_reduce(mp_int *x, const mp_int *m, const mp_int *mu); */ /* setups the montgomery reduction */ /* int mp_montgomery_setup(const mp_int *n, mp_digit *rho); */ /* computes a = B**n mod b without division or multiplication useful for * normalizing numbers in a Montgomery system. */ /* int mp_montgomery_calc_normalization(mp_int *a, const mp_int *b); */ /* computes x/R == x (mod N) via Montgomery Reduction */ /* int mp_montgomery_reduce(mp_int *x, const mp_int *n, mp_digit rho); */ /* returns 1 if a is a valid DR modulus */ /* int mp_dr_is_modulus(const mp_int *a); */ /* sets the value of "d" required for mp_dr_reduce */ /* void mp_dr_setup(const mp_int *a, mp_digit *d); */ /* reduces a modulo n using the Diminished Radix method */ /* int mp_dr_reduce(mp_int *x, const mp_int *n, mp_digit k); */ /* returns true if a can be reduced with mp_reduce_2k */ /* int mp_reduce_is_2k(const mp_int *a); */ |
︙ | ︙ | |||
638 639 640 641 642 643 644 | */ /* reduces a modulo b where b is of the form 2**p - k [0 <= a] */ /* int mp_reduce_2k_l(mp_int *a, const mp_int *n, const mp_int *d); */ | | | | 638 639 640 641 642 643 644 645 646 647 648 649 650 651 652 653 654 | */ /* reduces a modulo b where b is of the form 2**p - k [0 <= a] */ /* int mp_reduce_2k_l(mp_int *a, const mp_int *n, const mp_int *d); */ /* Y = G**X (mod P) */ /* int mp_exptmod(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y); */ /* ---> Primes <--- */ /* number of primes */ #ifdef MP_8BIT # define PRIME_SIZE 31 |
︙ | ︙ |
Changes to generic/tclTomMathInterface.c.
︙ | ︙ | |||
121 122 123 124 125 126 127 | mp_set_long_long(a, (Tcl_WideUInt)v); } } /* *---------------------------------------------------------------------- * | | | 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 | mp_set_long_long(a, (Tcl_WideUInt)v); } } /* *---------------------------------------------------------------------- * * TclInitBignumFromWideInt -- * * Allocate and initialize a 'bignum' from a Tcl_WideInt * * Results: * None. * * Side effects: |
︙ | ︙ | |||
153 154 155 156 157 158 159 | mp_set_long_long(a, (Tcl_WideUInt)v); } } /* *---------------------------------------------------------------------- * | | | 153 154 155 156 157 158 159 160 161 162 163 164 165 166 167 | mp_set_long_long(a, (Tcl_WideUInt)v); } } /* *---------------------------------------------------------------------- * * TclInitBignumFromWideUInt -- * * Allocate and initialize a 'bignum' from a Tcl_WideUInt * * Results: * None. * * Side effects: |
︙ | ︙ |
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; } /* *--------------------------------------------------------------------------- |
︙ | ︙ | |||
982 983 984 985 986 987 988 | *---------------------------------------------------------------------- */ int TclpUtfNcmp2( const char *cs, /* UTF string to compare to ct. */ const char *ct, /* UTF string cs is compared to. */ | | | 998 999 1000 1001 1002 1003 1004 1005 1006 1007 1008 1009 1010 1011 1012 | *---------------------------------------------------------------------- */ int TclpUtfNcmp2( const char *cs, /* UTF string to compare to ct. */ const char *ct, /* UTF string cs is compared to. */ unsigned long numBytes) /* Number of *bytes* to compare. */ { /* * We can't simply call 'memcmp(cs, ct, numBytes);' because we need to * check for Tcl's \xC0\x80 non-utf-8 null encoding. Otherwise utf-8 lexes * fine in the strcmp manner. */ |
︙ | ︙ | |||
1029 1030 1031 1032 1033 1034 1035 | *---------------------------------------------------------------------- */ int Tcl_UtfNcmp( const char *cs, /* UTF string to compare to ct. */ const char *ct, /* UTF string cs is compared to. */ | | > > > > > > > > > > | 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 | *---------------------------------------------------------------------- */ int Tcl_UtfNcmp( 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; /* * Cannot use 'memcmp(cs, ct, n);' as byte representation of \u0000 (the * pair of bytes 0xC0,0x80) is larger than byte representation of \u0001 * (the byte 0x01.) */ 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 return (ch1 - ch2); } } return 0; } /* |
︙ | ︙ | |||
1077 1078 1079 1080 1081 1082 1083 | *---------------------------------------------------------------------- */ int Tcl_UtfNcasecmp( const char *cs, /* UTF string to compare to ct. */ const char *ct, /* UTF string cs is compared to. */ | | > > > > > > > > > > > | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > < | > > > > > > > > > > > | 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 | *---------------------------------------------------------------------- */ 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; } } } |
︙ | ︙ | |||
1281 1282 1283 1284 1285 1286 1287 | *---------------------------------------------------------------------- */ int Tcl_UniCharNcmp( const Tcl_UniChar *ucs, /* Unicode string to compare to uct. */ const Tcl_UniChar *uct, /* Unicode string ucs is compared to. */ | | | 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 | *---------------------------------------------------------------------- */ int Tcl_UniCharNcmp( const Tcl_UniChar *ucs, /* Unicode string to compare to uct. */ const Tcl_UniChar *uct, /* Unicode string ucs is compared to. */ unsigned long numChars) /* Number of unichars to compare. */ { #ifdef WORDS_BIGENDIAN /* * We are definitely on a big-endian machine; memcmp() is safe */ return memcmp(ucs, uct, numChars*sizeof(Tcl_UniChar)); |
︙ | ︙ | |||
1326 1327 1328 1329 1330 1331 1332 | *---------------------------------------------------------------------- */ int Tcl_UniCharNcasecmp( const Tcl_UniChar *ucs, /* Unicode string to compare to uct. */ const Tcl_UniChar *uct, /* Unicode string ucs is compared to. */ | | | 1419 1420 1421 1422 1423 1424 1425 1426 1427 1428 1429 1430 1431 1432 1433 | *---------------------------------------------------------------------- */ int Tcl_UniCharNcasecmp( const Tcl_UniChar *ucs, /* Unicode string to compare to uct. */ const Tcl_UniChar *uct, /* Unicode string ucs is compared to. */ unsigned long numChars) /* Number of unichars to compare. */ { for ( ; numChars != 0; numChars--, ucs++, uct++) { if (*ucs != *uct) { Tcl_UniChar lcs = Tcl_UniCharToLower(*ucs); Tcl_UniChar lct = Tcl_UniCharToLower(*uct); if (lcs != lct) { |
︙ | ︙ |
Changes to generic/tclUtil.c.
︙ | ︙ | |||
89 90 91 92 93 94 95 | #define COMPAT 1 #define CONVERT_NONE 0 #define CONVERT_BRACE 2 #define CONVERT_ESCAPE 4 #define CONVERT_MASK (CONVERT_BRACE | CONVERT_ESCAPE) #define CONVERT_ANY 16 | < < < < < < < > > < | | > > > | | | 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 | #define COMPAT 1 #define CONVERT_NONE 0 #define CONVERT_BRACE 2 #define CONVERT_ESCAPE 4 #define CONVERT_MASK (CONVERT_BRACE | CONVERT_ESCAPE) #define CONVERT_ANY 16 /* * Prototypes for functions defined later in this file. */ static void ClearHash(Tcl_HashTable *tablePtr); static void FreeProcessGlobalValue(ClientData clientData); static void FreeThreadHash(ClientData clientData); static int GetEndOffsetFromObj(Tcl_Obj *objPtr, int endValue, int *indexPtr); static Tcl_HashTable * GetThreadHash(Tcl_ThreadDataKey *keyPtr); static int SetEndOffsetFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static int FindElement(Tcl_Interp *interp, const char *string, int stringLength, const char *typeStr, const char *typeCode, const char **elementPtr, const char **nextPtr, int *sizePtr, int *literalPtr); /* * The following is the Tcl object type definition for an object that * represents a list index in the form, "end-offset". It is used as a * performance optimization in TclGetIntForIndex. The internal rep is * stored directly in the wideValue, so no memory management is required * for it. This is a caching intrep, keeping the result of a parse * around. This type is only created from a pre-existing string, so an * updateStringProc will never be called and need not exist. */ static const Tcl_ObjType endOffsetType = { "end-offset", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ NULL, /* updateStringProc */ SetEndOffsetFromAny }; /* * * STRING REPRESENTATION OF LISTS * * * * * The next several routines implement the conversions of strings to and from |
︙ | ︙ | |||
933 934 935 936 937 938 939 | * None. * *---------------------------------------------------------------------- */ int Tcl_ScanElement( | | | | | 930 931 932 933 934 935 936 937 938 939 940 941 942 943 944 945 946 | * None. * *---------------------------------------------------------------------- */ int Tcl_ScanElement( register const char *src, /* String to convert to list element. */ register int *flagPtr) /* Where to store information to guide * Tcl_ConvertCountedElement. */ { return Tcl_ScanCountedElement(src, -1, flagPtr); } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
1296 1297 1298 1299 1300 1301 1302 | * None. * *---------------------------------------------------------------------- */ int Tcl_ConvertElement( | | | | | 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 1305 1306 1307 1308 1309 | * None. * *---------------------------------------------------------------------- */ int Tcl_ConvertElement( register const char *src, /* Source information for list element. */ register char *dst, /* Place to put list-ified element. */ register int flags) /* Flags produced by Tcl_ScanElement. */ { return Tcl_ConvertCountedElement(src, -1, dst, flags); } /* *---------------------------------------------------------------------- * |
︙ | ︙ | |||
1362 1363 1364 1365 1366 1367 1368 | */ int TclConvertElement( register const char *src, /* Source information for list element. */ int length, /* Number of bytes in src, or -1. */ char *dst, /* Place to put list-ified element. */ | | | | 1359 1360 1361 1362 1363 1364 1365 1366 1367 1368 1369 1370 1371 1372 1373 1374 1375 | */ int TclConvertElement( register const char *src, /* Source information for list element. */ int length, /* Number of bytes in src, or -1. */ char *dst, /* Place to put list-ified element. */ int flags) /* Flags produced by Tcl_ScanElement. */ { int conversion = flags & CONVERT_MASK; char *p = dst; /* * Let the caller demand we use escape sequences rather than braces. */ if ((flags & TCL_DONT_USE_BRACES) && (conversion & CONVERT_BRACE)) { |
︙ | ︙ | |||
1544 1545 1546 1547 1548 1549 1550 | char * Tcl_Merge( int argc, /* How many strings to merge. */ const char *const *argv) /* Array of string values. */ { #define LOCAL_SIZE 64 | | | | 1541 1542 1543 1544 1545 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 | 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) { |
︙ | ︙ | |||
1603 1604 1605 1606 1607 1608 1609 | } return result; } /* *---------------------------------------------------------------------- * | > > > > > > > > > > > > > | > > > > > > > > | > > > > > > > > > > > > > > | < > | | | | < < < < < < < < < < < < < | 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 | } return result; } /* *---------------------------------------------------------------------- * * UtfWellFormedEnd -- * Checks the end of utf string is malformed, if yes - wraps bytes * to the given buffer (as well-formed NTS string). The buffer * argument should be initialized by the caller and ready to use. * * Results: * The bytes with well-formed end of the string. * * Side effects: * Buffer (DString) may be allocated, so must be released. * *---------------------------------------------------------------------- */ static inline const char* UtfWellFormedEnd( Tcl_DString *buffer, /* Buffer used to hold well-formed string. */ const char *bytes, /* Pointer to the beginning of the string. */ int length) /* Length of the string. */ { const char *l = bytes + length; const char *p = Tcl_UtfPrev(l, bytes); if (Tcl_UtfCharComplete(p, l - p)) { return bytes; } /* * Malformed utf-8 end, be sure we've NTS to safe compare of end-character, * avoid segfault by access violation out of range. */ Tcl_DStringAppend(buffer, bytes, length); return Tcl_DStringValue(buffer); } /* *---------------------------------------------------------------------- * * TclTrimRight -- * Takes two counted strings in the Tcl encoding. Conceptually * finds the sub string (offset) to trim from the right side of the * first string all characters found in the second string. * * Results: * The number of bytes to be removed from the end of the string. * * Side effects: * None. * *---------------------------------------------------------------------- */ static inline int TrimRight( 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; /* * 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; |
︙ | ︙ | |||
1680 1681 1682 1683 1684 1685 1686 1687 1688 1689 1690 1691 1692 | p += pInc; break; } } while (p > bytes); return numBytes - (p - bytes); } /* *---------------------------------------------------------------------- * * TclTrimLeft -- * | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | | < < < < < < < < < < < < < | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 1841 1842 1843 1844 1845 1846 1847 1848 1849 1850 1851 1852 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 1886 1887 1888 1889 1890 1891 1892 1893 1894 1895 1896 1897 1898 1899 | p += pInc; break; } } while (p > bytes); return numBytes - (p - bytes); } int TclTrimRight( 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 */ { int res; Tcl_DString bytesBuf, trimBuf; /* Empty strings -> nothing to do */ if ((numBytes == 0) || (numTrim == 0)) { return 0; } Tcl_DStringInit(&bytesBuf); Tcl_DStringInit(&trimBuf); bytes = UtfWellFormedEnd(&bytesBuf, bytes, numBytes); trim = UtfWellFormedEnd(&trimBuf, trim, numTrim); res = TrimRight(bytes, numBytes, trim, numTrim); if (res > numBytes) { res = numBytes; } Tcl_DStringFree(&bytesBuf); Tcl_DStringFree(&trimBuf); return res; } /* *---------------------------------------------------------------------- * * TclTrimLeft -- * * Takes two counted strings in the Tcl encoding. Conceptually * finds the sub string (offset) to trim from the left side of the * first string all characters found in the second string. * * Results: * The number of bytes to be removed from the start of the string. * * Side effects: * None. * *---------------------------------------------------------------------- */ static inline int TrimLeft( 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; /* * 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; bytesLeft -= qInc; } while (bytesLeft); if (bytesLeft == 0) { /* * No match; trim task done; *p is first non-trimmed char. */ break; } p += pInc; numBytes -= pInc; } while (numBytes > 0); return p - bytes; } int 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 */ { int res; Tcl_DString bytesBuf, trimBuf; /* Empty strings -> nothing to do */ if ((numBytes == 0) || (numTrim == 0)) { return 0; } Tcl_DStringInit(&bytesBuf); Tcl_DStringInit(&trimBuf); bytes = UtfWellFormedEnd(&bytesBuf, bytes, numBytes); trim = UtfWellFormedEnd(&trimBuf, trim, numTrim); res = TrimLeft(bytes, numBytes, trim, numTrim); if (res > numBytes) { res = numBytes; } Tcl_DStringFree(&bytesBuf); Tcl_DStringFree(&trimBuf); return res; } /* *---------------------------------------------------------------------- * * TclTrim -- * Finds the sub string (offset) to trim from both sides of the * first string all characters found in the second string. * * Results: * The number of bytes to be removed from the start of the string * * Side effects: * None. * *---------------------------------------------------------------------- */ int TclTrim( 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 */ int *trimRight) /* Offset from the end of the string. */ { int trimLeft; Tcl_DString bytesBuf, trimBuf; *trimRight = 0; /* Empty strings -> nothing to do */ if ((numBytes == 0) || (numTrim == 0)) { return 0; } Tcl_DStringInit(&bytesBuf); Tcl_DStringInit(&trimBuf); bytes = UtfWellFormedEnd(&bytesBuf, bytes, numBytes); trim = UtfWellFormedEnd(&trimBuf, trim, numTrim); trimLeft = TrimLeft(bytes, numBytes, trim, numTrim); if (trimLeft > numBytes) { trimLeft = numBytes; } numBytes -= trimLeft; /* have to trim yet (first char was already verified within TrimLeft) */ if (numBytes > 1) { bytes += trimLeft; *trimRight = TrimRight(bytes, numBytes, trim, numTrim); if (*trimRight > numBytes) { *trimRight = numBytes; } } Tcl_DStringFree(&bytesBuf); Tcl_DStringFree(&trimBuf); return trimLeft; } /* *---------------------------------------------------------------------- * * Tcl_Concat -- * * Concatenate a set of strings into a single large string. |
︙ | ︙ | |||
1827 1828 1829 1830 1831 1832 1833 | /* * All element bytes + (argc - 1) spaces + 1 terminating NULL. */ result = ckalloc((unsigned) (bytesNeeded + argc)); for (p = result, i = 0; i < argc; i++) { | | < | < < | | | | < < | < < < < | < | 1953 1954 1955 1956 1957 1958 1959 1960 1961 1962 1963 1964 1965 1966 1967 1968 1969 1970 1971 1972 1973 1974 1975 1976 1977 1978 1979 1980 | /* * All element bytes + (argc - 1) spaces + 1 terminating NULL. */ result = ckalloc((unsigned) (bytesNeeded + argc)); for (p = result, i = 0; i < argc; i++) { int triml, trimr, elemLength; const char *element; element = argv[i]; elemLength = strlen(argv[i]); /* Trim away the leading/trailing whitespace. */ triml = TclTrim(element, elemLength, CONCAT_TRIM_SET, CONCAT_WS_SIZE, &trimr); element += triml; elemLength -= triml + trimr; /* Do not permit trimming to expose a final backslash character. */ elemLength += trimr && (element[elemLength - 1] == '\\'); /* * If we're left with empty element after trimming, do nothing. */ if (elemLength == 0) { continue; |
︙ | ︙ | |||
1970 1971 1972 1973 1974 1975 1976 | */ TclNewObj(resPtr); (void) Tcl_AttemptSetObjLength(resPtr, bytesNeeded + objc - 1); Tcl_SetObjLength(resPtr, 0); for (i = 0; i < objc; i++) { | | < | < < | | | | < < | < < < < | < | 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 | */ TclNewObj(resPtr); (void) Tcl_AttemptSetObjLength(resPtr, bytesNeeded + objc - 1); Tcl_SetObjLength(resPtr, 0); for (i = 0; i < objc; i++) { int triml, trimr; element = TclGetStringFromObj(objv[i], &elemLength); /* Trim away the leading/trailing whitespace. */ triml = TclTrim(element, elemLength, CONCAT_TRIM_SET, CONCAT_WS_SIZE, &trimr); element += triml; elemLength -= triml + trimr; /* Do not permit trimming to expose a final backslash character. */ elemLength += trimr && (element[elemLength - 1] == '\\'); /* * If we're left with empty element after trimming, do nothing. */ if (elemLength == 0) { continue; |
︙ | ︙ | |||
2069 2070 2071 2072 2073 2074 2075 | 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; | | | 2175 2176 2177 2178 2179 2180 2181 2182 2183 2184 2185 2186 2187 2188 2189 | 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 |
︙ | ︙ | |||
2179 2180 2181 2182 2183 2184 2185 | /* * 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 == '[') { | | | 2285 2286 2287 2288 2289 2290 2291 2292 2293 2294 2295 2296 2297 2298 2299 | /* * 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 { |
︙ | ︙ | |||
2492 2493 2494 2495 2496 2497 2498 | if ((strObj->typePtr == &tclStringType) || (strObj->typePtr == NULL)) { Tcl_UniChar *udata, *uptn; udata = Tcl_GetUnicodeFromObj(strObj, &length); uptn = Tcl_GetUnicodeFromObj(ptnObj, &plen); match = TclUniCharMatch(udata, length, uptn, plen, flags); | | > | 2598 2599 2600 2601 2602 2603 2604 2605 2606 2607 2608 2609 2610 2611 2612 2613 | if ((strObj->typePtr == &tclStringType) || (strObj->typePtr == NULL)) { Tcl_UniChar *udata, *uptn; udata = Tcl_GetUnicodeFromObj(strObj, &length); uptn = Tcl_GetUnicodeFromObj(ptnObj, &plen); match = TclUniCharMatch(udata, length, uptn, plen, flags); } else if (TclIsPureByteArray(strObj) && TclIsPureByteArray(ptnObj) && !flags) { unsigned char *data, *ptn; data = Tcl_GetByteArrayFromObj(strObj, &length); ptn = Tcl_GetByteArrayFromObj(ptnObj, &plen); match = TclByteArrayMatch(data, length, ptn, plen, 0); } else { match = Tcl_StringCaseMatch(TclGetString(strObj), |
︙ | ︙ | |||
3001 3002 3003 3004 3005 3006 3007 | * * Tcl_PrintDouble -- * * Given a floating-point value, this function converts it to an ASCII * string using. * * Results: | | < | | | < < < | 3108 3109 3110 3111 3112 3113 3114 3115 3116 3117 3118 3119 3120 3121 3122 3123 3124 3125 3126 3127 3128 3129 3130 3131 3132 3133 3134 3135 3136 3137 3138 3139 3140 3141 3142 3143 | * * Tcl_PrintDouble -- * * Given a floating-point value, this function converts it to an ASCII * string using. * * Results: * The ASCII equivalent of "value" is written at "dst". It is guaranteed * to contain a decimal point or exponent, so that it looks like a * floating-point value and not an integer. * * Side effects: * None. * *---------------------------------------------------------------------- */ void Tcl_PrintDouble( Tcl_Interp *interp, /* Not used */ double value, /* Value to print as string. */ char *dst) /* Where to store converted value; must have * at least TCL_DOUBLE_SPACE characters. */ { char *p, c; int exponent; int signum; char *digits; char *end; /* * Handle NaN. */ if (TclIsNaN(value)) { TclFormatNaN(value, dst); |
︙ | ︙ | |||
3058 3059 3060 3061 3062 3063 3064 | return; } /* * Ordinary (normal and denormal) values. */ | < | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | < < < | 3161 3162 3163 3164 3165 3166 3167 3168 3169 3170 3171 3172 3173 3174 3175 3176 3177 3178 3179 3180 3181 3182 3183 3184 3185 3186 3187 3188 3189 3190 3191 3192 3193 3194 3195 3196 | return; } /* * Ordinary (normal and denormal) values. */ digits = TclDoubleDigits(value, -1, TCL_DD_SHORTEST, &exponent, &signum, &end); if (signum) { *dst++ = '-'; } p = digits; if (exponent < -4 || exponent > 16) { /* * E format for numbers < 1e-3 or >= 1e17. */ *dst++ = *p++; c = *p; if (c != '\0') { *dst++ = '.'; while (c != '\0') { *dst++ = c; c = *++p; } } sprintf(dst, "e%+d", exponent); } else { /* * F format for others. */ if (exponent < 0) { *dst++ = '0'; |
︙ | ︙ | |||
3167 3168 3169 3170 3171 3172 3173 | c = *++p; } } *dst++ = '\0'; } ckfree(digits); } | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 3216 3217 3218 3219 3220 3221 3222 3223 3224 3225 3226 3227 3228 3229 | c = *++p; } } *dst++ = '\0'; } ckfree(digits); } /* *---------------------------------------------------------------------- * * TclNeedSpace -- * * This function checks to see whether it is appropriate to add a space |
︙ | ︙ | |||
3362 3363 3364 3365 3366 3367 3368 | *---------------------------------------------------------------------- */ int TclFormatInt( char *buffer, /* Points to the storage into which the * formatted characters are written. */ | | | | 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 | *---------------------------------------------------------------------- */ 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. */ |
︙ | ︙ | |||
3387 3388 3389 3390 3391 3392 3393 | * 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. */ | | | 3358 3359 3360 3361 3362 3363 3364 3365 3366 3367 3368 3369 3370 3371 3372 | * 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); |
︙ | ︙ | |||
3426 3427 3428 3429 3430 3431 3432 | } /* *---------------------------------------------------------------------- * * TclGetIntForIndex -- * | | | | | | < > > | < > > > | | > | > | | | 3397 3398 3399 3400 3401 3402 3403 3404 3405 3406 3407 3408 3409 3410 3411 3412 3413 3414 3415 3416 3417 3418 3419 3420 3421 3422 3423 3424 3425 3426 3427 3428 3429 3430 | } /* *---------------------------------------------------------------------- * * TclGetIntForIndex -- * * Provides an integer corresponding to the list index held in a Tcl * object. The string value 'objPtr' is expected have the format * integer([+-]integer)? or end([+-]integer)?. * * Value * TCL_OK * * The index is stored at the address given by by 'indexPtr'. If * 'objPtr' has the value "end", the value stored is 'endValue'. * * TCL_ERROR * * The value of 'objPtr' does not have one of the expected formats. If * 'interp' is non-NULL, an error message is left in the interpreter's * result object. * * Effect * * The object referenced by 'objPtr' is converted, as needed, to an * integer, wide integer, or end-based-index object. * *---------------------------------------------------------------------- */ int TclGetIntForIndex( Tcl_Interp *interp, /* Interpreter to use for error reporting. If |
︙ | ︙ | |||
3465 3466 3467 3468 3469 3470 3471 | char *opPtr; const char *bytes; if (TclGetIntFromObj(NULL, objPtr, indexPtr) == TCL_OK) { return TCL_OK; } | < < < < < | < | 3441 3442 3443 3444 3445 3446 3447 3448 3449 3450 3451 3452 3453 3454 3455 | char *opPtr; const char *bytes; if (TclGetIntFromObj(NULL, objPtr, indexPtr) == TCL_OK) { return TCL_OK; } if (GetEndOffsetFromObj(objPtr, endValue, indexPtr) == TCL_OK) { return TCL_OK; } bytes = TclGetString(objPtr); length = objPtr->length; /* |
︙ | ︙ | |||
3537 3538 3539 3540 3541 3542 3543 | return TCL_ERROR; } /* *---------------------------------------------------------------------- * | | | | | | < < < | | | > > > > | | | | > | < < > | < < < | | | 3507 3508 3509 3510 3511 3512 3513 3514 3515 3516 3517 3518 3519 3520 3521 3522 3523 3524 3525 3526 3527 3528 3529 3530 3531 3532 3533 3534 3535 3536 3537 3538 3539 3540 3541 3542 3543 3544 3545 3546 3547 3548 3549 3550 3551 3552 | return TCL_ERROR; } /* *---------------------------------------------------------------------- * * GetEndOffsetFromObj -- * * Look for a string of the form "end[+-]offset" and convert it to an * internal representation holding the offset. * * Results: * Tcl return code. * * Side effects: * May store a Tcl_ObjType. * *---------------------------------------------------------------------- */ static int GetEndOffsetFromObj( Tcl_Obj *objPtr, /* Pointer to the object to parse */ int endValue, /* The value to be stored at "indexPtr" if * "objPtr" holds "end". */ int *indexPtr) /* Location filled in with an integer * representing an index. */ { if (SetEndOffsetFromAny(NULL, objPtr) != TCL_OK) { return TCL_ERROR; } /* TODO: Handle overflow cases sensibly */ *indexPtr = endValue + (int)objPtr->internalRep.wideValue; return TCL_OK; } /* *---------------------------------------------------------------------- * * SetEndOffsetFromAny -- * * Look for a string of the form "end[+-]offset" and convert it to an * internal representation holding the offset. |
︙ | ︙ | |||
3594 3595 3596 3597 3598 3599 3600 | */ static int SetEndOffsetFromAny( Tcl_Interp *interp, /* Tcl interpreter or NULL */ Tcl_Obj *objPtr) /* Pointer to the object to parse */ { | | | | 3562 3563 3564 3565 3566 3567 3568 3569 3570 3571 3572 3573 3574 3575 3576 3577 3578 3579 3580 3581 3582 3583 3584 | */ 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. */ if (objPtr->typePtr == &endOffsetType) { return TCL_OK; } /* * Check for a string rep of the right form. */ |
︙ | ︙ | |||
3630 3631 3632 3633 3634 3635 3636 | */ if (length <= 3) { offset = 0; } else if ((length > 4) && ((bytes[3] == '-') || (bytes[3] == '+'))) { /* * This is our limited string expression evaluator. Pass everything | | > | > > > > > > | 3598 3599 3600 3601 3602 3603 3604 3605 3606 3607 3608 3609 3610 3611 3612 3613 3614 3615 3616 3617 3618 3619 3620 3621 3622 3623 3624 3625 3626 3627 3628 | */ 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] == '-') { /* TODO: Review overflow concerns here! */ offset = -offset; } } else { /* * Conversion failed. Report the error. */ |
︙ | ︙ | |||
3662 3663 3664 3665 3666 3667 3668 | /* * The conversion succeeded. Free the old internal rep and set the new * one. */ TclFreeIntRep(objPtr); | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 3712 3713 3714 3715 3716 3717 3718 3719 3720 3721 3722 3723 3724 3725 3726 3727 3728 3729 3730 3731 3732 3733 3734 3735 3736 3737 3738 3739 3740 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 3769 3770 3771 3772 3773 3774 3775 3776 3777 3778 3779 3780 3781 3782 3783 3784 3785 3786 3787 3788 3789 3790 3791 3792 | /* * The conversion succeeded. Free the old internal rep and set the new * one. */ TclFreeIntRep(objPtr); objPtr->internalRep.wideValue = offset; objPtr->typePtr = &endOffsetType; return TCL_OK; } /* *---------------------------------------------------------------------- * * TclIndexEncode -- * * Parse objPtr to determine if it is an index value. Two cases * are possible. The value objPtr might be parsed as an absolute * index value in the C signed int range. Note that this includes * index values that are integers as presented and it includes index * arithmetic expressions. The absolute index values that can be * directly meaningful as an index into either a list or a string are * those integer values >= TCL_INDEX_START (0) * and < TCL_INDEX_AFTER (INT_MAX). * The largest string supported in Tcl 8 has bytelength INT_MAX. * This means the largest supported character length is also INT_MAX, * and the index of the last character in a string of length INT_MAX * is INT_MAX-1. * * Any absolute index value parsed outside that range is encoded * using the before and after values passed in by the * caller as the encoding to use for indices that are either * less than or greater than the usable index range. TCL_INDEX_AFTER * is available as a good choice for most callers to use for * after. Likewise, the value TCL_INDEX_BEFORE is good for * most callers to use for before. Other values are possible * when the caller knows it is helpful in producing its own behavior * for indices before and after the indexed item. * * A token can also be parsed as an end-relative index expression. * All end-relative expressions that indicate an index larger * than end (end+2, end--5) point beyond the end of the indexed * collection, and can be encoded as after. The end-relative * expressions that indicate an index less than or equal to end * are encoded relative to the value TCL_INDEX_END (-2). The * index "end" is encoded as -2, down to the index "end-0x7ffffffe" * which is encoded as INT_MIN. Since the largest index into a * string possible in Tcl 8 is 0x7ffffffe, the interpretation of * "end-0x7ffffffe" for that largest string would be 0. Thus, * if the tokens "end-0x7fffffff" or "end+-0x80000000" are parsed, * they can be encoded with the before value. * * These details will require re-examination whenever string and * list length limits are increased, but that will likely also * mean a revised routine capable of returning Tcl_WideInt values. * * Returns: * TCL_OK if parsing succeeded, and TCL_ERROR if it failed. * * Side effects: * When TCL_OK is returned, the encoded index value is written * to *indexPtr. * *---------------------------------------------------------------------- */ int TclIndexEncode( Tcl_Interp *interp, /* For error reporting, may be NULL */ Tcl_Obj *objPtr, /* Index value to parse */ int before, /* Value to return for index before beginning */ int after, /* Value to return for index after end */ int *indexPtr) /* Where to write the encoded answer, not NULL */ { int idx; if (TCL_OK == TclGetIntFromObj(NULL, objPtr, &idx)) { /* We parsed a value in the range INT_MIN...INT_MAX */ integerEncode: if (idx < TCL_INDEX_START) { /* All negative absolute indices are "before the beginning" */ idx = before; } else if (idx == INT_MAX) { /* This index value is always "after the end" */ idx = after; } /* usual case, the absolute index value encodes itself */ } else if (TCL_OK == GetEndOffsetFromObj(objPtr, 0, &idx)) { /* * We parsed an end+offset index value. * idx holds the offset value in the range INT_MIN...INT_MAX. */ if (idx > 0) { /* * All end+postive or end-negative expressions * always indicate "after the end". */ idx = after; } else if (idx < INT_MIN - TCL_INDEX_END) { /* These indices always indicate "before the beginning */ idx = before; } else { /* Encoded end-positive (or end+negative) are offset */ idx += TCL_INDEX_END; } /* TODO: Consider flag to suppress repeated end-offset parse. */ } else if (TCL_OK == TclGetIntForIndexM(interp, objPtr, 0, &idx)) { /* * Only reach this case when the index value is a * constant index arithmetic expression, and idx * holds the result. Treat it the same as if it were * parsed as an absolute integer value. */ goto integerEncode; } else { return TCL_ERROR; } *indexPtr = idx; return TCL_OK; } /* *---------------------------------------------------------------------- * * TclIndexDecode -- * * Decodes a value previously encoded by TclIndexEncode. The argument * endValue indicates what value of "end" should be used in the * decoding. * * Results: * The decoded index value. * *---------------------------------------------------------------------- */ int TclIndexDecode( int encoded, /* Value to decode */ int endValue) /* Meaning of "end" to use, > TCL_INDEX_END */ { if (encoded <= TCL_INDEX_END) { return (encoded - TCL_INDEX_END) + endValue; } return encoded; } /* *---------------------------------------------------------------------- * * ClearHash -- * * Remove all the entries in the hash table *tablePtr. |
︙ | ︙ |
Changes to generic/tclVar.c.
︙ | ︙ | |||
296 297 298 299 300 301 302 | Var *varPtr, /* Pointer to variable that may be a candidate * for being expunged. */ Var *arrayPtr) /* Array that contains the variable, or NULL * if this variable isn't an array element. */ { if (TclIsVarUndefined(varPtr) && TclIsVarInHash(varPtr) && !TclIsVarTraced(varPtr) | | | | 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 | Var *varPtr, /* Pointer to variable that may be a candidate * for being expunged. */ Var *arrayPtr) /* Array that contains the variable, or NULL * if this variable isn't an array element. */ { if (TclIsVarUndefined(varPtr) && TclIsVarInHash(varPtr) && !TclIsVarTraced(varPtr) && (VarHashRefCount(varPtr) == (unsigned)!TclIsVarDeadHash(varPtr))) { if (VarHashRefCount(varPtr) == 0) { ckfree(varPtr); } else { VarHashDeleteEntry(varPtr); } } if (arrayPtr != NULL && TclIsVarUndefined(arrayPtr) && TclIsVarInHash(arrayPtr) && !TclIsVarTraced(arrayPtr) && (VarHashRefCount(arrayPtr) == (unsigned)!TclIsVarDeadHash(arrayPtr))) { if (VarHashRefCount(arrayPtr) == 0) { ckfree(arrayPtr); } else { VarHashDeleteEntry(arrayPtr); } } } |
︙ | ︙ |
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); } } /* *---------------------------------------------------------------------- * |
︙ | ︙ |
Deleted library/http1.0/http.tcl.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
Deleted library/http1.0/pkgIndex.tcl.
|
| < < < < < < < < < < < |
Changes to library/init.tcl.
︙ | ︙ | |||
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/msgcat/msgcat.tcl.
1 2 3 4 5 6 | # msgcat.tcl -- # # This file defines various procedures which implement a # message catalog facility for Tcl programs. It should be # loaded with the command "package require msgcat". # | | > | | > | | | 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 | # msgcat.tcl -- # # This file defines various procedures which implement a # message catalog facility for Tcl programs. It should be # loaded with the command "package require msgcat". # # Copyright (c) 2010-2018 by Harald Oehlmann. # Copyright (c) 1998-2000 by Ajuba Solutions. # Copyright (c) 1998 by Mark Harrison. # # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # We use oo::define::self, which is new in Tcl 8.7 package require Tcl 8.7- # When the version number changes, be sure to update the pkgIndex.tcl file, # and the installation directory in the Makefiles. package provide msgcat 1.7.0 namespace eval msgcat { namespace export mc mcn mcexists mcload mclocale mcmax\ mcmset mcpreferences mcset\ mcunknown mcflset mcflmset mcloadedlocales mcforgetpackage\ mcpackagenamespaceget mcpackageconfig mcpackagelocale mcutil # Records the list of locales to search variable Loclist {} # List of currently loaded locales variable LoadedLocales {} |
︙ | ︙ | |||
37 38 39 40 41 42 43 | unknowncmd {} loadedlocales {} loclist {}] # Records the mapping between source strings and translated strings. The # dict key is of the form "<namespace> <locale> <src>", where locale and # namespace should be themselves dict values and the value is # the translated string. variable Msgs [dict create] | | > > > > > > | 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 | unknowncmd {} loadedlocales {} loclist {}] # Records the mapping between source strings and translated strings. The # dict key is of the form "<namespace> <locale> <src>", where locale and # namespace should be themselves dict values and the value is # the translated string. variable Msgs [dict create] } # create ensemble namespace for mcutil command namespace eval msgcat::mcutil { namespace export getsystemlocale getpreferences namespace ensemble create -prefix 0 # Map of language codes used in Windows registry to those of ISO-639 if {[info sharedlibextension] eq ".dll"} { variable WinRegToISO639 [dict create {*}{ 01 ar 0401 ar_SA 0801 ar_IQ 0c01 ar_EG 1001 ar_LY 1401 ar_DZ 1801 ar_MA 1c01 ar_TN 2001 ar_OM 2401 ar_YE 2801 ar_SY 2c01 ar_JO 3001 ar_LB 3401 ar_KW 3801 ar_AE 3c01 ar_BH 4001 ar_QA |
︙ | ︙ | |||
188 189 190 191 192 193 194 | # src The string to translate. # args Args to pass to the format command # # Results: # Returns the translated string. Propagates errors thrown by the # format command. | | > > | > > > > > > > > > > > > > > > > > > | | < | | 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 | # src The string to translate. # args Args to pass to the format command # # Results: # Returns the translated string. Propagates errors thrown by the # format command. proc msgcat::mc {args} { tailcall mcn [PackageNamespaceGet] {*}$args } # msgcat::mcn -- # # Find the translation for the given string based on the current # locale setting. Check the passed namespace first, then look in each # parent namespace until the source is found. If additional args are # specified, use the format command to work them into the traslated # string. # If no catalog item is found, mcunknown is called in the caller frame # and its result is returned. # # Arguments: # ns Package namespace of the translation # src The string to translate. # args Args to pass to the format command # # Results: # Returns the translated string. Propagates errors thrown by the # format command. proc msgcat::mcn {ns src args} { # Check for the src in each namespace starting from the local and # ending in the global. variable Msgs variable Loclist set loclist [PackagePreferences $ns] set nscur $ns while {$nscur != ""} { foreach loc $loclist { if {[dict exists $Msgs $nscur $loc $src]} { return [DefaultUnknown "" [dict get $Msgs $nscur $loc $src]\ {*}$args] } } set nscur [namespace parent $nscur] } # call package local or default unknown command set args [linsert $args 0 [lindex $loclist 0] $src] switch -exact -- [Invoke unknowncmd $args $ns result 1] { 0 { tailcall mcunknown {*}$args } 1 { return [DefaultUnknown {*}$args] } default { return $result } } } # msgcat::mcexists -- # |
︙ | ︙ | |||
241 242 243 244 245 246 247 | proc msgcat::mcexists {args} { variable Msgs variable Loclist variable PackageConfig | < < < > | > > > > | > | > > > > > | | 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 | proc msgcat::mcexists {args} { variable Msgs variable Loclist variable PackageConfig while {[llength $args] != 1} { set args [lassign $args option] switch -glob -- $option { -exactnamespace - -exactlocale { set $option 1 } -namespace { if {[llength $args] < 2} { return -code error\ "Argument missing for switch \"-namespace\"" } set args [lassign $args ns] } -* { return -code error "unknown option \"$option\"" } default { return -code error "wrong # args: should be\ \"[lindex [info level 0] 0] ?-exactnamespace?\ ?-exactlocale? ?-namespace ns? src\"" } } } set src [lindex $args 0] if {![info exists ns]} { set ns [PackageNamespaceGet] } set loclist [PackagePreferences $ns] if {[info exists -exactlocale]} { set loclist [lrange $loclist 0 0] } while {$ns ne ""} { foreach loc $loclist { if {[dict exists $Msgs $ns $loc $src]} { return 1 } } if {[info exists -exactnamespace]} {return 0} set ns [namespace parent $ns] } return 0 } # msgcat::mclocale -- # |
︙ | ︙ | |||
299 300 301 302 303 304 305 | if {$len == 1} { set newLocale [string tolower [lindex $args 0]] if {$newLocale ne [file tail $newLocale]} { return -code error "invalid newLocale value \"$newLocale\":\ could be path to unsafe code." } | < < | < < < < < | > > | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | if {$len == 1} { set newLocale [string tolower [lindex $args 0]] if {$newLocale ne [file tail $newLocale]} { return -code error "invalid newLocale value \"$newLocale\":\ could be path to unsafe code." } mcpreferences {*}[mcutil getpreferences $newLocale] } return [lindex $Loclist 0] } # msgcat::mcutil::getpreferences -- # # Get list of locales from a locale. # The first element is always the lowercase locale. # Other elements have one component separated by "_" less. # Multiple "_" are seen as one separator: de__ch_spec de__ch de {} # # This method is part of the ensemble mcutil # # Arguments: # Locale. # # Results: # Locale list proc msgcat::mcutil::getpreferences {locale} { set locale [string tolower $locale] set loclist [list $locale] while {-1 !=[set pos [string last "_" $locale]]} { set locale [string range $locale 0 $pos-1] if { "_" ne [string index $locale end] } { lappend loclist $locale } } if {"" ne [lindex $loclist end]} { lappend loclist {} } return $loclist } # msgcat::mcpreferences -- # # Fetch the list of locales used to look up strings, ordered from # most preferred to least preferred. # # Arguments: # New location list # # Results: # Returns an ordered list of the locales preferred by the user. proc msgcat::mcpreferences {args} { variable Loclist if {[llength $args] > 0} { # args is the new loclist if {![ListEqualString $args $Loclist]} { set Loclist $args # locale not loaded jet LoadAll $Loclist # Invoke callback Invoke changecmd $Loclist } } return $Loclist } # msgcat::ListStringEqual -- # # Compare two strings for equal string contents # # Arguments: # list1 first list # list2 second list # # Results: # 1 if lists of strings are identical, 0 otherwise proc msgcat::ListEqualString {list1 list2} { if {[llength $list1] != [llength $list2]} { return 0 } foreach item1 $list1 item2 $list2 { if {$item1 ne $item2} { return 0 } } return 1 } # msgcat::mcloadedlocales -- # # Get or change the list of currently loaded default locales # # The following subcommands are available: # loaded |
︙ | ︙ | |||
438 439 440 441 442 443 444 | # Arguments: # subcommand see list above # locale package locale (only set subcommand) # # Results: # Empty string, if not stated differently for the subcommand | | | < < < < < | | | | < < | < > > > > > > | > > | > > > > > > > > > > > > > > > > > > > > > > > > > > > | > | | | | > | > < < < > > > | | 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 | # Arguments: # subcommand see list above # locale package locale (only set subcommand) # # Results: # Empty string, if not stated differently for the subcommand proc msgcat::mcpackagelocale {subcommand args} { # todo: implement using an ensemble variable Loclist variable LoadedLocales variable Msgs variable PackageConfig # Check option # check if required item is exactly provided if { [llength $args] > 0 && $subcommand in {"get" "isset" "unset" "loaded" "clear"} } { return -code error "wrong # args: should be\ \"[lrange [info level 0] 0 1]\"" } set ns [PackageNamespaceGet] switch -exact -- $subcommand { get { return [lindex [PackagePreferences $ns] 0] } loaded { return [PackageLocales $ns] } present { if {[llength $args] != 1} { return -code error "wrong # args: should be\ \"[lrange [info level 0] 0 1] locale\"" } return [expr {[string tolower [lindex $args 0]] in [PackageLocales $ns]} ] } isset { return [dict exists $PackageConfig loclist $ns] } set - preferences { # set a package locale or add a package locale set fSet [expr {$subcommand eq "set"}] # Check parameter if {$fSet && 1 < [llength $args] } { return -code error "wrong # args: should be\ \"[lrange [info level 0] 0 1] ?locale?\"" } # > Return preferences if no parameter if {!$fSet && 0 == [llength $args] } { return [PackagePreferences $ns] } # Copy the default locale if no package locale set so far if {![dict exists $PackageConfig loclist $ns]} { dict set PackageConfig loclist $ns $Loclist dict set PackageConfig loadedlocales $ns $LoadedLocales } # No argument for set: return current package locale # The difference to no argument and subcommand "preferences" is, # that "preferences" does not set the package locale property. # This case is processed above, so no check for fSet here if { 0 == [llength $args] } { return [lindex [dict get $PackageConfig loclist $ns] 0] } # Get new loclist if {$fSet} { set loclist [mcutil getpreferences [lindex $args 0]] } else { set loclist $args } # Check if not changed to return imediately if { [ListEqualString $loclist\ [dict get $PackageConfig loclist $ns]] } { if {$fSet} { return [lindex $loclist 0] } return $loclist } # Change loclist dict set PackageConfig loclist $ns $loclist # load eventual missing locales set loadedLocales [dict get $PackageConfig loadedlocales $ns] set loadLocales [ListComplement $loadedLocales $loclist] dict set PackageConfig loadedlocales $ns\ [concat $loadedLocales $loadLocales] Load $ns $loadLocales if {$fSet} { return [lindex $loclist 0] } return $loclist } clear { # Remove all locales not contained in Loclist if {![dict exists $PackageConfig loclist $ns]} { return -code error "clear only when package locale set" } set loclist [dict get $PackageConfig loclist $ns] dict set PackageConfig loadedlocales $ns $loclist |
︙ | ︙ | |||
547 548 549 550 551 552 553 | # Remove any data of the calling package from msgcat # proc msgcat::mcforgetpackage {} { # todo: this may be implemented using an ensemble variable PackageConfig variable Msgs | | > > > > > > > > > | 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 | # Remove any data of the calling package from msgcat # proc msgcat::mcforgetpackage {} { # todo: this may be implemented using an ensemble variable PackageConfig variable Msgs set ns [PackageNamespaceGet] # Remove MC items dict unset Msgs $ns # Remove config items foreach key [dict keys $PackageConfig] { dict unset PackageConfig $key $ns } return } # msgcat::mcgetmynamespace -- # # Return the package namespace of the caller # This consideres to be called from a class or object. proc msgcat::mcpackagenamespaceget {} { return [PackageNamespaceGet] } # msgcat::mcpackageconfig -- # # Get or modify the per caller namespace (e.g. packages) config options. # # Available subcommands are: # |
︙ | ︙ | |||
612 613 614 615 616 617 618 | # # Results: # Depends on the subcommand and option and is described there proc msgcat::mcpackageconfig {subcommand option {value ""}} { variable PackageConfig # get namespace | | | 716 717 718 719 720 721 722 723 724 725 726 727 728 729 730 | # # Results: # Depends on the subcommand and option and is described there proc msgcat::mcpackageconfig {subcommand option {value ""}} { variable PackageConfig # get namespace set ns [PackageNamespaceGet] if {$option ni {"mcfolder" "loadcmd" "changecmd" "unknowncmd"}} { return -code error "bad option \"$option\": must be mcfolder, loadcmd,\ changecmd, or unknowncmd" } # check if value argument is exactly provided |
︙ | ︙ | |||
752 753 754 755 756 757 758 | # Arguments: # langdir The directory to search. # # Results: # Returns the number of message catalogs that were loaded. proc msgcat::mcload {langdir} { | < | | 856 857 858 859 860 861 862 863 864 865 866 867 868 869 870 | # Arguments: # langdir The directory to search. # # Results: # Returns the number of message catalogs that were loaded. proc msgcat::mcload {langdir} { tailcall mcpackageconfig set mcfolder $langdir } # msgcat::LoadAll -- # # Load a list of locales for all packages not having a package locale # list. # |
︙ | ︙ | |||
919 920 921 922 923 924 925 | proc msgcat::mcset {locale src {dest ""}} { variable Msgs if {[llength [info level 0]] == 3} { ;# dest not specified set dest $src } | | | 1022 1023 1024 1025 1026 1027 1028 1029 1030 1031 1032 1033 1034 1035 1036 | proc msgcat::mcset {locale src {dest ""}} { variable Msgs if {[llength [info level 0]] == 3} { ;# dest not specified set dest $src } set ns [PackageNamespaceGet] set locale [string tolower $locale] dict set Msgs $ns $locale $src $dest return $dest } |
︙ | ︙ | |||
947 948 949 950 951 952 953 | variable FileLocale variable Msgs if {![info exists FileLocale]} { return -code error "must only be used inside a message catalog loaded\ with ::msgcat::mcload" } | | | 1050 1051 1052 1053 1054 1055 1056 1057 1058 1059 1060 1061 1062 1063 1064 | variable FileLocale variable Msgs if {![info exists FileLocale]} { return -code error "must only be used inside a message catalog loaded\ with ::msgcat::mcload" } tailcall mcset $FileLocale $src $dest } # msgcat::mcmset -- # # Set the translation for multiple strings in a specified locale. # # Arguments: |
︙ | ︙ | |||
971 972 973 974 975 976 977 | set length [llength $pairs] if {$length % 2} { return -code error "bad translation list:\ should be \"[lindex [info level 0] 0] locale {src dest ...}\"" } set locale [string tolower $locale] | | | 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 1086 1087 1088 | set length [llength $pairs] if {$length % 2} { return -code error "bad translation list:\ should be \"[lindex [info level 0] 0] locale {src dest ...}\"" } set locale [string tolower $locale] set ns [PackageNamespaceGet] foreach {src dest} $pairs { dict set Msgs $ns $locale $src $dest } return [expr {$length / 2}] } |
︙ | ︙ | |||
998 999 1000 1001 1002 1003 1004 | variable FileLocale variable Msgs if {![info exists FileLocale]} { return -code error "must only be used inside a message catalog loaded\ with ::msgcat::mcload" } | | | 1101 1102 1103 1104 1105 1106 1107 1108 1109 1110 1111 1112 1113 1114 1115 | variable FileLocale variable Msgs if {![info exists FileLocale]} { return -code error "must only be used inside a message catalog loaded\ with ::msgcat::mcload" } tailcal mcmset $FileLocale $pairs } # msgcat::mcunknown -- # # This routine is called by msgcat::mc if a translation cannot # be found for a string and no unknowncmd is set for the current # package. This routine is intended to be replaced |
︙ | ︙ | |||
1020 1021 1022 1023 1024 1025 1026 | # src The string to be translated. # args Args to pass to the format command # # Results: # Returns the translated value. proc msgcat::mcunknown {args} { | | | 1123 1124 1125 1126 1127 1128 1129 1130 1131 1132 1133 1134 1135 1136 1137 | # src The string to be translated. # args Args to pass to the format command # # Results: # Returns the translated value. proc msgcat::mcunknown {args} { tailcall DefaultUnknown {*}$args } # msgcat::DefaultUnknown -- # # This routine is called by msgcat::mc if a translation cannot # be found for a string in the following circumstances: # - Default global handler, if mcunknown is not redefined. |
︙ | ︙ | |||
1063 1064 1065 1066 1067 1068 1069 1070 | # args strings to translate. # # Results: # Returns the length of the longest translated string. proc msgcat::mcmax {args} { set max 0 foreach string $args { | > | | | 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 | # args strings to translate. # # Results: # Returns the length of the longest translated string. proc msgcat::mcmax {args} { set max 0 set ns [PackageNamespaceGet] foreach string $args { set translated [uplevel 1 [list [namespace origin mcn] $ns $string]] set len [string length $translated] if {$len>$max} { set max $len } } return $max } # Convert the locale values stored in environment variables to a form # suitable for passing to [mclocale] proc msgcat::mcutil::ConvertLocale {value} { # Assume $value is of form: $language[_$territory][.$codeset][@modifier] # Convert to form: $language[_$territory][_$modifier] # # Comment out expanded RE version -- bugs alleged # regexp -expanded { # ^ # Match all the way to the beginning # ([^_.@]*) # Match "lanugage"; ends with _, ., or @ |
︙ | ︙ | |||
1102 1103 1104 1105 1106 1107 1108 1109 | } if {[string length $modifier]} { append ret _$modifier } return $ret } # Initialize the default locale | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | < | < | < | < | < | | 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 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 1277 1278 1279 1280 | } if {[string length $modifier]} { append ret _$modifier } return $ret } # helper function to find package namespace of stack-frame -2 # There are 4 possibilities: # - called from a proc # - called within a class definition script # - called from an class defined oo object # - called from a classless oo object proc ::msgcat::PackageNamespaceGet {} { uplevel 2 { # Check self namespace to determine environment switch -exact -- [namespace which self] { {::oo::define::self} { # We are within a class definition return [namespace qualifiers [self]] } {::oo::Helpers::self} { # We are within an object set Class [info object class [self]] # Check for classless defined object if {$Class eq {::oo::object}} { return [namespace qualifiers [self]] } # Class defined object return [namespace qualifiers $Class] } default { # Not in object environment return [namespace current] } } } } # Initialize the default locale proc msgcat::mcutil::getsystemlocale {} { global env # # set default locale, try to get from environment # foreach varName {LC_ALL LC_MESSAGES LANG} { if {[info exists env($varName)] && ("" ne $env($varName))} { if {![catch { ConvertLocale $env($varName) } locale]} { return $locale } } } # # On Darwin, fallback to current CFLocale identifier if available. # if {[info exists ::tcl::mac::locale] && $::tcl::mac::locale ne ""} { if {![catch { ConvertLocale $::tcl::mac::locale } locale]} { return $locale } } # # The rest of this routine is special processing for Windows or # Cygwin. All other platforms, get out now. # if {([info sharedlibextension] ne ".dll") || [catch {package require registry}]} { return C } # # On Windows or Cygwin, try to set locale depending on registry # settings, or fall back on locale of "C". # # On Vista and later: |
︙ | ︙ | |||
1166 1167 1168 1169 1170 1171 1172 | if {"" ne $territory} { append locale _ $territory } set modifierDict [dict create latn latin cyrl cyrillic] if {[dict exists $modifierDict $script]} { append locale @ [dict get $modifierDict $script] } | | | < | | | | | | | 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 | if {"" ne $territory} { append locale _ $territory } set modifierDict [dict create latn latin cyrl cyrillic] if {[dict exists $modifierDict $script]} { append locale @ [dict get $modifierDict $script] } if {![catch {ConvertLocale $locale} locale]} { return $locale } } } # then check value locale which contains a numerical language ID if {[catch { set locale [registry get $key "locale"] }]} { return C } # # Keep trying to match against smaller and smaller suffixes # of the registry value, since the latter hexadigits appear # to determine general language and earlier hexadigits determine # more precise information, such as territory. For example, # 0409 - English - United States # 0809 - English - United Kingdom # Add more translations to the WinRegToISO639 array above. # variable WinRegToISO639 set locale [string tolower $locale] while {[string length $locale]} { if {![catch { ConvertLocale [dict get $WinRegToISO639 $locale] } localeOut]} { return $localeOut } set locale [string range $locale 1 end] } # # No translation known. Fall back on "C" locale # return C } msgcat::mclocale [msgcat::mcutil getsystemlocale] |
Changes to library/msgcat/pkgIndex.tcl.
|
| | | | 1 2 | if {![package vsatisfies [package provide Tcl] 8.7-]} {return} package ifneeded msgcat 1.7.0 [list source [file join $dir msgcat.tcl]] |
Changes to library/opt/optparse.tcl.
1 2 3 4 5 6 7 8 9 10 | # optparse.tcl -- # # (private) Option parsing package # Primarily used internally by the safe:: code. # # WARNING: This code will go away in a future release # of Tcl. It is NOT supported and you should not rely # on it. If your code does rely on this package you # may directly incorporate this code into your application. | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 | # optparse.tcl -- # # (private) Option parsing package # Primarily used internally by the safe:: code. # # WARNING: This code will go away in a future release # of Tcl. It is NOT supported and you should not rely # on it. If your code does rely on this package you # may directly incorporate this code into your application. package require Tcl 8.5- # When this version number changes, update the pkgIndex.tcl file # and the install directory in the Makefiles. package provide opt 0.4.7 namespace eval ::tcl { # Exported APIs namespace export OptKeyRegister OptKeyDelete OptKeyError OptKeyParse \ OptProc OptProcArgGiven OptParse \ Lempty Lget \ |
︙ | ︙ |
Changes to library/opt/pkgIndex.tcl.
1 2 3 4 5 6 7 8 9 10 | # Tcl package index file, version 1.1 # This file is generated by the "pkg_mkIndex -direct" command # and sourced either when an application starts up or # by a "package unknown" script. It invokes the # "package ifneeded" command to set up package-related # information so that packages will be loaded automatically # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. | | | | 1 2 3 4 5 6 7 8 9 10 11 12 | # Tcl package index file, version 1.1 # This file is generated by the "pkg_mkIndex -direct" command # and sourced either when an application starts up or # by a "package unknown" script. It invokes the # "package ifneeded" command to set up package-related # information so that packages will be loaded automatically # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. if {![package vsatisfies [package provide Tcl] 8.5-]} {return} package ifneeded opt 0.4.7 [list source [file join $dir optparse.tcl]] |
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 tcl9.0 ?) 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 library/tcltest/pkgIndex.tcl.
1 2 3 4 5 6 7 8 9 10 11 | # Tcl package index file, version 1.1 # This file is generated by the "pkg_mkIndex -direct" command # and sourced either when an application starts up or # by a "package unknown" script. It invokes the # "package ifneeded" command to set up package-related # information so that packages will be loaded automatically # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. if {![package vsatisfies [package provide Tcl] 8.5-]} {return} | | | 1 2 3 4 5 6 7 8 9 10 11 12 | # Tcl package index file, version 1.1 # This file is generated by the "pkg_mkIndex -direct" command # and sourced either when an application starts up or # by a "package unknown" script. It invokes the # "package ifneeded" command to set up package-related # information so that packages will be loaded automatically # in response to "package require" commands. When this # script is sourced, the variable $dir must contain the # full path name of this file's directory. if {![package vsatisfies [package provide Tcl] 8.5-]} {return} package ifneeded tcltest 2.4.1 [list source [file join $dir tcltest.tcl]] |
Changes to library/tcltest/tcltest.tcl.
︙ | ︙ | |||
18 19 20 21 22 23 24 | package require Tcl 8.5- ;# -verbose line uses [info frame] namespace eval tcltest { # When the version number changes, be sure to update the pkgIndex.tcl file, # and the install directory in the Makefiles. When the minor version # changes (new feature) be sure to update the man page as well. | | | 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 | package require Tcl 8.5- ;# -verbose line uses [info frame] namespace eval tcltest { # When the version number changes, be sure to update the pkgIndex.tcl file, # and the install directory in the Makefiles. When the minor version # changes (new feature) be sure to update the man page as well. variable Version 2.4.1 # Compatibility support for dumb variables defined in tcltest 1 # Do not use these. Call [package provide Tcl] and [info patchlevel] # yourself. You don't need tcltest to wrap it for you. variable version [package provide Tcl] variable patchLevel [info patchlevel] |
︙ | ︙ |
Changes to library/tzdata/Africa/Sao_Tome.
1 | # created by tools/tclZIC.tcl - do not edit | < < | | > > > > > | 1 2 3 4 5 6 7 8 | # created by tools/tclZIC.tcl - do not edit set TZData(:Africa/Sao_Tome) { {-9223372036854775808 1616 0 LMT} {-2713912016 -2205 0 LMT} {-1830381795 0 0 GMT} {1514768400 3600 0 WAT} } |
Changes to library/tzdata/America/Campo_Grande.
︙ | ︙ | |||
87 88 89 90 91 92 93 | {1424574000 -14400 0 -04} {1445140800 -10800 1 -03} {1456023600 -14400 0 -04} {1476590400 -10800 1 -03} {1487473200 -14400 0 -04} {1508040000 -10800 1 -03} {1518922800 -14400 0 -04} | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | {1424574000 -14400 0 -04} {1445140800 -10800 1 -03} {1456023600 -14400 0 -04} {1476590400 -10800 1 -03} {1487473200 -14400 0 -04} {1508040000 -10800 1 -03} {1518922800 -14400 0 -04} {1541304000 -10800 1 -03} {1550372400 -14400 0 -04} {1572753600 -10800 1 -03} {1581822000 -14400 0 -04} {1604203200 -10800 1 -03} {1613876400 -14400 0 -04} {1636257600 -10800 1 -03} {1645326000 -14400 0 -04} {1667707200 -10800 1 -03} {1677380400 -14400 0 -04} {1699156800 -10800 1 -03} {1708225200 -14400 0 -04} {1730606400 -10800 1 -03} {1739674800 -14400 0 -04} {1762056000 -10800 1 -03} {1771729200 -14400 0 -04} {1793505600 -10800 1 -03} {1803178800 -14400 0 -04} {1825560000 -10800 1 -03} {1834628400 -14400 0 -04} {1857009600 -10800 1 -03} {1866078000 -14400 0 -04} {1888459200 -10800 1 -03} {1897527600 -14400 0 -04} {1919908800 -10800 1 -03} {1928977200 -14400 0 -04} {1951358400 -10800 1 -03} {1960426800 -14400 0 -04} {1983412800 -10800 1 -03} {1992481200 -14400 0 -04} {2014862400 -10800 1 -03} {2024535600 -14400 0 -04} {2046312000 -10800 1 -03} {2055380400 -14400 0 -04} {2077761600 -10800 1 -03} {2086830000 -14400 0 -04} {2109211200 -10800 1 -03} {2118884400 -14400 0 -04} {2140660800 -10800 1 -03} {2150334000 -14400 0 -04} {2172715200 -10800 1 -03} {2181783600 -14400 0 -04} {2204164800 -10800 1 -03} {2213233200 -14400 0 -04} {2235614400 -10800 1 -03} {2244682800 -14400 0 -04} {2267064000 -10800 1 -03} {2276132400 -14400 0 -04} {2298513600 -10800 1 -03} {2307582000 -14400 0 -04} {2329963200 -10800 1 -03} {2339636400 -14400 0 -04} {2362017600 -10800 1 -03} {2371086000 -14400 0 -04} {2393467200 -10800 1 -03} {2402535600 -14400 0 -04} {2424916800 -10800 1 -03} {2433985200 -14400 0 -04} {2456366400 -10800 1 -03} {2465434800 -14400 0 -04} {2487816000 -10800 1 -03} {2497489200 -14400 0 -04} {2519870400 -10800 1 -03} {2528938800 -14400 0 -04} {2551320000 -10800 1 -03} {2560388400 -14400 0 -04} {2582769600 -10800 1 -03} {2591838000 -14400 0 -04} {2614219200 -10800 1 -03} {2623287600 -14400 0 -04} {2645668800 -10800 1 -03} {2654737200 -14400 0 -04} {2677118400 -10800 1 -03} {2686791600 -14400 0 -04} {2709172800 -10800 1 -03} {2718241200 -14400 0 -04} {2740622400 -10800 1 -03} {2749690800 -14400 0 -04} {2772072000 -10800 1 -03} {2781140400 -14400 0 -04} {2803521600 -10800 1 -03} {2812590000 -14400 0 -04} {2834971200 -10800 1 -03} {2844039600 -14400 0 -04} {2867025600 -10800 1 -03} {2876094000 -14400 0 -04} {2898475200 -10800 1 -03} {2907543600 -14400 0 -04} {2929924800 -10800 1 -03} {2938993200 -14400 0 -04} {2961374400 -10800 1 -03} {2970442800 -14400 0 -04} {2992824000 -10800 1 -03} {3001892400 -14400 0 -04} {3024273600 -10800 1 -03} {3033946800 -14400 0 -04} {3056328000 -10800 1 -03} {3065396400 -14400 0 -04} {3087777600 -10800 1 -03} {3096846000 -14400 0 -04} {3119227200 -10800 1 -03} {3128295600 -14400 0 -04} {3150676800 -10800 1 -03} {3159745200 -14400 0 -04} {3182126400 -10800 1 -03} {3191194800 -14400 0 -04} {3213576000 -10800 1 -03} {3223249200 -14400 0 -04} {3245630400 -10800 1 -03} {3254698800 -14400 0 -04} {3277080000 -10800 1 -03} {3286148400 -14400 0 -04} {3308529600 -10800 1 -03} {3317598000 -14400 0 -04} {3339979200 -10800 1 -03} {3349047600 -14400 0 -04} {3371428800 -10800 1 -03} {3381102000 -14400 0 -04} {3403483200 -10800 1 -03} {3412551600 -14400 0 -04} {3434932800 -10800 1 -03} {3444001200 -14400 0 -04} {3466382400 -10800 1 -03} {3475450800 -14400 0 -04} {3497832000 -10800 1 -03} {3506900400 -14400 0 -04} {3529281600 -10800 1 -03} {3538350000 -14400 0 -04} {3560731200 -10800 1 -03} {3570404400 -14400 0 -04} {3592785600 -10800 1 -03} {3601854000 -14400 0 -04} {3624235200 -10800 1 -03} {3633303600 -14400 0 -04} {3655684800 -10800 1 -03} {3664753200 -14400 0 -04} {3687134400 -10800 1 -03} {3696202800 -14400 0 -04} {3718584000 -10800 1 -03} {3727652400 -14400 0 -04} {3750638400 -10800 1 -03} {3759706800 -14400 0 -04} {3782088000 -10800 1 -03} {3791156400 -14400 0 -04} {3813537600 -10800 1 -03} {3822606000 -14400 0 -04} {3844987200 -10800 1 -03} {3854055600 -14400 0 -04} {3876436800 -10800 1 -03} {3885505200 -14400 0 -04} {3907886400 -10800 1 -03} {3917559600 -14400 0 -04} {3939940800 -10800 1 -03} {3949009200 -14400 0 -04} {3971390400 -10800 1 -03} {3980458800 -14400 0 -04} {4002840000 -10800 1 -03} {4011908400 -14400 0 -04} {4034289600 -10800 1 -03} {4043358000 -14400 0 -04} {4065739200 -10800 1 -03} {4074807600 -14400 0 -04} {4097188800 -10800 1 -03} } |
Changes to library/tzdata/America/Cuiaba.
︙ | ︙ | |||
87 88 89 90 91 92 93 | {1424574000 -14400 0 -04} {1445140800 -10800 1 -03} {1456023600 -14400 0 -04} {1476590400 -10800 1 -03} {1487473200 -14400 0 -04} {1508040000 -10800 1 -03} {1518922800 -14400 0 -04} | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | {1424574000 -14400 0 -04} {1445140800 -10800 1 -03} {1456023600 -14400 0 -04} {1476590400 -10800 1 -03} {1487473200 -14400 0 -04} {1508040000 -10800 1 -03} {1518922800 -14400 0 -04} {1541304000 -10800 1 -03} {1550372400 -14400 0 -04} {1572753600 -10800 1 -03} {1581822000 -14400 0 -04} {1604203200 -10800 1 -03} {1613876400 -14400 0 -04} {1636257600 -10800 1 -03} {1645326000 -14400 0 -04} {1667707200 -10800 1 -03} {1677380400 -14400 0 -04} {1699156800 -10800 1 -03} {1708225200 -14400 0 -04} {1730606400 -10800 1 -03} {1739674800 -14400 0 -04} {1762056000 -10800 1 -03} {1771729200 -14400 0 -04} {1793505600 -10800 1 -03} {1803178800 -14400 0 -04} {1825560000 -10800 1 -03} {1834628400 -14400 0 -04} {1857009600 -10800 1 -03} {1866078000 -14400 0 -04} {1888459200 -10800 1 -03} {1897527600 -14400 0 -04} {1919908800 -10800 1 -03} {1928977200 -14400 0 -04} {1951358400 -10800 1 -03} {1960426800 -14400 0 -04} {1983412800 -10800 1 -03} {1992481200 -14400 0 -04} {2014862400 -10800 1 -03} {2024535600 -14400 0 -04} {2046312000 -10800 1 -03} {2055380400 -14400 0 -04} {2077761600 -10800 1 -03} {2086830000 -14400 0 -04} {2109211200 -10800 1 -03} {2118884400 -14400 0 -04} {2140660800 -10800 1 -03} {2150334000 -14400 0 -04} {2172715200 -10800 1 -03} {2181783600 -14400 0 -04} {2204164800 -10800 1 -03} {2213233200 -14400 0 -04} {2235614400 -10800 1 -03} {2244682800 -14400 0 -04} {2267064000 -10800 1 -03} {2276132400 -14400 0 -04} {2298513600 -10800 1 -03} {2307582000 -14400 0 -04} {2329963200 -10800 1 -03} {2339636400 -14400 0 -04} {2362017600 -10800 1 -03} {2371086000 -14400 0 -04} {2393467200 -10800 1 -03} {2402535600 -14400 0 -04} {2424916800 -10800 1 -03} {2433985200 -14400 0 -04} {2456366400 -10800 1 -03} {2465434800 -14400 0 -04} {2487816000 -10800 1 -03} {2497489200 -14400 0 -04} {2519870400 -10800 1 -03} {2528938800 -14400 0 -04} {2551320000 -10800 1 -03} {2560388400 -14400 0 -04} {2582769600 -10800 1 -03} {2591838000 -14400 0 -04} {2614219200 -10800 1 -03} {2623287600 -14400 0 -04} {2645668800 -10800 1 -03} {2654737200 -14400 0 -04} {2677118400 -10800 1 -03} {2686791600 -14400 0 -04} {2709172800 -10800 1 -03} {2718241200 -14400 0 -04} {2740622400 -10800 1 -03} {2749690800 -14400 0 -04} {2772072000 -10800 1 -03} {2781140400 -14400 0 -04} {2803521600 -10800 1 -03} {2812590000 -14400 0 -04} {2834971200 -10800 1 -03} {2844039600 -14400 0 -04} {2867025600 -10800 1 -03} {2876094000 -14400 0 -04} {2898475200 -10800 1 -03} {2907543600 -14400 0 -04} {2929924800 -10800 1 -03} {2938993200 -14400 0 -04} {2961374400 -10800 1 -03} {2970442800 -14400 0 -04} {2992824000 -10800 1 -03} {3001892400 -14400 0 -04} {3024273600 -10800 1 -03} {3033946800 -14400 0 -04} {3056328000 -10800 1 -03} {3065396400 -14400 0 -04} {3087777600 -10800 1 -03} {3096846000 -14400 0 -04} {3119227200 -10800 1 -03} {3128295600 -14400 0 -04} {3150676800 -10800 1 -03} {3159745200 -14400 0 -04} {3182126400 -10800 1 -03} {3191194800 -14400 0 -04} {3213576000 -10800 1 -03} {3223249200 -14400 0 -04} {3245630400 -10800 1 -03} {3254698800 -14400 0 -04} {3277080000 -10800 1 -03} {3286148400 -14400 0 -04} {3308529600 -10800 1 -03} {3317598000 -14400 0 -04} {3339979200 -10800 1 -03} {3349047600 -14400 0 -04} {3371428800 -10800 1 -03} {3381102000 -14400 0 -04} {3403483200 -10800 1 -03} {3412551600 -14400 0 -04} {3434932800 -10800 1 -03} {3444001200 -14400 0 -04} {3466382400 -10800 1 -03} {3475450800 -14400 0 -04} {3497832000 -10800 1 -03} {3506900400 -14400 0 -04} {3529281600 -10800 1 -03} {3538350000 -14400 0 -04} {3560731200 -10800 1 -03} {3570404400 -14400 0 -04} {3592785600 -10800 1 -03} {3601854000 -14400 0 -04} {3624235200 -10800 1 -03} {3633303600 -14400 0 -04} {3655684800 -10800 1 -03} {3664753200 -14400 0 -04} {3687134400 -10800 1 -03} {3696202800 -14400 0 -04} {3718584000 -10800 1 -03} {3727652400 -14400 0 -04} {3750638400 -10800 1 -03} {3759706800 -14400 0 -04} {3782088000 -10800 1 -03} {3791156400 -14400 0 -04} {3813537600 -10800 1 -03} {3822606000 -14400 0 -04} {3844987200 -10800 1 -03} {3854055600 -14400 0 -04} {3876436800 -10800 1 -03} {3885505200 -14400 0 -04} {3907886400 -10800 1 -03} {3917559600 -14400 0 -04} {3939940800 -10800 1 -03} {3949009200 -14400 0 -04} {3971390400 -10800 1 -03} {3980458800 -14400 0 -04} {4002840000 -10800 1 -03} {4011908400 -14400 0 -04} {4034289600 -10800 1 -03} {4043358000 -14400 0 -04} {4065739200 -10800 1 -03} {4074807600 -14400 0 -04} {4097188800 -10800 1 -03} } |
Changes to library/tzdata/America/La_Paz.
1 2 3 4 5 | # created by tools/tclZIC.tcl - do not edit set TZData(:America/La_Paz) { {-9223372036854775808 -16356 0 LMT} {-2524505244 -16356 0 CMT} | | | 1 2 3 4 5 6 7 8 | # created by tools/tclZIC.tcl - do not edit set TZData(:America/La_Paz) { {-9223372036854775808 -16356 0 LMT} {-2524505244 -16356 0 CMT} {-1205954844 -12756 1 BST} {-1192307244 -14400 0 -04} } |
Changes to library/tzdata/America/Sao_Paulo.
︙ | ︙ | |||
88 89 90 91 92 93 94 | {1424570400 -10800 0 -03} {1445137200 -7200 1 -02} {1456020000 -10800 0 -03} {1476586800 -7200 1 -02} {1487469600 -10800 0 -03} {1508036400 -7200 1 -02} {1518919200 -10800 0 -03} | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | 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 | {1424570400 -10800 0 -03} {1445137200 -7200 1 -02} {1456020000 -10800 0 -03} {1476586800 -7200 1 -02} {1487469600 -10800 0 -03} {1508036400 -7200 1 -02} {1518919200 -10800 0 -03} {1541300400 -7200 1 -02} {1550368800 -10800 0 -03} {1572750000 -7200 1 -02} {1581818400 -10800 0 -03} {1604199600 -7200 1 -02} {1613872800 -10800 0 -03} {1636254000 -7200 1 -02} {1645322400 -10800 0 -03} {1667703600 -7200 1 -02} {1677376800 -10800 0 -03} {1699153200 -7200 1 -02} {1708221600 -10800 0 -03} {1730602800 -7200 1 -02} {1739671200 -10800 0 -03} {1762052400 -7200 1 -02} {1771725600 -10800 0 -03} {1793502000 -7200 1 -02} {1803175200 -10800 0 -03} {1825556400 -7200 1 -02} {1834624800 -10800 0 -03} {1857006000 -7200 1 -02} {1866074400 -10800 0 -03} {1888455600 -7200 1 -02} {1897524000 -10800 0 -03} {1919905200 -7200 1 -02} {1928973600 -10800 0 -03} {1951354800 -7200 1 -02} {1960423200 -10800 0 -03} {1983409200 -7200 1 -02} {1992477600 -10800 0 -03} {2014858800 -7200 1 -02} {2024532000 -10800 0 -03} {2046308400 -7200 1 -02} {2055376800 -10800 0 -03} {2077758000 -7200 1 -02} {2086826400 -10800 0 -03} {2109207600 -7200 1 -02} {2118880800 -10800 0 -03} {2140657200 -7200 1 -02} {2150330400 -10800 0 -03} {2172711600 -7200 1 -02} {2181780000 -10800 0 -03} {2204161200 -7200 1 -02} {2213229600 -10800 0 -03} {2235610800 -7200 1 -02} {2244679200 -10800 0 -03} {2267060400 -7200 1 -02} {2276128800 -10800 0 -03} {2298510000 -7200 1 -02} {2307578400 -10800 0 -03} {2329959600 -7200 1 -02} {2339632800 -10800 0 -03} {2362014000 -7200 1 -02} {2371082400 -10800 0 -03} {2393463600 -7200 1 -02} {2402532000 -10800 0 -03} {2424913200 -7200 1 -02} {2433981600 -10800 0 -03} {2456362800 -7200 1 -02} {2465431200 -10800 0 -03} {2487812400 -7200 1 -02} {2497485600 -10800 0 -03} {2519866800 -7200 1 -02} {2528935200 -10800 0 -03} {2551316400 -7200 1 -02} {2560384800 -10800 0 -03} {2582766000 -7200 1 -02} {2591834400 -10800 0 -03} {2614215600 -7200 1 -02} {2623284000 -10800 0 -03} {2645665200 -7200 1 -02} {2654733600 -10800 0 -03} {2677114800 -7200 1 -02} {2686788000 -10800 0 -03} {2709169200 -7200 1 -02} {2718237600 -10800 0 -03} {2740618800 -7200 1 -02} {2749687200 -10800 0 -03} {2772068400 -7200 1 -02} {2781136800 -10800 0 -03} {2803518000 -7200 1 -02} {2812586400 -10800 0 -03} {2834967600 -7200 1 -02} {2844036000 -10800 0 -03} {2867022000 -7200 1 -02} {2876090400 -10800 0 -03} {2898471600 -7200 1 -02} {2907540000 -10800 0 -03} {2929921200 -7200 1 -02} {2938989600 -10800 0 -03} {2961370800 -7200 1 -02} {2970439200 -10800 0 -03} {2992820400 -7200 1 -02} {3001888800 -10800 0 -03} {3024270000 -7200 1 -02} {3033943200 -10800 0 -03} {3056324400 -7200 1 -02} {3065392800 -10800 0 -03} {3087774000 -7200 1 -02} {3096842400 -10800 0 -03} {3119223600 -7200 1 -02} {3128292000 -10800 0 -03} {3150673200 -7200 1 -02} {3159741600 -10800 0 -03} {3182122800 -7200 1 -02} {3191191200 -10800 0 -03} {3213572400 -7200 1 -02} {3223245600 -10800 0 -03} {3245626800 -7200 1 -02} {3254695200 -10800 0 -03} {3277076400 -7200 1 -02} {3286144800 -10800 0 -03} {3308526000 -7200 1 -02} {3317594400 -10800 0 -03} {3339975600 -7200 1 -02} {3349044000 -10800 0 -03} {3371425200 -7200 1 -02} {3381098400 -10800 0 -03} {3403479600 -7200 1 -02} {3412548000 -10800 0 -03} {3434929200 -7200 1 -02} {3443997600 -10800 0 -03} {3466378800 -7200 1 -02} {3475447200 -10800 0 -03} {3497828400 -7200 1 -02} {3506896800 -10800 0 -03} {3529278000 -7200 1 -02} {3538346400 -10800 0 -03} {3560727600 -7200 1 -02} {3570400800 -10800 0 -03} {3592782000 -7200 1 -02} {3601850400 -10800 0 -03} {3624231600 -7200 1 -02} {3633300000 -10800 0 -03} {3655681200 -7200 1 -02} {3664749600 -10800 0 -03} {3687130800 -7200 1 -02} {3696199200 -10800 0 -03} {3718580400 -7200 1 -02} {3727648800 -10800 0 -03} {3750634800 -7200 1 -02} {3759703200 -10800 0 -03} {3782084400 -7200 1 -02} {3791152800 -10800 0 -03} {3813534000 -7200 1 -02} {3822602400 -10800 0 -03} {3844983600 -7200 1 -02} {3854052000 -10800 0 -03} {3876433200 -7200 1 -02} {3885501600 -10800 0 -03} {3907882800 -7200 1 -02} {3917556000 -10800 0 -03} {3939937200 -7200 1 -02} {3949005600 -10800 0 -03} {3971386800 -7200 1 -02} {3980455200 -10800 0 -03} {4002836400 -7200 1 -02} {4011904800 -10800 0 -03} {4034286000 -7200 1 -02} {4043354400 -10800 0 -03} {4065735600 -7200 1 -02} {4074804000 -10800 0 -03} {4097185200 -7200 1 -02} } |
Changes to library/tzdata/Asia/Tokyo.
1 2 3 4 5 | # created by tools/tclZIC.tcl - do not edit set TZData(:Asia/Tokyo) { {-9223372036854775808 33539 0 LMT} {-2587712400 32400 0 JST} | | | | | | | | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | # created by tools/tclZIC.tcl - do not edit set TZData(:Asia/Tokyo) { {-9223372036854775808 33539 0 LMT} {-2587712400 32400 0 JST} {-683802000 36000 1 JDT} {-672314400 32400 0 JST} {-654771600 36000 1 JDT} {-640864800 32400 0 JST} {-620298000 36000 1 JDT} {-609415200 32400 0 JST} {-588848400 36000 1 JDT} {-577965600 32400 0 JST} } |
Changes to libtommath/README.md.
|
| > > > > > > | | < > > > | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 | # libtommath This is the git repository for [LibTomMath](http://www.libtom.net/LibTomMath/), a free open source portable number theoretic multiple-precision integer (MPI) library written entirely in C. ## Build Status master - [](https://travis-ci.org/libtom/libtommath) develop - [](https://travis-ci.org/libtom/libtommath) ## Summary The `develop` branch contains the in-development version. Stable releases are tagged. Documentation is built from the LaTeX file `bn.tex`. There is also limited documentation in `tommath.h`. There is also a document, `tommath.pdf`, which describes the goals of the project and many of the algorithms used. The project can be build by using `make`. Along with the usual `make`, `make clean` and `make install`, there are several other build targets, see the makefile for details. There are also makefiles for certain specific platforms. ## Testing Tests are located in `demo/` and can be built in two flavors. * `make test` creates a test binary that is intended to be run against `mtest`. `mtest` can be built with `make mtest` and test execution is done like `./mtest/mtest | ./test`. `mtest` is creating test vectors using an alternative MPI library and `test` is consuming these vectors to verify correct behavior of ltm * `make test_standalone` creates a stand-alone test binary that executes several test routines. |
Changes to libtommath/bn_error.c.
︙ | ︙ | |||
23 24 25 26 27 28 29 | { MP_MEM, "Out of heap" }, { MP_VAL, "Value out of range" } }; /* return a char * string for a given code */ const char *mp_error_to_string(int code) { | | | | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 | { MP_MEM, "Out of heap" }, { MP_VAL, "Value out of range" } }; /* return a char * string for a given code */ const char *mp_error_to_string(int code) { size_t x; /* scan the lookup table for the given message */ for (x = 0; x < (sizeof(msgs) / sizeof(msgs[0])); x++) { if (msgs[x].code == code) { return msgs[x].msg; } } /* generic reply for invalid code */ return "Invalid error code"; |
︙ | ︙ |
Changes to libtommath/bn_fast_mp_invmod.c.
︙ | ︙ | |||
41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 | goto LBL_ERR; } /* we need y = |a| */ if ((res = mp_mod(a, b, &y)) != MP_OKAY) { goto LBL_ERR; } /* 3. u=x, v=y, A=1, B=0, C=0,D=1 */ if ((res = mp_copy(&x, &u)) != MP_OKAY) { goto LBL_ERR; } if ((res = mp_copy(&y, &v)) != MP_OKAY) { goto LBL_ERR; } | > > > > > > | | 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 | goto LBL_ERR; } /* we need y = |a| */ if ((res = mp_mod(a, b, &y)) != MP_OKAY) { goto LBL_ERR; } /* if one of x,y is zero return an error! */ if ((mp_iszero(&x) == MP_YES) || (mp_iszero(&y) == MP_YES)) { res = MP_VAL; goto LBL_ERR; } /* 3. u=x, v=y, A=1, B=0, C=0,D=1 */ if ((res = mp_copy(&x, &u)) != MP_OKAY) { goto LBL_ERR; } if ((res = mp_copy(&y, &v)) != MP_OKAY) { goto LBL_ERR; } mp_set(&D, 1uL); top: /* 4. while u is even do */ while (mp_iseven(&u) == MP_YES) { /* 4.1 u = u/2 */ if ((res = mp_div_2(&u, &u)) != MP_OKAY) { goto LBL_ERR; |
︙ | ︙ | |||
118 119 120 121 122 123 124 | if (mp_iszero(&u) == MP_NO) { goto top; } /* now a = C, b = D, gcd == g*v */ /* if v != 1 then there is no inverse */ | | | 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 | if (mp_iszero(&u) == MP_NO) { goto top; } /* now a = C, b = D, gcd == g*v */ /* if v != 1 then there is no inverse */ if (mp_cmp_d(&v, 1uL) != MP_EQ) { res = MP_VAL; goto LBL_ERR; } /* b is now the inverse */ neg = a->sign; while (D.sign == MP_NEG) { |
︙ | ︙ |
Changes to libtommath/bn_fast_mp_montgomery_reduce.c.
︙ | ︙ | |||
23 24 25 26 27 28 29 30 31 32 33 34 35 36 | * * Based on Algorithm 14.32 on pp.601 of HAC. */ int fast_mp_montgomery_reduce(mp_int *x, const mp_int *n, mp_digit rho) { int ix, res, olduse; mp_word W[MP_WARRAY]; /* get old used count */ olduse = x->used; /* grow a as required */ if (x->alloc < (n->used + 1)) { if ((res = mp_grow(x, n->used + 1)) != MP_OKAY) { | > > > > | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 | * * Based on Algorithm 14.32 on pp.601 of HAC. */ int fast_mp_montgomery_reduce(mp_int *x, const mp_int *n, mp_digit rho) { int ix, res, olduse; mp_word W[MP_WARRAY]; if (x->used > (int)MP_WARRAY) { return MP_VAL; } /* get old used count */ olduse = x->used; /* grow a as required */ if (x->alloc < (n->used + 1)) { if ((res = mp_grow(x, n->used + 1)) != MP_OKAY) { |
︙ | ︙ | |||
69 70 71 72 73 74 75 | /* mu = ai * m' mod b * * We avoid a double precision multiplication (which isn't required) * by casting the value down to a mp_digit. Note this requires * that W[ix-1] have the carry cleared (see after the inner loop) */ mp_digit mu; | | | 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 | /* mu = ai * m' mod b * * We avoid a double precision multiplication (which isn't required) * by casting the value down to a mp_digit. Note this requires * that W[ix-1] have the carry cleared (see after the inner loop) */ mp_digit mu; mu = ((W[ix] & MP_MASK) * rho) & MP_MASK; /* a = a + mu * m * b**i * * This is computed in place and on the fly. The multiplication * by b**i is handled by offseting which columns the results * are added to. * |
︙ | ︙ | |||
98 99 100 101 102 103 104 | tmpn = n->dp; /* Alias for the columns set by an offset of ix */ _W = W + ix; /* inner loop */ for (iy = 0; iy < n->used; iy++) { | | | | | | 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 | tmpn = n->dp; /* Alias for the columns set by an offset of ix */ _W = W + ix; /* inner loop */ for (iy = 0; iy < n->used; iy++) { *_W++ += (mp_word)mu * (mp_word)*tmpn++; } } /* now fix carry for next digit, W[ix+1] */ W[ix + 1] += W[ix] >> (mp_word)DIGIT_BIT; } /* now we have to propagate the carries and * shift the words downward [all those least * significant digits we zeroed]. */ { mp_digit *tmpx; mp_word *_W, *_W1; /* nox fix rest of carries */ /* alias for current word */ _W1 = W + ix; /* alias for next word, where the carry goes */ _W = W + ++ix; for (; ix <= ((n->used * 2) + 1); ix++) { *_W++ += *_W1++ >> (mp_word)DIGIT_BIT; } /* copy out, A = A/b**n * * The result is A/b**n but instead of converting from an * array of mp_word to mp_digit than calling mp_rshd * we just copy them in the right order */ /* alias for destination word */ tmpx = x->dp; /* alias for shifted double precision result */ _W = W + n->used; for (ix = 0; ix < (n->used + 1); ix++) { *tmpx++ = *_W++ & (mp_word)MP_MASK; } /* zero oldused digits, if the input a was larger than * m->used+1 we'll have to clear the digits */ for (; ix < olduse; ix++) { *tmpx++ = 0; |
︙ | ︙ |
Changes to libtommath/bn_fast_s_mp_mul_digs.c.
︙ | ︙ | |||
65 66 67 68 69 70 71 | /* this is the number of times the loop will iterrate, essentially while (tx++ < a->used && ty-- >= 0) { ... } */ iy = MIN(a->used-tx, ty+1); /* execute loop */ for (iz = 0; iz < iy; ++iz) { | | | | | | 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 | /* this is the number of times the loop will iterrate, essentially while (tx++ < a->used && ty-- >= 0) { ... } */ iy = MIN(a->used-tx, ty+1); /* execute loop */ for (iz = 0; iz < iy; ++iz) { _W += (mp_word)*tmpx++ * (mp_word)*tmpy--; } /* store term */ W[ix] = (mp_digit)_W & MP_MASK; /* make next carry */ _W = _W >> (mp_word)DIGIT_BIT; } /* setup dest */ olduse = c->used; c->used = pa; { mp_digit *tmpc; tmpc = c->dp; for (ix = 0; ix < pa; ix++) { /* now extract the previous digit [below the carry] */ *tmpc++ = W[ix]; } /* clear unused digits [that existed in the old copy of c] */ for (; ix < olduse; ix++) { *tmpc++ = 0; |
︙ | ︙ |
Changes to libtommath/bn_fast_s_mp_mul_high_digs.c.
︙ | ︙ | |||
56 57 58 59 60 61 62 | /* this is the number of times the loop will iterrate, essentially its while (tx++ < a->used && ty-- >= 0) { ... } */ iy = MIN(a->used-tx, ty+1); /* execute loop */ for (iz = 0; iz < iy; iz++) { | | | | | 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 | /* this is the number of times the loop will iterrate, essentially its while (tx++ < a->used && ty-- >= 0) { ... } */ iy = MIN(a->used-tx, ty+1); /* execute loop */ for (iz = 0; iz < iy; iz++) { _W += (mp_word)*tmpx++ * (mp_word)*tmpy--; } /* store term */ W[ix] = (mp_digit)_W & MP_MASK; /* make next carry */ _W = _W >> (mp_word)DIGIT_BIT; } /* setup dest */ olduse = c->used; c->used = pa; { |
︙ | ︙ |
Changes to libtommath/bn_fast_s_mp_sqr.c.
︙ | ︙ | |||
66 67 68 69 70 71 72 | * we halve the distance since they approach at a rate of 2x * and we have to round because odd cases need to be executed */ iy = MIN(iy, ((ty-tx)+1)>>1); /* execute loop */ for (iz = 0; iz < iy; iz++) { | | | | | | | 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 | * we halve the distance since they approach at a rate of 2x * and we have to round because odd cases need to be executed */ iy = MIN(iy, ((ty-tx)+1)>>1); /* execute loop */ for (iz = 0; iz < iy; iz++) { _W += (mp_word)*tmpx++ * (mp_word)*tmpy--; } /* double the inner product and add carry */ _W = _W + _W + W1; /* even columns have the square term in them */ if (((unsigned)ix & 1u) == 0u) { _W += (mp_word)a->dp[ix>>1] * (mp_word)a->dp[ix>>1]; } /* store it */ W[ix] = _W & MP_MASK; /* make next carry */ W1 = _W >> (mp_word)DIGIT_BIT; } /* setup dest */ olduse = b->used; b->used = a->used+a->used; { |
︙ | ︙ |
Changes to libtommath/bn_mp_2expt.c.
︙ | ︙ | |||
32 33 34 35 36 37 38 | return res; } /* set the used count of where the bit will go */ a->used = (b / DIGIT_BIT) + 1; /* put the single bit in its place */ | | | 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 | return res; } /* set the used count of where the bit will go */ a->used = (b / DIGIT_BIT) + 1; /* put the single bit in its place */ a->dp[b / DIGIT_BIT] = (mp_digit)1 << (mp_digit)(b % DIGIT_BIT); return MP_OKAY; } #endif /* ref: $Format:%D$ */ /* git commit: $Format:%H$ */ |
︙ | ︙ |
Changes to libtommath/bn_mp_clamp.c.
︙ | ︙ | |||
23 24 25 26 27 28 29 | * are no more leading digits */ void mp_clamp(mp_int *a) { /* decrease used while the most significant digit is * zero. */ | | | 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 | * are no more leading digits */ void mp_clamp(mp_int *a) { /* decrease used while the most significant digit is * zero. */ while ((a->used > 0) && (a->dp[a->used - 1] == 0u)) { --(a->used); } /* reset the sign flag if used == 0 */ if (a->used == 0) { a->sign = MP_ZPOS; } |
︙ | ︙ |
Changes to libtommath/bn_mp_clear_multi.c.
︙ | ︙ | |||
10 11 12 13 14 15 16 17 18 19 20 21 22 23 | * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://libtom.org */ #include <stdarg.h> void mp_clear_multi(mp_int *mp, ...) { mp_int *next_mp = mp; va_list args; va_start(args, mp); | > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://libtom.org */ #include <stdarg.h> void mp_clear_multi(mp_int *mp, ...) { mp_int *next_mp = mp; va_list args; va_start(args, mp); |
︙ | ︙ |
Changes to libtommath/bn_mp_cnt_lsb.c.
︙ | ︙ | |||
27 28 29 30 31 32 33 | /* easy out */ if (mp_iszero(a) == MP_YES) { return 0; } /* scan lower digits until non-zero */ | | | | | | 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 | /* easy out */ if (mp_iszero(a) == MP_YES) { return 0; } /* scan lower digits until non-zero */ for (x = 0; (x < a->used) && (a->dp[x] == 0u); x++) {} q = a->dp[x]; x *= DIGIT_BIT; /* now scan this digit until a 1 is found */ if ((q & 1u) == 0u) { do { qq = q & 15u; x += lnz[qq]; q >>= 4; } while (qq == 0u); } return x; } #endif /* ref: $Format:%D$ */ |
︙ | ︙ |
Changes to libtommath/bn_mp_count_bits.c.
︙ | ︙ | |||
27 28 29 30 31 32 33 | } /* get number of digits and add that */ r = (a->used - 1) * DIGIT_BIT; /* take the last digit and count the bits in it */ q = a->dp[a->used - 1]; | | | | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 | } /* get number of digits and add that */ r = (a->used - 1) * DIGIT_BIT; /* take the last digit and count the bits in it */ q = a->dp[a->used - 1]; while (q > (mp_digit)0) { ++r; q >>= (mp_digit)1; } return r; } #endif /* ref: $Format:%D$ */ /* git commit: $Format:%H$ */ |
︙ | ︙ |
Changes to libtommath/bn_mp_div.c.
︙ | ︙ | |||
43 44 45 46 47 48 49 | /* init our temps */ if ((res = mp_init_multi(&ta, &tb, &tq, &q, NULL)) != MP_OKAY) { return res; } | | | 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 | /* init our temps */ if ((res = mp_init_multi(&ta, &tb, &tq, &q, NULL)) != MP_OKAY) { return res; } mp_set(&tq, 1uL); n = mp_count_bits(a) - mp_count_bits(b); if (((res = mp_abs(a, &ta)) != MP_OKAY) || ((res = mp_abs(b, &tb)) != MP_OKAY) || ((res = mp_mul_2d(&tb, n, &tb)) != MP_OKAY) || ((res = mp_mul_2d(&tq, n, &tq)) != MP_OKAY)) { goto LBL_ERR; } |
︙ | ︙ | |||
146 147 148 149 150 151 152 | /* fix the sign */ neg = (a->sign == b->sign) ? MP_ZPOS : MP_NEG; x.sign = y.sign = MP_ZPOS; /* normalize both x and y, ensure that y >= b/2, [b == 2**DIGIT_BIT] */ norm = mp_count_bits(&y) % DIGIT_BIT; | | | | 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 | /* fix the sign */ neg = (a->sign == b->sign) ? MP_ZPOS : MP_NEG; x.sign = y.sign = MP_ZPOS; /* normalize both x and y, ensure that y >= b/2, [b == 2**DIGIT_BIT] */ norm = mp_count_bits(&y) % DIGIT_BIT; if (norm < (DIGIT_BIT - 1)) { norm = (DIGIT_BIT - 1) - norm; if ((res = mp_mul_2d(&x, norm, &x)) != MP_OKAY) { goto LBL_Y; } if ((res = mp_mul_2d(&y, norm, &y)) != MP_OKAY) { goto LBL_Y; } } else { |
︙ | ︙ | |||
186 187 188 189 190 191 192 | if (i > x.used) { continue; } /* step 3.1 if xi == yt then set q{i-t-1} to b-1, * otherwise set q{i-t-1} to (xi*b + x{i-1})/yt */ if (x.dp[i] == y.dp[t]) { | | | | | | | | | | | | | 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 | if (i > x.used) { continue; } /* step 3.1 if xi == yt then set q{i-t-1} to b-1, * otherwise set q{i-t-1} to (xi*b + x{i-1})/yt */ if (x.dp[i] == y.dp[t]) { q.dp[(i - t) - 1] = ((mp_digit)1 << (mp_digit)DIGIT_BIT) - (mp_digit)1; } else { mp_word tmp; tmp = (mp_word)x.dp[i] << (mp_word)DIGIT_BIT; tmp |= (mp_word)x.dp[i - 1]; tmp /= (mp_word)y.dp[t]; if (tmp > (mp_word)MP_MASK) { tmp = MP_MASK; } q.dp[(i - t) - 1] = (mp_digit)(tmp & (mp_word)MP_MASK); } /* while (q{i-t-1} * (yt * b + y{t-1})) > xi * b**2 + xi-1 * b + xi-2 do q{i-t-1} -= 1; */ q.dp[(i - t) - 1] = (q.dp[(i - t) - 1] + 1uL) & (mp_digit)MP_MASK; do { q.dp[(i - t) - 1] = (q.dp[(i - t) - 1] - 1uL) & (mp_digit)MP_MASK; /* find left hand */ mp_zero(&t1); t1.dp[0] = ((t - 1) < 0) ? 0u : y.dp[t - 1]; t1.dp[1] = y.dp[t]; t1.used = 2; if ((res = mp_mul_d(&t1, q.dp[(i - t) - 1], &t1)) != MP_OKAY) { goto LBL_Y; } /* find right hand */ t2.dp[0] = ((i - 2) < 0) ? 0u : x.dp[i - 2]; t2.dp[1] = ((i - 1) < 0) ? 0u : x.dp[i - 1]; t2.dp[2] = x.dp[i]; t2.used = 3; } while (mp_cmp_mag(&t1, &t2) == MP_GT); /* step 3.3 x = x - q{i-t-1} * y * b**{i-t-1} */ if ((res = mp_mul_d(&y, q.dp[(i - t) - 1], &t1)) != MP_OKAY) { goto LBL_Y; |
︙ | ︙ | |||
248 249 250 251 252 253 254 | if ((res = mp_lshd(&t1, (i - t) - 1)) != MP_OKAY) { goto LBL_Y; } if ((res = mp_add(&x, &t1, &x)) != MP_OKAY) { goto LBL_Y; } | | | 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 | if ((res = mp_lshd(&t1, (i - t) - 1)) != MP_OKAY) { goto LBL_Y; } if ((res = mp_add(&x, &t1, &x)) != MP_OKAY) { goto LBL_Y; } q.dp[(i - t) - 1] = (q.dp[(i - t) - 1] - 1uL) & MP_MASK; } } /* now q is the quotient and x is the remainder * [which we have to normalize] */ |
︙ | ︙ |
Changes to libtommath/bn_mp_div_2.c.
︙ | ︙ | |||
38 39 40 41 42 43 44 | /* dest alias */ tmpb = b->dp + b->used - 1; /* carry */ r = 0; for (x = b->used - 1; x >= 0; x--) { /* get the carry for the next iteration */ | | | 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 | /* dest alias */ tmpb = b->dp + b->used - 1; /* carry */ r = 0; for (x = b->used - 1; x >= 0; x--) { /* get the carry for the next iteration */ rr = *tmpa & 1u; /* shift the current digit, add in carry and store */ *tmpb-- = (*tmpa-- >> 1) | (r << (DIGIT_BIT - 1)); /* forward carry to next iteration */ r = rr; } |
︙ | ︙ |
Changes to libtommath/bn_mp_div_2d.c.
︙ | ︙ | |||
40 41 42 43 44 45 46 | if (d != NULL) { if ((res = mp_mod_2d(a, b, d)) != MP_OKAY) { return res; } } /* shift by as many digits in the bit count */ | | | | | | 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 | if (d != NULL) { if ((res = mp_mod_2d(a, b, d)) != MP_OKAY) { return res; } } /* shift by as many digits in the bit count */ if (b >= DIGIT_BIT) { mp_rshd(c, b / DIGIT_BIT); } /* shift any bit count < DIGIT_BIT */ D = (mp_digit)(b % DIGIT_BIT); if (D != 0u) { mp_digit *tmpc, mask, shift; /* mask */ mask = ((mp_digit)1 << D) - 1uL; /* shift for lsb */ shift = (mp_digit)DIGIT_BIT - D; /* alias */ tmpc = c->dp + (c->used - 1); /* carry */ r = 0; for (x = c->used - 1; x >= 0; x--) { |
︙ | ︙ |
Changes to libtommath/bn_mp_div_3.c.
︙ | ︙ | |||
20 21 22 23 24 25 26 | { mp_int q; mp_word w, t; mp_digit b; int res, ix; /* b = 2**DIGIT_BIT / 3 */ | | | | | | | | | 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 | { mp_int q; mp_word w, t; mp_digit b; int res, ix; /* b = 2**DIGIT_BIT / 3 */ b = ((mp_word)1 << (mp_word)DIGIT_BIT) / (mp_word)3; if ((res = mp_init_size(&q, a->used)) != MP_OKAY) { return res; } q.used = a->used; q.sign = a->sign; w = 0; for (ix = a->used - 1; ix >= 0; ix--) { w = (w << (mp_word)DIGIT_BIT) | (mp_word)a->dp[ix]; if (w >= 3u) { /* multiply w by [1/3] */ t = (w * (mp_word)b) >> (mp_word)DIGIT_BIT; /* now subtract 3 * [w/3] from w, to get the remainder */ w -= t+t+t; /* fixup the remainder as required since * the optimization is not exact. */ while (w >= 3u) { t += 1u; w -= 3u; } } else { t = 0; } q.dp[ix] = (mp_digit)t; } |
︙ | ︙ |
Changes to libtommath/bn_mp_div_d.c.
︙ | ︙ | |||
20 21 22 23 24 25 26 | { mp_int q; mp_word w; mp_digit t; int res, ix; /* cannot divide by zero */ | | | | | | | | | 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 | { mp_int q; mp_word w; mp_digit t; int res, ix; /* cannot divide by zero */ if (b == 0u) { return MP_VAL; } /* quick outs */ if ((b == 1u) || (mp_iszero(a) == MP_YES)) { if (d != NULL) { *d = 0; } if (c != NULL) { return mp_copy(a, c); } return MP_OKAY; } /* power of two ? */ if (((b & (b-1)) == 0)) { for (ix = 1; ix < DIGIT_BIT; ix++) { if (b == (((mp_digit)1)<<ix)) { break; } } if (d != NULL) { *d = a->dp[0] & (((mp_digit)1<<(mp_digit)ix) - 1uL); } if (c != NULL) { return mp_div_2d(a, ix, c, NULL); } return MP_OKAY; } #ifdef BN_MP_DIV_3_C /* three? */ if (b == 3u) { return mp_div_3(a, c, d); } #endif /* no easy answer [c'est la vie]. Just division */ if ((res = mp_init_size(&q, a->used)) != MP_OKAY) { return res; } q.used = a->used; q.sign = a->sign; w = 0; for (ix = a->used - 1; ix >= 0; ix--) { w = (w << (mp_word)DIGIT_BIT) | (mp_word)a->dp[ix]; if (w >= b) { t = (mp_digit)(w / b); w -= (mp_word)t * (mp_word)b; } else { t = 0; } q.dp[ix] = t; } if (d != NULL) { *d = (mp_digit)w; } if (c != NULL) { |
︙ | ︙ |
Changes to libtommath/bn_mp_dr_reduce.c.
︙ | ︙ | |||
57 58 59 60 61 62 63 | tmpx2 = x->dp + m; /* set carry to zero */ mu = 0; /* compute (x mod B**m) + k * [x/B**m] inline and inplace */ for (i = 0; i < m; i++) { | | | 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 | tmpx2 = x->dp + m; /* set carry to zero */ mu = 0; /* compute (x mod B**m) + k * [x/B**m] inline and inplace */ for (i = 0; i < m; i++) { r = ((mp_word)*tmpx2++ * (mp_word)k) + *tmpx1 + mu; *tmpx1++ = (mp_digit)(r & MP_MASK); mu = (mp_digit)(r >> ((mp_word)DIGIT_BIT)); } /* set final carry */ *tmpx1++ = mu; |
︙ | ︙ |
Changes to libtommath/bn_mp_dr_setup.c.
︙ | ︙ | |||
17 18 19 20 21 22 23 | /* determines the setup value */ void mp_dr_setup(const mp_int *a, mp_digit *d) { /* the casts are required if DIGIT_BIT is one less than * the number of bits in a mp_digit [e.g. DIGIT_BIT==31] */ | | | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | /* determines the setup value */ void mp_dr_setup(const mp_int *a, mp_digit *d) { /* the casts are required if DIGIT_BIT is one less than * the number of bits in a mp_digit [e.g. DIGIT_BIT==31] */ *d = (mp_digit)(((mp_word)1 << (mp_word)DIGIT_BIT) - (mp_word)a->dp[0]); } #endif /* ref: $Format:%D$ */ /* git commit: $Format:%H$ */ /* commit time: $Format:%ai$ */ |
Changes to libtommath/bn_mp_export.c.
︙ | ︙ | |||
34 35 36 37 38 39 40 | if (endian == 0) { union { unsigned int i; char c[4]; } lint; lint.i = 0x01020304; | | | | | | | | | | | | 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 | if (endian == 0) { union { unsigned int i; char c[4]; } lint; lint.i = 0x01020304; endian = (lint.c[0] == '\x04') ? -1 : 1; } odd_nails = (nails % 8u); odd_nail_mask = 0xff; for (i = 0; i < odd_nails; ++i) { odd_nail_mask ^= (unsigned char)(1u << (7u - i)); } nail_bytes = nails / 8u; bits = (size_t)mp_count_bits(&t); count = (bits / ((size * 8u) - nails)) + (((bits % ((size * 8u) - nails)) != 0u) ? 1u : 0u); for (i = 0; i < count; ++i) { for (j = 0; j < size; ++j) { unsigned char *byte = (unsigned char *)rop + (((order == -1) ? i : ((count - 1u) - i)) * size) + ((endian == -1) ? j : ((size - 1u) - j)); if (j >= (size - nail_bytes)) { *byte = 0; continue; } *byte = (unsigned char)((j == ((size - nail_bytes) - 1u)) ? (t.dp[0] & odd_nail_mask) : (t.dp[0] & 0xFFuL)); if ((result = mp_div_2d(&t, (j == ((size - nail_bytes) - 1u)) ? (int)(8u - odd_nails) : 8, &t, NULL)) != MP_OKAY) { mp_clear(&t); return result; } } } mp_clear(&t); |
︙ | ︙ |
Changes to libtommath/bn_mp_expt_d_ex.c.
︙ | ︙ | |||
24 25 26 27 28 29 30 | mp_int g; if ((res = mp_init_copy(&g, a)) != MP_OKAY) { return res; } /* set initial result */ | | | | | | | | 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 | mp_int g; if ((res = mp_init_copy(&g, a)) != MP_OKAY) { return res; } /* set initial result */ mp_set(c, 1uL); if (fast != 0) { while (b > 0u) { /* if the bit is set multiply */ if ((b & 1u) != 0u) { if ((res = mp_mul(c, &g, c)) != MP_OKAY) { mp_clear(&g); return res; } } /* square */ if (b > 1u) { if ((res = mp_sqr(&g, &g)) != MP_OKAY) { mp_clear(&g); return res; } } /* shift to next bit */ b >>= 1; } } else { for (x = 0; x < (unsigned)DIGIT_BIT; x++) { /* square */ if ((res = mp_sqr(c, c)) != MP_OKAY) { mp_clear(&g); return res; } /* if the bit is set multiply */ if ((b & ((mp_digit)1 << (DIGIT_BIT - 1))) != 0u) { if ((res = mp_mul(c, &g, c)) != MP_OKAY) { mp_clear(&g); return res; } } /* shift to next bit */ |
︙ | ︙ |
Changes to libtommath/bn_mp_exptmod_fast.c.
︙ | ︙ | |||
35 36 37 38 39 40 41 | mp_digit buf, mp; int err, bitbuf, bitcpy, bitcnt, mode, digidx, x, y, winsize; /* use a pointer to the reduction algorithm. This allows us to use * one of many reduction algorithms without modding the guts of * the code with if statements everywhere. */ | | | 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 | mp_digit buf, mp; int err, bitbuf, bitcpy, bitcnt, mode, digidx, x, y, winsize; /* use a pointer to the reduction algorithm. This allows us to use * one of many reduction algorithms without modding the guts of * the code with if statements everywhere. */ int (*redux)(mp_int *x, const mp_int *n, mp_digit rho); /* find window size */ x = mp_count_bits(X); if (x <= 7) { winsize = 2; } else if (x <= 36) { winsize = 3; |
︙ | ︙ | |||
92 93 94 95 96 97 98 | #else err = MP_VAL; goto LBL_M; #endif /* automatically pick the comba one if available (saves quite a few calls/ifs) */ #ifdef BN_FAST_MP_MONTGOMERY_REDUCE_C | | | 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 | #else err = MP_VAL; goto LBL_M; #endif /* automatically pick the comba one if available (saves quite a few calls/ifs) */ #ifdef BN_FAST_MP_MONTGOMERY_REDUCE_C if ((((P->used * 2) + 1) < (int)MP_WARRAY) && (P->used < (1 << ((CHAR_BIT * sizeof(mp_word)) - (2 * DIGIT_BIT))))) { redux = fast_mp_montgomery_reduce; } else #endif { #ifdef BN_MP_MONTGOMERY_REDUCE_C /* use slower baseline Montgomery method */ |
︙ | ︙ | |||
156 157 158 159 160 161 162 | goto LBL_RES; } #else err = MP_VAL; goto LBL_RES; #endif } else { | | | 156 157 158 159 160 161 162 163 164 165 166 167 168 169 170 | goto LBL_RES; } #else err = MP_VAL; goto LBL_RES; #endif } else { mp_set(&res, 1uL); if ((err = mp_mod(G, P, &M[1])) != MP_OKAY) { goto LBL_RES; } } /* compute the value at M[1<<(winsize-1)] by squaring M[1] (winsize-1) times */ if ((err = mp_copy(&M[1], &M[1 << (winsize - 1)])) != MP_OKAY) { |
︙ | ︙ |
Changes to libtommath/bn_mp_exteuclid.c.
︙ | ︙ | |||
24 25 26 27 28 29 30 | int err; if ((err = mp_init_multi(&u1, &u2, &u3, &v1, &v2, &v3, &t1, &t2, &t3, &q, &tmp, NULL)) != MP_OKAY) { return err; } /* initialize, (u1,u2,u3) = (1,0,a) */ | | | | | | | | | | | | | | | | | | | | | | 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 | int err; if ((err = mp_init_multi(&u1, &u2, &u3, &v1, &v2, &v3, &t1, &t2, &t3, &q, &tmp, NULL)) != MP_OKAY) { return err; } /* initialize, (u1,u2,u3) = (1,0,a) */ mp_set(&u1, 1uL); if ((err = mp_copy(a, &u3)) != MP_OKAY) { goto LBL_ERR; } /* initialize, (v1,v2,v3) = (0,1,b) */ mp_set(&v2, 1uL); if ((err = mp_copy(b, &v3)) != MP_OKAY) { goto LBL_ERR; } /* loop while v3 != 0 */ while (mp_iszero(&v3) == MP_NO) { /* q = u3/v3 */ if ((err = mp_div(&u3, &v3, &q, NULL)) != MP_OKAY) { goto LBL_ERR; } /* (t1,t2,t3) = (u1,u2,u3) - (v1,v2,v3)q */ if ((err = mp_mul(&v1, &q, &tmp)) != MP_OKAY) { goto LBL_ERR; } if ((err = mp_sub(&u1, &tmp, &t1)) != MP_OKAY) { goto LBL_ERR; } if ((err = mp_mul(&v2, &q, &tmp)) != MP_OKAY) { goto LBL_ERR; } if ((err = mp_sub(&u2, &tmp, &t2)) != MP_OKAY) { goto LBL_ERR; } if ((err = mp_mul(&v3, &q, &tmp)) != MP_OKAY) { goto LBL_ERR; } if ((err = mp_sub(&u3, &tmp, &t3)) != MP_OKAY) { goto LBL_ERR; } /* (u1,u2,u3) = (v1,v2,v3) */ if ((err = mp_copy(&v1, &u1)) != MP_OKAY) { goto LBL_ERR; } if ((err = mp_copy(&v2, &u2)) != MP_OKAY) { goto LBL_ERR; } if ((err = mp_copy(&v3, &u3)) != MP_OKAY) { goto LBL_ERR; } /* (v1,v2,v3) = (t1,t2,t3) */ if ((err = mp_copy(&t1, &v1)) != MP_OKAY) { goto LBL_ERR; } if ((err = mp_copy(&t2, &v2)) != MP_OKAY) { goto LBL_ERR; } if ((err = mp_copy(&t3, &v3)) != MP_OKAY) { goto LBL_ERR; } } /* make sure U3 >= 0 */ if (u3.sign == MP_NEG) { if ((err = mp_neg(&u1, &u1)) != MP_OKAY) { goto LBL_ERR; } if ((err = mp_neg(&u2, &u2)) != MP_OKAY) { goto LBL_ERR; } if ((err = mp_neg(&u3, &u3)) != MP_OKAY) { goto LBL_ERR; } } /* copy result out */ if (U1 != NULL) { mp_exch(U1, &u1); |
︙ | ︙ |
Changes to libtommath/bn_mp_fread.c.
︙ | ︙ | |||
16 17 18 19 20 21 22 23 24 25 26 27 28 | */ #ifndef LTM_NO_FILE /* read a bigint from a file stream in ASCII */ int mp_fread(mp_int *a, int radix, FILE *stream) { int err, ch, neg, y; /* clear a */ mp_zero(a); /* if first digit is - then set negative */ ch = fgetc(stream); | > | < | | | | | > | > | | | | 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 | */ #ifndef LTM_NO_FILE /* read a bigint from a file stream in ASCII */ int mp_fread(mp_int *a, int radix, FILE *stream) { int err, ch, neg, y; unsigned pos; /* clear a */ mp_zero(a); /* if first digit is - then set negative */ ch = fgetc(stream); if (ch == (int)'-') { neg = MP_NEG; ch = fgetc(stream); } else { neg = MP_ZPOS; } for (;;) { pos = (unsigned)(ch - (int)'('); if (mp_s_rmap_reverse_sz < pos) { break; } y = (int)mp_s_rmap_reverse[pos]; if ((y == 0xff) || (y >= radix)) { break; } /* shift up and add */ if ((err = mp_mul_d(a, (mp_digit)radix, a)) != MP_OKAY) { return err; } if ((err = mp_add_d(a, (mp_digit)y, a)) != MP_OKAY) { return err; } ch = fgetc(stream); } if (mp_cmp_d(a, 0uL) != MP_EQ) { a->sign = neg; } return MP_OKAY; } #endif |
︙ | ︙ |
Changes to libtommath/bn_mp_fwrite.c.
︙ | ︙ | |||
21 22 23 24 25 26 27 | char *buf; int err, len, x; if ((err = mp_radix_size(a, radix, &len)) != MP_OKAY) { return err; } | | | | 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 | char *buf; int err, len, x; if ((err = mp_radix_size(a, radix, &len)) != MP_OKAY) { return err; } buf = OPT_CAST(char) XMALLOC((size_t)len); if (buf == NULL) { return MP_MEM; } if ((err = mp_toradix(a, buf, radix)) != MP_OKAY) { XFREE(buf); return err; } for (x = 0; x < len; x++) { if (fputc((int)buf[x], stream) == EOF) { XFREE(buf); return MP_VAL; } } XFREE(buf); return MP_OKAY; |
︙ | ︙ |
Changes to libtommath/bn_mp_get_int.c.
︙ | ︙ | |||
22 23 24 25 26 27 28 | mp_min_u32 res; if (a->used == 0) { return 0; } /* get number of digits of the lsb we have to read */ | | | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 | mp_min_u32 res; if (a->used == 0) { return 0; } /* get number of digits of the lsb we have to read */ i = MIN(a->used, ((((int)sizeof(unsigned long) * CHAR_BIT) + DIGIT_BIT - 1) / DIGIT_BIT)) - 1; /* get most significant digit of result */ res = DIGIT(a, i); while (--i >= 0) { res = (res << DIGIT_BIT) | DIGIT(a, i); } |
︙ | ︙ |
Changes to libtommath/bn_mp_get_long.c.
︙ | ︙ | |||
22 23 24 25 26 27 28 | unsigned long res; if (a->used == 0) { return 0; } /* get number of digits of the lsb we have to read */ | | | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 | unsigned long res; if (a->used == 0) { return 0; } /* get number of digits of the lsb we have to read */ i = MIN(a->used, ((((int)sizeof(unsigned long) * CHAR_BIT) + DIGIT_BIT - 1) / DIGIT_BIT)) - 1; /* get most significant digit of result */ res = DIGIT(a, i); #if (ULONG_MAX != 0xffffffffuL) || (DIGIT_BIT < 32) while (--i >= 0) { res = (res << DIGIT_BIT) | DIGIT(a, i); |
︙ | ︙ |
Changes to libtommath/bn_mp_get_long_long.c.
︙ | ︙ | |||
22 23 24 25 26 27 28 | Tcl_WideUInt res; if (a->used == 0) { return 0; } /* get number of digits of the lsb we have to read */ | | | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 | Tcl_WideUInt res; if (a->used == 0) { return 0; } /* get number of digits of the lsb we have to read */ i = MIN(a->used, ((((int)sizeof(Tcl_WideUInt) * CHAR_BIT) + DIGIT_BIT - 1) / DIGIT_BIT)) - 1; /* get most significant digit of result */ res = DIGIT(a, i); #if DIGIT_BIT < 64 while (--i >= 0) { res = (res << DIGIT_BIT) | DIGIT(a, i); |
︙ | ︙ |
Changes to libtommath/bn_mp_grow.c.
︙ | ︙ | |||
28 29 30 31 32 33 34 | /* reallocate the array a->dp * * We store the return in a temporary variable * in case the operation failed we don't want * to overwrite the dp member of a. */ | | | 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | /* reallocate the array a->dp * * We store the return in a temporary variable * in case the operation failed we don't want * to overwrite the dp member of a. */ tmp = OPT_CAST(mp_digit) XREALLOC(a->dp, sizeof(mp_digit) * (size_t)size); if (tmp == NULL) { /* reallocation failed but "a" is still valid [can be freed] */ return MP_MEM; } /* reallocation succeeded so set a->dp */ a->dp = tmp; |
︙ | ︙ |
Changes to libtommath/bn_mp_import.c.
︙ | ︙ | |||
30 31 32 33 34 35 36 | if (endian == 0) { union { unsigned int i; char c[4]; } lint; lint.i = 0x01020304; | | | | | | | | | | 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 | if (endian == 0) { union { unsigned int i; char c[4]; } lint; lint.i = 0x01020304; endian = (lint.c[0] == '\x04') ? -1 : 1; } odd_nails = (nails % 8u); odd_nail_mask = 0xff; for (i = 0; i < odd_nails; ++i) { odd_nail_mask ^= (unsigned char)(1u << (7u - i)); } nail_bytes = nails / 8u; for (i = 0; i < count; ++i) { for (j = 0; j < (size - nail_bytes); ++j) { unsigned char byte = *((unsigned char *)op + (((order == 1) ? i : ((count - 1u) - i)) * size) + ((endian == 1) ? (j + nail_bytes) : (((size - 1u) - j) - nail_bytes))); if ((result = mp_mul_2d(rop, (j == 0u) ? (int)(8u - odd_nails) : 8, rop)) != MP_OKAY) { return result; } rop->dp[0] |= (j == 0u) ? (mp_digit)(byte & odd_nail_mask) : (mp_digit)byte; rop->used += 1; } } mp_clamp(rop); return MP_OKAY; |
︙ | ︙ |
Changes to libtommath/bn_mp_init.c.
︙ | ︙ | |||
17 18 19 20 21 22 23 | /* init a new mp_int */ int mp_init(mp_int *a) { int i; /* allocate memory required and clear it */ | | | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | /* init a new mp_int */ int mp_init(mp_int *a) { int i; /* allocate memory required and clear it */ a->dp = OPT_CAST(mp_digit) XMALLOC(sizeof(mp_digit) * (size_t)MP_PREC); if (a->dp == NULL) { return MP_MEM; } /* set the digits to zero */ for (i = 0; i < MP_PREC; i++) { a->dp[i] = 0; |
︙ | ︙ |
Changes to libtommath/bn_mp_init_multi.c.
︙ | ︙ | |||
10 11 12 13 14 15 16 17 18 19 20 21 22 23 | * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://libtom.org */ #include <stdarg.h> int mp_init_multi(mp_int *mp, ...) { mp_err res = MP_OKAY; /* Assume ok until proven otherwise */ int n = 0; /* Number of ok inits */ mp_int *cur_arg = mp; | > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://libtom.org */ #include <stdarg.h> int mp_init_multi(mp_int *mp, ...) { mp_err res = MP_OKAY; /* Assume ok until proven otherwise */ int n = 0; /* Number of ok inits */ mp_int *cur_arg = mp; |
︙ | ︙ |
Changes to libtommath/bn_mp_init_size.c.
︙ | ︙ | |||
20 21 22 23 24 25 26 | { int x; /* pad size so there are always extra digits */ size += (MP_PREC * 2) - (size % MP_PREC); /* alloc mem */ | | | 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 | { int x; /* pad size so there are always extra digits */ size += (MP_PREC * 2) - (size % MP_PREC); /* alloc mem */ a->dp = OPT_CAST(mp_digit) XMALLOC(sizeof(mp_digit) * (size_t)size); if (a->dp == NULL) { return MP_MEM; } /* set the members */ a->used = 0; a->alloc = size; |
︙ | ︙ |
Changes to libtommath/bn_mp_invmod.c.
︙ | ︙ | |||
14 15 16 17 18 19 20 | * * Tom St Denis, [email protected], http://libtom.org */ /* hac 14.61, pp608 */ int mp_invmod(const mp_int *a, const mp_int *b, mp_int *c) { | | | | | 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 | * * Tom St Denis, [email protected], http://libtom.org */ /* hac 14.61, pp608 */ int mp_invmod(const mp_int *a, const mp_int *b, mp_int *c) { /* b cannot be negative and has to be >1 */ if ((b->sign == MP_NEG) || (mp_cmp_d(b, 1uL) != MP_GT)) { return MP_VAL; } #ifdef BN_FAST_MP_INVMOD_C /* if the modulus is odd we can use a faster routine instead */ if ((mp_isodd(b) == MP_YES)) { return fast_mp_invmod(a, b, c); } #endif #ifdef BN_MP_INVMOD_SLOW_C return mp_invmod_slow(a, b, c); #else |
︙ | ︙ |
Changes to libtommath/bn_mp_invmod_slow.c.
︙ | ︙ | |||
49 50 51 52 53 54 55 | /* 3. u=x, v=y, A=1, B=0, C=0,D=1 */ if ((res = mp_copy(&x, &u)) != MP_OKAY) { goto LBL_ERR; } if ((res = mp_copy(&y, &v)) != MP_OKAY) { goto LBL_ERR; } | | | | 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 | /* 3. u=x, v=y, A=1, B=0, C=0,D=1 */ if ((res = mp_copy(&x, &u)) != MP_OKAY) { goto LBL_ERR; } if ((res = mp_copy(&y, &v)) != MP_OKAY) { goto LBL_ERR; } mp_set(&A, 1uL); mp_set(&D, 1uL); top: /* 4. while u is even do */ while (mp_iseven(&u) == MP_YES) { /* 4.1 u = u/2 */ if ((res = mp_div_2(&u, &u)) != MP_OKAY) { goto LBL_ERR; |
︙ | ︙ | |||
139 140 141 142 143 144 145 | /* if not zero goto step 4 */ if (mp_iszero(&u) == MP_NO) goto top; /* now a = C, b = D, gcd == g*v */ /* if v != 1 then there is no inverse */ | | | | 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 | /* if not zero goto step 4 */ if (mp_iszero(&u) == MP_NO) goto top; /* now a = C, b = D, gcd == g*v */ /* if v != 1 then there is no inverse */ if (mp_cmp_d(&v, 1uL) != MP_EQ) { res = MP_VAL; goto LBL_ERR; } /* if its too low */ while (mp_cmp_d(&C, 0uL) == MP_LT) { if ((res = mp_add(&C, b, &C)) != MP_OKAY) { goto LBL_ERR; } } /* too big */ while (mp_cmp_mag(&C, b) != MP_LT) { |
︙ | ︙ |
Changes to libtommath/bn_mp_is_square.c.
︙ | ︙ | |||
54 55 56 57 58 59 60 | /* digits used? (TSD) */ if (arg->used == 0) { return MP_OKAY; } /* First check mod 128 (suppose that DIGIT_BIT is at least 7) */ | | | | | | | | | | | | 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 | /* digits used? (TSD) */ if (arg->used == 0) { return MP_OKAY; } /* First check mod 128 (suppose that DIGIT_BIT is at least 7) */ if (rem_128[127u & DIGIT(arg, 0)] == (char)1) { return MP_OKAY; } /* Next check mod 105 (3*5*7) */ if ((res = mp_mod_d(arg, 105uL, &c)) != MP_OKAY) { return res; } if (rem_105[c] == (char)1) { return MP_OKAY; } if ((res = mp_init_set_int(&t, 11L*13L*17L*19L*23L*29L*31L)) != MP_OKAY) { return res; } if ((res = mp_mod(arg, &t, &t)) != MP_OKAY) { goto ERR; } r = mp_get_int(&t); /* Check for other prime modules, note it's not an ERROR but we must * free "t" so the easiest way is to goto ERR. We know that res * is already equal to MP_OKAY from the mp_mod call */ if (((1uL<<(r%11uL)) & 0x5C4uL) != 0uL) goto ERR; if (((1uL<<(r%13uL)) & 0x9E4uL) != 0uL) goto ERR; if (((1uL<<(r%17uL)) & 0x5CE8uL) != 0uL) goto ERR; if (((1uL<<(r%19uL)) & 0x4F50CuL) != 0uL) goto ERR; if (((1uL<<(r%23uL)) & 0x7ACCA0uL) != 0uL) goto ERR; if (((1uL<<(r%29uL)) & 0xC2EDD0CuL) != 0uL) goto ERR; if (((1uL<<(r%31uL)) & 0x6DE2B848uL) != 0uL) goto ERR; /* Final check - is sqr(sqrt(arg)) == arg ? */ if ((res = mp_sqrt(arg, &t)) != MP_OKAY) { goto ERR; } if ((res = mp_sqr(&t, &t)) != MP_OKAY) { goto ERR; |
︙ | ︙ |
Changes to libtommath/bn_mp_jacobi.c.
︙ | ︙ | |||
28 29 30 31 32 33 34 | /* if a < 0 return MP_VAL */ if (mp_isneg(a) == MP_YES) { return MP_VAL; } /* if n <= 0 return MP_VAL */ | | | | | 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 | /* if a < 0 return MP_VAL */ if (mp_isneg(a) == MP_YES) { return MP_VAL; } /* if n <= 0 return MP_VAL */ if (mp_cmp_d(n, 0uL) != MP_GT) { return MP_VAL; } /* step 1. handle case of a == 0 */ if (mp_iszero(a) == MP_YES) { /* special case of a == 0 and n == 1 */ if (mp_cmp_d(n, 1uL) == MP_EQ) { *c = 1; } else { *c = 0; } return MP_OKAY; } /* step 2. if a == 1, return 1 */ if (mp_cmp_d(a, 1uL) == MP_EQ) { *c = 1; return MP_OKAY; } /* default */ s = 0; |
︙ | ︙ | |||
68 69 70 71 72 73 74 | /* divide out larger power of two */ k = mp_cnt_lsb(&a1); if ((res = mp_div_2d(&a1, k, &a1, NULL)) != MP_OKAY) { goto LBL_P1; } /* step 4. if e is even set s=1 */ | | | | | | | | 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 | /* divide out larger power of two */ k = mp_cnt_lsb(&a1); if ((res = mp_div_2d(&a1, k, &a1, NULL)) != MP_OKAY) { goto LBL_P1; } /* step 4. if e is even set s=1 */ if (((unsigned)k & 1u) == 0u) { s = 1; } else { /* else set s=1 if p = 1/7 (mod 8) or s=-1 if p = 3/5 (mod 8) */ residue = n->dp[0] & 7u; if ((residue == 1u) || (residue == 7u)) { s = 1; } else if ((residue == 3u) || (residue == 5u)) { s = -1; } } /* step 5. if p == 3 (mod 4) *and* a1 == 3 (mod 4) then s = -s */ if (((n->dp[0] & 3u) == 3u) && ((a1.dp[0] & 3u) == 3u)) { s = -s; } /* if a1 == 1 we're done */ if (mp_cmp_d(&a1, 1uL) == MP_EQ) { *c = s; } else { /* n1 = n mod a1 */ if ((res = mp_mod(n, &a1, &p1)) != MP_OKAY) { goto LBL_P1; } if ((res = mp_jacobi(&p1, &a1, &r)) != MP_OKAY) { |
︙ | ︙ |
Changes to libtommath/bn_mp_lshd.c.
︙ | ︙ | |||
19 20 21 22 23 24 25 26 27 28 29 30 31 32 | int mp_lshd(mp_int *a, int b) { int x, res; /* if its less than zero return */ if (b <= 0) { return MP_OKAY; } /* grow to fit the new digits */ if (a->alloc < (a->used + b)) { if ((res = mp_grow(a, a->used + b)) != MP_OKAY) { return res; } | > > > > | 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 | int mp_lshd(mp_int *a, int b) { int x, res; /* if its less than zero return */ if (b <= 0) { return MP_OKAY; } /* no need to shift 0 around */ if (mp_iszero(a) == MP_YES) { return MP_OKAY; } /* grow to fit the new digits */ if (a->alloc < (a->used + b)) { if ((res = mp_grow(a, a->used + b)) != MP_OKAY) { return res; } |
︙ | ︙ |
Changes to libtommath/bn_mp_mod_2d.c.
︙ | ︙ | |||
23 24 25 26 27 28 29 | /* if b is <= 0 then zero the int */ if (b <= 0) { mp_zero(c); return MP_OKAY; } /* if the modulus is larger than the value than return */ | | | | 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 | /* if b is <= 0 then zero the int */ if (b <= 0) { mp_zero(c); return MP_OKAY; } /* if the modulus is larger than the value than return */ if (b >= (a->used * DIGIT_BIT)) { res = mp_copy(a, c); return res; } /* copy */ if ((res = mp_copy(a, c)) != MP_OKAY) { return res; } /* zero digits above the last digit of the modulus */ for (x = (b / DIGIT_BIT) + (((b % DIGIT_BIT) == 0) ? 0 : 1); x < c->used; x++) { c->dp[x] = 0; } /* clear the digit that is not completely outside/inside the modulus */ c->dp[b / DIGIT_BIT] &= ((mp_digit)1 << (mp_digit)(b % DIGIT_BIT)) - (mp_digit)1; mp_clamp(c); return MP_OKAY; } #endif /* ref: $Format:%D$ */ /* git commit: $Format:%H$ */ /* commit time: $Format:%ai$ */ |
Changes to libtommath/bn_mp_montgomery_calc_normalization.c.
︙ | ︙ | |||
29 30 31 32 33 34 35 | bits = mp_count_bits(b) % DIGIT_BIT; if (b->used > 1) { if ((res = mp_2expt(a, ((b->used - 1) * DIGIT_BIT) + bits - 1)) != MP_OKAY) { return res; } } else { | | | 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 | bits = mp_count_bits(b) % DIGIT_BIT; if (b->used > 1) { if ((res = mp_2expt(a, ((b->used - 1) * DIGIT_BIT) + bits - 1)) != MP_OKAY) { return res; } } else { mp_set(a, 1uL); bits = 1; } /* now compute C = A * B mod b */ for (x = bits - 1; x < (int)DIGIT_BIT; x++) { if ((res = mp_mul_2(a, a)) != MP_OKAY) { |
︙ | ︙ |
Changes to libtommath/bn_mp_montgomery_reduce.c.
︙ | ︙ | |||
24 25 26 27 28 29 30 | /* can the fast reduction [comba] method be used? * * Note that unlike in mul you're safely allowed *less* * than the available columns [255 per default] since carries * are fixed up in the inner loop. */ digs = (n->used * 2) + 1; | > | | | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 | /* can the fast reduction [comba] method be used? * * Note that unlike in mul you're safely allowed *less* * than the available columns [255 per default] since carries * are fixed up in the inner loop. */ digs = (n->used * 2) + 1; if ((digs < (int)MP_WARRAY) && (x->used <= (int)MP_WARRAY) && (n->used < (int)(1u << (((size_t)CHAR_BIT * sizeof(mp_word)) - (2u * (size_t)DIGIT_BIT))))) { return fast_mp_montgomery_reduce(x, n, rho); } /* grow the input as required */ if (x->alloc < digs) { if ((res = mp_grow(x, digs)) != MP_OKAY) { return res; |
︙ | ︙ | |||
68 69 70 71 72 73 74 | /* set the carry to zero */ u = 0; /* Multiply and add in place */ for (iy = 0; iy < n->used; iy++) { /* compute product and sum */ r = ((mp_word)mu * (mp_word)*tmpn++) + | | | | | | 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 | /* set the carry to zero */ u = 0; /* Multiply and add in place */ for (iy = 0; iy < n->used; iy++) { /* compute product and sum */ r = ((mp_word)mu * (mp_word)*tmpn++) + (mp_word)u + (mp_word)*tmpx; /* get carry */ u = (mp_digit)(r >> (mp_word)DIGIT_BIT); /* fix digit */ *tmpx++ = (mp_digit)(r & (mp_word)MP_MASK); } /* At this point the ix'th digit of x should be zero */ /* propagate carries upwards as required*/ while (u != 0u) { *tmpx += u; u = *tmpx >> DIGIT_BIT; *tmpx++ &= MP_MASK; } } } |
︙ | ︙ |
Changes to libtommath/bn_mp_montgomery_setup.c.
︙ | ︙ | |||
26 27 28 29 30 31 32 | * * XA = 1 (mod 2**n) => (X(2-XA)) A = 1 (mod 2**2n) * => 2*X*A - X*X*A*A = 1 * => 2*(1) - (1) = 1 */ b = n->dp[0]; | | | | | | | | | 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 | * * XA = 1 (mod 2**n) => (X(2-XA)) A = 1 (mod 2**2n) * => 2*X*A - X*X*A*A = 1 * => 2*(1) - (1) = 1 */ b = n->dp[0]; if ((b & 1u) == 0u) { return MP_VAL; } x = (((b + 2u) & 4u) << 1) + b; /* here x*a==1 mod 2**4 */ x *= 2u - (b * x); /* here x*a==1 mod 2**8 */ #if !defined(MP_8BIT) x *= 2u - (b * x); /* here x*a==1 mod 2**16 */ #endif #if defined(MP_64BIT) || !(defined(MP_8BIT) || defined(MP_16BIT)) x *= 2u - (b * x); /* here x*a==1 mod 2**32 */ #endif #ifdef MP_64BIT x *= 2u - (b * x); /* here x*a==1 mod 2**64 */ #endif /* rho = -1/m mod b */ *rho = (mp_digit)(((mp_word)1 << (mp_word)DIGIT_BIT) - x) & MP_MASK; return MP_OKAY; } #endif /* ref: $Format:%D$ */ /* git commit: $Format:%H$ */ |
︙ | ︙ |
Changes to libtommath/bn_mp_mul.c.
︙ | ︙ | |||
39 40 41 42 43 44 45 | * The fast multiplier can be used if the output will * have less than MP_WARRAY digits and the number of * digits won't affect carry propagation */ int digs = a->used + b->used + 1; #ifdef BN_FAST_S_MP_MUL_DIGS_C | | | | 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 | * The fast multiplier can be used if the output will * have less than MP_WARRAY digits and the number of * digits won't affect carry propagation */ int digs = a->used + b->used + 1; #ifdef BN_FAST_S_MP_MUL_DIGS_C if ((digs < (int)MP_WARRAY) && (MIN(a->used, b->used) <= (int)(1u << (((size_t)CHAR_BIT * sizeof(mp_word)) - (2u * (size_t)DIGIT_BIT))))) { res = fast_s_mp_mul_digs(a, b, c, digs); } else #endif { #ifdef BN_S_MP_MUL_DIGS_C res = s_mp_mul(a, b, c); /* uses s_mp_mul_digs */ #else |
︙ | ︙ |
Changes to libtommath/bn_mp_mul_2.c.
︙ | ︙ | |||
42 43 44 45 46 47 48 | /* carry */ r = 0; for (x = 0; x < a->used; x++) { /* get what will be the *next* carry bit from the * MSB of the current digit */ | | | | | 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 | /* carry */ r = 0; for (x = 0; x < a->used; x++) { /* get what will be the *next* carry bit from the * MSB of the current digit */ rr = *tmpa >> (mp_digit)(DIGIT_BIT - 1); /* now shift up this digit, add in the carry [from the previous] */ *tmpb++ = ((*tmpa++ << 1uL) | r) & MP_MASK; /* copy the carry that would be from the source * digit into the next iteration */ r = rr; } /* new leading digit? */ if (r != 0u) { /* add a MSB which is always 1 at this point */ *tmpb = 1; ++(b->used); } /* now zero any excess digits on the destination * that we didn't write to |
︙ | ︙ |
Changes to libtommath/bn_mp_mul_2d.c.
︙ | ︙ | |||
24 25 26 27 28 29 30 | /* copy */ if (a != c) { if ((res = mp_copy(a, c)) != MP_OKAY) { return res; } } | | | | | | | | 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 | /* copy */ if (a != c) { if ((res = mp_copy(a, c)) != MP_OKAY) { return res; } } if (c->alloc < (c->used + (b / DIGIT_BIT) + 1)) { if ((res = mp_grow(c, c->used + (b / DIGIT_BIT) + 1)) != MP_OKAY) { return res; } } /* shift by as many digits in the bit count */ if (b >= DIGIT_BIT) { if ((res = mp_lshd(c, b / DIGIT_BIT)) != MP_OKAY) { return res; } } /* shift any bit count < DIGIT_BIT */ d = (mp_digit)(b % DIGIT_BIT); if (d != 0u) { mp_digit *tmpc, shift, mask, r, rr; int x; /* bitmask for carries */ mask = ((mp_digit)1 << d) - (mp_digit)1; /* shift for msbs */ shift = (mp_digit)DIGIT_BIT - d; /* alias */ tmpc = c->dp; /* carry */ r = 0; for (x = 0; x < c->used; x++) { /* get the higher bits of the current word */ rr = (*tmpc >> shift) & mask; /* shift the current word and OR in the carry */ *tmpc = ((*tmpc << d) | r) & MP_MASK; ++tmpc; /* set the carry to the carry bits of the current word */ r = rr; } /* set final carry */ if (r != 0u) { c->dp[(c->used)++] = r; } } mp_clamp(c); return MP_OKAY; } #endif /* ref: $Format:%D$ */ /* git commit: $Format:%H$ */ /* commit time: $Format:%ai$ */ |
Changes to libtommath/bn_mp_mul_d.c.
︙ | ︙ | |||
46 47 48 49 50 51 52 | /* compute columns */ for (ix = 0; ix < a->used; ix++) { /* compute product and carry sum for this term */ r = (mp_word)u + ((mp_word)*tmpa++ * (mp_word)b); /* mask off higher bits to get a single digit */ | | | | 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 | /* compute columns */ for (ix = 0; ix < a->used; ix++) { /* compute product and carry sum for this term */ r = (mp_word)u + ((mp_word)*tmpa++ * (mp_word)b); /* mask off higher bits to get a single digit */ *tmpc++ = (mp_digit)(r & (mp_word)MP_MASK); /* send carry into next iteration */ u = (mp_digit)(r >> (mp_word)DIGIT_BIT); } /* store final carry [if any] and increment ix offset */ *tmpc++ = u; ++ix; /* now zero digits above the top */ |
︙ | ︙ |
Changes to libtommath/bn_mp_n_root_ex.c.
︙ | ︙ | |||
27 28 29 30 31 32 33 | */ int mp_n_root_ex(const mp_int *a, mp_digit b, mp_int *c, int fast) { mp_int t1, t2, t3, a_; int res; /* input must be positive if b is even */ | | | | | 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 | */ int mp_n_root_ex(const mp_int *a, mp_digit b, mp_int *c, int fast) { mp_int t1, t2, t3, a_; int res; /* input must be positive if b is even */ if (((b & 1u) == 0u) && (a->sign == MP_NEG)) { return MP_VAL; } if ((res = mp_init(&t1)) != MP_OKAY) { return res; } if ((res = mp_init(&t2)) != MP_OKAY) { goto LBL_T1; } if ((res = mp_init(&t3)) != MP_OKAY) { goto LBL_T2; } /* if a is negative fudge the sign but keep track */ a_ = *a; a_.sign = MP_ZPOS; /* t2 = 2 */ mp_set(&t2, 2uL); do { /* t1 = t2 */ if ((res = mp_copy(&t2, &t1)) != MP_OKAY) { goto LBL_T3; } /* t2 = t1 - ((t1**b - a) / (b * t1**(b-1))) */ /* t3 = t1**(b-1) */ if ((res = mp_expt_d_ex(&t1, b - 1u, &t3, fast)) != MP_OKAY) { goto LBL_T3; } /* numerator */ /* t2 = t1**b */ if ((res = mp_mul(&t3, &t1, &t2)) != MP_OKAY) { goto LBL_T3; |
︙ | ︙ | |||
97 98 99 100 101 102 103 | /* result can be off by a few so check */ for (;;) { if ((res = mp_expt_d_ex(&t1, b, &t2, fast)) != MP_OKAY) { goto LBL_T3; } if (mp_cmp(&t2, &a_) == MP_GT) { | | | 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 | /* result can be off by a few so check */ for (;;) { if ((res = mp_expt_d_ex(&t1, b, &t2, fast)) != MP_OKAY) { goto LBL_T3; } if (mp_cmp(&t2, &a_) == MP_GT) { if ((res = mp_sub_d(&t1, 1uL, &t1)) != MP_OKAY) { goto LBL_T3; } } else { break; } } |
︙ | ︙ |
Changes to libtommath/bn_mp_prime_fermat.c.
︙ | ︙ | |||
28 29 30 31 32 33 34 | mp_int t; int err; /* default to composite */ *result = MP_NO; /* ensure b > 1 */ | | | 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | mp_int t; int err; /* default to composite */ *result = MP_NO; /* ensure b > 1 */ if (mp_cmp_d(b, 1uL) != MP_GT) { return MP_VAL; } /* init t */ if ((err = mp_init(&t)) != MP_OKAY) { return err; } |
︙ | ︙ |
Changes to libtommath/bn_mp_prime_is_divisible.c.
︙ | ︙ | |||
31 32 33 34 35 36 37 | for (ix = 0; ix < PRIME_SIZE; ix++) { /* what is a mod LBL_prime_tab[ix] */ if ((err = mp_mod_d(a, ltm_prime_tab[ix], &res)) != MP_OKAY) { return err; } /* is the residue zero? */ | | | 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 | for (ix = 0; ix < PRIME_SIZE; ix++) { /* what is a mod LBL_prime_tab[ix] */ if ((err = mp_mod_d(a, ltm_prime_tab[ix], &res)) != MP_OKAY) { return err; } /* is the residue zero? */ if (res == 0u) { *result = MP_YES; return MP_OKAY; } } return MP_OKAY; } |
︙ | ︙ |
Changes to libtommath/bn_mp_prime_miller_rabin.c.
︙ | ︙ | |||
27 28 29 30 31 32 33 | mp_int n1, y, r; int s, j, err; /* default */ *result = MP_NO; /* ensure b > 1 */ | | | | 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 | mp_int n1, y, r; int s, j, err; /* default */ *result = MP_NO; /* ensure b > 1 */ if (mp_cmp_d(b, 1uL) != MP_GT) { return MP_VAL; } /* get n1 = a - 1 */ if ((err = mp_init_copy(&n1, a)) != MP_OKAY) { return err; } if ((err = mp_sub_d(&n1, 1uL, &n1)) != MP_OKAY) { goto LBL_N1; } /* set 2**s * r = n1 */ if ((err = mp_init_copy(&r, &n1)) != MP_OKAY) { goto LBL_N1; } |
︙ | ︙ | |||
63 64 65 66 67 68 69 | goto LBL_R; } if ((err = mp_exptmod(b, &r, a, &y)) != MP_OKAY) { goto LBL_Y; } /* if y != 1 and y != n1 do */ | | | | 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 | goto LBL_R; } if ((err = mp_exptmod(b, &r, a, &y)) != MP_OKAY) { goto LBL_Y; } /* if y != 1 and y != n1 do */ if ((mp_cmp_d(&y, 1uL) != MP_EQ) && (mp_cmp(&y, &n1) != MP_EQ)) { j = 1; /* while j <= s-1 and y != n1 */ while ((j <= (s - 1)) && (mp_cmp(&y, &n1) != MP_EQ)) { if ((err = mp_sqrmod(&y, a, &y)) != MP_OKAY) { goto LBL_Y; } /* if y == 1 then composite */ if (mp_cmp_d(&y, 1uL) == MP_EQ) { goto LBL_Y; } ++j; } /* if y != n1 then composite */ |
︙ | ︙ |
Changes to libtommath/bn_mp_prime_next_prime.c.
︙ | ︙ | |||
42 43 44 45 46 47 48 | if (bbs_style == 1) { /* ok we found a prime smaller or * equal [so the next is larger] * * however, the prime must be * congruent to 3 mod 4 */ | | | | | | | | | 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 | if (bbs_style == 1) { /* ok we found a prime smaller or * equal [so the next is larger] * * however, the prime must be * congruent to 3 mod 4 */ if ((ltm_prime_tab[x + 1] & 3u) != 3u) { /* scan upwards for a prime congruent to 3 mod 4 */ for (y = x + 1; y < PRIME_SIZE; y++) { if ((ltm_prime_tab[y] & 3u) == 3u) { mp_set(a, ltm_prime_tab[y]); return MP_OKAY; } } } } else { mp_set(a, ltm_prime_tab[x + 1]); return MP_OKAY; } } } /* at this point a maybe 1 */ if (mp_cmp_d(a, 1uL) == MP_EQ) { mp_set(a, 2uL); return MP_OKAY; } /* fall through to the sieve */ } /* generate a prime congruent to 3 mod 4 or 1/3 mod 4? */ if (bbs_style == 1) { kstep = 4; } else { kstep = 2; } /* at this point we will use a combination of a sieve and Miller-Rabin */ if (bbs_style == 1) { /* if a mod 4 != 3 subtract the correct value to make it so */ if ((a->dp[0] & 3u) != 3u) { if ((err = mp_sub_d(a, (a->dp[0] & 3u) + 1u, a)) != MP_OKAY) { return err; }; } } else { if (mp_iseven(a) == MP_YES) { /* force odd */ if ((err = mp_sub_d(a, 1uL, a)) != MP_OKAY) { return err; } } } /* generate the restable */ for (x = 1; x < PRIME_SIZE; x++) { |
︙ | ︙ | |||
123 124 125 126 127 128 129 | /* subtract the modulus [instead of using division] */ if (res_tab[x] >= ltm_prime_tab[x]) { res_tab[x] -= ltm_prime_tab[x]; } /* set flag if zero */ | | | | | 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 | /* subtract the modulus [instead of using division] */ if (res_tab[x] >= ltm_prime_tab[x]) { res_tab[x] -= ltm_prime_tab[x]; } /* set flag if zero */ if (res_tab[x] == 0u) { y = 1; } } } while ((y == 1) && (step < (((mp_digit)1 << DIGIT_BIT) - kstep))); /* add the step */ if ((err = mp_add_d(a, step, a)) != MP_OKAY) { goto LBL_ERR; } /* if didn't pass sieve and step == MAX then skip test */ if ((y == 1) && (step >= (((mp_digit)1 << DIGIT_BIT) - kstep))) { continue; } /* is this prime? */ for (x = 0; x < t; x++) { mp_set(&b, ltm_prime_tab[x]); if ((err = mp_prime_miller_rabin(a, &b, &res)) != MP_OKAY) { |
︙ | ︙ |
Changes to libtommath/bn_mp_prime_random_ex.c.
︙ | ︙ | |||
45 46 47 48 49 50 51 | flags |= LTM_PRIME_BBS; } /* calc the byte size */ bsize = (size>>3) + ((size&7)?1:0); /* we need a buffer of bsize bytes */ | | | 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 | flags |= LTM_PRIME_BBS; } /* calc the byte size */ bsize = (size>>3) + ((size&7)?1:0); /* we need a buffer of bsize bytes */ tmp = OPT_CAST(unsigned char) XMALLOC((size_t)bsize); if (tmp == NULL) { return MP_MEM; } /* calc the maskAND value for the MSbyte*/ maskAND = ((size&7) == 0) ? 0xFF : (0xFF >> (8 - (size & 7))); |
︙ | ︙ | |||
82 83 84 85 86 87 88 | tmp[0] |= 1 << ((size - 1) & 7); /* mix in the maskORs */ tmp[maskOR_msb_offset] |= maskOR_msb; tmp[bsize-1] |= maskOR_lsb; /* read it in */ | | | | | | | | | 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 | tmp[0] |= 1 << ((size - 1) & 7); /* mix in the maskORs */ tmp[maskOR_msb_offset] |= maskOR_msb; tmp[bsize-1] |= maskOR_lsb; /* read it in */ if ((err = mp_read_unsigned_bin(a, tmp, bsize)) != MP_OKAY) { goto error; } /* is it prime? */ if ((err = mp_prime_is_prime(a, t, &res)) != MP_OKAY) { goto error; } if (res == MP_NO) { continue; } if ((flags & LTM_PRIME_SAFE) != 0) { /* see if (a-1)/2 is prime */ if ((err = mp_sub_d(a, 1uL, a)) != MP_OKAY) { goto error; } if ((err = mp_div_2(a, a)) != MP_OKAY) { goto error; } /* is it prime? */ if ((err = mp_prime_is_prime(a, t, &res)) != MP_OKAY) { goto error; } } } while (res == MP_NO); if ((flags & LTM_PRIME_SAFE) != 0) { /* restore a to the original value */ if ((err = mp_mul_2(a, a)) != MP_OKAY) { goto error; } if ((err = mp_add_d(a, 1uL, a)) != MP_OKAY) { goto error; } } err = MP_OKAY; error: XFREE(tmp); |
︙ | ︙ |
Changes to libtommath/bn_mp_radix_smap.c.
︙ | ︙ | |||
13 14 15 16 17 18 19 20 21 22 23 24 | * guarantee it works. * * Tom St Denis, [email protected], http://libtom.org */ /* chars used in radix conversions */ const char *mp_s_rmap = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz+/"; #endif /* ref: $Format:%D$ */ /* git commit: $Format:%H$ */ /* commit time: $Format:%ai$ */ | > > > > > > > > > > > > > > | 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 | * guarantee it works. * * Tom St Denis, [email protected], http://libtom.org */ /* chars used in radix conversions */ const char *mp_s_rmap = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz+/"; const unsigned char mp_s_rmap_reverse[] = { 0xff, 0xff, 0xff, 0x3e, 0xff, 0xff, 0xff, 0x3f, /* ()*+,-./ */ 0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, /* 01234567 */ 0x08, 0x09, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, /* 89:;<=>? */ 0xff, 0x0a, 0x0b, 0x0c, 0x0d, 0x0e, 0x0f, 0x10, /* @ABCDEFG */ 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, 0x18, /* HIJKLMNO */ 0x19, 0x1a, 0x1b, 0x1c, 0x1d, 0x1e, 0x1f, 0x20, /* PQRSTUVW */ 0x21, 0x22, 0x23, 0xff, 0xff, 0xff, 0xff, 0xff, /* XYZ[\]^_ */ 0xff, 0x24, 0x25, 0x26, 0x27, 0x28, 0x29, 0x2a, /* `abcdefg */ 0x2b, 0x2c, 0x2d, 0x2e, 0x2f, 0x30, 0x31, 0x32, /* hijklmno */ 0x33, 0x34, 0x35, 0x36, 0x37, 0x38, 0x39, 0x3a, /* pqrstuvw */ 0x3b, 0x3c, 0x3d, 0xff, 0xff, 0xff, 0xff, 0xff, /* xyz{|}~. */ }; const size_t mp_s_rmap_reverse_sz = sizeof(mp_s_rmap_reverse); #endif /* ref: $Format:%D$ */ /* git commit: $Format:%H$ */ /* commit time: $Format:%ai$ */ |
Changes to libtommath/bn_mp_rand.c.
︙ | ︙ | |||
11 12 13 14 15 16 17 | * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://libtom.org */ | > > > | > | 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 | * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://libtom.org */ #if defined(MP_8BIT) || defined(MP_16BIT) #define MP_GEN_RANDOM_SHIFT DIGIT_BIT #else #if MP_GEN_RANDOM_MAX == 0xffffffffu #define MP_GEN_RANDOM_SHIFT 32 #elif MP_GEN_RANDOM_MAX == 32767 /* SHRT_MAX */ #define MP_GEN_RANDOM_SHIFT 15 #elif MP_GEN_RANDOM_MAX == 2147483647 /* INT_MAX */ #define MP_GEN_RANDOM_SHIFT 31 #elif !defined(MP_GEN_RANDOM_SHIFT) #error Thou shalt define their own valid MP_GEN_RANDOM_SHIFT #endif #endif /* makes a pseudo-random int of a given size */ static mp_digit s_gen_random(void) { mp_digit d = 0, msk = 0; do { |
︙ | ︙ | |||
50 51 52 53 54 55 56 | if (digits <= 0) { return MP_OKAY; } /* first place a random non-zero digit */ do { d = s_gen_random(); | | | 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 | if (digits <= 0) { return MP_OKAY; } /* first place a random non-zero digit */ do { d = s_gen_random(); } while (d == 0u); if ((res = mp_add_d(a, d, a)) != MP_OKAY) { return res; } while (--digits > 0) { if ((res = mp_lshd(a, 1)) != MP_OKAY) { |
︙ | ︙ |
Changes to libtommath/bn_mp_read_radix.c.
︙ | ︙ | |||
15 16 17 18 19 20 21 22 23 24 25 26 27 28 | * Tom St Denis, [email protected], http://libtom.org */ /* read a string [ASCII] in a given radix */ int mp_read_radix(mp_int *a, const char *str, int radix) { int y, res, neg; char ch; /* zero the digit bignum */ mp_zero(a); /* make sure the radix is ok */ if ((radix < 2) || (radix > 64)) { | > | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 | * Tom St Denis, [email protected], http://libtom.org */ /* read a string [ASCII] in a given radix */ int mp_read_radix(mp_int *a, const char *str, int radix) { int y, res, neg; unsigned pos; char ch; /* zero the digit bignum */ mp_zero(a); /* make sure the radix is ok */ if ((radix < 2) || (radix > 64)) { |
︙ | ︙ | |||
45 46 47 48 49 50 51 | /* process each digit of the string */ while (*str != '\0') { /* if the radix <= 36 the conversion is case insensitive * this allows numbers like 1AB and 1ab to represent the same value * [e.g. in hex] */ ch = (radix <= 36) ? (char)toupper((int)*str) : *str; | | | | | < > | > > | | | | | < < < | | 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 | /* process each digit of the string */ while (*str != '\0') { /* if the radix <= 36 the conversion is case insensitive * this allows numbers like 1AB and 1ab to represent the same value * [e.g. in hex] */ ch = (radix <= 36) ? (char)toupper((int)*str) : *str; pos = (unsigned)(ch - '('); if (mp_s_rmap_reverse_sz < pos) { break; } y = (int)mp_s_rmap_reverse[pos]; /* if the char was found in the map * and is less than the given radix add it * to the number, otherwise exit the loop. */ if ((y == 0xff) || (y >= radix)) { break; } if ((res = mp_mul_d(a, (mp_digit)radix, a)) != MP_OKAY) { return res; } if ((res = mp_add_d(a, (mp_digit)y, a)) != MP_OKAY) { return res; } ++str; } /* if an illegal character was found, fail. */ if (!((*str == '\0') || (*str == '\r') || (*str == '\n'))) { mp_zero(a); return MP_VAL; } /* set the sign only if a != 0 */ if (mp_iszero(a) != MP_YES) { a->sign = neg; |
︙ | ︙ |
Changes to libtommath/bn_mp_read_signed_bin.c.
︙ | ︙ | |||
22 23 24 25 26 27 28 | /* read magnitude */ if ((res = mp_read_unsigned_bin(a, b + 1, c - 1)) != MP_OKAY) { return res; } /* first byte is 0 for positive, non-zero for negative */ | | | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 | /* read magnitude */ if ((res = mp_read_unsigned_bin(a, b + 1, c - 1)) != MP_OKAY) { return res; } /* first byte is 0 for positive, non-zero for negative */ if (b[0] == (unsigned char)0) { a->sign = MP_ZPOS; } else { a->sign = MP_NEG; } return MP_OKAY; } |
︙ | ︙ |
Changes to libtommath/bn_mp_read_unsigned_bin.c.
︙ | ︙ | |||
37 38 39 40 41 42 43 | } #ifndef MP_8BIT a->dp[0] |= *b++; a->used += 1; #else a->dp[0] = (*b & MP_MASK); | | | 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 | } #ifndef MP_8BIT a->dp[0] |= *b++; a->used += 1; #else a->dp[0] = (*b & MP_MASK); a->dp[1] |= ((*b++ >> 7) & 1u); a->used += 2; #endif } mp_clamp(a); return MP_OKAY; } #endif |
︙ | ︙ |
Changes to libtommath/bn_mp_reduce.c.
︙ | ︙ | |||
29 30 31 32 33 34 35 | return res; } /* q1 = x / b**(k-1) */ mp_rshd(&q, um - 1); /* according to HAC this optimization is ok */ | | | 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 | return res; } /* q1 = x / b**(k-1) */ mp_rshd(&q, um - 1); /* according to HAC this optimization is ok */ if ((mp_digit)um > ((mp_digit)1 << (DIGIT_BIT - 1))) { if ((res = mp_mul(&q, mu, &q)) != MP_OKAY) { goto CLEANUP; } } else { #ifdef BN_S_MP_MUL_HIGH_DIGS_C if ((res = s_mp_mul_high_digs(&q, mu, &q, um)) != MP_OKAY) { goto CLEANUP; |
︙ | ︙ | |||
69 70 71 72 73 74 75 | /* x = x - q */ if ((res = mp_sub(x, &q, x)) != MP_OKAY) { goto CLEANUP; } /* If x < 0, add b**(k+1) to it */ | | | | 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 | /* x = x - q */ if ((res = mp_sub(x, &q, x)) != MP_OKAY) { goto CLEANUP; } /* If x < 0, add b**(k+1) to it */ if (mp_cmp_d(x, 0uL) == MP_LT) { mp_set(&q, 1uL); if ((res = mp_lshd(&q, um + 1)) != MP_OKAY) goto CLEANUP; if ((res = mp_add(x, &q, x)) != MP_OKAY) goto CLEANUP; } /* Back off if it's too big */ |
︙ | ︙ |
Changes to libtommath/bn_mp_reduce_2k.c.
︙ | ︙ | |||
28 29 30 31 32 33 34 | p = mp_count_bits(n); top: /* q = a/2**p, a = a mod 2**p */ if ((res = mp_div_2d(a, p, &q, a)) != MP_OKAY) { goto ERR; } | | | 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | p = mp_count_bits(n); top: /* q = a/2**p, a = a mod 2**p */ if ((res = mp_div_2d(a, p, &q, a)) != MP_OKAY) { goto ERR; } if (d != 1u) { /* q = q * d */ if ((res = mp_mul_d(&q, d, &q)) != MP_OKAY) { goto ERR; } } /* a = a + q */ |
︙ | ︙ |
Changes to libtommath/bn_mp_reduce_is_2k.c.
︙ | ︙ | |||
28 29 30 31 32 33 34 | } else if (a->used > 1) { iy = mp_count_bits(a); iz = 1; iw = 1; /* Test every bit from the second digit up, must be 1 */ for (ix = DIGIT_BIT; ix < iy; ix++) { | | | 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 | } else if (a->used > 1) { iy = mp_count_bits(a); iz = 1; iw = 1; /* Test every bit from the second digit up, must be 1 */ for (ix = DIGIT_BIT; ix < iy; ix++) { if ((a->dp[iw] & iz) == 0u) { return MP_NO; } iz <<= 1; if (iz > (mp_digit)MP_MASK) { ++iw; iz = 1; } |
︙ | ︙ |
Changes to libtommath/bn_mp_set.c.
︙ | ︙ | |||
16 17 18 19 20 21 22 | */ /* set to a digit */ void mp_set(mp_int *a, mp_digit b) { mp_zero(a); a->dp[0] = b & MP_MASK; | | | 16 17 18 19 20 21 22 23 24 25 26 27 28 29 | */ /* set to a digit */ void mp_set(mp_int *a, mp_digit b) { mp_zero(a); a->dp[0] = b & MP_MASK; a->used = (a->dp[0] != 0u) ? 1 : 0; } #endif /* ref: $Format:%D$ */ /* git commit: $Format:%H$ */ /* commit time: $Format:%ai$ */ |
Changes to libtommath/bn_mp_set_int.c.
︙ | ︙ | |||
26 27 28 29 30 31 32 | for (x = 0; x < 8; x++) { /* shift the number up four bits */ if ((res = mp_mul_2d(a, 4, a)) != MP_OKAY) { return res; } /* OR in the top four bits of the source */ | | | 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 | for (x = 0; x < 8; x++) { /* shift the number up four bits */ if ((res = mp_mul_2d(a, 4, a)) != MP_OKAY) { return res; } /* OR in the top four bits of the source */ a->dp[0] |= (mp_digit)(b >> 28) & 15uL; /* shift the source up to the next four bits */ b <<= 4; /* ensure that digits are not clamped off */ a->used += 1; } |
︙ | ︙ |
Changes to libtommath/bn_mp_shrink.c.
︙ | ︙ | |||
22 23 24 25 26 27 28 | int used = 1; if (a->used > 0) { used = a->used; } if (a->alloc != used) { | | | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 | int used = 1; if (a->used > 0) { used = a->used; } if (a->alloc != used) { if ((tmp = OPT_CAST(mp_digit) XREALLOC(a->dp, sizeof(mp_digit) * (size_t)used)) == NULL) { return MP_MEM; } a->dp = tmp; a->alloc = used; } return MP_OKAY; } |
︙ | ︙ |
Changes to libtommath/bn_mp_sqr.c.
︙ | ︙ | |||
31 32 33 34 35 36 37 | if (a->used >= KARATSUBA_SQR_CUTOFF) { res = mp_karatsuba_sqr(a, b); } else #endif { #ifdef BN_FAST_S_MP_SQR_C /* can we use the fast comba multiplier? */ | | | | 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 | if (a->used >= KARATSUBA_SQR_CUTOFF) { res = mp_karatsuba_sqr(a, b); } else #endif { #ifdef BN_FAST_S_MP_SQR_C /* can we use the fast comba multiplier? */ if ((((a->used * 2) + 1) < (int)MP_WARRAY) && (a->used < (int)(1u << (((sizeof(mp_word) * (size_t)CHAR_BIT) - (2u * (size_t)DIGIT_BIT)) - 1u)))) { res = fast_s_mp_sqr(a, b); } else #endif { #ifdef BN_S_MP_SQR_C res = s_mp_sqr(a, b); #else |
︙ | ︙ |
Changes to libtommath/bn_mp_sqrtmod_prime.c.
︙ | ︙ | |||
18 19 20 21 22 23 24 | int mp_sqrtmod_prime(const mp_int *n, const mp_int *prime, mp_int *ret) { int res, legendre; mp_int t1, C, Q, S, Z, M, T, R, two; mp_digit i; /* first handle the simple cases */ | | | | | | | | | | | | | | | | 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 | int mp_sqrtmod_prime(const mp_int *n, const mp_int *prime, mp_int *ret) { int res, legendre; mp_int t1, C, Q, S, Z, M, T, R, two; mp_digit i; /* first handle the simple cases */ if (mp_cmp_d(n, 0uL) == MP_EQ) { mp_zero(ret); return MP_OKAY; } if (mp_cmp_d(prime, 2uL) == MP_EQ) return MP_VAL; /* prime must be odd */ if ((res = mp_jacobi(n, prime, &legendre)) != MP_OKAY) return res; if (legendre == -1) return MP_VAL; /* quadratic non-residue mod prime */ if ((res = mp_init_multi(&t1, &C, &Q, &S, &Z, &M, &T, &R, &two, NULL)) != MP_OKAY) { return res; } /* SPECIAL CASE: if prime mod 4 == 3 * compute directly: res = n^(prime+1)/4 mod prime * Handbook of Applied Cryptography algorithm 3.36 */ if ((res = mp_mod_d(prime, 4uL, &i)) != MP_OKAY) goto cleanup; if (i == 3u) { if ((res = mp_add_d(prime, 1uL, &t1)) != MP_OKAY) goto cleanup; if ((res = mp_div_2(&t1, &t1)) != MP_OKAY) goto cleanup; if ((res = mp_div_2(&t1, &t1)) != MP_OKAY) goto cleanup; if ((res = mp_exptmod(n, &t1, prime, ret)) != MP_OKAY) goto cleanup; res = MP_OKAY; goto cleanup; } /* NOW: Tonelli-Shanks algorithm */ /* factor out powers of 2 from prime-1, defining Q and S as: prime-1 = Q*2^S */ if ((res = mp_copy(prime, &Q)) != MP_OKAY) goto cleanup; if ((res = mp_sub_d(&Q, 1uL, &Q)) != MP_OKAY) goto cleanup; /* Q = prime - 1 */ mp_zero(&S); /* S = 0 */ while (mp_iseven(&Q) != MP_NO) { if ((res = mp_div_2(&Q, &Q)) != MP_OKAY) goto cleanup; /* Q = Q / 2 */ if ((res = mp_add_d(&S, 1uL, &S)) != MP_OKAY) goto cleanup; /* S = S + 1 */ } /* find a Z such that the Legendre symbol (Z|prime) == -1 */ if ((res = mp_set_int(&Z, 2uL)) != MP_OKAY) goto cleanup; /* Z = 2 */ while (1) { if ((res = mp_jacobi(&Z, prime, &legendre)) != MP_OKAY) goto cleanup; if (legendre == -1) break; if ((res = mp_add_d(&Z, 1uL, &Z)) != MP_OKAY) goto cleanup; /* Z = Z + 1 */ } if ((res = mp_exptmod(&Z, &Q, prime, &C)) != MP_OKAY) goto cleanup; /* C = Z ^ Q mod prime */ if ((res = mp_add_d(&Q, 1uL, &t1)) != MP_OKAY) goto cleanup; if ((res = mp_div_2(&t1, &t1)) != MP_OKAY) goto cleanup; /* t1 = (Q + 1) / 2 */ if ((res = mp_exptmod(n, &t1, prime, &R)) != MP_OKAY) goto cleanup; /* R = n ^ ((Q + 1) / 2) mod prime */ if ((res = mp_exptmod(n, &Q, prime, &T)) != MP_OKAY) goto cleanup; /* T = n ^ Q mod prime */ if ((res = mp_copy(&S, &M)) != MP_OKAY) goto cleanup; /* M = S */ if ((res = mp_set_int(&two, 2uL)) != MP_OKAY) goto cleanup; res = MP_VAL; while (1) { if ((res = mp_copy(&T, &t1)) != MP_OKAY) goto cleanup; i = 0; while (1) { if (mp_cmp_d(&t1, 1uL) == MP_EQ) break; if ((res = mp_exptmod(&t1, &two, prime, &t1)) != MP_OKAY) goto cleanup; i++; } if (i == 0u) { if ((res = mp_copy(&R, ret)) != MP_OKAY) goto cleanup; res = MP_OKAY; goto cleanup; } if ((res = mp_sub_d(&M, i, &t1)) != MP_OKAY) goto cleanup; if ((res = mp_sub_d(&t1, 1uL, &t1)) != MP_OKAY) goto cleanup; if ((res = mp_exptmod(&two, &t1, prime, &t1)) != MP_OKAY) goto cleanup; /* t1 = 2 ^ (M - i - 1) */ if ((res = mp_exptmod(&C, &t1, prime, &t1)) != MP_OKAY) goto cleanup; /* t1 = C ^ (2 ^ (M - i - 1)) mod prime */ if ((res = mp_sqrmod(&t1, prime, &C)) != MP_OKAY) goto cleanup; /* C = (t1 * t1) mod prime */ if ((res = mp_mulmod(&R, &t1, prime, &R)) != MP_OKAY) goto cleanup; |
︙ | ︙ |
Changes to libtommath/bn_mp_sub_d.c.
︙ | ︙ | |||
63 64 65 66 67 68 69 | } else { /* positive/size */ c->sign = MP_ZPOS; c->used = a->used; /* subtract first digit */ *tmpc = *tmpa++ - b; | | | | 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 | } else { /* positive/size */ c->sign = MP_ZPOS; c->used = a->used; /* subtract first digit */ *tmpc = *tmpa++ - b; mu = *tmpc >> ((sizeof(mp_digit) * (size_t)CHAR_BIT) - 1u); *tmpc++ &= MP_MASK; /* handle rest of the digits */ for (ix = 1; ix < a->used; ix++) { *tmpc = *tmpa++ - mu; mu = *tmpc >> ((sizeof(mp_digit) * (size_t)CHAR_BIT) - 1u); *tmpc++ &= MP_MASK; } } /* zero excess digits */ while (ix++ < oldused) { *tmpc++ = 0; |
︙ | ︙ |
Changes to libtommath/bn_mp_to_signed_bin_n.c.
︙ | ︙ | |||
17 18 19 20 21 22 23 | /* store in signed [big endian] format */ int mp_to_signed_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen) { if (*outlen < (unsigned long)mp_signed_bin_size(a)) { return MP_VAL; } | | | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | /* store in signed [big endian] format */ int mp_to_signed_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen) { if (*outlen < (unsigned long)mp_signed_bin_size(a)) { return MP_VAL; } *outlen = (unsigned long)mp_signed_bin_size(a); return mp_to_signed_bin(a, b); } #endif /* ref: $Format:%D$ */ /* git commit: $Format:%H$ */ /* commit time: $Format:%ai$ */ |
Changes to libtommath/bn_mp_to_unsigned_bin.c.
︙ | ︙ | |||
24 25 26 27 28 29 30 | if ((res = mp_init_copy(&t, a)) != MP_OKAY) { return res; } x = 0; while (mp_iszero(&t) == MP_NO) { #ifndef MP_8BIT | | | | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 | if ((res = mp_init_copy(&t, a)) != MP_OKAY) { return res; } x = 0; while (mp_iszero(&t) == MP_NO) { #ifndef MP_8BIT b[x++] = (unsigned char)(t.dp[0] & 255u); #else b[x++] = (unsigned char)(t.dp[0] | ((t.dp[1] & 1u) << 7)); #endif if ((res = mp_div_2d(&t, 8, &t, NULL)) != MP_OKAY) { mp_clear(&t); return res; } } bn_reverse(b, x); |
︙ | ︙ |
Changes to libtommath/bn_mp_to_unsigned_bin_n.c.
︙ | ︙ | |||
17 18 19 20 21 22 23 | /* store in unsigned [big endian] format */ int mp_to_unsigned_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen) { if (*outlen < (unsigned long)mp_unsigned_bin_size(a)) { return MP_VAL; } | | | 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 | /* store in unsigned [big endian] format */ int mp_to_unsigned_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen) { if (*outlen < (unsigned long)mp_unsigned_bin_size(a)) { return MP_VAL; } *outlen = (unsigned long)mp_unsigned_bin_size(a); return mp_to_unsigned_bin(a, b); } #endif /* ref: $Format:%D$ */ /* git commit: $Format:%H$ */ /* commit time: $Format:%ai$ */ |
Changes to libtommath/bn_mp_toom_mul.c.
︙ | ︙ | |||
215 216 217 218 219 220 221 | if ((res = mp_mul_2d(&w4, 3, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_sub(&w3, &tmp1, &w3)) != MP_OKAY) { goto ERR; } /* 3r2 - r1 - r3 */ | | | 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 | if ((res = mp_mul_2d(&w4, 3, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_sub(&w3, &tmp1, &w3)) != MP_OKAY) { goto ERR; } /* 3r2 - r1 - r3 */ if ((res = mp_mul_d(&w2, 3uL, &w2)) != MP_OKAY) { goto ERR; } if ((res = mp_sub(&w2, &w1, &w2)) != MP_OKAY) { goto ERR; } if ((res = mp_sub(&w2, &w3, &w2)) != MP_OKAY) { goto ERR; |
︙ | ︙ |
Changes to libtommath/bn_mp_toom_sqr.c.
︙ | ︙ | |||
158 159 160 161 162 163 164 | if ((res = mp_mul_2d(&w4, 3, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_sub(&w3, &tmp1, &w3)) != MP_OKAY) { goto ERR; } /* 3r2 - r1 - r3 */ | | | 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 | if ((res = mp_mul_2d(&w4, 3, &tmp1)) != MP_OKAY) { goto ERR; } if ((res = mp_sub(&w3, &tmp1, &w3)) != MP_OKAY) { goto ERR; } /* 3r2 - r1 - r3 */ if ((res = mp_mul_d(&w2, 3uL, &w2)) != MP_OKAY) { goto ERR; } if ((res = mp_sub(&w2, &w1, &w2)) != MP_OKAY) { goto ERR; } if ((res = mp_sub(&w2, &w3, &w2)) != MP_OKAY) { goto ERR; |
︙ | ︙ |
Changes to libtommath/bn_mp_unsigned_bin_size.c.
︙ | ︙ | |||
15 16 17 18 19 20 21 | * Tom St Denis, [email protected], http://libtom.org */ /* get the size for an unsigned equivalent */ int mp_unsigned_bin_size(const mp_int *a) { int size = mp_count_bits(a); | | | 15 16 17 18 19 20 21 22 23 24 25 26 27 28 | * Tom St Denis, [email protected], http://libtom.org */ /* get the size for an unsigned equivalent */ int mp_unsigned_bin_size(const mp_int *a) { int size = mp_count_bits(a); return (size / 8) + ((((unsigned)size & 7u) != 0u) ? 1 : 0); } #endif /* ref: $Format:%D$ */ /* git commit: $Format:%H$ */ /* commit time: $Format:%ai$ */ |
Changes to libtommath/bn_prime_tab.c.
︙ | ︙ | |||
10 11 12 13 14 15 16 17 18 19 20 21 22 23 | * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://libtom.org */ const mp_digit ltm_prime_tab[] = { 0x0002, 0x0003, 0x0005, 0x0007, 0x000B, 0x000D, 0x0011, 0x0013, 0x0017, 0x001D, 0x001F, 0x0025, 0x0029, 0x002B, 0x002F, 0x0035, 0x003B, 0x003D, 0x0043, 0x0047, 0x0049, 0x004F, 0x0053, 0x0059, 0x0061, 0x0065, 0x0067, 0x006B, 0x006D, 0x0071, 0x007F, #ifndef MP_8BIT 0x0083, | > | 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 | * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://libtom.org */ const mp_digit ltm_prime_tab[] = { 0x0002, 0x0003, 0x0005, 0x0007, 0x000B, 0x000D, 0x0011, 0x0013, 0x0017, 0x001D, 0x001F, 0x0025, 0x0029, 0x002B, 0x002F, 0x0035, 0x003B, 0x003D, 0x0043, 0x0047, 0x0049, 0x004F, 0x0053, 0x0059, 0x0061, 0x0065, 0x0067, 0x006B, 0x006D, 0x0071, 0x007F, #ifndef MP_8BIT 0x0083, |
︙ | ︙ |
Changes to libtommath/bn_s_mp_add.c.
︙ | ︙ | |||
63 64 65 66 67 68 69 | /* zero the carry */ u = 0; for (i = 0; i < min; i++) { /* Compute the sum at one digit, T[i] = A[i] + B[i] + U */ *tmpc = *tmpa++ + *tmpb++ + u; /* U = carry bit of T[i] */ | | | | 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 | /* zero the carry */ u = 0; for (i = 0; i < min; i++) { /* Compute the sum at one digit, T[i] = A[i] + B[i] + U */ *tmpc = *tmpa++ + *tmpb++ + u; /* U = carry bit of T[i] */ u = *tmpc >> (mp_digit)DIGIT_BIT; /* take away carry bit from T[i] */ *tmpc++ &= MP_MASK; } /* now copy higher words if any, that is in A+B * if A or B has more digits add those in */ if (min != max) { for (; i < max; i++) { /* T[i] = X[i] + U */ *tmpc = x->dp[i] + u; /* U = carry bit of T[i] */ u = *tmpc >> (mp_digit)DIGIT_BIT; /* take away carry bit from T[i] */ *tmpc++ &= MP_MASK; } } /* add carry */ |
︙ | ︙ |
Changes to libtommath/bn_s_mp_exptmod.c.
︙ | ︙ | |||
10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 | * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://libtom.org */ #ifdef MP_LOW_MEM # define TAB_SIZE 32 #else # define TAB_SIZE 256 #endif int s_mp_exptmod(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y, int redmode) { mp_int M[TAB_SIZE], res, mu; mp_digit buf; int err, bitbuf, bitcpy, bitcnt, mode, digidx, x, y, winsize; | > | | 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 | * additional optimizations in place. * * The library is free for all purposes without any express * guarantee it works. * * Tom St Denis, [email protected], http://libtom.org */ #ifdef MP_LOW_MEM # define TAB_SIZE 32 #else # define TAB_SIZE 256 #endif int s_mp_exptmod(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y, int redmode) { mp_int M[TAB_SIZE], res, mu; mp_digit buf; int err, bitbuf, bitcpy, bitcnt, mode, digidx, x, y, winsize; int (*redux)(mp_int *x, const mp_int *m, const mp_int *mu); /* find window size */ x = mp_count_bits(X); if (x <= 7) { winsize = 2; } else if (x <= 36) { winsize = 3; |
︙ | ︙ | |||
129 130 131 132 133 134 135 | } } /* setup result */ if ((err = mp_init(&res)) != MP_OKAY) { goto LBL_MU; } | | | 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 | } } /* setup result */ if ((err = mp_init(&res)) != MP_OKAY) { goto LBL_MU; } mp_set(&res, 1uL); /* set initial mode and bit cnt */ mode = 0; bitcnt = 1; buf = 0; digidx = X->used - 1; bitcpy = 0; |
︙ | ︙ |
Changes to libtommath/bn_s_mp_mul_digs.c.
︙ | ︙ | |||
24 25 26 27 28 29 30 | mp_int t; int res, pa, pb, ix, iy; mp_digit u; mp_word r; mp_digit tmpx, *tmpt, *tmpy; /* can we use the fast multiplier? */ | | | | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 | mp_int t; int res, pa, pb, ix, iy; mp_digit u; mp_word r; mp_digit tmpx, *tmpt, *tmpy; /* can we use the fast multiplier? */ if ((digs < (int)MP_WARRAY) && (MIN(a->used, b->used) < (int)(1u << (((size_t)CHAR_BIT * sizeof(mp_word)) - (2u * (size_t)DIGIT_BIT))))) { return fast_s_mp_mul_digs(a, b, c, digs); } if ((res = mp_init_size(&t, digs)) != MP_OKAY) { return res; } t.used = digs; |
︙ | ︙ | |||
62 63 64 65 66 67 68 | for (iy = 0; iy < pb; iy++) { /* compute the column as a mp_word */ r = (mp_word)*tmpt + ((mp_word)tmpx * (mp_word)*tmpy++) + (mp_word)u; /* the new column is the lower part of the result */ | | | | 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 | for (iy = 0; iy < pb; iy++) { /* compute the column as a mp_word */ r = (mp_word)*tmpt + ((mp_word)tmpx * (mp_word)*tmpy++) + (mp_word)u; /* the new column is the lower part of the result */ *tmpt++ = (mp_digit)(r & (mp_word)MP_MASK); /* get the carry word from the result */ u = (mp_digit)(r >> (mp_word)DIGIT_BIT); } /* set carry if it is placed below digs */ if ((ix + iy) < digs) { *tmpt = u; } } |
︙ | ︙ |
Changes to libtommath/bn_s_mp_mul_high_digs.c.
︙ | ︙ | |||
24 25 26 27 28 29 30 | int res, pa, pb, ix, iy; mp_digit u; mp_word r; mp_digit tmpx, *tmpt, *tmpy; /* can we use the fast multiplier? */ #ifdef BN_FAST_S_MP_MUL_HIGH_DIGS_C | | | | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | int res, pa, pb, ix, iy; mp_digit u; mp_word r; mp_digit tmpx, *tmpt, *tmpy; /* can we use the fast multiplier? */ #ifdef BN_FAST_S_MP_MUL_HIGH_DIGS_C if (((a->used + b->used + 1) < (int)MP_WARRAY) && (MIN(a->used, b->used) < (int)(1u << (((size_t)CHAR_BIT * sizeof(mp_word)) - (2u * (size_t)DIGIT_BIT))))) { return fast_s_mp_mul_high_digs(a, b, c, digs); } #endif if ((res = mp_init_size(&t, a->used + b->used + 1)) != MP_OKAY) { return res; } |
︙ | ︙ | |||
57 58 59 60 61 62 63 | for (iy = digs - ix; iy < pb; iy++) { /* calculate the double precision result */ r = (mp_word)*tmpt + ((mp_word)tmpx * (mp_word)*tmpy++) + (mp_word)u; /* get the lower part */ | | | | 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 | for (iy = digs - ix; iy < pb; iy++) { /* calculate the double precision result */ r = (mp_word)*tmpt + ((mp_word)tmpx * (mp_word)*tmpy++) + (mp_word)u; /* get the lower part */ *tmpt++ = (mp_digit)(r & (mp_word)MP_MASK); /* carry the carry */ u = (mp_digit)(r >> (mp_word)DIGIT_BIT); } *tmpt = u; } mp_clamp(&t); mp_exch(&t, c); mp_clear(&t); return MP_OKAY; } #endif /* ref: $Format:%D$ */ /* git commit: $Format:%H$ */ /* commit time: $Format:%ai$ */ |
Changes to libtommath/bn_s_mp_sqr.c.
︙ | ︙ | |||
34 35 36 37 38 39 40 | for (ix = 0; ix < pa; ix++) { /* first calculate the digit at 2*ix */ /* calculate double precision result */ r = (mp_word)t.dp[2*ix] + ((mp_word)a->dp[ix] * (mp_word)a->dp[ix]); /* store lower part in result */ | | | | | | | | | | | | 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 | for (ix = 0; ix < pa; ix++) { /* first calculate the digit at 2*ix */ /* calculate double precision result */ r = (mp_word)t.dp[2*ix] + ((mp_word)a->dp[ix] * (mp_word)a->dp[ix]); /* store lower part in result */ t.dp[ix+ix] = (mp_digit)(r & (mp_word)MP_MASK); /* get the carry */ u = (mp_digit)(r >> (mp_word)DIGIT_BIT); /* left hand side of A[ix] * A[iy] */ tmpx = a->dp[ix]; /* alias for where to store the results */ tmpt = t.dp + ((2 * ix) + 1); for (iy = ix + 1; iy < pa; iy++) { /* first calculate the product */ r = (mp_word)tmpx * (mp_word)a->dp[iy]; /* now calculate the double precision result, note we use * addition instead of *2 since it's easier to optimize */ r = (mp_word)*tmpt + r + r + (mp_word)u; /* store lower part */ *tmpt++ = (mp_digit)(r & (mp_word)MP_MASK); /* get carry */ u = (mp_digit)(r >> (mp_word)DIGIT_BIT); } /* propagate upwards */ while (u != 0uL) { r = (mp_word)*tmpt + (mp_word)u; *tmpt++ = (mp_digit)(r & (mp_word)MP_MASK); u = (mp_digit)(r >> (mp_word)DIGIT_BIT); } } mp_clamp(&t); mp_exch(&t, b); mp_clear(&t); return MP_OKAY; |
︙ | ︙ |
Changes to libtommath/bn_s_mp_sub.c.
︙ | ︙ | |||
49 50 51 52 53 54 55 | *tmpc = (*tmpa++ - *tmpb++) - u; /* U = carry bit of T[i] * Note this saves performing an AND operation since * if a carry does occur it will propagate all the way to the * MSB. As a result a single shift is enough to get the carry */ | | | | 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 | *tmpc = (*tmpa++ - *tmpb++) - u; /* U = carry bit of T[i] * Note this saves performing an AND operation since * if a carry does occur it will propagate all the way to the * MSB. As a result a single shift is enough to get the carry */ u = *tmpc >> (((size_t)CHAR_BIT * sizeof(mp_digit)) - 1u); /* Clear carry from T[i] */ *tmpc++ &= MP_MASK; } /* now copy higher words if any, e.g. if A has more digits than B */ for (; i < max; i++) { /* T[i] = A[i] - U */ *tmpc = *tmpa++ - u; /* U = carry bit of T[i] */ u = *tmpc >> (((size_t)CHAR_BIT * sizeof(mp_digit)) - 1u); /* Clear carry from T[i] */ *tmpc++ &= MP_MASK; } /* clear digits above used (since we may not have grown result above) */ for (i = c->used; i < olduse; i++) { |
︙ | ︙ |
Changes to libtommath/makefile.
︙ | ︙ | |||
98 99 100 101 102 103 104 | test_standalone: $(LIBNAME) demo/demo.o $(CC) $(CFLAGS) demo/demo.o $(LIBNAME) $(LFLAGS) -o test .PHONY: mtest mtest: cd mtest ; $(CC) $(CFLAGS) -O0 mtest.c $(LFLAGS) -o mtest | < < < < | 98 99 100 101 102 103 104 105 106 107 108 109 110 111 | test_standalone: $(LIBNAME) demo/demo.o $(CC) $(CFLAGS) demo/demo.o $(LIBNAME) $(LFLAGS) -o test .PHONY: mtest mtest: cd mtest ; $(CC) $(CFLAGS) -O0 mtest.c $(LFLAGS) -o mtest timing: $(LIBNAME) $(CC) $(CFLAGS) -DTIMER demo/timing.c $(LIBNAME) $(LFLAGS) -o ltmtest # You have to create a file .coveralls.yml with the content "repo_token: <the token>" # in the base folder to be able to submit to coveralls coveralls: lcov coveralls-lcov |
︙ | ︙ | |||
144 145 146 147 148 149 150 | gpg -b -a ltm-$(VERSION).zip new_file: bash updatemakes.sh perl dep.pl perlcritic: | | | | 140 141 142 143 144 145 146 147 148 149 150 | gpg -b -a ltm-$(VERSION).zip new_file: bash updatemakes.sh perl dep.pl perlcritic: perlcritic *.pl doc/*.pl astyle: astyle --options=astylerc $(OBJECTS:.o=.c) tommath*.h demo/*.c etc/*.c mtest/mtest.c |
Changes to libtommath/makefile_include.mk.
︙ | ︙ | |||
55 56 57 58 59 60 61 62 63 64 65 66 67 68 | endif endif # COMPILE_SIZE endif # COMPILE_DEBUG ifneq ($(findstring clang,$(CC)),) CFLAGS += -Wno-typedef-redefinition -Wno-tautological-compare -Wno-builtin-requires-header endif ifeq ($(PLATFORM), Darwin) CFLAGS += -Wno-nullability-completeness endif # adjust coverage set ifneq ($(filter $(shell arch), i386 i686 x86_64 amd64 ia64),) | > > > | 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 | endif endif # COMPILE_SIZE endif # COMPILE_DEBUG ifneq ($(findstring clang,$(CC)),) CFLAGS += -Wno-typedef-redefinition -Wno-tautological-compare -Wno-builtin-requires-header endif ifneq ($(findstring mingw,$(CC)),) CFLAGS += -Wno-shadow endif ifeq ($(PLATFORM), Darwin) CFLAGS += -Wno-nullability-completeness endif # adjust coverage set ifneq ($(filter $(shell arch), i386 i686 x86_64 amd64 ia64),) |
︙ | ︙ |
Changes to libtommath/tommath.h.
︙ | ︙ | |||
21 22 23 24 25 26 27 28 29 30 31 32 33 34 | #include <limits.h> #include <tommath_class.h> #ifdef __cplusplus extern "C" { #endif /* detect 64-bit mode if possible */ #if defined(__x86_64__) || defined(_M_X64) || defined(_M_AMD64) || \ defined(__powerpc64__) || defined(__ppc64__) || defined(__PPC64__) || \ defined(__s390x__) || defined(__arch64__) || defined(__aarch64__) || \ defined(__sparcv9) || defined(__sparc_v9__) || defined(__sparc64__) || \ defined(__ia64) || defined(__ia64__) || defined(__itanium__) || defined(_M_IA64) || \ | > > > > > | 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | #include <limits.h> #include <tommath_class.h> #ifdef __cplusplus extern "C" { #endif /* MS Visual C++ doesn't have a 128bit type for words, so fall back to 32bit MPI's (where words are 64bit) */ #if defined(_MSC_VER) || defined(__LLP64__) # define MP_32BIT #endif /* detect 64-bit mode if possible */ #if defined(__x86_64__) || defined(_M_X64) || defined(_M_AMD64) || \ defined(__powerpc64__) || defined(__ppc64__) || defined(__PPC64__) || \ defined(__s390x__) || defined(__arch64__) || defined(__aarch64__) || \ defined(__sparcv9) || defined(__sparc_v9__) || defined(__sparc64__) || \ defined(__ia64) || defined(__ia64__) || defined(__itanium__) || defined(_M_IA64) || \ |
︙ | ︙ | |||
61 62 63 64 65 66 67 | # define MP_SIZEOF_MP_DIGIT 2 # ifdef DIGIT_BIT # error You must not define DIGIT_BIT when using MP_16BIT # endif #elif defined(MP_64BIT) /* for GCC only on supported platforms */ typedef uint64_t mp_digit; | | < < | 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 | # define MP_SIZEOF_MP_DIGIT 2 # ifdef DIGIT_BIT # error You must not define DIGIT_BIT when using MP_16BIT # endif #elif defined(MP_64BIT) /* for GCC only on supported platforms */ typedef uint64_t mp_digit; # if defined(__GNUC__) typedef unsigned long mp_word __attribute__((mode(TI))); # else /* it seems you have a problem * but we assume you can somewhere define your own uint128_t */ typedef uint128_t mp_word; # endif |
︙ | ︙ | |||
100 101 102 103 104 105 106 | #else typedef mp_digit mp_min_u32; #endif /* use arc4random on platforms that support it */ #if defined(__FreeBSD__) || defined(__OpenBSD__) || defined(__NetBSD__) || defined(__DragonFly__) # define MP_GEN_RANDOM() arc4random() | | | 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 | #else typedef mp_digit mp_min_u32; #endif /* use arc4random on platforms that support it */ #if defined(__FreeBSD__) || defined(__OpenBSD__) || defined(__NetBSD__) || defined(__DragonFly__) # define MP_GEN_RANDOM() arc4random() # define MP_GEN_RANDOM_MAX 0xffffffffu #endif /* use rand() as fall-back if there's no better rand function */ #ifndef MP_GEN_RANDOM # define MP_GEN_RANDOM() rand() # define MP_GEN_RANDOM_MAX RAND_MAX #endif |
︙ | ︙ | |||
155 156 157 158 159 160 161 | # define MP_PREC 32 /* default digits of precision */ # else # define MP_PREC 8 /* default digits of precision */ # endif #endif /* size of comba arrays, should be at least 2 * 2**(BITS_PER_WORD - BITS_PER_DIGIT*2) */ | | | 158 159 160 161 162 163 164 165 166 167 168 169 170 171 172 | # define MP_PREC 32 /* default digits of precision */ # else # define MP_PREC 8 /* default digits of precision */ # endif #endif /* size of comba arrays, should be at least 2 * 2**(BITS_PER_WORD - BITS_PER_DIGIT*2) */ #define MP_WARRAY (1u << (((sizeof(mp_word) * CHAR_BIT) - (2 * DIGIT_BIT)) + 1)) /* the infamous mp_int structure */ typedef struct { int used, alloc, sign; mp_digit *dp; } mp_int; |
︙ | ︙ | |||
390 391 392 393 394 395 396 | int mp_n_root(const mp_int *a, mp_digit b, mp_int *c); int mp_n_root_ex(const mp_int *a, mp_digit b, mp_int *c, int fast); /* special sqrt algo */ int mp_sqrt(const mp_int *arg, mp_int *ret); /* special sqrt (mod prime) */ | | | | | | | | | | | | 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 | int mp_n_root(const mp_int *a, mp_digit b, mp_int *c); int mp_n_root_ex(const mp_int *a, mp_digit b, mp_int *c, int fast); /* special sqrt algo */ int mp_sqrt(const mp_int *arg, mp_int *ret); /* special sqrt (mod prime) */ int mp_sqrtmod_prime(const mp_int *n, const mp_int *prime, mp_int *ret); /* is number a square? */ int mp_is_square(const mp_int *arg, int *ret); /* computes the jacobi c = (a | n) (or Legendre if b is prime) */ int mp_jacobi(const mp_int *a, const mp_int *n, int *c); /* used to setup the Barrett reduction for a given modulus b */ int mp_reduce_setup(mp_int *a, const mp_int *b); /* Barrett Reduction, computes a (mod b) with a precomputed value c * * Assumes that 0 < x <= m*m, note if 0 > x > -(m*m) then you can merely * compute the reduction as -1 * mp_reduce(mp_abs(x)) [pseudo code]. */ int mp_reduce(mp_int *x, const mp_int *m, const mp_int *mu); /* setups the montgomery reduction */ int mp_montgomery_setup(const mp_int *n, mp_digit *rho); /* computes a = B**n mod b without division or multiplication useful for * normalizing numbers in a Montgomery system. */ int mp_montgomery_calc_normalization(mp_int *a, const mp_int *b); /* computes x/R == x (mod N) via Montgomery Reduction */ int mp_montgomery_reduce(mp_int *x, const mp_int *n, mp_digit rho); /* returns 1 if a is a valid DR modulus */ int mp_dr_is_modulus(const mp_int *a); /* sets the value of "d" required for mp_dr_reduce */ void mp_dr_setup(const mp_int *a, mp_digit *d); /* reduces a modulo n using the Diminished Radix method */ int mp_dr_reduce(mp_int *x, const mp_int *n, mp_digit k); /* returns true if a can be reduced with mp_reduce_2k */ int mp_reduce_is_2k(const mp_int *a); /* determines k value for 2k reduction */ int mp_reduce_2k_setup(const mp_int *a, mp_digit *d); /* reduces a modulo b where b is of the form 2**p - k [0 <= a] */ int mp_reduce_2k(mp_int *a, const mp_int *n, mp_digit d); /* returns true if a can be reduced with mp_reduce_2k_l */ int mp_reduce_is_2k_l(const mp_int *a); /* determines k value for 2k reduction */ int mp_reduce_2k_setup_l(const mp_int *a, mp_int *d); /* reduces a modulo b where b is of the form 2**p - k [0 <= a] */ int mp_reduce_2k_l(mp_int *a, const mp_int *n, const mp_int *d); /* Y = G**X (mod P) */ int mp_exptmod(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y); /* ---> Primes <--- */ /* number of primes */ #ifdef MP_8BIT # define PRIME_SIZE 31 #else |
︙ | ︙ |
Changes to libtommath/tommath_private.h.
︙ | ︙ | |||
72 73 74 75 76 77 78 79 80 81 82 83 84 85 | int mp_invmod_slow(const mp_int *a, const mp_int *b, mp_int *c); int fast_mp_montgomery_reduce(mp_int *x, const mp_int *n, mp_digit rho); int mp_exptmod_fast(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y, int redmode); int s_mp_exptmod(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y, int redmode); void bn_reverse(unsigned char *s, int len); extern const char *mp_s_rmap; /* Fancy macro to set an MPI from another type. * There are several things assumed: * x is the counter and unsigned * a is the pointer to the MPI * b is the original value that should be set in the MPI. */ | > > | 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 | int mp_invmod_slow(const mp_int *a, const mp_int *b, mp_int *c); int fast_mp_montgomery_reduce(mp_int *x, const mp_int *n, mp_digit rho); int mp_exptmod_fast(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y, int redmode); int s_mp_exptmod(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y, int redmode); void bn_reverse(unsigned char *s, int len); extern const char *mp_s_rmap; extern const unsigned char mp_s_rmap_reverse[]; extern const size_t mp_s_rmap_reverse_sz; /* Fancy macro to set an MPI from another type. * There are several things assumed: * x is the counter and unsigned * a is the pointer to the MPI * b is the original value that should be set in the MPI. */ |
︙ | ︙ | |||
95 96 97 98 99 100 101 | for (x = 0; x < (sizeof(type) * 2u); x++) { \ /* shift the number up four bits */ \ if ((res = mp_mul_2d (a, 4, a)) != MP_OKAY) { \ return res; \ } \ \ /* OR in the top four bits of the source */ \ | | | 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 | for (x = 0; x < (sizeof(type) * 2u); x++) { \ /* shift the number up four bits */ \ if ((res = mp_mul_2d (a, 4, a)) != MP_OKAY) { \ return res; \ } \ \ /* OR in the top four bits of the source */ \ a->dp[0] |= (mp_digit)(b >> ((sizeof(type) * 8u) - 4u)) & 15uL;\ \ /* shift the source up to the next four bits */ \ b <<= 4; \ \ /* ensure that digits are not clamped off */ \ a->used += 1; \ } \ |
︙ | ︙ |
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. '../../tcl9.0', 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. '9.0'). Setup this shell variable as follows: ver="9.0" 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 pkgs/README.
︙ | ︙ | |||
35 36 37 38 39 40 41 | TCLSH_PROG, TESTFLAGS variables. clean: Delete all files generated by the default build target. distclean: Delete all generated files. dist: Produce a copy of the package's source code distribution. | | | 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 | TCLSH_PROG, TESTFLAGS variables. clean: Delete all files generated by the default build target. distclean: Delete all generated files. dist: Produce a copy of the package's source code distribution. Must respect the DIST_ROOT variable determining where to write the generated directory. Packages that are written to make use of the Tcl Extension Architecture (TEA) and that make use of the tclconfig collection of support files, should conform to these conventions without further efforts. These conventions are subject to revision and refinement over time to |
︙ | ︙ |
Changes to tests/assemble.test.
︙ | ︙ | |||
528 529 530 531 532 533 534 | } } x } -result 12 -cleanup {rename x {}} } | < < < < < < < < < < < < | 528 529 530 531 532 533 534 535 536 537 538 539 540 541 | } } x } -result 12 -cleanup {rename x {}} } test assemble-7.18 {lappendArrayStk} { -body { proc x {} { set able(baker) charlie assemble { push able push baker |
︙ | ︙ | |||
1580 1581 1582 1583 1584 1585 1586 1587 1588 1589 1590 1591 1592 1593 | } test assemble-15.7 {listIndexImm} { -body { assemble {push {a b c}; listIndexImm end} } -result c } # assemble-16 - invokeStk test assemble-16.1 {invokeStk - wrong # args} { -body { assemble {invokeStk} } | > > > > > > | 1568 1569 1570 1571 1572 1573 1574 1575 1576 1577 1578 1579 1580 1581 1582 1583 1584 1585 1586 1587 | } test assemble-15.7 {listIndexImm} { -body { assemble {push {a b c}; listIndexImm end} } -result c } test assemble-15.8 {listIndexImm} { assemble {push {a b c}; listIndexImm end+2} } {} test assemble-15.9 {listIndexImm} { assemble {push {a b c}; listIndexImm -1-1} } {} # assemble-16 - invokeStk test assemble-16.1 {invokeStk - wrong # args} { -body { assemble {invokeStk} } |
︙ | ︙ |
Changes to tests/basic.test.
︙ | ︙ | |||
889 890 891 892 893 894 895 | set leak [expr {$end - $tmp}] } -cleanup { unset end i tmp rename getbytes {} rename stress {} } -result 0 | | < < < | < | | 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 | set leak [expr {$end - $tmp}] } -cleanup { unset end i tmp rename getbytes {} rename stress {} } -result 0 test basic-48.17.$noComp {expansion: object safety} -constraints $constraints -body { set third [expr {1.0/3.0}] set l [list $third $third] set x [run {list $third {*}$l $third}] set res [list] foreach t $x { lappend res [expr {$t * 3.0}] } set res } -cleanup { unset res t l x third } -result {1.0 1.0 1.0 1.0} test basic-48.18.$noComp {expansion: list semantics} -constraints $constraints -body { set badcmd { list a b set apa 10 } |
︙ | ︙ | |||
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 | > > > > > > > > > > | 975 976 977 978 979 980 981 982 983 984 985 986 987 988 989 990 991 992 993 994 995 996 997 998 | 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.
︙ | ︙ | |||
5341 5342 5343 5344 5345 5346 5347 | set x [format "%#o" [expr $stats(mode)&0o777]] chan puts $f "line 1" chan close $f set f [open $path(test3) r] lappend x [chan gets $f] } -cleanup { chan close $f | | | | 5341 5342 5343 5344 5345 5346 5347 5348 5349 5350 5351 5352 5353 5354 5355 5356 5357 5358 5359 5360 5361 5362 5363 | set x [format "%#o" [expr $stats(mode)&0o777]] chan puts $f "line 1" chan close $f set f [open $path(test3) r] lappend x [chan gets $f] } -cleanup { chan close $f } -result {0o600 {line 1}} test chan-io-40.3 {POSIX open access modes: CREAT} -setup { file delete $path(test3) } -constraints {unix umask} -body { # This test only works if your umask is 2, like ouster's. chan close [open $path(test3) {WRONLY CREAT}] file stat $path(test3) stats format "%#o" [expr $stats(mode)&0o777] } -result [format %#5o [expr {0o666 & ~ $umaskValue}]] test chan-io-40.4 {POSIX open access modes: CREAT} -setup { file delete $path(test3) } -body { set f [open $path(test3) w] chan configure $f -eofchar {} chan puts $f xyzzy chan close $f |
︙ | ︙ | |||
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 170 171 172 173 174 175 | } -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] test cmdIL-1.41 {lsort -stride and -index} -body { lsort -stride 2 -index -2 {a 2 b 1} } -returnCodes error -result {index "-2" cannot select an element from any list} test cmdIL-1.42 {lsort -stride and-index} -body { lsort -stride 2 -index -1-1 {a 2 b 1} } -returnCodes error -result {index "-1-1" cannot select an element from any list} # 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 |
︙ | ︙ | |||
199 200 201 202 203 204 205 206 207 208 209 210 211 212 | } -returnCodes error -result {expected integer but got "c"} test cmdIL-3.4.1 {SortCompare procedure, -index option} -body { lsort -integer -index 2 "{1 2 3} \\\{" } -returnCodes error -result {unmatched open brace in list} test cmdIL-3.5 {SortCompare procedure, -index option} -body { lsort -integer -index 2 {{20 10 13} {15}} } -returnCodes error -result {element 2 missing from sublist "15"} test cmdIL-3.6 {SortCompare procedure, -index option} { lsort -integer -index 2 {{1 15 30} {2 5 25} {3 25 20}} } {{3 25 20} {2 5 25} {1 15 30}} test cmdIL-3.7 {SortCompare procedure, -ascii option} { lsort -ascii {d e c b a d35 d300 100 20} } {100 20 a b c d d300 d35 e} test cmdIL-3.8 {SortCompare procedure, -dictionary option} { | > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | } -returnCodes error -result {expected integer but got "c"} test cmdIL-3.4.1 {SortCompare procedure, -index option} -body { lsort -integer -index 2 "{1 2 3} \\\{" } -returnCodes error -result {unmatched open brace in list} test cmdIL-3.5 {SortCompare procedure, -index option} -body { lsort -integer -index 2 {{20 10 13} {15}} } -returnCodes error -result {element 2 missing from sublist "15"} test cmdIL-3.5.1 {SortCompare procedure, -index option (out of range, calculated index)} -body { lsort -index 1+3 {{1 . c} {2 . b} {3 . a}} } -returnCodes error -result {element 4 missing from sublist "1 . c"} test cmdIL-3.5.2 {SortCompare procedure, -index option (out of range, calculated index)} -body { lsort -index -1-1 {{1 . c} {2 . b} {3 . a}} } -returnCodes error -result {index "-1-1" cannot select an element from any list} test cmdIL-3.5.3 {SortCompare procedure, -index option (out of range, calculated index)} -body { lsort -index -2 {{1 . c} {2 . b} {3 . a}} } -returnCodes error -result {index "-2" cannot select an element from any list} test cmdIL-3.5.4 {SortCompare procedure, -index option (out of range, calculated index)} -body { lsort -index end-4 {{1 . c} {2 . b} {3 . a}} } -returnCodes error -result {element -2 missing from sublist "1 . c"} test cmdIL-3.5.5 {SortCompare procedure, -index option} { lsort -index {} {a b} } {a b} test cmdIL-3.5.6 {SortCompare procedure, -index option} { lsort -index {} [list a \{] } {a \{} test cmdIL-3.5.7 {SortCompare procedure, -index option (out of range, calculated index)} -body { lsort -index end--1 {{1 . c} {2 . b} {3 . a}} } -returnCodes error -result {index "end--1" cannot select an element from any list} test cmdIL-3.5.8 {SortCompare procedure, -index option (out of range, calculated index)} -body { lsort -index end+1 {{1 . c} {2 . b} {3 . a}} } -returnCodes error -result {index "end+1" cannot select an element from any list} test cmdIL-3.5.9 {SortCompare procedure, -index option (out of range, calculated index)} -body { lsort -index end+2 {{1 . c} {2 . b} {3 . a}} } -returnCodes error -result {index "end+2" cannot select an element from any list} test cmdIL-3.6 {SortCompare procedure, -index option} { lsort -integer -index 2 {{1 15 30} {2 5 25} {3 25 20}} } {{3 25 20} {2 5 25} {1 15 30}} test cmdIL-3.7 {SortCompare procedure, -ascii option} { lsort -ascii {d e c b a d35 d300 100 20} } {100 20 a b c d d300 d35 e} test cmdIL-3.8 {SortCompare procedure, -dictionary option} { |
︙ | ︙ |
Changes to tests/coroutine.test.
︙ | ︙ | |||
735 736 737 738 739 740 741 742 743 744 745 746 747 748 | } proc boom {} { cc ; # coro created at level 2 C ; # and called at level 1 } boom ; # does not crash: the coro floor is a good insulator list } -result {} test coroutine-8.0.0 {coro inject executed} -body { coroutine demo apply {{} { foreach i {1 2} yield }} demo set ::result none tcl::unsupported::inject demo set ::result inject-executed | > > | 735 736 737 738 739 740 741 742 743 744 745 746 747 748 749 750 | } proc boom {} { cc ; # coro created at level 2 C ; # and called at level 1 } boom ; # does not crash: the coro floor is a good insulator list } -cleanup { rename boom {}; rename cc {}; rename c {} } -result {} test coroutine-8.0.0 {coro inject executed} -body { coroutine demo apply {{} { foreach i {1 2} yield }} demo set ::result none tcl::unsupported::inject demo set ::result inject-executed |
︙ | ︙ |
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.
︙ | ︙ | |||
455 456 457 458 459 460 461 | expr {! $x} } 1 test execute-3.71 {TclExecuteByteCode, INST_LNOT, op is non-numeric} {testobj} { set x [teststringobj set 1 foo] list [catch {expr {! $x}} msg] $msg } {1 {can't use non-numeric string "foo" as operand of "!"}} | < < < < | 455 456 457 458 459 460 461 462 463 464 465 466 467 468 | expr {! $x} } 1 test execute-3.71 {TclExecuteByteCode, INST_LNOT, op is non-numeric} {testobj} { set x [teststringobj set 1 foo] list [catch {expr {! $x}} msg] $msg } {1 {can't use non-numeric string "foo" as operand of "!"}} # INST_TRY_CVT_TO_NUMERIC is partially tested: test execute-3.72 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is int} {testobj} { set x [testintobj set 1 1] expr {$x} } 1 test execute-3.73 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is double} {testobj} { set x [testdoubleobj set 1 1.0] |
︙ | ︙ |
Changes to tests/expr-old.test.
︙ | ︙ | |||
1139 1140 1141 1142 1143 1144 1145 | 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 { | | | > > > > > > | | > > > > > > | 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 | 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.
︙ | ︙ | |||
5794 5795 5796 5797 5798 5799 5800 5801 5802 5803 5804 5805 5806 5807 | } [expr (1<<63)-1] test expr-32.5 {Bug 1585704} { expr (1<<32)%(1<<63) } [expr 1<<32] test expr-32.6 {Bug 1585704} { expr -(1<<32)%(1<<63) } [expr (1<<63)-(1<<32)] test expr-33.1 {parse largest long value} longIs32bit { set max_long_str 2147483647 set max_long_hex "0x7FFFFFFF " # Convert to integer (long, not wide) internal rep set max_long 2147483647 | > > > > > > > > > | 5794 5795 5796 5797 5798 5799 5800 5801 5802 5803 5804 5805 5806 5807 5808 5809 5810 5811 5812 5813 5814 5815 5816 | } [expr (1<<63)-1] test expr-32.5 {Bug 1585704} { expr (1<<32)%(1<<63) } [expr 1<<32] test expr-32.6 {Bug 1585704} { expr -(1<<32)%(1<<63) } [expr (1<<63)-(1<<32)] test expr-32.7 {bignum regression} { expr {0%(1<<63)} } 0 test expr-32.8 {bignum regression} { expr {0%-(1<<63)} } 0 test expr-32.9 {bignum regression} { expr {0%-(1+(1<<63))} } 0 test expr-33.1 {parse largest long value} longIs32bit { set max_long_str 2147483647 set max_long_hex "0x7FFFFFFF " # Convert to integer (long, not wide) internal rep set max_long 2147483647 |
︙ | ︙ |
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/foreach.test.
︙ | ︙ | |||
208 209 210 211 212 213 214 | } {a b} test foreach-6.3 {break tests} {catch {break foo} msg} 1 test foreach-6.4 {break tests} { catch {break foo} msg set msg } {wrong # args: should be "break"} # Check for bug #406709 | | | > > | 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 | } {a b} test foreach-6.3 {break tests} {catch {break foo} msg} 1 test foreach-6.4 {break tests} { catch {break foo} msg set msg } {wrong # args: should be "break"} # Check for bug #406709 test foreach-6.5 {break tests} -body { proc a {} { set a 1 foreach b b {list [concat a; break]; incr a} incr a } a } -cleanup { rename a {} } -result {2} # Test for incorrect "double evaluation" semantics test foreach-7.1 {delayed substitution of body} { proc foo {} { set a 0 foreach a [list 1 2 3] " set x $a |
︙ | ︙ |
Changes to tests/format.test.
︙ | ︙ | |||
24 25 26 27 28 29 30 | testConstraint pointerIs64bit [expr {$tcl_platform(pointerSize) >= 8}] test format-1.1 {integer formatting} { format "%*d %d %d %d" 6 34 16923 -12 -1 } { 34 16923 -12 -1} test format-1.2 {integer formatting} { format "%4d %4d %4d %4d %d %#x %#X" 6 34 16923 -12 -1 14 12 | | | 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 | testConstraint pointerIs64bit [expr {$tcl_platform(pointerSize) >= 8}] test format-1.1 {integer formatting} { format "%*d %d %d %d" 6 34 16923 -12 -1 } { 34 16923 -12 -1} test format-1.2 {integer formatting} { format "%4d %4d %4d %4d %d %#x %#X" 6 34 16923 -12 -1 14 12 } { 6 34 16923 -12 -1 0xe 0xC} test format-1.3 {integer formatting} longIs32bit { format "%4u %4u %4u %4u %d %#o" 6 34 16923 -12 -1 0 } { 6 34 16923 4294967284 -1 0} test format-1.3.1 {integer formatting} longIs64bit { format "%4u %4u %4u %4u %d %#o" 6 34 16923 -12 -1 0 } { 6 34 16923 18446744073709551604 -1 0} test format-1.4 {integer formatting} { |
︙ | ︙ | |||
50 51 52 53 54 55 56 | format "%4x %4x %4x %4x" 6 34 16923 -12 -1 } { 6 22 421b fffffff4} test format-1.7.1 {integer formatting} longIs64bit { format "%4x %4x %4x %4x" 6 34 16923 -12 -1 } { 6 22 421b fffffffffffffff4} test format-1.8 {integer formatting} longIs32bit { format "%#x %#x %#X %#X %#x" 0 6 34 16923 -12 -1 | | | | | | | | | | | | | | | | 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 | format "%4x %4x %4x %4x" 6 34 16923 -12 -1 } { 6 22 421b fffffff4} test format-1.7.1 {integer formatting} longIs64bit { format "%4x %4x %4x %4x" 6 34 16923 -12 -1 } { 6 22 421b fffffffffffffff4} test format-1.8 {integer formatting} longIs32bit { format "%#x %#x %#X %#X %#x" 0 6 34 16923 -12 -1 } {0 0x6 0x22 0x421B 0xfffffff4} test format-1.8.1 {integer formatting} longIs64bit { format "%#x %#x %#X %#X %#x" 0 6 34 16923 -12 -1 } {0 0x6 0x22 0x421B 0xfffffffffffffff4} test format-1.9 {integer formatting} longIs32bit { format "%#5x %#20x %#20x %#20x %#20x" 0 6 34 16923 -12 -1 } { 0 0x6 0x22 0x421b 0xfffffff4} test format-1.9.1 {integer formatting} longIs64bit { format "%#5x %#20x %#20x %#20x %#20x" 0 6 34 16923 -12 -1 } { 0 0x6 0x22 0x421b 0xfffffffffffffff4} test format-1.10 {integer formatting} longIs32bit { format "%-#5x %-#20x %-#20x %-#20x %-#20x" 0 6 34 16923 -12 -1 } {0 0x6 0x22 0x421b 0xfffffff4 } test format-1.10.1 {integer formatting} longIs64bit { format "%-#5x %-#20x %-#20x %-#20x %-#20x" 0 6 34 16923 -12 -1 } {0 0x6 0x22 0x421b 0xfffffffffffffff4 } test format-1.11 {integer formatting} longIs32bit { format "%-#5o %-#20o %#-20o %#-20o %#-20o" 0 6 34 16923 -12 -1 } {0 0o6 0o42 0o41033 0o37777777764 } test format-1.11.1 {integer formatting} longIs64bit { format "%-#5o %-#20o %#-20o %#-20o %#-20o" 0 6 34 16923 -12 -1 } {0 0o6 0o42 0o41033 0o1777777777777777777764} test format-1.12 {integer formatting} { format "%b %#b %#b %llb" 5 0 5 [expr {2**100}] } {101 0 0b101 10000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000} test format-1.13 {integer formatting} { format "%#0d %#0d %#0d %#0d %#0d" 0 6 34 16923 -12 -1 } {0 6 34 16923 -12} test format-1.14 {integer formatting} { format "%#05d %#020d %#020d %#020d %#020d" 0 6 34 16923 -12 -1 } {00000 00000000000000000006 00000000000000000034 00000000000000016923 -0000000000000000012} test format-1.15 {integer formatting} { format "%-#05d %-#020d %-#020d %-#020d %-#020d" 0 6 34 16923 -12 -1 } {00000 00000000000000000006 00000000000000000034 00000000000000016923 -0000000000000000012} test format-2.1 {string formatting} { format "%s %s %c %s" abcd {This is a very long test string.} 120 x } {abcd This is a very long test string. x x} test format-2.2 {string formatting} { format "%20s %20s %20c %20s" abcd {This is a very long test string.} 120 x |
︙ | ︙ | |||
557 558 559 560 561 562 563 | format %ld 42 } 42 test format-17.4 {testing %l with non-integer} { format %lf 1 } 1.000000 test format-17.5 {testing %llu with positive bignum} -body { format %llu 0xabcdef0123456789abcdef | | | 557 558 559 560 561 562 563 564 565 566 567 568 569 570 571 | format %ld 42 } 42 test format-17.4 {testing %l with non-integer} { format %lf 1 } 1.000000 test format-17.5 {testing %llu with positive bignum} -body { format %llu 0xabcdef0123456789abcdef } -result 207698809136909011942886895 test format-17.6 {testing %llu with negative number} -body { format %llu -1 } -returnCodes 1 -result {unsigned bignum format is invalid} test format-18.1 {do not demote existing numeric values} { set a 0xaaaaaaaa # Ensure $a and $b are separate objects |
︙ | ︙ |
Deleted tests/httpold.test.
|
| < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < |
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.
︙ | ︙ | |||
5634 5635 5636 5637 5638 5639 5640 | close $f set x } {zzy abzzy} test io-40.2 {POSIX open access modes: CREAT} {unix} { file delete $path(test3) set f [open $path(test3) {WRONLY CREAT} 0o600] file stat $path(test3) stats | | | | 5634 5635 5636 5637 5638 5639 5640 5641 5642 5643 5644 5645 5646 5647 5648 5649 5650 5651 5652 5653 5654 5655 5656 5657 5658 5659 5660 5661 5662 5663 | close $f set x } {zzy abzzy} test io-40.2 {POSIX open access modes: CREAT} {unix} { file delete $path(test3) set f [open $path(test3) {WRONLY CREAT} 0o600] file stat $path(test3) stats set x [format "%#o" [expr $stats(mode)&0o777]] puts $f "line 1" close $f set f [open $path(test3) r] lappend x [gets $f] close $f set x } {0o600 {line 1}} test io-40.3 {POSIX open access modes: CREAT} {unix umask} { # This test only works if your umask is 2, like ouster's. file delete $path(test3) set f [open $path(test3) {WRONLY CREAT}] close $f file stat $path(test3) stats format "%#o" [expr $stats(mode)&0o777] } [format %#5o [expr {0o666 & ~ $umaskValue}]] test io-40.4 {POSIX open access modes: CREAT} { file delete $path(test3) set f [open $path(test3) w] fconfigure $f -eofchar {} puts $f xyzzy close $f set f [open $path(test3) {WRONLY CREAT}] |
︙ | ︙ | |||
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 |
︙ | ︙ | |||
2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 | lappend res [catch {interp eval $idb [list puts $chan shoo]} msg] $msg lappend res [catch {interp eval $idb [list tell $chan]} msg] $msg lappend res [catch {interp eval $idb [list seek $chan 1]} msg] $msg lappend res [catch {interp eval $idb [list gets $chan]} msg] $msg lappend res [catch {interp eval $idb [list close $chan]} msg] $msg set res } -constraints {testchannel} \ -result {1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}} test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -match glob -body { set ida [interp create];#puts <<$ida>> set idb [interp create];#puts <<$idb>> | > > | 2053 2054 2055 2056 2057 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 | lappend res [catch {interp eval $idb [list puts $chan shoo]} msg] $msg lappend res [catch {interp eval $idb [list tell $chan]} msg] $msg lappend res [catch {interp eval $idb [list seek $chan 1]} msg] $msg lappend res [catch {interp eval $idb [list gets $chan]} msg] $msg lappend res [catch {interp eval $idb [list close $chan]} msg] $msg set res } -cleanup { interp delete $idb } -constraints {testchannel} \ -result {1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}} test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -match glob -body { set ida [interp create];#puts <<$ida>> set idb [interp create];#puts <<$idb>> |
︙ | ︙ | |||
2096 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 | # wait a bit, give the main thread the time to start its event # loop to wait for the response from B after 2000 catch { puts $chan shoo } res set res }] set res } -constraints {testchannel} -result {Owner lost} test iocmd-32.2 {delete interp of reflected chan} { # Bug 3034840 # Run this test in an interp with memory debugging to panic # on the double free interp create slave | > > | 2097 2098 2099 2100 2101 2102 2103 2104 2105 2106 2107 2108 2109 2110 2111 2112 | # wait a bit, give the main thread the time to start its event # loop to wait for the response from B after 2000 catch { puts $chan shoo } res set res }] set res } -cleanup { interp delete $idb } -constraints {testchannel} -result {Owner lost} test iocmd-32.2 {delete interp of reflected chan} { # Bug 3034840 # Run this test in an interp with memory debugging to panic # on the double free interp create slave |
︙ | ︙ | |||
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 | < | < | 3835 3836 3837 3838 3839 3840 3841 3842 3843 3844 | 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/ioTrans.test.
︙ | ︙ | |||
1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 | [catch {interp eval $idb [list close $chan]} msg] $msg #lappend res [interp eval $ida {set res}] # actions: clear|write|clear|write|clear|flush|limit?|drain|flush # The 'tell' is ok, as it passed through the transform to the base channel # without invoking the transform handler. } -cleanup { tempdone } -result {1 {Owner lost} 0 0 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}} test iortrans-11.1 {origin interpreter of moved transform destroyed during access} -setup { set ida [interp create]; #puts <<$ida>> set idb [interp create]; #puts <<$idb>> # Magic to get the test* commands in the slaves load {} Tcltest $ida load {} Tcltest $idb | > | 1196 1197 1198 1199 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 | [catch {interp eval $idb [list close $chan]} msg] $msg #lappend res [interp eval $ida {set res}] # actions: clear|write|clear|write|clear|flush|limit?|drain|flush # The 'tell' is ok, as it passed through the transform to the base channel # without invoking the transform handler. } -cleanup { tempdone interp delete $idb } -result {1 {Owner lost} 0 0 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}} test iortrans-11.1 {origin interpreter of moved transform destroyed during access} -setup { set ida [interp create]; #puts <<$ida>> set idb [interp create]; #puts <<$idb>> # Magic to get the test* commands in the slaves load {} Tcltest $ida load {} Tcltest $idb |
︙ | ︙ | |||
1236 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 | # wait for the response from B after 50 catch { puts $chan shoo } res set res }] } -cleanup { tempdone } -result {Owner lost} test iortrans-11.2 {delete interp of reflected transform} -setup { interp create slave # Magic to get the test* commands into the slave load {} Tcltest slave } -constraints {testchannel} -body { # Get base channel into the slave | > | 1237 1238 1239 1240 1241 1242 1243 1244 1245 1246 1247 1248 1249 1250 1251 | # wait for the response from B after 50 catch { puts $chan shoo } res set res }] } -cleanup { tempdone interp delete $idb } -result {Owner lost} test iortrans-11.2 {delete interp of reflected transform} -setup { interp create slave # Magic to get the test* commands into the slave load {} Tcltest slave } -constraints {testchannel} -body { # Get base channel into the slave |
︙ | ︙ |
Changes to tests/join.test.
︙ | ︙ | |||
41 42 43 44 45 46 47 48 49 50 51 52 53 54 | test join-3.1 {joinString is binary ok} { string length [join {a b c} a\0b] } 9 test join-3.2 {join is binary ok} { string length [join "a\0b a\0b a\0b"] } 11 # cleanup ::tcltest::cleanupTests return # Local Variables: # mode: tcl | > > > > > | 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 | test join-3.1 {joinString is binary ok} { string length [join {a b c} a\0b] } 9 test join-3.2 {join is binary ok} { string length [join "a\0b a\0b a\0b"] } 11 test join-4.1 {shimmer segfault prevention} { set l {0 0} join $l $l } {00 00} # cleanup ::tcltest::cleanupTests return # Local Variables: # mode: tcl |
︙ | ︙ |
Changes to tests/lindex.test.
︙ | ︙ | |||
75 76 77 78 79 80 81 82 83 84 85 86 87 88 | set x -0o9 list [catch { testevalex {lindex {a b c} $x} } result] $result } -match glob -result {1 {*}} 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 test lindex-4.1 {index = end} testevalex { set x end list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}] } {c c} | > > > > > > > > > | 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 | set x -0o9 list [catch { testevalex {lindex {a b c} $x} } result] $result } -match glob -result {1 {*}} 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} test lindex-3.8 {compiled with static indices out of range, negative} { list [lindex {a b c} -1] [lindex {a b c} -2] [lindex {a b c} -3] } [lrepeat 3 {}] test lindex-3.9 {compiled with calculated indices out of range, negative constant} { list [lindex {a b c} -1-1] [lindex {a b c} -2+0] [lindex {a b c} -2+1] } [lrepeat 3 {}] test lindex-3.10 {compiled with calculated indices out of range, after end} { list [lindex {a b c} end+1] [lindex {a b c} end+2] [lindex {a b c} end+3] } [lrepeat 3 {}] # Indices relative to end test lindex-4.1 {index = end} testevalex { set x end list [testevalex {lindex {a b c} $x}] [testevalex {lindex {a b c} $x}] } {c c} |
︙ | ︙ |
Changes to tests/lrange.test.
︙ | ︙ | |||
86 87 88 89 90 91 92 93 94 95 96 97 98 99 | } {1 {unmatched open brace in list}} test lrange-3.1 {Bug 3588366: end-offsets before start} { apply {l { lrange $l 0 end-5 }} {1 2 3 4 5} } {} # cleanup ::tcltest::cleanupTests return # Local Variables: # mode: tcl | > > > > > > > > > > > > > > > > > > | 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 | } {1 {unmatched open brace in list}} test lrange-3.1 {Bug 3588366: end-offsets before start} { apply {l { lrange $l 0 end-5 }} {1 2 3 4 5} } {} test lrange-3.2 {compiled with static indices out of range, negative} { list [lrange {a b c} -1 -2] [lrange {a b c} -2 -1] [lrange {a b c} -3 -2] [lrange {a b c} -2 -3] } [lrepeat 4 {}] test lrange-3.3 {compiled with calculated indices out of range, negative constant} { list [lrange {a b c} 0-1 -1-1] [lrange {a b c} -2+0 0-1] [lrange {a b c} -2-1 -2+1] [lrange {a b c} -2+1 -2-1] } [lrepeat 4 {}] test lrange-3.4 {compiled with calculated indices out of range, after end} { list [lrange {a b c} end+1 end+2] [lrange {a b c} end+2 end+1] [lrange {a b c} end+2 end+3] [lrange {a b c} end+3 end+2] } [lrepeat 4 {}] test lrange-3.5 {compiled with calculated indices, start out of range (negative)} { list [lrange {a b c} -1 1] [lrange {a b c} -1+0 end-1] [lrange {a b c} -2 1] [lrange {a b c} -2+0 0+1] } [lrepeat 4 {a b}] test lrange-3.6 {compiled with calculated indices, end out of range (after end)} { list [lrange {a b c} 1 end+1] [lrange {a b c} 1+0 2+1] [lrange {a b c} 1 end+1] [lrange {a b c} end-1 3+1] } [lrepeat 4 {b c}] # cleanup ::tcltest::cleanupTests return # Local Variables: # mode: tcl |
︙ | ︙ |
Changes to tests/lreplace.test.
︙ | ︙ | |||
94 95 96 97 98 99 100 | test lreplace-1.26 {lreplace command} { catch {unset foo} set foo {a b} list [set foo [lreplace $foo end end]] \ [set foo [lreplace $foo end end]] \ [set foo [lreplace $foo end end]] } {a {} {}} | | | | > > | > > > > | 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 | test lreplace-1.26 {lreplace command} { catch {unset foo} set foo {a b} list [set foo [lreplace $foo end end]] \ [set foo [lreplace $foo end end]] \ [set foo [lreplace $foo end end]] } {a {} {}} test lreplace-1.27 {lreplace command} -body { lreplace x 1 1 } -returnCodes 1 -result {list doesn't contain element 1} test lreplace-1.28 {lreplace command} -body { lreplace x 1 1 y } -returnCodes 1 -result {list doesn't contain element 1} test lreplace-1.29 {lreplace command} -body { lreplace x 1 1 [error foo] } -returnCodes 1 -result {foo} test lreplace-1.30 {lreplace command} -body { lreplace {not {}alist} 0 0 [error foo] } -returnCodes 1 -result {foo} test lreplace-2.1 {lreplace errors} { list [catch lreplace msg] $msg } {1 {wrong # args: should be "lreplace list first last ?element ...?"}} test lreplace-2.2 {lreplace errors} { list [catch {lreplace a b} msg] $msg } {1 {wrong # args: should be "lreplace list first last ?element ...?"}} |
︙ | ︙ |
Changes to tests/lsearch.test.
︙ | ︙ | |||
55 56 57 58 59 60 61 | lsearch -glob {xyz bbcc *bc*} *bc* } 1 test lsearch-2.9 {search modes} { lsearch -glob {b.x ^bc xy bcx} ^bc } 1 test lsearch-2.10 {search modes} -returnCodes error -body { lsearch -glib {b.x bx xy bcx} b.x | | | 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 | lsearch -glob {xyz bbcc *bc*} *bc* } 1 test lsearch-2.9 {search modes} { lsearch -glob {b.x ^bc xy bcx} ^bc } 1 test lsearch-2.10 {search modes} -returnCodes error -body { lsearch -glib {b.x bx xy bcx} b.x } -result {bad option "-glib": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, -stride, or -subindices} test lsearch-2.11 {search modes with -nocase} { lsearch -exact -nocase {a b c A B C} A } 0 test lsearch-2.12 {search modes with -nocase} { lsearch -glob -nocase {a b c A B C} A* } 0 test lsearch-2.13 {search modes with -nocase} { |
︙ | ︙ | |||
83 84 85 86 87 88 89 | lsearch } -result {wrong # args: should be "lsearch ?-option value ...? list pattern"} test lsearch-3.2 {lsearch errors} -returnCodes error -body { lsearch a } -result {wrong # args: should be "lsearch ?-option value ...? list pattern"} test lsearch-3.3 {lsearch errors} -returnCodes error -body { lsearch a b c | | | | 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 | lsearch } -result {wrong # args: should be "lsearch ?-option value ...? list pattern"} test lsearch-3.2 {lsearch errors} -returnCodes error -body { lsearch a } -result {wrong # args: should be "lsearch ?-option value ...? list pattern"} test lsearch-3.3 {lsearch errors} -returnCodes error -body { lsearch a b c } -result {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, -stride, or -subindices} test lsearch-3.4 {lsearch errors} -returnCodes error -body { lsearch a b c d } -result {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, -stride, or -subindices} test lsearch-3.5 {lsearch errors} -returnCodes error -body { lsearch "\{" b } -result {unmatched open brace in list} test lsearch-3.6 {lsearch errors} -returnCodes error -body { lsearch -index a b } -result {"-index" option must be followed by list index} test lsearch-3.7 {lsearch errors} -returnCodes error -body { |
︙ | ︙ | |||
414 415 416 417 418 419 420 421 422 423 424 425 426 427 428 429 430 431 432 433 434 435 436 437 | } {0 1} test lsearch-17.6 {lsearch -index option, basic functionality} { lsearch -all -index 1 -glob {{ab cb} {ab bb} {db bx}} b* } {1 2} test lsearch-17.7 {lsearch -index option, basic functionality} { lsearch -all -index 1 -regexp {{ab cb} {ab bb} {ab ab}} {[cb]b} } {0 1} test lsearch-18.1 {lsearch -index option, list as index basic functionality} { lsearch -index {0 0} {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a } 1 test lsearch-18.2 {lsearch -index option, list as index basic functionality} { lsearch -index {2 0} -exact {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a } 0 test lsearch-18.3 {lsearch -index option, list as index basic functionality} { lsearch -index {1 1} -glob {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} b* } 0 test lsearch-18.4 {lsearch -index option, list as index basic functionality} { lsearch -index {0 1} -regexp {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} {[cb]b} } 0 test lsearch-18.5 {lsearch -index option, list as index basic functionality} { lsearch -all -index {0 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a } {0 1} | > > > > > > > > > > > > > > > > > > > > > > > > > > > > | | | | | > > > > > > > > > | 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 | } {0 1} test lsearch-17.6 {lsearch -index option, basic functionality} { lsearch -all -index 1 -glob {{ab cb} {ab bb} {db bx}} b* } {1 2} test lsearch-17.7 {lsearch -index option, basic functionality} { lsearch -all -index 1 -regexp {{ab cb} {ab bb} {ab ab}} {[cb]b} } {0 1} test lsearch-17.8 {lsearch -index option, empty argument} { lsearch -index {} a a } 0 test lsearch-17.9 {lsearch -index option, empty argument} { lsearch -index {} a a } [lsearch a a] test lsearch-17.10 {lsearch -index option, empty argument} { lsearch -index {} [list \{] \{ } 0 test lsearch-17.11 {lsearch -index option, empty argument} { lsearch -index {} [list \{] \{ } [lsearch [list \{] \{] test lsearch-17.12 {lsearch -index option, encoding aliasing} -body { lsearch -index -2 a a } -returnCodes error -result {index "-2" cannot select an element from any list} test lsearch-17.13 {lsearch -index option, encoding aliasing} -body { lsearch -index -1-1 a a } -returnCodes error -result {index "-1-1" cannot select an element from any list} test lsearch-17.14 {lsearch -index option, encoding aliasing} -body { lsearch -index end--1 a a } -returnCodes error -result {index "end--1" cannot select an element from any list} test lsearch-17.15 {lsearch -index option, encoding aliasing} -body { lsearch -index end+1 a a } -returnCodes error -result {index "end+1" cannot select an element from any list} test lsearch-17.16 {lsearch -index option, encoding aliasing} -body { lsearch -index end+2 a a } -returnCodes error -result {index "end+2" cannot select an element from any list} test lsearch-18.1 {lsearch -index option, list as index basic functionality} { lsearch -index {0 0} {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a } 1 test lsearch-18.2 {lsearch -index option, list as index basic functionality} { lsearch -index {2 0} -exact {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a } 0 test lsearch-18.3 {lsearch -index option, list as index basic functionality} { lsearch -index {1 1} -glob {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} b* } 0 test lsearch-18.4 {lsearch -index option, list as index basic functionality} { lsearch -index {0 1} -regexp {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} {[cb]b} } 0 test lsearch-18.5 {lsearch -index option, list as index basic functionality} { lsearch -all -index {0 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a } {0 1} test lsearch-19.1 {lsearch -subindices option} { lsearch -subindices -index {0 0} {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a } {1 0 0} test lsearch-19.2 {lsearch -subindices option} { lsearch -subindices -index {2 0} -exact {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a } {0 2 0} test lsearch-19.3 {lsearch -subindices option} { lsearch -subindices -index {1 1} -glob {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} b* } {0 1 1} test lsearch-19.4 {lsearch -subindices option} { lsearch -subindices -index {0 1} -regexp {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} {[cb]b} } {0 0 1} test lsearch-19.5 {lsearch -subindices option} { lsearch -subindices -all -index {0 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a } {{0 0 0} {1 0 0}} test lsearch-19.6 {lsearch -subindices option} { lsearch -subindices -all -index {1 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a } {{0 1 0} {1 1 0}} test lsearch-19.7 {lsearch -subindices option} { lsearch -subindices -index end {{1 a}} a } {0 1} test lsearch-19.8 {lsearch -subindices option} { lsearch -subindices -all -index end {{1 a}} a } {{0 1}} test lsearch-20.1 {lsearch -index option, index larger than sublists} -body { lsearch -index 2 {{a c} {a b} {a a}} a } -returnCodes error -result {element 2 missing from sublist "a c"} test lsearch-20.2 {lsearch -index option, malformed index} -body { lsearch -index foo {{a c} {a b} {a a}} a } -returnCodes error -result {bad index "foo": must be integer?[+-]integer? or end?[+-]integer?} |
︙ | ︙ | |||
505 506 507 508 509 510 511 512 513 514 515 516 517 518 | } -result {10 8 5 2} test lsearch-22.5 {lsearch -bisect, all equal} { lsearch -bisect -integer {5 5 5 5} 5 } {3} test lsearch-22.6 {lsearch -sorted, all equal} { lsearch -sorted -integer {5 5 5 5} 5 } {0} # cleanup catch {unset res} catch {unset increasingIntegers} catch {unset decreasingIntegers} catch {unset increasingDoubles} catch {unset decreasingDoubles} | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | } -result {10 8 5 2} test lsearch-22.5 {lsearch -bisect, all equal} { lsearch -bisect -integer {5 5 5 5} 5 } {3} test lsearch-22.6 {lsearch -sorted, all equal} { lsearch -sorted -integer {5 5 5 5} 5 } {0} test lsearch-23.1 {lsearch -stride option, errors} -body { lsearch -stride {a b} a } -returnCodes error -result {"-stride" option must be followed by stride length} test lsearch-23.2 {lsearch -stride option, errors} -body { lsearch -stride 0 {a b} a } -returnCodes error -result {stride length must be at least 1} test lsearch-23.3 {lsearch -stride option, errors} -body { lsearch -stride 2 {a b c} a } -returnCodes error -result {list size must be a multiple of the stride length} test lsearch-23.4 {lsearch -stride option, errors} -body { lsearch -stride 5 {a b c} a } -returnCodes error -result {list size must be a multiple of the stride length} test lsearch-23.5 {lsearch -stride option, errors} -body { # Stride equal to length is ok lsearch -stride 3 {a b c} a } -result 0 test lsearch-24.1 {lsearch -stride option} -body { lsearch -stride 2 {a b c d e f g h} d } -result -1 test lsearch-24.2 {lsearch -stride option} -body { lsearch -stride 2 {a b c d e f g h} e } -result 4 test lsearch-24.3 {lsearch -stride option} -body { lsearch -stride 3 {a b c d e f g h i} e } -result -1 test lsearch-24.4 {lsearch -stride option} -body { # Result points first in group lsearch -stride 3 -index 1 {a b c d e f g h i} e } -result 3 test lsearch-24.5 {lsearch -stride option} -body { lsearch -inline -stride 2 {a b c d e f g h} d } -result {} test lsearch-24.6 {lsearch -stride option} -body { # Inline result is a "single element" strided list lsearch -inline -stride 2 {a b c d e f g h} e } -result "e f" test lsearch-24.7 {lsearch -stride option} -body { lsearch -inline -stride 3 {a b c d e f g h i} e } -result {} test lsearch-24.8 {lsearch -stride option} -body { lsearch -inline -stride 3 -index 1 {a b c d e f g h i} e } -result "d e f" test lsearch-24.9 {lsearch -stride option} -body { lsearch -all -inline -stride 3 -index 1 {a b c d e f g e i} e } -result "d e f g e i" test lsearch-24.10 {lsearch -stride option} -body { lsearch -all -inline -stride 3 -index 0 {a b c d e f a e i} a } -result "a b c a e i" test lsearch-24.11 {lsearch -stride option} -body { # Stride 1 is same as no stride lsearch -stride 1 {a b c d e f g h} d } -result 3 # 25* mimics 19* but with -inline added to -subindices test lsearch-25.1 {lsearch -subindices option} { lsearch -inline -subindices -index {0 0} {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a } {a} test lsearch-25.2 {lsearch -subindices option} { lsearch -inline -subindices -index {2 0} -exact {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a } {a} test lsearch-25.3 {lsearch -subindices option} { lsearch -inline -subindices -index {1 1} -glob {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} b* } {bb} test lsearch-25.4 {lsearch -subindices option} { lsearch -inline -subindices -index {0 1} -regexp {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} {[cb]b} } {cb} test lsearch-25.5 {lsearch -subindices option} { lsearch -inline -subindices -all -index {0 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a } {a a} test lsearch-25.6 {lsearch -subindices option} { lsearch -inline -subindices -all -index {1 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a } {a a} # 26* mimics 19* but with -stride added test lsearch-26.1 {lsearch -stride + -subindices option} { lsearch -stride 3 -subindices -index {0 0} {{x x} {x b} {a d} {a c} {a b} {a a}} a } {3 0} test lsearch-26.2 {lsearch -stride + -subindices option} { lsearch -stride 3 -subindices -index {2 0} -exact {{x x} {x b} {a d} {a c} {a b} {a a}} a } {2 0} test lsearch-26.3 {lsearch -stride + -subindices option} { lsearch -stride 3 -subindices -index {1 1} -glob {{ab cb} {ab bb} {ab ab} {ab cb} {ab bb} {ab ab}} b* } {1 1} test lsearch-26.4 {lsearch -stride + -subindices option} { lsearch -stride 3 -subindices -index {0 1} -regexp {{ab cb} {ab bb} {ab ab} {ab cb} {ab bb} {ab ab}} {[cb]b} } {0 1} test lsearch-26.5 {lsearch -stride + -subindices option} { lsearch -stride 3 -subindices -all -index {0 0} -exact {{a c} {a b} {d a} {a c} {a b} {d a}} a } {{0 0} {3 0}} test lsearch-26.6 {lsearch -stride + -subindices option} { lsearch -stride 3 -subindices -all -index {1 0} -exact {{a c} {a b} {d a} {x c} {a b} {d a}} a } {{1 0} {4 0}} # 27* mimics 25* but with -stride added test lsearch-27.1 {lsearch -stride + -subindices option} { lsearch -inline -stride 3 -subindices -index {0 0} {{x x} {x b} {a d} {a c} {a b} {a a}} a } {a} test lsearch-27.2 {lsearch -stride + -subindices option} { lsearch -inline -stride 3 -subindices -index {2 0} -exact {{x x} {x b} {a d} {a c} {a b} {a a}} a } {a} test lsearch-27.3 {lsearch -stride + -subindices option} { lsearch -inline -stride 3 -subindices -index {1 1} -glob {{ab cb} {ab bb} {ab ab} {ab cb} {ab bb} {ab ab}} b* } {bb} test lsearch-27.4 {lsearch -stride + -subindices option} { lsearch -inline -stride 3 -subindices -index {0 1} -regexp {{ab cb} {ab bb} {ab ab} {ab cb} {ab bb} {ab ab}} {[cb]b} } {cb} test lsearch-27.5 {lsearch -stride + -subindices option} { lsearch -inline -stride 3 -subindices -all -index {0 0} -exact {{a c} {a b} {d a} {a c} {a b} {d a}} a } {a a} test lsearch-27.6 {lsearch -stride + -subindices option} { lsearch -inline -stride 3 -subindices -all -index {1 0} -exact {{a c} {a b} {d a} {x c} {a b} {d a}} a } {a a} test lsearch-28.1 {lsearch -sorted with -stride} -body { lsearch -sorted -stride 2 {5 3 7 8 9 2} 5 } -result 0 test lsearch-28.2 {lsearch -sorted with -stride} -body { lsearch -sorted -stride 2 {5 3 7 8 9 2} 3 } -result -1 test lsearch-28.3 {lsearch -sorted with -stride} -body { lsearch -sorted -stride 2 {5 3 7 8 9 2} 7 } -result 2 test lsearch-28.4 {lsearch -sorted with -stride} -body { lsearch -sorted -stride 2 {5 3 7 8 9 2} 8 } -result -1 test lsearch-28.5 {lsearch -sorted with -stride} -body { lsearch -sorted -stride 2 {5 3 7 8 9 2} 9 } -result 4 test lsearch-28.6 {lsearch -sorted with -stride} -body { lsearch -sorted -stride 2 {5 3 7 8 9 2} 2 } -result -1 test lsearch-28.7 {lsearch -sorted with -stride} -body { lsearch -sorted -stride 2 -index 0 -subindices {5 3 7 8 9 2} 9 } -result 4 test lsearch-28.8 {lsearch -sorted with -stride} -body { lsearch -sorted -stride 2 -index 1 -subindices {3 5 8 7 2 9} 9 } -result 5 test lsearch-28.9 {lsearch -sorted with -stride} -body { lsearch -sorted -stride 2 -index 1 -subindices -inline {3 5 8 7 2 9} 9 } -result 9 # cleanup catch {unset res} catch {unset increasingIntegers} catch {unset decreasingIntegers} catch {unset increasingDoubles} catch {unset decreasingDoubles} |
︙ | ︙ |
Changes to tests/msgcat.test.
︙ | ︙ | |||
51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 | variable body variable result variable setVars foreach setVars [PowerSet $envVars] { set result [string tolower [lindex $setVars 0]] if {[string length $result] == 0} { if {[info exists ::tcl::mac::locale]} { set result [string tolower \ [msgcat::ConvertLocale $::tcl::mac::locale]] } else { if {([info sharedlibextension] eq ".dll") && ![catch {package require registry}]} { # Windows and Cygwin have other ways to determine the # locale when the environment variables are missing # and the registry package is present continue | > > > > > | 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 | variable body variable result variable setVars foreach setVars [PowerSet $envVars] { set result [string tolower [lindex $setVars 0]] if {[string length $result] == 0} { if {[info exists ::tcl::mac::locale]} { if {[package vsatisfies [package provide msgcat] 1.7]} { set result [string tolower \ [msgcat::mcutil::ConvertLocale $::tcl::mac::locale]] } else { set result [string tolower \ [msgcat::ConvertLocale $::tcl::mac::locale]] } } else { if {([info sharedlibextension] eq ".dll") && ![catch {package require registry}]} { # Windows and Cygwin have other ways to determine the # locale when the environment variables are missing # and the registry package is present continue |
︙ | ︙ | |||
189 190 191 192 193 194 195 196 197 198 199 200 201 202 | test msgcat-1.13 {mclocale set, reject evil input} -setup { variable locale [mclocale] } -cleanup { mclocale $locale } -body { mclocale looks/ok/../../../../but/is/path/to/evil/code } -returnCodes error -match glob -result {invalid newLocale value *} # Tests msgcat-2.*: [mcset], [mcmset], namespace partitioning test msgcat-2.1 {mcset, global scope} { namespace eval :: ::msgcat::mcset foo_BAR text1 text2 } {text2} | > > > > > > > > > > > > > > > > > > > > > > | 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 | test msgcat-1.13 {mclocale set, reject evil input} -setup { variable locale [mclocale] } -cleanup { mclocale $locale } -body { mclocale looks/ok/../../../../but/is/path/to/evil/code } -returnCodes error -match glob -result {invalid newLocale value *} test msgcat-1.14 {mcpreferences, custom locale preferences} -setup { variable locale [mclocale] mclocale en mcpreferences fr en {} } -cleanup { mclocale $locale } -body { mcpreferences } -result {fr en {}} test msgcat-1.15 {mcpreferences, overwrite custom locale preferences}\ -setup { variable locale [mclocale] mcpreferences fr en {} mclocale en } -cleanup { mclocale $locale } -body { mcpreferences } -result {en {}} # Tests msgcat-2.*: [mcset], [mcmset], namespace partitioning test msgcat-2.1 {mcset, global scope} { namespace eval :: ::msgcat::mcset foo_BAR text1 text2 } {text2} |
︙ | ︙ | |||
684 685 686 687 688 689 690 | removeDirectory msgdir3 # Tests msgcat-9.*: [mcexists] test msgcat-9.1 {mcexists no parameter} -body { mcexists } -returnCodes 1\ | | | 711 712 713 714 715 716 717 718 719 720 721 722 723 724 725 | removeDirectory msgdir3 # Tests msgcat-9.*: [mcexists] test msgcat-9.1 {mcexists no parameter} -body { mcexists } -returnCodes 1\ -result {wrong # args: should be "mcexists ?-exactnamespace? ?-exactlocale? ?-namespace ns? src"} test msgcat-9.2 {mcexists unknown option} -body { mcexists -unknown src } -returnCodes 1\ -result {unknown option "-unknown"} test msgcat-9.3 {mcexists} -setup { |
︙ | ︙ | |||
720 721 722 723 724 725 726 727 | test msgcat-9.5 {mcexists parent namespace} -setup { mcforgetpackage variable locale [mclocale] mclocale foo_bar mcset foo k1 v1 } -cleanup { mclocale $locale } -body { | > | | | > > > > > > > > > > > > > > > > > > > > > | 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 | test msgcat-9.5 {mcexists parent namespace} -setup { mcforgetpackage variable locale [mclocale] mclocale foo_bar mcset foo k1 v1 } -cleanup { mclocale $locale namespace delete ::foo } -body { namespace eval ::foo { list [::msgcat::mcexists k1]\ [::msgcat::mcexists -namespace ::msgcat::test k1] } } -result {0 1} test msgcat-9.6 {mcexists -namespace ns parameter} -setup { mcforgetpackage variable locale [mclocale] mclocale foo_bar mcset foo k1 v1 } -cleanup { mclocale $locale namespace delete ::foo } -body { namespace eval ::foo { list [::msgcat::mcexists k1]\ [::msgcat::mcexists -namespace ::msgcat::test k1] } } -result {0 1} test msgcat-9.7 {mcexists -namespace - ns argument missing} -body { mcexists -namespace src } -returnCodes 1\ -result {Argument missing for switch "-namespace"} # Tests msgcat-10.*: [mcloadedlocales] test msgcat-10.1 {mcloadedlocales no arg} -body { mcloadedlocales } -returnCodes 1\ -result {wrong # args: should be "mcloadedlocales subcommand"} |
︙ | ︙ | |||
807 808 809 810 811 812 813 | } -result {1 0} # Tests msgcat-12.*: [mcpackagelocale] test msgcat-12.1 {mcpackagelocale no subcommand} -body { mcpackagelocale } -returnCodes 1\ | | > > > > > | 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 | } -result {1 0} # Tests msgcat-12.*: [mcpackagelocale] test msgcat-12.1 {mcpackagelocale no subcommand} -body { mcpackagelocale } -returnCodes 1\ -result {wrong # args: should be "mcpackagelocale subcommand ?arg ...?"} test msgcat-12.2 {mclpackagelocale wrong subcommand} -body { mcpackagelocale junk } -returnCodes 1\ -result {unknown subcommand "junk": must be clear, get, isset, loaded, present, set, or unset} test msgcat-12.2.1 {mclpackagelocale set multiple args} -body { mcpackagelocale set a b } -returnCodes 1\ -result {wrong # args: should be "mcpackagelocale set ?locale?"} test msgcat-12.3 {mcpackagelocale set} -setup { variable locale [mclocale] } -cleanup { mclocale $locale mcforgetpackage } -body { mclocale foo |
︙ | ︙ | |||
918 919 920 921 922 923 924 925 926 927 928 929 930 931 | mcloadedlocales clear mclocale foo mcpackagelocale set bar mcpackagelocale clear list [mcpackagelocale present foo] [mcpackagelocale present bar] } -result {0 1} # Tests msgcat-13.*: [mcpackageconfig subcmds] test msgcat-13.1 {mcpackageconfig no subcommand} -body { mcpackageconfig } -returnCodes 1\ -result {wrong # args: should be "mcpackageconfig subcommand option ?value?"} | > > > > > > > > > > > > > > > > > > > > > > > > | 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 1002 1003 1004 1005 1006 1007 1008 1009 | mcloadedlocales clear mclocale foo mcpackagelocale set bar mcpackagelocale clear list [mcpackagelocale present foo] [mcpackagelocale present bar] } -result {0 1} test msgcat-12.11 {mcpackagelocale custom preferences} -setup { variable locale [mclocale] } -cleanup { mclocale $locale mcforgetpackage } -body { mclocale foo set res [list [mcpackagelocale preferences]] mcpackagelocale preferences bar {} lappend res [mcpackagelocale preferences] } -result {{foo {}} {bar {}}} test msgcat-12.12 {mcpackagelocale preferences -> no isset} -setup { variable locale [mclocale] } -cleanup { mclocale $locale mcforgetpackage } -body { mclocale foo mcpackagelocale preferences mcpackagelocale isset } -result {0} # Tests msgcat-13.*: [mcpackageconfig subcmds] test msgcat-13.1 {mcpackageconfig no subcommand} -body { mcpackageconfig } -returnCodes 1\ -result {wrong # args: should be "mcpackageconfig subcommand option ?value?"} |
︙ | ︙ | |||
1068 1069 1070 1071 1072 1073 1074 1075 1076 1077 1078 1079 1080 1081 1082 1083 1084 1085 | mcforgetpackage } -body { mcpackageconfig set unknowncmd [namespace code callbackfailproc] mclocale foo_bar mc k1 } -returnCodes 1\ -result {fail} interp bgerror {} $bgerrorsaved cleanupTests } namespace delete ::msgcat::test return # Local Variables: # mode: tcl # End: | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 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 | mcforgetpackage } -body { mcpackageconfig set unknowncmd [namespace code callbackfailproc] mclocale foo_bar mc k1 } -returnCodes 1\ -result {fail} # Tests msgcat-15.*: tcloo coverage # There are 4 use-cases, where 3 must be tested now: # - namespace defined, in class definition, class defined oo, classless test msgcat-15.1 {mc in class setup} -setup { # full namespace is ::msgcat::test:bar namespace eval bar { ::msgcat::mcset foo_BAR con2 con2bar oo::class create ClassCur } variable locale [mclocale] mclocale foo_BAR } -cleanup { mclocale $locale namespace eval bar {::msgcat::mcforgetpackage} namespace delete bar } -body { oo::define bar::ClassCur msgcat::mc con2 } -result con2bar test msgcat-15.2 {mc in class} -setup { # full namespace is ::msgcat::test:bar namespace eval bar { ::msgcat::mcset foo_BAR con2 con2bar oo::class create ClassCur oo::define ClassCur method method1 {} {::msgcat::mc con2} } # full namespace is ::msgcat::test:baz namespace eval baz { set ObjCur [::msgcat::test::bar::ClassCur new] } variable locale [mclocale] mclocale foo_BAR } -cleanup { mclocale $locale namespace eval bar {::msgcat::mcforgetpackage} namespace delete bar baz } -body { $baz::ObjCur method1 } -result con2bar test msgcat-15.3 {mc in classless object} -setup { # full namespace is ::msgcat::test:bar namespace eval bar { ::msgcat::mcset foo_BAR con2 con2bar oo::object create ObjCur oo::objdefine ObjCur method method1 {} {::msgcat::mc con2} } variable locale [mclocale] mclocale foo_BAR } -cleanup { mclocale $locale namespace eval bar {::msgcat::mcforgetpackage} namespace delete bar } -body { bar::ObjCur method1 } -result con2bar test msgcat-15.4 {mc in classless object with explicite namespace eval}\ -setup { # full namespace is ::msgcat::test:bar namespace eval bar { ::msgcat::mcset foo_BAR con2 con2bar oo::object create ObjCur oo::objdefine ObjCur method method1 {} { namespace eval ::msgcat::test::baz { ::msgcat::mc con2 } } } namespace eval baz { ::msgcat::mcset foo_BAR con2 con2baz } variable locale [mclocale] mclocale foo_BAR } -cleanup { mclocale $locale namespace eval bar {::msgcat::mcforgetpackage} namespace eval baz {::msgcat::mcforgetpackage} namespace delete bar baz } -body { bar::ObjCur method1 } -result con2baz # Test msgcat-16.*: command mcpackagenamespaceget test msgcat-16.1 {mcpackagenamespaceget in namespace procedure} -body { namespace eval baz {msgcat::mcpackagenamespaceget} } -result ::msgcat::test::baz test msgcat-16.2 {mcpackagenamespaceget in class setup} -setup { namespace eval bar { oo::class create ClassCur oo::define ClassCur variable a } } -cleanup { namespace delete bar } -body { oo::define bar::ClassCur msgcat::mcpackagenamespaceget } -result ::msgcat::test::bar test msgcat-16.3 {mcpackagenamespaceget in class} -setup { namespace eval bar { oo::class create ClassCur oo::define ClassCur method method1 {} {msgcat::mcpackagenamespaceget} } namespace eval baz { set ObjCur [::msgcat::test::bar::ClassCur new] } } -cleanup { namespace delete bar baz } -body { $baz::ObjCur method1 } -result ::msgcat::test::bar test msgcat-16.4 {mcpackagenamespaceget in classless object} -setup { namespace eval bar { oo::object create ObjCur oo::objdefine ObjCur method method1 {} {msgcat::mcpackagenamespaceget} } } -cleanup { namespace delete bar } -body { bar::ObjCur method1 } -result ::msgcat::test::bar test msgcat-16.5\ {mcpackagenamespaceget in classless object with explicite namespace eval}\ -setup { namespace eval bar { oo::object create ObjCur oo::objdefine ObjCur method method1 {} { namespace eval ::msgcat::test::baz { msgcat::mcpackagenamespaceget } } } } -cleanup { namespace delete bar baz } -body { bar::ObjCur method1 } -result ::msgcat::test::baz # Test msgcat-17.*: mcn command test msgcat-17.1 {mcn no parameters} -body { mcn } -returnCodes 1\ -result {wrong # args: should be "mcn ns src ?arg ...?"} test msgcat-17.2 {mcn} -setup { namespace eval bar {::msgcat::mcset foo_BAR con1 con1bar} variable locale [mclocale] mclocale foo_BAR } -cleanup { mclocale $locale } -body { ::msgcat::mcn [namespace current]::bar con1 } -result con1bar interp bgerror {} $bgerrorsaved # Tests msgcat-15.*: [mcutil] test msgcat-15.1 {mcutil - no argument} -body { mcutil } -returnCodes 1\ -result {wrong # args: should be "mcutil subcommand ?arg ...?"} test msgcat-15.2 {mcutil - wrong argument} -body { mcutil junk } -returnCodes 1\ -result {unknown subcommand "junk": must be getpreferences, or getsystemlocale} test msgcat-15.3 {mcutil - partial argument} -body { mcutil getsystem } -returnCodes 1\ -result {unknown subcommand "getsystem": must be getpreferences, or getsystemlocale} test msgcat-15.4 {mcutil getpreferences - no argument} -body { mcutil getpreferences } -returnCodes 1\ -result {wrong # args: should be "mcutil getpreferences locale"} test msgcat-15.5 {mcutil getpreferences - DE_de} -body { mcutil getpreferences DE_de } -result {de_de de {}} test msgcat-15.6 {mcutil getsystemlocale - wrong argument} -body { mcutil getsystemlocale DE_de } -returnCodes 1\ -result {wrong # args: should be "mcutil getsystemlocale"} # The result is system dependent # So just test if it runs # The environment variable version was test with test 0.x test msgcat-15.7 {mcutil getsystemlocale} -body { mcutil getsystemlocale set ok ok } -result {ok} cleanupTests } namespace delete ::msgcat::test return # Local Variables: # mode: tcl # End: |
Changes to tests/namespace.test.
︙ | ︙ | |||
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 |
︙ | ︙ | |||
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 | | | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 1854 1855 1856 1857 1858 1859 1860 1861 1862 1863 1864 1865 | 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 {} | | | 1972 1973 1974 1975 1976 1977 1978 1979 1980 1981 1982 1983 1984 1985 1986 | } {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] | | | 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 2149 2150 | 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"}\ | | | 3235 3236 3237 3238 3239 3240 3241 3242 3243 3244 3245 3246 3247 3248 3249 | } -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: | > > > > > > > > > > > > | 3319 3320 3321 3322 3323 3324 3325 3326 3327 3328 3329 3330 3331 3332 3333 3334 3335 3336 3337 3338 3339 3340 3341 3342 3343 3344 3345 3346 3347 3348 3349 3350 | 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/obj.test.
︙ | ︙ | |||
22 23 24 25 26 27 28 | testConstraint testobj [llength [info commands testobj]] testConstraint longIs32bit [expr {int(0x80000000) < 0}] testConstraint wideBiggerThanInt [expr {wide(0x80000000) != int(0x80000000)}] test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} testobj { set r 1 foreach {t} { | < < | 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 | testConstraint testobj [llength [info commands testobj]] testConstraint longIs32bit [expr {int(0x80000000) < 0}] testConstraint wideBiggerThanInt [expr {wide(0x80000000) != int(0x80000000)}] test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} testobj { set r 1 foreach {t} { bytearray bytecode cmdName dict regexp string } { set first [string first $t [testobj types]] set r [expr {$r && ($first != -1)}] } set result $r |
︙ | ︙ | |||
49 50 51 52 53 54 55 | lappend result [testobj freeallvars] lappend result [testintobj set 1 12] lappend result [testobj convert 1 bytearray] lappend result [testobj type 1] lappend result [testobj refcount 1] } {{} 12 12 bytearray 3} | < < < < < < < < < | 47 48 49 50 51 52 53 54 55 56 57 58 59 60 | lappend result [testobj freeallvars] lappend result [testintobj set 1 12] lappend result [testobj convert 1 bytearray] lappend result [testobj type 1] lappend result [testobj refcount 1] } {{} 12 12 bytearray 3} test obj-4.1 {Tcl_NewObj and AllocateFreeObjects} testobj { set result "" lappend result [testobj freeallvars] lappend result [testobj newobj 1] lappend result [testobj type 1] lappend result [testobj refcount 1] } {{} {} string 2} |
︙ | ︙ | |||
548 549 550 551 552 553 554 | lappend result [testbooleanobj set 2 0] ;# must copy on write, now 2 objs lappend result [testobj type 2] lappend result [testobj refcount 1] lappend result [testobj refcount 2] } {{} 1024 1024 int 4 4 0 int 3 2} | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 537 538 539 540 541 542 543 544 545 546 547 548 549 550 | lappend result [testbooleanobj set 2 0] ;# must copy on write, now 2 objs lappend result [testobj type 2] lappend result [testobj refcount 1] lappend result [testobj refcount 2] } {{} 1024 1024 int 4 4 0 int 3 2} test obj-32.1 {freeing very large object trees} { set x {} for {set i 0} {$i<100000} {incr i} { set x [list $x {}] } unset x } {} |
︙ | ︙ |
Changes to tests/oo.test.
︙ | ︙ | |||
8 9 10 11 12 13 14 15 16 17 18 19 20 21 | # this file, and for a DISCLAIMER OF ALL WARRANTIES. package require TclOO 1.0.3 package require tcltest 2 if {"::tcltest" in [namespace children]} { namespace import -force ::tcltest::* } testConstraint memory [llength [info commands memory]] if {[testConstraint memory]} { proc getbytes {} { set lines [split [memory info] \n] return [lindex $lines 3 3] } | > > > > > > > | 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 | # this file, and for a DISCLAIMER OF ALL WARRANTIES. package require TclOO 1.0.3 package require tcltest 2 if {"::tcltest" in [namespace children]} { namespace import -force ::tcltest::* } # The foundational objects oo::object and oo::class are sensitive to reference # counting errors and are deallocated only when an interp is deleted, so in # this test suite, interp creation and interp deletion are often used in # leaktests in order to leverage this sensitivity. testConstraint memory [llength [info commands memory]] if {[testConstraint memory]} { proc getbytes {} { set lines [split [memory info] \n] return [lindex $lines 3 3] } |
︙ | ︙ | |||
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 { | | > > > > > > | | 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 | 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 } } -constraints memory -result 0 test oo-0.5.1 {testing object foundation cleanup} memory { leaktest { interp create foo interp delete foo } } 0 test oo-0.5.2 {testing literal leak on interp delete} memory { leaktest { interp create foo foo eval {oo::object new} interp delete foo } } 0 test oo-0.6 {cleaning the core class pair; way #1} -setup { |
︙ | ︙ | |||
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 | > > > > > > > | 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 | 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 |
︙ | ︙ | |||
254 255 256 257 258 259 260 | } -body { oo::define B constructor {} {A create test-oo-1.18} B create C } -cleanup { rename test-oo-1.18 {} A destroy } -result ::C | > > > > > > > > > > > > > > | | | 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 | } -body { oo::define B constructor {} {A create test-oo-1.18} B create C } -cleanup { rename test-oo-1.18 {} A destroy } -result ::C test oo-1.18.1 {no memory leak: superclass} -setup { } -constraints memory -body { leaktest { interp create t t eval { oo::class create A { superclass oo::class } } interp delete t } } -cleanup { } -result 0 test oo-1.18.2 {Bug 75b8433707: memory leak in oo-1.18} -setup { proc test-oo-1.18 {} return } -constraints memory -body { leaktest { oo::class create A oo::class create B {superclass A} oo::define B constructor {} {A create test-oo-1.18} B create C A destroy } } -cleanup { rename test-oo-1.18 {} } -result 0 test oo-1.18.3 {Bug 21c144f0f5} -setup { interp create slave } -body { slave eval { oo::define [oo::class create foo] superclass oo::class oo::class destroy } } -cleanup { |
︙ | ︙ | |||
1478 1479 1480 1481 1482 1483 1484 1485 1486 1487 1488 1489 1490 1491 | oo::class create bar oo::define bar superclass bar1 bar2 bar create foo set result [list [catch {bar create foo} msg] $msg] lappend result [bar0 destroy] [oo::object create foo] [foo destroy] \ [oo::object create bar2] [bar2 destroy] } {1 {can't create object "foo": command already exists with that name} destroyed {} ::foo {} ::bar2 {}} test oo-12.1 {OO: filters} { oo::class create Aclass Aclass create Aobject oo::define Aclass { method concatenate args { global result | > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | oo::class create bar oo::define bar superclass bar1 bar2 bar create foo set result [list [catch {bar create foo} msg] $msg] lappend result [bar0 destroy] [oo::object create foo] [foo destroy] \ [oo::object create bar2] [bar2 destroy] } {1 {can't create object "foo": command already exists with that name} destroyed {} ::foo {} ::bar2 {}} test oo-11.5 {OO: cleanup} { oo::class create obj1 trace add command obj1 delete {apply {{name1 name2 action} { set namespace [info object namespace $name1] namespace delete $namespace }}} rename obj1 {} # No segmentation fault return done } done test oo-11.6.1 { OO: cleanup of when an class is mixed into itself } -constraints memory -body { leaktest { interp create interp1 oo::class create obj1 ::oo::define obj1 {self mixin [uplevel 1 {namespace which obj1}]} rename obj1 {} interp delete interp1 } } -result 0 -cleanup { } test oo-11.6.2 { OO: cleanup ReleaseClassContents() where class is mixed into one of its instances } -constraints memory -body { leaktest { interp create interp1 interp1 eval { oo::class create obj1 ::oo::copy obj1 obj2 rename obj2 {} rename obj1 {} } interp delete interp1 } } -result 0 -cleanup { } test oo-11.6.3 { OO: cleanup ReleaseClassContents() where class is mixed into one of its instances } -constraints memory -body { leaktest { interp create interp1 interp1 eval { oo::class create obj1 ::oo::define obj1 {self mixin [uplevel 1 {namespace which obj1}]} ::oo::copy obj1 obj2 rename obj2 {} rename obj1 {} } interp delete interp1 } } -result 0 -cleanup { } test oo-11.6.4 { 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 |
︙ | ︙ | |||
1664 1665 1666 1667 1668 1669 1670 | return $result } {::foo {in A ::foo} {in B ::foo} foo} test oo-13.2 {OO: changing an object's class} -body { oo::object create foo oo::objdefine foo class oo::class } -cleanup { foo destroy | | | | 1779 1780 1781 1782 1783 1784 1785 1786 1787 1788 1789 1790 1791 1792 1793 1794 1795 1796 1797 1798 1799 | return $result } {::foo {in A ::foo} {in B ::foo} foo} test oo-13.2 {OO: changing an object's class} -body { oo::object create foo oo::objdefine foo class oo::class } -cleanup { foo destroy } -result {} test oo-13.3 {OO: changing an object's class} -body { oo::class create foo oo::objdefine foo class oo::object } -cleanup { foo destroy } -result {} test oo-13.4 {OO: changing an object's class} -body { oo::class create foo { method m {} { set result [list [self class] [info object class [self]]] oo::objdefine [self] class ::bar lappend result [self class] [info object class [self]] } |
︙ | ︙ | |||
2022 2023 2024 2025 2026 2027 2028 | } -body { namespace eval ::existing {} oo::copy Cls {} ::existing } -returnCodes error -cleanup { Super destroy catch {namespace delete ::existing} } -result {::existing refers to an existing namespace} | > > > > > > > > > > > > > | | 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 2162 2163 2164 | } -body { namespace eval ::existing {} oo::copy Cls {} ::existing } -returnCodes error -cleanup { Super destroy catch {namespace delete ::existing} } -result {::existing refers to an existing namespace} test oo-15.13.1 { OO: object cloning with target NS Valgrind will report a leak if the reference count of the namespace isn't properly incremented. } -setup { oo::class create Cls {} } -body { oo::copy Cls Cls2 ::dupens return done } -cleanup { Cls destroy Cls2 destroy } -result done test oo-15.13.2 {OO: object cloning with target NS} -setup { oo::class create Super oo::class create Cls {superclass Super} } -body { list [namespace exist ::dupens] [oo::copy Cls Cls2 ::dupens] [namespace exist ::dupens] } -cleanup { Super destroy } -result {0 ::Cls2 1} |
︙ | ︙ | |||
3618 3619 3620 3621 3622 3623 3624 | } } list [leaktest {[cls new] destroy}] [info class instances cls] } -cleanup { cls destroy } -result {0 {}} | > > | | | | | | | | | | | | | | | | | | | | | > > > > > > > > > > | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | | > | < < | 3746 3747 3748 3749 3750 3751 3752 3753 3754 3755 3756 3757 3758 3759 3760 3761 3762 3763 3764 3765 3766 3767 3768 3769 3770 3771 3772 3773 3774 3775 3776 3777 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 | } } list [leaktest {[cls new] destroy}] [info class instances cls] } -cleanup { cls destroy } -result {0 {}} proc SampleSlotSetup script { set script0 { oo::class create SampleSlot { superclass oo::Slot constructor {} { variable contents {a b c} ops {} } method contents {} {variable contents; return $contents} method ops {} {variable ops; return $ops} method Get {} { variable contents variable ops lappend ops [info level] Get return $contents } method Set {lst} { variable contents $lst variable ops lappend ops [info level] Set $lst return } } } append script0 \n$script } proc SampleSlotCleanup script { set script0 { SampleSlot destroy } append script \n$script0 } test oo-32.1 {TIP 380: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot }] -body { list [info level] [sampleSlot contents] [sampleSlot ops] } -cleanup [SampleSlotCleanup { rename sampleSlot {} }] -result {0 {a b c} {}} test oo-32.2 {TIP 380: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot }] -body { list [info level] [sampleSlot -clear] \ [sampleSlot contents] [sampleSlot ops] } -cleanup [SampleSlotCleanup { rename sampleSlot {} }] -result {0 {} {} {1 Set {}}} test oo-32.3 {TIP 380: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot }] -body { list [info level] [sampleSlot -append g h i] \ [sampleSlot contents] [sampleSlot ops] } -cleanup [SampleSlotCleanup { rename sampleSlot {} }] -result {0 {} {a b c g h i} {1 Get 1 Set {a b c g h i}}} test oo-32.4 {TIP 380: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot }] -body { list [info level] [sampleSlot -set d e f] \ [sampleSlot contents] [sampleSlot ops] } -cleanup [SampleSlotCleanup { rename sampleSlot {} }] -result {0 {} {d e f} {1 Set {d e f}}} test oo-32.5 {TIP 380: slots - class test} -setup [SampleSlotSetup { SampleSlot create sampleSlot }] -body { list [info level] [sampleSlot -set d e f] [sampleSlot -append g h i] \ [sampleSlot contents] [sampleSlot ops] } -cleanup [SampleSlotCleanup { rename sampleSlot {} }] -result {0 {} {} {d e f g h i} {1 Set {d e f} 1 Get 1 Set {d e f g h i}}} test oo-33.1 {TIP 380: slots - defaulting} -setup [SampleSlotSetup { set s [SampleSlot new] }] -body { list [$s x y] [$s contents] } -cleanup [SampleSlotCleanup { rename $s {} }] -result {{} {a b c x y}} test oo-33.2 {TIP 380: slots - defaulting} -setup [SampleSlotSetup { set s [SampleSlot new] }] -body { list [$s destroy; $s unknown] [$s contents] } -cleanup [SampleSlotCleanup { rename $s {} }] -result {{} {a b c destroy unknown}} test oo-33.3 {TIP 380: slots - defaulting} -setup [SampleSlotSetup { set s [SampleSlot new] }] -body { oo::objdefine $s forward --default-operation my -set list [$s destroy; $s unknown] [$s contents] [$s ops] } -cleanup [SampleSlotCleanup { rename $s {} }] -result {{} unknown {1 Set destroy 1 Set unknown}} test oo-33.4 {TIP 380: slots - errors} -setup [SampleSlotSetup { set s [SampleSlot new] }] -body { # Method names beginning with "-" are special to slots $s -grill q } -returnCodes error -cleanup [SampleSlotCleanup { rename $s {} }] -result \ {unknown method "-grill": must be -append, -clear, -set, contents or ops} test oo-34.1 {TIP 380: slots - presence} -setup { set obj [oo::object new] set result {} } -body { oo::define oo::object { ::lappend ::result [::info object class filter] |
︙ | ︙ | |||
3830 3831 3832 3833 3834 3835 3836 3837 3838 3839 3840 3841 3842 3843 | 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 | > > > > > > > > > > > > > > > > > > > > > > | 3969 3970 3971 3972 3973 3974 3975 3976 3977 3978 3979 3980 3981 3982 3983 3984 3985 3986 3987 3988 3989 3990 3991 3992 3993 3994 3995 3996 3997 3998 3999 4000 4001 4002 4003 4004 | 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 799 800 801 802 803 804 805 806 807 808 809 810 | 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-3.54 {Tcl_PkgRequire procedure, coroutine support} -setup { package forget t } -body { coroutine coro1 apply {{} { package ifneeded t 2.1 { yield package provide t 2.1 } package require t 2.1 }} list [catch {coro1} msg] $msg } -match glob -result {0 2.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 } } | | < < | | | | | > | | > | | 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 | } 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 |
︙ | ︙ |
Added tests/process.test.
> > > > > > > > > > > > > > > > > > > > > > > > > > > > > > > | 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 | # process.test -- # # This file contains a collection of tests for the tcl::process ensemble. # Sourcing this file into Tcl runs the tests and generates output for # errors. No output means no errors were found. # # Copyright (c) 2017 Frederic Bonnet # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } test process-1.1 {tcl::process command basic syntax} -returnCodes error -body { tcl::process } -result {wrong # args: should be "tcl::process subcommand ?arg ...?"} test process-1.2 {tcl::process command basic syntax} -returnCodes error -body { tcl::process ? } -match glob -result {unknown or ambiguous subcommand "?": must be autopurge, list, purge, or status} test process-2.1 {tcl::process autopurge get} {tcl::process autopurge} {1} test process-2.2 {tcl::process autopurge set true} { tcl::process autopurge true tcl::process autopurge } {1} test process-2.3 {tcl::process autopurge set false} { tcl::process autopurge false tcl::process autopurge } {0} |
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 564 565 566 567 568 | } -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 } -result {1 207698809136909011942886895} test scan-6.1 {floating-point scanning} -setup { set a {}; set b {}; set c {}; set d {} } -body { list [scan "2.1 -3.0e8 .99962 a" "%f%g%e%f" a b c d] $a $b $c $d } -result {3 2.1 -300000000.0 0.99962 {}} test scan-6.2 {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 34 35 36 37 | ::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]] test string-1.1 {error conditions} { list [catch {string gorp a b} msg] $msg } {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-1.2 {error conditions} { list [catch {string} msg] $msg } {1 {wrong # args: should be "string subcommand ?arg ...?"}} | > > > > > > | 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 | ::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] } test string-1.1 {error conditions} { list [catch {string gorp a b} msg] $msg } {1 {unknown or ambiguous subcommand "gorp": must be bytelength, cat, compare, equal, first, index, is, last, length, map, match, range, repeat, replace, reverse, tolower, totitle, toupper, trim, trimleft, trimright, wordend, or wordstart}} test string-1.2 {error conditions} { list [catch {string} msg] $msg } {1 {wrong # args: should be "string subcommand ?arg ...?"}} |
︙ | ︙ | |||
220 221 222 223 224 225 226 227 228 229 230 231 232 233 | test string-4.15 {string first, ability to two-byte encoded utf-8 chars} { # Test for a bug in Tcl 8.3 where test for all-single-byte-encoded # strings was incorrect, leading to an index returned by [string first] # which pointed past the end of the string. set uchar \u057e ;# character with two-byte encoding in utf-8 string first % %#$uchar$uchar#$uchar$uchar#% 3 } 8 test string-5.1 {string index} { list [catch {string index} msg] $msg } {1 {wrong # args: should be "string index string charIndex"}} test string-5.2 {string index} { list [catch {string index a b c} msg] $msg } {1 {wrong # args: should be "string index string charIndex"}} | > > > > > > > | 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241 242 243 244 245 246 | test string-4.15 {string first, ability to two-byte encoded utf-8 chars} { # Test for a bug in Tcl 8.3 where test for all-single-byte-encoded # strings was incorrect, leading to an index returned by [string first] # which pointed past the end of the string. set uchar \u057e ;# character with two-byte encoding in utf-8 string first % %#$uchar$uchar#$uchar$uchar#% 3 } 8 test string-4.16 {string first, normal string vs pure unicode string} { set s hello regexp ll $s m # Representation checks are canaries list [representationpoke $s] [representationpoke $m] \ [string first $m $s] } {{string 1} {string 0} 2} test string-5.1 {string index} { list [catch {string index} msg] $msg } {1 {wrong # args: should be "string index string charIndex"}} test string-5.2 {string index} { list [catch {string index a b c} msg] $msg } {1 {wrong # args: should be "string index string charIndex"}} |
︙ | ︙ | |||
1187 1188 1189 1190 1191 1192 1193 1194 1195 1196 1197 1198 1199 1200 | list [string match *cba* $longString] \ [string match *a*l*\u0000* $longString] \ [string match *a*l*\u0000*123 $longString] \ [string match *a*l*\u0000*123* $longString] \ [string match *a*l*\u0000*cba* $longString] \ [string match *===* $longString] } {0 1 1 1 0 0} test string-12.1 {string range} { list [catch {string range} msg] $msg } {1 {wrong # args: should be "string range string first last"}} test string-12.2 {string range} { list [catch {string range a 1} msg] $msg } {1 {wrong # args: should be "string range string first last"}} | > > > | 1200 1201 1202 1203 1204 1205 1206 1207 1208 1209 1210 1211 1212 1213 1214 1215 1216 | list [string match *cba* $longString] \ [string match *a*l*\u0000* $longString] \ [string match *a*l*\u0000*123 $longString] \ [string match *a*l*\u0000*123* $longString] \ [string match *a*l*\u0000*cba* $longString] \ [string match *===* $longString] } {0 1 1 1 0 0} test string-11.55 {string match, invalid binary optimization} { [format string] match \u0141 [binary format c 65] } 0 test string-12.1 {string range} { list [catch {string range} msg] $msg } {1 {wrong # args: should be "string range string first last"}} test string-12.2 {string range} { list [catch {string range a 1} msg] $msg } {1 {wrong # args: should be "string range string first last"}} |
︙ | ︙ | |||
1272 1273 1274 1275 1276 1277 1278 1279 1280 1281 1282 1283 1284 1285 | 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"}} | > > > | 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 1301 1302 1303 1304 | 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"}} |
︙ | ︙ | |||
1370 1371 1372 1373 1374 1375 1376 1377 1378 1379 1380 1381 1382 1383 | } {foo} test string-14.17 {string replace} { string replace abcdefghijklmnop end end-1 } {abcdefghijklmnop} test string-14.18 {string replace} { string replace abcdefghijklmnop 10 9 XXX } {abcdefghijklmnop} test string-15.1 {string tolower too few args} { list [catch {string tolower} msg] $msg } {1 {wrong # args: should be "string tolower string ?first? ?last?"}} test string-15.2 {string tolower bad args} { list [catch {string tolower a b} msg] $msg } {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}} | > > > | 1389 1390 1391 1392 1393 1394 1395 1396 1397 1398 1399 1400 1401 1402 1403 1404 1405 | } {foo} test string-14.17 {string replace} { string replace abcdefghijklmnop end end-1 } {abcdefghijklmnop} test string-14.18 {string replace} { string replace abcdefghijklmnop 10 9 XXX } {abcdefghijklmnop} test string-14.19 {string replace} { string replace {} -1 0 A } A test string-15.1 {string tolower too few args} { list [catch {string tolower} msg] $msg } {1 {wrong # args: should be "string tolower string ?first? ?last?"}} test string-15.2 {string tolower bad args} { list [catch {string tolower a b} msg] $msg } {1 {bad index "b": must be integer?[+-]integer? or end?[+-]integer?}} |
︙ | ︙ | |||
1681 1682 1683 1684 1685 1686 1687 | } edcba test string-24.4 {string reverse command - unshared string} { set x abc set y de string reverse $x$y } edcba test string-24.5 {string reverse command - shared unicode string} { | | | | | | | | | | | | | | | 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 | } edcba test string-24.4 {string reverse command - unshared string} { set x abc set y de string reverse $x$y } edcba test string-24.5 {string reverse command - shared unicode string} { set x abcde\ud0ad string reverse $x } \ud0adedcba test string-24.6 {string reverse command - unshared string} { set x abc set y de\ud0ad string reverse $x$y } \ud0adedcba test string-24.7 {string reverse command - simple case} { string reverse a } a test string-24.8 {string reverse command - simple case} { string reverse \ud0ad } \ud0ad test string-24.9 {string reverse command - simple case} { string reverse {} } {} test string-24.10 {string reverse command - corner case} { set x \ubeef\ud0ad string reverse $x } \ud0ad\ubeef test string-24.11 {string reverse command - corner case} { set x \ubeef set y \ud0ad string reverse $x$y } \ud0ad\ubeef test string-24.12 {string reverse command - corner case} { set x \ubeef set y \ud0ad string is ascii [string reverse $x$y] } 0 test string-24.13 {string reverse command - pure Unicode string} { string reverse [string range \ubeef\ud0ad\ubeef\ud0ad\ubeef\ud0ad 1 5] } \ud0ad\ubeef\ud0ad\ubeef\ud0ad test string-24.14 {string reverse command - pure bytearray} { binary scan [string reverse [binary format H* 010203]] H* x set x } 030201 test string-24.15 {string reverse command - pure bytearray} { binary scan [tcl::string::reverse [binary format H* 010203]] H* x set x |
︙ | ︙ | |||
2038 2039 2040 2041 2042 2043 2044 | set e [encoding convertto utf-8 {}] set f [encoding convertto utf-8 {}] } -cleanup { unset e f } -body { tcl::unsupported::representation [string cat $e $f $e $f [list x]] } -match glob -result {*no string representation} | | < < | 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 2072 2073 2074 2075 2076 | set e [encoding convertto utf-8 {}] set f [encoding convertto utf-8 {}] } -cleanup { unset e f } -body { tcl::unsupported::representation [string cat $e $f $e $f [list x]] } -match glob -result {*no string representation} # cleanup rename MemStress {} catch {rename foo {}} ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: |
Changes to tests/stringObj.test.
︙ | ︙ | |||
476 477 478 479 480 481 482 | teststringobj set 1 foo teststringobj appendself2 1 2 } fooo test stringObj-15.8 {Tcl_Append*ToObj: self appends} testobj { teststringobj set 1 foo teststringobj appendself2 1 3 } foo | < > > > > | 476 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 | teststringobj set 1 foo teststringobj appendself2 1 2 } fooo test stringObj-15.8 {Tcl_Append*ToObj: self appends} testobj { teststringobj set 1 foo teststringobj appendself2 1 3 } foo if {[testConstraint testobj]} { testobj freeallvars } # cleanup ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: |
Changes to tests/unixFCmd.test.
︙ | ︙ | |||
217 218 219 220 221 222 223 | } -cleanup { cleanup } -result {fifo fifo} test unixFCmd-2.5 {TclpCopyFile: copy attributes} -setup { cleanup } -constraints {unix notRoot} -body { close [open tf1 a] | | | | 217 218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234 235 236 | } -cleanup { cleanup } -result {fifo fifo} test unixFCmd-2.5 {TclpCopyFile: copy attributes} -setup { cleanup } -constraints {unix notRoot} -body { close [open tf1 a] file attributes tf1 -permissions 0o472 file copy tf1 tf2 file attributes tf2 -permissions } -cleanup { cleanup } -result 0o472 ;# i.e. perms field of [exec ls -l tf2] is -r--rwx-w- test unixFCmd-3.1 {CopyFile not done} {emptyTest unix notRoot} { } {} test unixFCmd-4.1 {TclpDeleteFile not done} {emptyTest unix notRoot} { } {} |
︙ | ︙ | |||
371 372 373 374 375 376 377 | foreach permstr $permList { file attributes foo.test -permissions $permstr lappend result [file attributes foo.test -permissions] } set result } $expected } | | | | | | | 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 | foreach permstr $permList { file attributes foo.test -permissions $permstr lappend result [file attributes foo.test -permissions] } set result } $expected } permcheck unixFCmd-17.5 rwxrwxrwx 0o777 permcheck unixFCmd-17.6 r--r---w- 0o442 permcheck unixFCmd-17.7 {0 u+rwx,g+r u-w o+rwx} {00000 0o740 0o540 0o547} permcheck unixFCmd-17.11 --x--x--x 0o111 permcheck unixFCmd-17.12 {0 a+rwx} {00000 0o777} file delete -force -- foo.test test unixFCmd-18.1 {Unix pwd} -constraints {unix notRoot nonPortable} -setup { set cd [pwd] } -body { # This test is nonPortable because SunOS generates a weird error # message when the current directory isn't readable. |
︙ | ︙ |
Changes to tests/utf.test.
︙ | ︙ | |||
64 65 66 67 68 69 70 | string length [testbytestring "\xE2\xA2"] } {2} test utf-2.7 {Tcl_UtfToUniChar: lead (3-byte) followed by 2 trail} testbytestring { string length [testbytestring "\xE4\xb9\x8e"] } {1} test utf-2.8 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} -constraints {fullutf testbytestring} -body { string length [testbytestring "\xF0\x90\x80\x80"] | | | > > > | 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 | string length [testbytestring "\xE2\xA2"] } {2} test utf-2.7 {Tcl_UtfToUniChar: lead (3-byte) followed by 2 trail} testbytestring { string length [testbytestring "\xE4\xb9\x8e"] } {1} test utf-2.8 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} -constraints {fullutf testbytestring} -body { string length [testbytestring "\xF0\x90\x80\x80"] } -result {2} test utf-2.9 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail} -constraints {fullutf testbytestring} -body { string length [testbytestring "\xF4\x8F\xBF\xBF"] } -result {2} test utf-2.10 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail, underflow} testbytestring { string length [testbytestring "\xF0\x8F\xBF\xBF"] } {4} test utf-2.11 {Tcl_UtfToUniChar: lead (4-byte) followed by 3 trail, overflow} testbytestring { string length [testbytestring "\xF4\x90\x80\x80"] } {4} test utf-2.12 {Tcl_UtfToUniChar: longer UTF sequences not supported} testbytestring { 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/util.test.
︙ | ︙ | |||
381 382 383 384 385 386 387 | test util-5.50 {Tcl_StringMatch} { Wrapper_Tcl_StringMatch *. "" } 0 test util-5.51 {Tcl_StringMatch} { Wrapper_Tcl_StringMatch "" "" } 1 | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397 398 399 400 401 | test util-5.50 {Tcl_StringMatch} { Wrapper_Tcl_StringMatch *. "" } 0 test util-5.51 {Tcl_StringMatch} { Wrapper_Tcl_StringMatch "" "" } 1 test util-6.5 {Tcl_PrintDouble - make sure there's a decimal point} { concat x[expr 2.0] } {x2.0} test util-6.6 {Tcl_PrintDouble - make sure there's a decimal point} { concat x[expr 3.0e98] } {x3e+98} # This test always succeeded in the C locale anyway... test util-8.1 {TclNeedSpace - correct UTF8 handling} { # Bug 411825 # Note that this test relies on the fact that # [interp target] calls on Tcl_AppendElement() # which calls on TclNeedSpace(). If [interp target] # is ever updated, this test will no longer test |
︙ | ︙ | |||
2134 2135 2136 2137 2138 2139 2140 | } -result 0x8010000000000000 -cleanup { unset x } } | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 2058 2059 2060 2061 2062 2063 2064 2065 2066 2067 2068 2069 2070 2071 | } -result 0x8010000000000000 -cleanup { unset x } } test util-17.1 {bankers' rounding [Bug 3349507]} {ieeeFloatingPoint} { set r {} foreach {input} { 0x1ffffffffffffc000 0x1ffffffffffffc800 0x1ffffffffffffd000 0x1ffffffffffffd800 |
︙ | ︙ | |||
4080 4081 4082 4083 4084 4085 4086 | testprint "%I64d %td" 65536 } {65536 65536} test util-18.12 {Tcl_ObjPrintf} {testprint} { testprint "%I64d %Id" 65537 } {65537 65537} | < < | 2135 2136 2137 2138 2139 2140 2141 2142 2143 2144 2145 2146 2147 2148 | testprint "%I64d %td" 65536 } {65536 65536} test util-18.12 {Tcl_ObjPrintf} {testprint} { testprint "%I64d %Id" 65537 } {65537 65537} # cleanup ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: |
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 | 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 2 a {} vv namespace } p } # Modified: that should create a global var according to the docs! list $test_ns_var::vv [set test_ns_var::vv 123] $a } -result {456 123 123} test var-3.5 {MakeUpvar, no call frame so my var will be in global :: ns} -setup { |
︙ | ︙ |
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/tcl9.0 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., tcl9.0/*/*.[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.) |
︙ | ︙ | |||
46 47 48 49 50 51 52 | Tcl_SavedResult \ Tcl_ThreadDataKey \ Tcl_ThreadId \ Tcl_Time \ Tcl_TimerToken \ Tcl_Token \ Tcl_Trace \ | < < | 46 47 48 49 50 51 52 53 54 55 56 57 58 59 | Tcl_SavedResult \ Tcl_ThreadDataKey \ Tcl_ThreadId \ Tcl_Time \ Tcl_TimerToken \ Tcl_Token \ Tcl_Trace \ Tcl_Var \ Tk_3DBorder \ Tk_ArgvInfo \ Tk_BindingTable \ Tk_Canvas \ Tk_CanvasTextInfo \ Tk_ConfigSpec \ |
︙ | ︙ | |||
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" | | | 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 | 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/tcl9.0" 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.ac.
1 2 3 4 | 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) | | | 1 2 3 4 5 6 7 8 9 10 11 12 | 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. #-------------------------------------------------------------------- |
︙ | ︙ |
Changes to tools/genStubs.tcl.
︙ | ︙ | |||
596 597 598 599 600 601 602 | } if {$args eq ""} { append text $rtype " *" $lfname "; /* $index */\n" return $text } if {[string range $rtype end-8 end] eq "__stdcall"} { append text [string trim [string range $rtype 0 end-9]] " (__stdcall *" $lfname ") " | < < | 596 597 598 599 600 601 602 603 604 605 606 607 608 609 | } if {$args eq ""} { append text $rtype " *" $lfname "; /* $index */\n" return $text } if {[string range $rtype end-8 end] eq "__stdcall"} { append text [string trim [string range $rtype 0 end-9]] " (__stdcall *" $lfname ") " } else { append text $rtype " (*" $lfname ") " } set arg1 [lindex $args 0] switch -exact $arg1 { void { append text "(void)" |
︙ | ︙ |
Changes to unix/Makefile.in.
︙ | ︙ | |||
299 300 301 302 303 304 305 | tclEnv.o tclEvent.o tclExecute.o tclFCmd.o tclFileName.o tclGet.o \ tclHash.o tclHistory.o tclIndexObj.o tclInterp.o tclIO.o tclIOCmd.o \ tclIORChan.o tclIORTrans.o tclIOGT.o tclIOSock.o tclIOUtil.o \ tclLink.o tclListObj.o \ tclLiteral.o tclLoad.o tclMain.o tclNamesp.o tclNotify.o \ tclObj.o tclOptimize.o tclPanic.o tclParse.o tclPathObj.o tclPipe.o \ tclPkg.o tclPkgConfig.o tclPosixStr.o \ | | | 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 | tclEnv.o tclEvent.o tclExecute.o tclFCmd.o tclFileName.o tclGet.o \ tclHash.o tclHistory.o tclIndexObj.o tclInterp.o tclIO.o tclIOCmd.o \ tclIORChan.o tclIORTrans.o tclIOGT.o tclIOSock.o tclIOUtil.o \ tclLink.o tclListObj.o \ tclLiteral.o tclLoad.o tclMain.o tclNamesp.o tclNotify.o \ tclObj.o tclOptimize.o tclPanic.o tclParse.o tclPathObj.o tclPipe.o \ tclPkg.o tclPkgConfig.o tclPosixStr.o \ tclPreserve.o tclProc.o tclProcess.o tclRegexp.o \ tclResolve.o tclResult.o tclScan.o tclStringObj.o \ tclStrToD.o tclThread.o \ tclThreadAlloc.o tclThreadJoin.o tclThreadStorage.o tclStubInit.o \ tclTimer.o tclTrace.o tclUtf.o tclUtil.o tclVar.o tclZlib.o \ tclTomMathInterface.o OO_OBJS = tclOO.o tclOOBasic.o tclOOCall.o tclOODefineCmds.o tclOOInfo.o \ |
︙ | ︙ | |||
439 440 441 442 443 444 445 446 447 448 449 450 451 452 | $(GENERIC_DIR)/tclPathObj.c \ $(GENERIC_DIR)/tclPipe.c \ $(GENERIC_DIR)/tclPkg.c \ $(GENERIC_DIR)/tclPkgConfig.c \ $(GENERIC_DIR)/tclPosixStr.c \ $(GENERIC_DIR)/tclPreserve.c \ $(GENERIC_DIR)/tclProc.c \ $(GENERIC_DIR)/tclRegexp.c \ $(GENERIC_DIR)/tclResolve.c \ $(GENERIC_DIR)/tclResult.c \ $(GENERIC_DIR)/tclScan.c \ $(GENERIC_DIR)/tclStubInit.c \ $(GENERIC_DIR)/tclStringObj.c \ $(GENERIC_DIR)/tclStrToD.c \ | > | 439 440 441 442 443 444 445 446 447 448 449 450 451 452 453 | $(GENERIC_DIR)/tclPathObj.c \ $(GENERIC_DIR)/tclPipe.c \ $(GENERIC_DIR)/tclPkg.c \ $(GENERIC_DIR)/tclPkgConfig.c \ $(GENERIC_DIR)/tclPosixStr.c \ $(GENERIC_DIR)/tclPreserve.c \ $(GENERIC_DIR)/tclProc.c \ $(GENERIC_DIR)/tclProcess.c \ $(GENERIC_DIR)/tclRegexp.c \ $(GENERIC_DIR)/tclResolve.c \ $(GENERIC_DIR)/tclResult.c \ $(GENERIC_DIR)/tclScan.c \ $(GENERIC_DIR)/tclStubInit.c \ $(GENERIC_DIR)/tclStringObj.c \ $(GENERIC_DIR)/tclStrToD.c \ |
︙ | ︙ | |||
823 824 825 826 827 828 829 | do \ if [ ! -d "$$i" ] ; then \ echo "Making directory $$i"; \ $(INSTALL_DATA_DIR) "$$i"; \ else true; \ fi; \ done; | | < < < < < | | | | | 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 | do \ if [ ! -d "$$i" ] ; then \ echo "Making directory $$i"; \ $(INSTALL_DATA_DIR) "$$i"; \ else true; \ fi; \ done; @for i in opt0.4 encoding ../tcl9 ../tcl9/9.0 ../tcl9/9.0/platform; \ 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 http 2.8.12 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl9/9.0/http-2.8.12.tm; @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.7.0 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl9/9.0/msgcat-1.7.0.tm; @echo "Installing package tcltest 2.4.1 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl9/9.0/tcltest-2.4.1.tm; @echo "Installing package platform 1.0.14 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl9/9.0/platform-1.0.14.tm; @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/platform/shell.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl9/9.0/platform/shell-1.1.4.tm; @echo "Installing encoding files to $(SCRIPT_INSTALL_DIR)/encoding/"; |
︙ | ︙ | |||
1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 1300 | tclPreserve.o: $(GENERIC_DIR)/tclPreserve.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclPreserve.c tclProc.o: $(GENERIC_DIR)/tclProc.c $(COMPILEHDR) $(NREHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclProc.c tclRegexp.o: $(GENERIC_DIR)/tclRegexp.c $(TCLREHDRS) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclRegexp.c tclResolve.o: $(GENERIC_DIR)/tclResolve.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclResolve.c tclResult.o: $(GENERIC_DIR)/tclResult.c | > > > | 1283 1284 1285 1286 1287 1288 1289 1290 1291 1292 1293 1294 1295 1296 1297 1298 1299 | tclPreserve.o: $(GENERIC_DIR)/tclPreserve.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclPreserve.c tclProc.o: $(GENERIC_DIR)/tclProc.c $(COMPILEHDR) $(NREHDR) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclProc.c tclProcess.o: $(GENERIC_DIR)/tclProcess.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclProcess.c tclRegexp.o: $(GENERIC_DIR)/tclRegexp.c $(TCLREHDRS) $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclRegexp.c tclResolve.o: $(GENERIC_DIR)/tclResolve.c $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclResolve.c tclResult.o: $(GENERIC_DIR)/tclResult.c |
︙ | ︙ | |||
2001 2002 2003 2004 2005 2006 2007 | cp -p $(GENERIC_DIR)/tclGetDate.y $(DISTDIR)/generic cp -p $(TOP_DIR)/changes $(TOP_DIR)/ChangeLog $(TOP_DIR)/README \ $(TOP_DIR)/ChangeLog.[12]??? $(TOP_DIR)/license.terms \ $(DISTDIR) @mkdir $(DISTDIR)/library cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/library/*.tcl \ $(TOP_DIR)/library/tclIndex $(DISTDIR)/library | | | 2000 2001 2002 2003 2004 2005 2006 2007 2008 2009 2010 2011 2012 2013 2014 | cp -p $(GENERIC_DIR)/tclGetDate.y $(DISTDIR)/generic cp -p $(TOP_DIR)/changes $(TOP_DIR)/ChangeLog $(TOP_DIR)/README \ $(TOP_DIR)/ChangeLog.[12]??? $(TOP_DIR)/license.terms \ $(DISTDIR) @mkdir $(DISTDIR)/library cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/library/*.tcl \ $(TOP_DIR)/library/tclIndex $(DISTDIR)/library for i in http opt msgcat reg dde tcltest platform; \ do \ mkdir $(DISTDIR)/library/$$i ;\ cp -p $(TOP_DIR)/library/$$i/*.tcl $(DISTDIR)/library/$$i; \ done; @mkdir $(DISTDIR)/library/encoding cp -p $(TOP_DIR)/library/encoding/*.enc $(DISTDIR)/library/encoding @mkdir $(DISTDIR)/library/msgs |
︙ | ︙ | |||
2041 2042 2043 2044 2045 2046 2047 | $(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 | < | | 2040 2041 2042 2043 2044 2045 2046 2047 2048 2049 2050 2051 2052 2053 2054 | $(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 \ |
︙ | ︙ | |||
2088 2089 2090 2091 2092 2093 2094 | 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 tcl9.* & | | | 2086 2087 2088 2089 2090 2091 2092 2093 2094 2095 2096 2097 2098 2099 2100 | 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 tcl9.* & # 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. # # Also note that the 8.6 tool build requires an installed 8.6 native Tcl |
︙ | ︙ |
Changes to unix/configure.
︙ | ︙ | |||
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 |
︙ | ︙ | |||
4276 4277 4278 4279 4280 4281 4282 | # Look for libraries that we will need when compiling the Tcl shell #-------------------------------------------------------------------- #-------------------------------------------------------------------- # On a few very rare systems, all of the libm.a stuff is # already in libc.a. Set compiler flags accordingly. | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 4256 4257 4258 4259 4260 4261 4262 4263 4264 4265 4266 4267 4268 4269 4270 4271 4272 4273 4274 4275 4276 4277 4278 | # Look for libraries that we will need when compiling the Tcl shell #-------------------------------------------------------------------- #-------------------------------------------------------------------- # On a few very rare systems, all of the libm.a stuff is # already in libc.a. Set compiler flags accordingly. #-------------------------------------------------------------------- ac_fn_c_check_func "$LINENO" "sin" "ac_cv_func_sin" if test "x$ac_cv_func_sin" = xyes; then : MATH_LIBS="" else MATH_LIBS="-lm" fi #-------------------------------------------------------------------- # Interactive UNIX requires -linet instead of -lsocket, plus it # needs net/errno.h to define the socket-related error codes. #-------------------------------------------------------------------- { $as_echo "$as_me:${as_lineno-$LINENO}: checking for main in -linet" >&5 |
︙ | ︙ | |||
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" | | | 5259 5260 5261 5262 5263 5264 5265 5266 5267 5268 5269 5270 5271 5272 5273 | 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" | | | 5581 5582 5583 5584 5585 5586 5587 5588 5589 5590 5591 5592 5593 5594 5595 | 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 | | | 5668 5669 5670 5671 5672 5673 5674 5675 5676 5677 5678 5679 5680 5681 5682 | 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" | | | 5695 5696 5697 5698 5699 5700 5701 5702 5703 5704 5705 5706 5707 5708 5709 | # 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}' |
︙ | ︙ | |||
6924 6925 6926 6927 6928 6929 6930 | _ACEOF if ac_fn_c_try_compile "$LINENO"; then : tcl_type_64bit=__int64 else tcl_type_64bit="long long" fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext | | | 6868 6869 6870 6871 6872 6873 6874 6875 6876 6877 6878 6879 6880 6881 6882 | _ACEOF if ac_fn_c_try_compile "$LINENO"; then : tcl_type_64bit=__int64 else tcl_type_64bit="long long" fi rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext # See if we could use long anyway Note that we substitute in the # type that is our current guess for a 64-bit type inside this check # program, so it should be modified only carefully... cat confdefs.h - <<_ACEOF >conftest.$ac_ext /* end confdefs.h. */ int main () |
︙ | ︙ | |||
6950 6951 6952 6953 6954 6955 6956 | rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi if test "${tcl_cv_type_64bit}" = none ; then $as_echo "#define TCL_WIDE_INT_IS_LONG 1" >>confdefs.h | | | | 6894 6895 6896 6897 6898 6899 6900 6901 6902 6903 6904 6905 6906 6907 6908 6909 | rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext fi if test "${tcl_cv_type_64bit}" = none ; then $as_echo "#define TCL_WIDE_INT_IS_LONG 1" >>confdefs.h { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5 $as_echo "yes" >&6; } else cat >>confdefs.h <<_ACEOF #define TCL_WIDE_INT_TYPE ${tcl_cv_type_64bit} _ACEOF { $as_echo "$as_me:${as_lineno-$LINENO}: result: ${tcl_cv_type_64bit}" >&5 |
︙ | ︙ |
Changes to unix/configure.ac.
1 2 3 4 5 6 | #! /bin/bash -norc dnl This file is an input file used by the GNU "autoconf" program to dnl generate the file "configure", which is run during Tcl installation dnl to configure the system for the local environment. AC_INIT([tcl],[9.0]) | | | 1 2 3 4 5 6 7 8 9 10 11 12 13 14 | #! /bin/bash -norc dnl This file is an input file used by the GNU "autoconf" program to dnl generate the file "configure", which is run during Tcl installation dnl to configure the system for the local environment. AC_INIT([tcl],[9.0]) AC_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 |
︙ | ︙ |
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 |
︙ | ︙ | |||
2369 2370 2371 2372 2373 2374 2375 | # #-------------------------------------------------------------------- AC_DEFUN([SC_TCL_LINK_LIBS], [ #-------------------------------------------------------------------- # On a few very rare systems, all of the libm.a stuff is # already in libc.a. Set compiler flags accordingly. | < < < | 2366 2367 2368 2369 2370 2371 2372 2373 2374 2375 2376 2377 2378 2379 2380 2381 2382 | # #-------------------------------------------------------------------- AC_DEFUN([SC_TCL_LINK_LIBS], [ #-------------------------------------------------------------------- # On a few very rare systems, all of the libm.a stuff is # already in libc.a. Set compiler flags accordingly. #-------------------------------------------------------------------- AC_CHECK_FUNC(sin, MATH_LIBS="", MATH_LIBS="-lm") #-------------------------------------------------------------------- # Interactive UNIX requires -linet instead of -lsocket, plus it # needs net/errno.h to define the socket-related error codes. #-------------------------------------------------------------------- AC_CHECK_LIB(inet, main, [LIBS="$LIBS -linet"]) |
︙ | ︙ | |||
2491 2492 2493 2494 2495 2496 2497 | AC_DEFUN([SC_TCL_64BIT_FLAGS], [ AC_MSG_CHECKING([for 64-bit integer type]) AC_CACHE_VAL(tcl_cv_type_64bit,[ tcl_cv_type_64bit=none # See if the compiler knows natively about __int64 AC_TRY_COMPILE(,[__int64 value = (__int64) 0;], tcl_type_64bit=__int64, tcl_type_64bit="long long") | | | | | 2485 2486 2487 2488 2489 2490 2491 2492 2493 2494 2495 2496 2497 2498 2499 2500 2501 2502 2503 2504 2505 2506 2507 | AC_DEFUN([SC_TCL_64BIT_FLAGS], [ AC_MSG_CHECKING([for 64-bit integer type]) AC_CACHE_VAL(tcl_cv_type_64bit,[ tcl_cv_type_64bit=none # See if the compiler knows natively about __int64 AC_TRY_COMPILE(,[__int64 value = (__int64) 0;], tcl_type_64bit=__int64, tcl_type_64bit="long long") # See if we could use long anyway Note that we substitute in the # type that is our current guess for a 64-bit type inside this check # program, so it should be modified only carefully... AC_TRY_COMPILE(,[switch (0) { case 1: case (sizeof(]${tcl_type_64bit}[)==sizeof(long)): ; }],tcl_cv_type_64bit=${tcl_type_64bit})]) if test "${tcl_cv_type_64bit}" = none ; then AC_DEFINE(TCL_WIDE_INT_IS_LONG, 1, [Do 'long' and 'long long' have the same size (64-bit)?]) AC_MSG_RESULT([yes]) else AC_DEFINE_UNQUOTED(TCL_WIDE_INT_TYPE,${tcl_cv_type_64bit}, [What type should be used to define wide integers?]) AC_MSG_RESULT([${tcl_cv_type_64bit}]) # Now check for auxiliary declarations AC_CACHE_CHECK([for struct dirent64], tcl_cv_struct_dirent64,[ |
︙ | ︙ |
Changes to unix/tclConfig.h.in.
︙ | ︙ | |||
107 108 109 110 111 112 113 114 115 116 117 118 119 120 | #undef HAVE_GETPWUID_R_4 /* Define to 1 if getpwuid_r takes 5 args. */ #undef HAVE_GETPWUID_R_5 /* Define to 1 if you have the `gmtime_r' function. */ #undef HAVE_GMTIME_R /* Do we have the intptr_t type? */ #undef HAVE_INTPTR_T /* Define to 1 if you have the <inttypes.h> header file. */ #undef HAVE_INTTYPES_H | > > > | 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 | #undef HAVE_GETPWUID_R_4 /* Define to 1 if getpwuid_r takes 5 args. */ #undef HAVE_GETPWUID_R_5 /* Define to 1 if you have the `gmtime_r' function. */ #undef HAVE_GMTIME_R /* Compiler support for module scope symbols */ #undef HAVE_HIDDEN /* Do we have the intptr_t type? */ #undef HAVE_INTPTR_T /* Define to 1 if you have the <inttypes.h> header file. */ #undef HAVE_INTTYPES_H |
︙ | ︙ | |||
288 289 290 291 292 293 294 | /* 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() */ |
︙ | ︙ | |||
327 328 329 330 331 332 333 | /* 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. */ |
︙ | ︙ | |||
396 397 398 399 400 401 402 | /* Do we allow unloading of shared libraries? */ #undef TCL_UNLOAD_DLLS /* Does this platform have wide high-resolution clicks? */ #undef TCL_WIDE_CLICKS | | | 390 391 392 393 394 395 396 397 398 399 400 401 402 403 404 | /* Do we allow unloading of shared libraries? */ #undef TCL_UNLOAD_DLLS /* Does this platform have wide high-resolution clicks? */ #undef TCL_WIDE_CLICKS /* Do Tcl_WideInt, 'long' and 'long long' all have the same size (64-bit) ? */ #undef TCL_WIDE_INT_IS_LONG /* What type should be used to define wide integers? */ #undef TCL_WIDE_INT_TYPE /* Define to 1 if you can safely include both <sys/time.h> and <time.h>. */ #undef TIME_WITH_SYS_TIME |
︙ | ︙ |
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 { |
︙ | ︙ | |||
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 win/Makefile.in.
︙ | ︙ | |||
281 282 283 284 285 286 287 288 289 290 291 292 293 294 | tclPathObj.$(OBJEXT) \ tclPipe.$(OBJEXT) \ tclPkg.$(OBJEXT) \ tclPkgConfig.$(OBJEXT) \ tclPosixStr.$(OBJEXT) \ tclPreserve.$(OBJEXT) \ tclProc.$(OBJEXT) \ tclRegexp.$(OBJEXT) \ tclResolve.$(OBJEXT) \ tclResult.$(OBJEXT) \ tclScan.$(OBJEXT) \ tclStringObj.$(OBJEXT) \ tclStrToD.$(OBJEXT) \ tclStubInit.$(OBJEXT) \ | > | 281 282 283 284 285 286 287 288 289 290 291 292 293 294 295 | tclPathObj.$(OBJEXT) \ tclPipe.$(OBJEXT) \ tclPkg.$(OBJEXT) \ tclPkgConfig.$(OBJEXT) \ tclPosixStr.$(OBJEXT) \ tclPreserve.$(OBJEXT) \ tclProc.$(OBJEXT) \ tclProcess.$(OBJEXT) \ tclRegexp.$(OBJEXT) \ tclResolve.$(OBJEXT) \ tclResult.$(OBJEXT) \ tclScan.$(OBJEXT) \ tclStringObj.$(OBJEXT) \ tclStrToD.$(OBJEXT) \ tclStubInit.$(OBJEXT) \ |
︙ | ︙ | |||
622 623 624 625 626 627 628 | do \ if [ ! -d $$i ] ; then \ echo "Making directory $$i"; \ $(MKDIR) $$i; \ else true; \ fi; \ done; | | | 623 624 625 626 627 628 629 630 631 632 633 634 635 636 637 | do \ if [ ! -d $$i ] ; then \ echo "Making directory $$i"; \ $(MKDIR) $$i; \ else true; \ fi; \ done; @for i in opt0.4 encoding ../tcl9 ../tcl9/9.0 ../tcl9/9.0/platform; \ do \ if [ ! -d $(SCRIPT_INSTALL_DIR)/$$i ] ; then \ echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \ $(MKDIR) $(SCRIPT_INSTALL_DIR)/$$i; \ else true; \ fi; \ done; |
︙ | ︙ | |||
644 645 646 647 648 649 650 | $(COPY) "$$i" "$(INCLUDE_INSTALL_DIR)"; \ done; @echo "Installing library files to $(SCRIPT_INSTALL_DIR)"; @for i in $(ROOT_DIR)/library/*.tcl $(ROOT_DIR)/library/tclIndex; \ do \ $(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)"; \ done; | < < < < < | | | 645 646 647 648 649 650 651 652 653 654 655 656 657 658 659 660 661 662 663 664 665 666 667 | $(COPY) "$$i" "$(INCLUDE_INSTALL_DIR)"; \ done; @echo "Installing library files to $(SCRIPT_INSTALL_DIR)"; @for i in $(ROOT_DIR)/library/*.tcl $(ROOT_DIR)/library/tclIndex; \ do \ $(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)"; \ done; @echo "Installing package http 2.8.12 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl9/9.0/http-2.8.12.tm; @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.7.0 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl9/9.0/msgcat-1.7.0.tm; @echo "Installing package tcltest 2.4.0 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl9/9.0/tcltest-2.4.0.tm; @echo "Installing package platform 1.0.14 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl9/9.0/platform-1.0.14.tm; @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/platform/shell.tcl $(SCRIPT_INSTALL_DIR)/../tcl9/9.0/platform/shell-1.1.4.tm; @echo "Installing encodings"; |
︙ | ︙ | |||
851 852 853 854 855 856 857 | "$(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 tcl9.* & | | | 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 | "$(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 tcl9.* & # 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/buildall.vc.bat.
︙ | ︙ | |||
34 35 36 37 38 39 40 | if defined WINDOWSSDKDIR (goto :startBuilding) :: We need to run the development environment batch script that comes :: with developer studio (v4,5,6,7,etc...) All have it. This path :: might not be correct. You should call it yourself prior to running :: this batchfile. :: | | > > | 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 | if defined WINDOWSSDKDIR (goto :startBuilding) :: We need to run the development environment batch script that comes :: with developer studio (v4,5,6,7,etc...) All have it. This path :: might not be correct. You should call it yourself prior to running :: this batchfile. :: REM call "C:\Program Files\Microsoft Developer Studio\vc98\bin\vcvars32.bat" set "VSCMD_START_DIR=%CD%" call "C:\Program Files (x86)\Microsoft Visual Studio\2017\Community\Common7\Tools\VsDevCmd.bat" if errorlevel 1 (goto no_vcvars) :startBuilding echo. echo Sit back and have a cup of coffee while this grinds through ;) echo You asked for *everything*, remember? |
︙ | ︙ |
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> |
︙ | ︙ | |||
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/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 |
︙ | ︙ | |||
323 324 325 326 327 328 329 330 331 332 333 334 335 336 | $(TMP_DIR)\tclPathObj.obj \ $(TMP_DIR)\tclPipe.obj \ $(TMP_DIR)\tclPkg.obj \ $(TMP_DIR)\tclPkgConfig.obj \ $(TMP_DIR)\tclPosixStr.obj \ $(TMP_DIR)\tclPreserve.obj \ $(TMP_DIR)\tclProc.obj \ $(TMP_DIR)\tclRegexp.obj \ $(TMP_DIR)\tclResolve.obj \ $(TMP_DIR)\tclResult.obj \ $(TMP_DIR)\tclScan.obj \ $(TMP_DIR)\tclStringObj.obj \ $(TMP_DIR)\tclStrToD.obj \ $(TMP_DIR)\tclStubInit.obj \ | > | 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228 | $(TMP_DIR)\tclPathObj.obj \ $(TMP_DIR)\tclPipe.obj \ $(TMP_DIR)\tclPkg.obj \ $(TMP_DIR)\tclPkgConfig.obj \ $(TMP_DIR)\tclPosixStr.obj \ $(TMP_DIR)\tclPreserve.obj \ $(TMP_DIR)\tclProc.obj \ $(TMP_DIR)\tclProcess.obj \ $(TMP_DIR)\tclRegexp.obj \ $(TMP_DIR)\tclResolve.obj \ $(TMP_DIR)\tclResult.obj \ $(TMP_DIR)\tclScan.obj \ $(TMP_DIR)\tclStringObj.obj \ $(TMP_DIR)\tclStrToD.obj \ $(TMP_DIR)\tclStubInit.obj \ |
︙ | ︙ | |||
453 454 455 456 457 458 459 | $(TMP_DIR)\tcl.res !endif TCLOBJS = $(COREOBJS) $(ZLIBOBJS) $(TOMMATHOBJS) $(PLATFORMOBJS) TCLSTUBOBJS = \ $(TMP_DIR)\tclStubLib.obj \ | | > | < | < < < < < < | < < < < < < < < < < < < < < < < | < < < < < < < < < < < < < < < < < < < < < < < < < | | < < < < | < < < | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | 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 | $(TMP_DIR)\tcl.res !endif TCLOBJS = $(COREOBJS) $(ZLIBOBJS) $(TOMMATHOBJS) $(PLATFORMOBJS) TCLSTUBOBJS = \ $(TMP_DIR)\tclStubLib.obj \ $(TMP_DIR)\tclTomMathStubLib.obj \ $(TMP_DIR)\tclOOStubLib.obj ### The following paths CANNOT have spaces in them as they appear on ### the left side of implicit rules. TOMMATHDIR = $(ROOT)\libtommath PKGSDIR = $(ROOT)\pkgs # Additional include and C macro definitions for the implicit rules # defined in rules.vc PRJ_INCLUDES = -I"$(TOMMATHDIR)" PRJ_DEFINES = -DTCL_TOMMATH -DMP_PREC=4 -Dinline=__inline -DHAVE_ZLIB=1 -D_CRT_SECURE_NO_DEPRECATE -D_CRT_NONSTDC_NO_DEPRECATE # Additional Link libraries needed beyond those in rules.vc PRJ_LIBS = netapi32.lib user32.lib userenv.lib ws2_32.lib #--------------------------------------------------------------------- # TclTest flags #--------------------------------------------------------------------- !if "$(TESTPAT)" != "" TESTFLAGS = $(TESTFLAGS) -file $(TESTPAT) |
︙ | ︙ | |||
590 591 592 593 594 595 596 597 598 599 600 | 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 | > < < < < < < < < < < < < < | < < < | > | > | > > | > | | | | < | | < | | 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 | 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" & \ |
︙ | ︙ | |||
701 702 703 704 705 706 707 | @if exist "%~fd\win\makefile.vc" ( \ pushd "%~fd\win" & \ $(MAKE) -$(MAKEFLAGS) -f makefile.vc TCLDIR=$(ROOT) clean &\ popd \ ) $(CAT32): $(WINDIR)\cat.c | | | < | 480 481 482 483 484 485 486 487 488 489 490 491 492 493 494 495 | @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: |
︙ | ︙ | |||
741 742 743 744 745 746 747 | > "$(GENERICDIR)\tclTomMath.h" !endif #--------------------------------------------------------------------- # Build the Windows HTML help file. #--------------------------------------------------------------------- | | > > > | | | | | > > | | | | | | | < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < < | > | > > > > | | | > > > > > > > | | | | 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 | > "$(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@ |
︙ | ︙ | |||
931 932 933 934 935 936 937 | $(GENERICDIR)/tclGetDate.y #--------------------------------------------------------------------- # Special case object file targets #--------------------------------------------------------------------- $(TMP_DIR)\testMain.obj: $(WINDIR)\tclAppInit.c | | | | | | | | | | | | | | > | > > | | 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 | $(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 |
︙ | ︙ | |||
1040 1041 1042 1043 1044 1045 1046 | !endif ### add a spacer in the output !message #--------------------------------------------------------------------- | > | < < < < < | < < < < < < < < < < | < < < < < < < | < < < < < | | > > | 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 | !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)\..\tcl9$(NULL)" \ $(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl9" @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl9\9.0$(NULL)" \ $(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl9\9.0" @if not exist "$(SCRIPT_INSTALL_DIR)\..\tcl9\9.0\platform$(NULL)" \ $(MKDIR) "$(SCRIPT_INSTALL_DIR)\..\tcl9\9.0\platform" @echo Installing header files @$(CPY) "$(GENERICDIR)\tcl.h" "$(INCLUDE_INSTALL_DIR)\" @$(CPY) "$(GENERICDIR)\tclDecls.h" "$(INCLUDE_INSTALL_DIR)\" @$(CPY) "$(GENERICDIR)\tclOO.h" "$(INCLUDE_INSTALL_DIR)\" @$(CPY) "$(GENERICDIR)\tclOODecls.h" "$(INCLUDE_INSTALL_DIR)\" @$(CPY) "$(GENERICDIR)\tclPlatDecls.h" "$(INCLUDE_INSTALL_DIR)\" @$(CPY) "$(GENERICDIR)\tclTomMath.h" "$(INCLUDE_INSTALL_DIR)\" |
︙ | ︙ | |||
1133 1134 1135 1136 1137 1138 1139 | @$(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)\" | | | | > | 847 848 849 850 851 852 853 854 855 856 857 858 859 860 861 862 863 864 | @$(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 opt0.4 directory @$(CPY) "$(ROOT)\library\opt\*.tcl" \ "$(SCRIPT_INSTALL_DIR)\opt0.4\" @echo Installing package http $(PKG_HTTP_VER) as a Tcl Module @$(COPY) "$(ROOT)\library\http\http.tcl" \ "$(SCRIPT_INSTALL_DIR)\..\tcl9\9.0\http-$(PKG_HTTP_VER).tm" @echo Installing package msgcat $(PKG_MSGCAT_VER) as a Tcl Module |
︙ | ︙ | |||
1177 1178 1179 1180 1181 1182 1183 | @$(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\" | | < | 892 893 894 895 896 897 898 899 900 901 902 903 904 905 906 | @$(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" |
︙ | ︙ | |||
1212 1213 1214 1215 1216 1217 1218 | @echo Removing $(TCLTEST) ... @if exist $(TCLTEST) del $(TCLTEST) @echo Removing $(TCLDDELIB) ... @if exist $(TCLDDELIB) del $(TCLDDELIB) @echo Removing $(TCLREGLIB) ... @if exist $(TCLREGLIB) del $(TCLREGLIB) | | < < < < < < < < < < < < < < < < | < < < < | 926 927 928 929 930 931 932 933 934 935 936 937 938 939 | @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.
︙ | ︙ | |||
10 11 12 13 14 15 16 | * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * ---------------------------------------------------------------------------- */ #define _CRT_SECURE_NO_DEPRECATE #include <windows.h> | < < < < < < > | 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 | * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * ---------------------------------------------------------------------------- */ #define _CRT_SECURE_NO_DEPRECATE #include <windows.h> #pragma comment (lib, "user32.lib") #pragma comment (lib, "kernel32.lib") #include <stdio.h> #include <math.h> /* * This library is required for x64 builds with _some_ versions of MSVC */ #if defined(_M_IA64) || defined(_M_AMD64) #if _MSC_VER >= 1400 && _MSC_VER < 1500 #pragma comment(lib, "bufferoverflowU") #endif #endif /* 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 |
︙ | ︙ | |||
70 71 72 73 74 75 76 | main( int argc, char *argv[]) { char msg[300]; DWORD dwWritten; int chars; | | | 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 | main( int argc, char *argv[]) { char msg[300]; DWORD dwWritten; int chars; const char *s; /* * Make sure children (cl.exe and link.exe) are kept quiet. */ SetErrorMode(SEM_FAILCRITICALERRORS | SEM_NOOPENFILEERRORBOX); |
︙ | ︙ | |||
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]); | > > > > > > > > > > > > | 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 | "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]); |
︙ | ︙ | |||
672 673 674 675 676 677 678 679 680 681 682 683 684 685 686 687 688 689 690 691 | list_free(&substPtr); } fclose(fp); return 0; } /* * QualifyPath -- * * This composes the current working directory with a provided path * and returns the fully qualified and normalized path. * Mostly needed to setup paths for testing. */ static int QualifyPath( const char *szPath) { char szCwd[MAX_PATH + 1]; | > > > > > > > > > > > > > > > > > > > > > > > > > > > > | > > | > > > > > > > > | > > > > > > > > > > > > | > > > > > > > > > > > > > > | > > > > | > > > > > > > | > > > > > > > > > > > > > > > > | > > > | | > > > | 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 | list_free(&substPtr); } fclose(fp); return 0; } BOOL FileExists(LPCTSTR szPath) { #ifndef INVALID_FILE_ATTRIBUTES #define INVALID_FILE_ATTRIBUTES ((DWORD)-1) #endif DWORD pathAttr = GetFileAttributes(szPath); return (pathAttr != INVALID_FILE_ATTRIBUTES && !(pathAttr & FILE_ATTRIBUTE_DIRECTORY)); } /* * QualifyPath -- * * This composes the current working directory with a provided path * and returns the fully qualified and normalized path. * Mostly needed to setup paths for testing. */ static int QualifyPath( const char *szPath) { char szCwd[MAX_PATH + 1]; GetFullPathName(szPath, sizeof(szCwd)-1, szCwd, NULL); 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 (FileExists(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 = 2 # 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 |
︙ | ︙ | |||
372 373 374 375 376 377 378 379 | !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 = $(_INSTALLDIR)\..\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) |
︙ | ︙ | |||
468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 | !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.
︙ | ︙ | |||
148 149 150 151 152 153 154 | # End Source File # Begin Source File SOURCE=..\compat\fixstrtod.c # End Source File # Begin Source File | < < < < | 148 149 150 151 152 153 154 155 156 157 158 159 160 161 | # 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 # End Source File # Begin Source File |
︙ | ︙ | |||
1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 | SOURCE=..\generic\tclPreserve.c # End Source File # Begin Source File SOURCE=..\generic\tclProc.c # End Source File # Begin Source File SOURCE=..\generic\tclRegexp.c # End Source File # Begin Source File SOURCE=..\generic\tclRegexp.h # End Source File | > > > > | 1259 1260 1261 1262 1263 1264 1265 1266 1267 1268 1269 1270 1271 1272 1273 1274 1275 1276 | SOURCE=..\generic\tclPreserve.c # End Source File # Begin Source File SOURCE=..\generic\tclProc.c # End Source File # Begin Source File SOURCE=..\generic\tclProcess.c # End Source File # Begin Source File SOURCE=..\generic\tclRegexp.c # End Source File # Begin Source File SOURCE=..\generic\tclRegexp.h # End Source File |
︙ | ︙ |
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=tcl90.cnt COPYRIGHT=Copyright � 2000 Ajuba Solutions HLP=tcl90.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 |
︙ | ︙ |
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/tclWinChan.c.
︙ | ︙ | |||
1375 1376 1377 1378 1379 1380 1381 | infoPtr->nextPtr = NULL; infoPtr->validMask = permissions; infoPtr->watchMask = 0; infoPtr->flags = appendMode; infoPtr->handle = handle; infoPtr->dirty = 0; | | | 1375 1376 1377 1378 1379 1380 1381 1382 1383 1384 1385 1386 1387 1388 1389 | infoPtr->nextPtr = NULL; infoPtr->validMask = permissions; infoPtr->watchMask = 0; infoPtr->flags = appendMode; infoPtr->handle = handle; infoPtr->dirty = 0; sprintf(channelName, "file%" TCL_Z_MODIFIER "x", (size_t) infoPtr); infoPtr->channel = Tcl_CreateChannel(&fileChannelType, channelName, infoPtr, permissions); /* * Files have default translation of AUTO and ^Z eof char, which means * that a ^Z will be accepted as EOF when reading. |
︙ | ︙ |
Changes to win/tclWinConsole.c.
︙ | ︙ | |||
1316 1317 1318 1319 1320 1321 1322 | /* * Use the pointer for the name of the result channel. This keeps the * channel names unique, since some may share handles (stdin/stdout/stderr * for instance). */ | | | 1316 1317 1318 1319 1320 1321 1322 1323 1324 1325 1326 1327 1328 1329 1330 | /* * Use the pointer for the name of the result channel. This keeps the * channel names unique, since some may share handles (stdin/stdout/stderr * for instance). */ sprintf(channelName, "file%" TCL_Z_MODIFIER "x", (size_t) infoPtr); infoPtr->channel = Tcl_CreateChannel(&consoleChannelType, channelName, infoPtr, permissions); if (permissions & TCL_READABLE) { /* * Make sure the console input buffer is ready for only character |
︙ | ︙ |
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/tclWinFCmd.c.
︙ | ︙ | |||
1546 1547 1548 1549 1550 1551 1552 | */ attr = 0; } } } | | | 1546 1547 1548 1549 1550 1551 1552 1553 1554 1555 1556 1557 1558 1559 1560 | */ attr = 0; } } } *attributePtrPtr = Tcl_NewBooleanObj(attr); return TCL_OK; } /* *---------------------------------------------------------------------- * * ConvertFileNameFormat -- |
︙ | ︙ |
Changes to win/tclWinInit.c.
︙ | ︙ | |||
74 75 76 77 78 79 80 | #endif #ifndef PROCESSOR_ARCHITECTURE_UNKNOWN #define PROCESSOR_ARCHITECTURE_UNKNOWN 0xFFFF #endif /* * The following arrays contain the human readable strings for the Windows | | < < < < < | 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 | #endif #ifndef PROCESSOR_ARCHITECTURE_UNKNOWN #define PROCESSOR_ARCHITECTURE_UNKNOWN 0xFFFF #endif /* * 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" }; /* |
︙ | ︙ | |||
473 474 475 476 477 478 479 | */ void TclpSetInitialEncodings(void) { Tcl_DString encodingName; | < < < < < < < | 468 469 470 471 472 473 474 475 476 477 478 479 480 481 482 483 484 485 486 | */ 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()); |
︙ | ︙ | |||
550 551 552 553 554 555 556 | /* * Define the tcl_platform array. */ Tcl_SetVar2(interp, "tcl_platform", "platform", "windows", TCL_GLOBAL_ONLY); | < | < < | 538 539 540 541 542 543 544 545 546 547 548 549 550 551 552 | /* * 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.
︙ | ︙ | |||
41 42 43 44 45 46 47 | # define STRINGIFY1(x) #x #endif #ifndef JOIN # define JOIN(a,b) JOIN1(a,b) # define JOIN1(a,b) a##b #endif | < < < < < < < < < < < < < < < < < < < | 41 42 43 44 45 46 47 48 49 50 51 52 53 54 | # define STRINGIFY1(x) #x #endif #ifndef JOIN # define JOIN(a,b) JOIN1(a,b) # define JOIN1(a,b) a##b #endif /* * Declarations of functions that are not accessible by way of the * stubs table. */ MODULE_SCOPE char TclWinDriveLetterForVolMountPoint( const TCHAR *mountPoint); |
︙ | ︙ |
Changes to win/tclWinLoad.c.
︙ | ︙ | |||
59 60 61 62 63 64 65 | * (*unloadProcPtr)() to unload the file. */ Tcl_FSUnloadFileProc **unloadProcPtr, /* Filled with address of Tcl_FSUnloadFileProc * function which should be used for this * file. */ int flags) { | | > | > > > | | 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 | * (*unloadProcPtr)() to unload the file. */ Tcl_FSUnloadFileProc **unloadProcPtr, /* Filled with address of Tcl_FSUnloadFileProc * function which should be used for this * file. */ int flags) { HINSTANCE hInstance = NULL; const TCHAR *nativeName; Tcl_LoadHandle handlePtr; DWORD firstError; /* * First try the full path the user gave us. This is particularly * important if the cwd is inside a vfs, and we are trying to load using a * relative path. */ nativeName = Tcl_FSGetNativePath(pathPtr); if (nativeName != NULL) { hInstance = LoadLibraryEx(nativeName, NULL, LOAD_WITH_ALTERED_SEARCH_PATH); } if (hInstance == NULL) { /* * Let the OS loader examine the binary search path for whatever * string the user gave us which hopefully refers to a file on the * binary path. */ Tcl_DString ds; /* * Remember the first error on load attempt to be used if the * second load attempt below also fails. */ firstError = (nativeName == NULL) ? ERROR_MOD_NOT_FOUND : GetLastError(); nativeName = Tcl_WinUtfToTChar(Tcl_GetString(pathPtr), -1, &ds); hInstance = LoadLibraryEx(nativeName, NULL, LOAD_WITH_ALTERED_SEARCH_PATH); Tcl_DStringFree(&ds); } |
︙ | ︙ |
Changes to win/tclWinPipe.c.
︙ | ︙ | |||
865 866 867 868 869 870 871 | { ProcInfo *infoPtr; PipeInit(); Tcl_MutexLock(&pipeMutex); for (infoPtr = procList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { | | | 865 866 867 868 869 870 871 872 873 874 875 876 877 878 879 | { ProcInfo *infoPtr; PipeInit(); Tcl_MutexLock(&pipeMutex); for (infoPtr = procList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) { if (infoPtr->dwProcessId == (DWORD) pid) { Tcl_MutexUnlock(&pipeMutex); return infoPtr->dwProcessId; } } Tcl_MutexUnlock(&pipeMutex); return (unsigned long) -1; } |
︙ | ︙ | |||
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 |
︙ | ︙ | |||
1176 1177 1178 1179 1180 1181 1182 | * CreateProcess() and CloseHandle(), the problem does not occur." PSS ID * Number: Q124121 */ WaitForInputIdle(procInfo.hProcess, 5000); CloseHandle(procInfo.hThread); | | | 1159 1160 1161 1162 1163 1164 1165 1166 1167 1168 1169 1170 1171 1172 1173 | * CreateProcess() and CloseHandle(), the problem does not occur." PSS ID * Number: Q124121 */ WaitForInputIdle(procInfo.hProcess, 5000); CloseHandle(procInfo.hThread); *pidPtr = (Tcl_Pid) procInfo.dwProcessId; if (*pidPtr != 0) { TclWinAddProcess(procInfo.hProcess, procInfo.dwProcessId); } result = TCL_OK; end: Tcl_DStringFree(&cmdLine); |
︙ | ︙ | |||
1619 1620 1621 1622 1623 1624 1625 | /* * For backward compatibility with previous versions of Tcl, we use * "file%d" as the base name for pipes even though it would be more * natural to use "pipe%d". Use the pointer to keep the channel names * unique, in case channels share handles (stdin/stdout). */ | | | 1602 1603 1604 1605 1606 1607 1608 1609 1610 1611 1612 1613 1614 1615 1616 | /* * For backward compatibility with previous versions of Tcl, we use * "file%d" as the base name for pipes even though it would be more * natural to use "pipe%d". Use the pointer to keep the channel names * unique, in case channels share handles (stdin/stdout). */ sprintf(channelName, "file%" TCL_Z_MODIFIER "x", (size_t) infoPtr); infoPtr->channel = Tcl_CreateChannel(&pipeChannelType, channelName, infoPtr, infoPtr->validMask); /* * Pipes have AUTO translation mode on Windows and ^Z eof char, which * means that a ^Z will be appended to them at close. This is needed for * Windows programs that expect a ^Z at EOF. |
︙ | ︙ | |||
2360 2361 2362 2363 2364 2365 2366 | * Find the process and cut it from the process list. */ Tcl_MutexLock(&pipeMutex); prevPtrPtr = &procList; for (infoPtr = procList; infoPtr != NULL; prevPtrPtr = &infoPtr->nextPtr, infoPtr = infoPtr->nextPtr) { | | | 2343 2344 2345 2346 2347 2348 2349 2350 2351 2352 2353 2354 2355 2356 2357 | * Find the process and cut it from the process list. */ Tcl_MutexLock(&pipeMutex); prevPtrPtr = &procList; for (infoPtr = procList; infoPtr != NULL; prevPtrPtr = &infoPtr->nextPtr, infoPtr = infoPtr->nextPtr) { if (infoPtr->dwProcessId == (DWORD) pid) { *prevPtrPtr = infoPtr->nextPtr; break; } } Tcl_MutexUnlock(&pipeMutex); /* |
︙ | ︙ |
Changes to win/tclWinPort.h.
︙ | ︙ | |||
477 478 479 480 481 482 483 484 485 486 487 488 489 490 | /* * MSVC 8.0 started to mark many standard C library functions depreciated * including the *printf family and others. Tell it to shut up. * (_MSC_VER is 1200 for VC6, 1300 or 1310 for vc7.net, 1400 for 8.0) */ #if defined(_MSC_VER) && (_MSC_VER >= 1400) # pragma warning(disable:4996) #endif /* *--------------------------------------------------------------------------- * The following macros and declarations represent the interface between * generic and windows-specific parts of Tcl. Some of the macros may | > > | 477 478 479 480 481 482 483 484 485 486 487 488 489 490 491 492 | /* * MSVC 8.0 started to mark many standard C library functions depreciated * including the *printf family and others. Tell it to shut up. * (_MSC_VER is 1200 for VC6, 1300 or 1310 for vc7.net, 1400 for 8.0) */ #if defined(_MSC_VER) && (_MSC_VER >= 1400) # pragma warning(disable:4244) # pragma warning(disable:4267) # pragma warning(disable:4996) #endif /* *--------------------------------------------------------------------------- * The following macros and declarations represent the interface between * generic and windows-specific parts of Tcl. Some of the macros may |
︙ | ︙ |
Changes to win/tclWinSerial.c.
︙ | ︙ | |||
1438 1439 1440 1441 1442 1443 1444 | infoPtr->sysBufWrite = 4096; /* * Use the pointer to keep the channel names unique, in case the handles * are shared between multiple channels (stdin/stdout). */ | | | 1438 1439 1440 1441 1442 1443 1444 1445 1446 1447 1448 1449 1450 1451 1452 | infoPtr->sysBufWrite = 4096; /* * Use the pointer to keep the channel names unique, in case the handles * are shared between multiple channels (stdin/stdout). */ sprintf(channelName, "file%" TCL_Z_MODIFIER "x", (size_t) infoPtr); infoPtr->channel = Tcl_CreateChannel(&serialChannelType, channelName, infoPtr, permissions); SetupComm(handle, infoPtr->sysBufRead, infoPtr->sysBufWrite); PurgeComm(handle, |
︙ | ︙ | |||
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/tclWinTest.c.
︙ | ︙ | |||
272 273 274 275 276 277 278 | t2.HighPart = sysTime.dwHighDateTime; t2.QuadPart -= t1.QuadPart; QueryPerformanceCounter(&p2); result = Tcl_NewObj(); Tcl_ListObjAppendElement(interp, result, | | | | | | 272 273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 | t2.HighPart = sysTime.dwHighDateTime; t2.QuadPart -= t1.QuadPart; QueryPerformanceCounter(&p2); result = Tcl_NewObj(); Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj((int) (t2.QuadPart / 10000000))); Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj((int) ((t2.QuadPart / 10) % 1000000))); Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(tclTime.sec)); Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(tclTime.usec)); Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(p1.QuadPart)); Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(p2.QuadPart)); Tcl_SetObjResult(interp, result); return TCL_OK; |
︙ | ︙ | |||
363 364 365 366 367 368 369 | }; int cmd; if (objc != 2) { Tcl_WrongNumArgs(interp, 0, objv, "<type-of-exception>"); return TCL_ERROR; } | | | | 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 | }; int cmd; if (objc != 2) { Tcl_WrongNumArgs(interp, 0, objv, "<type-of-exception>"); return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], cmds, "command", 0, &cmd) != TCL_OK) { return TCL_ERROR; } /* * Make sure the GPF dialog doesn't popup. */ |
︙ | ︙ |