diff options
52 files changed, 1016 insertions, 464 deletions
@@ -1,7 +1,195 @@ -2007-12-13 Donal K. Fellows <donal.k.fellows@manchester.ac.uk> +2008-01-22 Don Porter <dgp@users.sourceforge.net> + + * generic/tclTimer.c (AfterProc): Replace Tcl_EvalEx() with + Tcl_EvalObjEx() to evaluate [after] callbacks. Part of trend to + favor compiled execution over direct evaluation. + +2008-01-22 Miguel Sofer <msofer@users.sf.net> + + * generic/tclCmdIl.c (Tcl_LreverseObjCmd): + * tests/cmdIL.test (cmdIL-7.7): fix crash on reversing an empty + list [Bug 1876793]. + +2008-01-20 Jeff Hobbs <jeffh@ActiveState.com> + + * unix/README: minor typo fixes [Bug 1853072] + + * generic/tclIO.c (TclGetsObjBinary): operate on topmost channel. + [Bug 1869405] (Ficicchia) + +2008-01-17 Don Porter <dgp@users.sourceforge.net> + + * generic/tclCompExpr.c: Revision to preserve parsed intreps + of numeric and boolean literals when compiling expressions with + (optimize == 1). + +2008-01-15 Miguel Sofer <msofer@users.sf.net> + + * generic/tclCompExpr.c: add an 'optimize' argument to + * generic/tclCompile.c: TclCompileExpr() to profit from better + * generic/tclCompile.h: literal management according to usage. + * generic/tclExecute.c: + + + * generic/tclCompExpr.c: Fix literal leak in exprs [Bug 1869989] + * generic/tclExecute.c: (dgp) + * tests/compExpr.test: + + * doc/proc.n: changed wording for access to non-local variables; + added mention to [namespace upvar]. Lame attempt at dealing with + documentation [Bug 1872708] + +2008-01-15 Miguel Sofer <msofer@users.sf.net> + + * generic/tclBasic.c: Replacing 'operator' by 'op' in the def + * generic/tclCompExpr.c: of struct TclOpCmdClientData to + * generic/tclCompile.h: accomodate C++ compilers [Bug 1855644] + +2008-01-13 Jeff Hobbs <jeffh@ActiveState.com> + + * win/tclWinSerial.c (SerialCloseProc, TclWinOpenSerialChannel): + use critical section for read & write side. [Bug 1353846] (newman) + +2008-01-11 Miguel Sofer <msofer@users.sf.net> + + * unix/tclUnixThrd.c (TclpThreadGetStackSize): restore stack + checking functionality in freebsd [Bug 1850424] + + * unix/tclUnixThrd.c (TclpThreadGetStackSize): fix for crash in + freebsd [Bug 1860425]. + +2008-01-10 Don Porter <dgp@users.sourceforge.net> + + * generic/tclStringObj.c (Tcl_AppendFormatToObj): Correct failure to + * tests/format.test: account for big.used == 0 corner case in the + %ll(idox) format directives. [Bug 1867855]. + +2008-01-09 George Peter Staplin <georgeps@xmission.com> + + * doc/vwait.n: add a missing be to fix a typo. + +2008-01-04 Jeff Hobbs <jeffh@ActiveState.com> + + * tools/tcltk-man2html.tcl (make-man-pages): make man page title + use more specific info on lhs to improve tabbed browser view titles. + +2008-01-02 Donal K. Fellows <dkf@users.sf.net> + + * doc/binary.n: Fixed documentation bug reported on tcl-core, and + reordered documentation to discourage people from using the hex + formatter that is hardly ever useful. + +2008-01-02 Don Porter <dgp@users.sourceforge.net> + + * generic/tcl.h: Bump version number to 8.5.1b1 to distinguish + * library/init.tcl: CVS development snapshots from the 8.5.0 and + * unix/configure.in: 8.5.1 releases. + * unix/tcl.spec: + * win/configure.in: + * README + + * unix/configure: autoconf (2.59) + * win/configure: + +2007-12-31 Donal K. Fellows <dkf@users.sf.net> + + * doc/dict.n: Clarified meaning of dictionary values following + discussion on comp.lang.tcl. + +2007-12-26 Miguel Sofer <msofer@users.sf.net> + + * generic/tclCmdIL.c: more [lsort] data handling streamlines. The + function MergeSort is gone, essentially inlined into Tcl_LsortObjCmd. + It is not a straight inlining, two loops over all lists elements where + merged in the process: the linked list elements are now built and + merged into the temporary sublists in the same pass. + +2007-12-25 Miguel Sofer <msofer@users.sf.net> + + * generic/tclCmdIL.c: more [lsort] data handling streamlines. Extra + mem reqs of latest patches removed, restored to previous mem profile. + Improved -unique handling, now eliminating repeated elems immediately + instead of marking them to avoid reinsertion at the end. + +2007-12-23 Jeff Hobbs <jeffh@ActiveState.com> + + * generic/tclCompCmds.c (TclCompileRegexpCmd): TCL_REG_NOSUB cannot + * tests/regexp.test (regexp-22.2): be used because it + * tests/regexpComp.test: [Bug 1857126] disallows backrefs. + +2007-12-21 Miguel Sofer <msofer@users.sf.net> + + * generic/tclCmdIL.c: speed patch for lsort [Patch 1856994]. + +2007-12-21 Miguel Sofer <msofer@users.sf.net> + + * generic/tclCmdIL.c (Tcl_LsortObjCmd, Tcl_LsearchObjCmd): avoid + calling SelectObjFromSublist when there are no sublists. + +2007-12-21 Miguel Sofer <msofer@users.sf.net> + + * generic/tclCmdIL.c (Tcl_LsortObjCmd): preallocate a listObj of + sufficient length for the sorted list instead of growing it. Second + commit replaces calls to Tcl_ListObjAppenElement with direct access to + the internal rep. + +2007-12-19 Don Porter <dgp@users.sourceforge.net> *** 8.5.0 TAGGED FOR RELEASE *** + * changes: Updated for 8.5.0 release. + +2007-12-19 Jeff Hobbs <jeffh@ActiveState.com> + + * generic/tclCompCmds.c (TclCompileSwitchCmd): update switch -regexp + * tests/switch.test-14.*: compilation to pass + the cflags to INST_REGEXP (changed on 12-07). Added tests for + switch -regexp compilation (need more). [Bug 1854399] + +2007-12-18 Don Porter <dgp@users.sourceforge.net> + + * changes: Updated for 8.5.0 release. + +2007-12-18 Donal K. Fellows <donal.k.fellows@manchester.ac.uk> + + * generic/regguts.h, generic/regc_color.c, generic/regc_nfa.c: + Fixes for problems created when processing regular expressions that + generate very large automata. An enormous number of thanks to Will + Drewry <wad_at_google.com>, Tavis Ormandy <taviso_at_google.com>, + and Tom Lane <tgl_at_sss.pgh.pa.us> from the Postgresql crowd for + their help in tracking these problems down. [Bug 1810264] + +2007-12-17 Don Porter <dgp@users.sourceforge.net> + + * changes: Updated for 8.5.0 release. + +2007-12-17 Miguel Sofer <msofer@users.sf.net> + + * generic/tclAlloc.c: + * generic/tclExecute.c: + * generic/tclInt.h: + * generic/tclThreadAlloc.c: Fix alignment for memory returned by + TclStackAlloc; insure that all memory allocators align to 16-byte + boundaries on 64 bit platforms [Bug 1851832, 1851524] + +2007-12-14 Jeff Hobbs <jeffh@ActiveState.com> + + * generic/tclIOUtil.c (FsAddMountsToGlobResult): fix the tail + conversion of vfs mounts. [Bug 1602539] + + * win/README: updated notes + +2007-12-14 Pat Thoyts <patthoyts@users.sourceforge.net> + + * tests/winFile.test: Fixed tests for win2k with long machine name + +2007-12-14 Pat Thoyts <patthoyts@users.sourceforge.net> + + * win/nmakehlp.c: Support compilation with MSVC9 for AMD64. + * win/makefile.vc: + +2007-12-13 Donal K. Fellows <donal.k.fellows@manchester.ac.uk> + * doc/trace.n: Clarified documentation of enterstep and leavestep traces, including adding example. [Bug 614282, 1701540, 1755984] @@ -1,11 +1,11 @@ README: Tcl - This is the Tcl 8.5.0 source distribution. + This is the Tcl 8.5.1 source distribution. Tcl/Tk is also available through NetCVS: http://tcl.sourceforge.net/ You can get any source release of Tcl from the file distributions link at the above URL. -RCS: @(#) $Id: README,v 1.59.2.6 2007/12/10 18:32:53 dgp Exp $ +RCS: @(#) $Id: README,v 1.59.2.7 2008/01/23 16:42:16 dgp Exp $ Contents -------- @@ -1,6 +1,6 @@ Recent user-visible changes to Tcl: -RCS: @(#) $Id: changes,v 1.116.2.5 2007/12/13 06:24:09 dgp Exp $ +RCS: @(#) $Id: changes,v 1.116.2.6 2008/01/23 16:42:16 dgp Exp $ 1. No more [command1] [command2] construct for grouping multiple commands on a single command line. @@ -7097,6 +7097,13 @@ Many significant documentation improvements (fellows, sofer) 2007-12-05 (performance)[1845092] Tcl_ObjType for channel names (hobbs) +2007-12-14 (bug fix)[1602539] NUL pollution in [glob] result (hobbs) + +2007-12-17 (bug fix)[1851832,1851524] memory alignment correction (sofer) + +2007-12-18 (bug fix)[1810264] revised regexp engine to prevent debilitating +over-consumption of resources (drewry,lane,ormandy,fellows) + Several documentation and release notes improvements ---- Released 8.5.0, December 14, 2007 --- See ChangeLog for details --- +--- Released 8.5.0, December 20, 2007 --- See ChangeLog for details --- diff --git a/doc/binary.n b/doc/binary.n index 652cabb..047744c 100644 --- a/doc/binary.n +++ b/doc/binary.n @@ -4,7 +4,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: binary.n,v 1.29.6.2 2007/11/21 06:30:44 dgp Exp $ +'\" RCS: @(#) $Id: binary.n,v 1.29.6.3 2008/01/23 16:42:16 dgp Exp $ '\" .so man.macros .TH binary n 8.0 Tcl "Tcl Built-In Commands" @@ -17,7 +17,6 @@ binary \- Insert and extract fields from binary strings .br \fBbinary scan \fIstring formatString \fR?\fIvarName varName ...\fR? .BE - .SH DESCRIPTION .PP This command provides facilities for manipulating binary data. The @@ -139,13 +138,13 @@ high-to-low order within each byte. For example, .CE will return a string equivalent to \fB\exe0\exe1\exa0\fR. .RE -.IP \fBh\fR 5 -Stores a string of \fIcount\fR hexadecimal digits in low-to-high +.IP \fBH\fR 5 +Stores a string of \fIcount\fR hexadecimal digits in high-to-low within each byte in the output string. \fIArg\fR must contain a sequence of characters in the set .QW 0123456789abcdefABCDEF . The resulting bytes are emitted in first to last order with the hex digits -being formatted in low-to-high order within each byte. If \fIarg\fR +being formatted in high-to-low order within each byte. If \fIarg\fR has fewer than \fIcount\fR digits, then zeros will be used for the remaining digits. If \fIarg\fR has more than the specified number of digits, the extra digits will be ignored. If \fIcount\fR is @@ -155,18 +154,18 @@ number of digits formatted does not end at a byte boundary, the remaining bits of the last byte will be zeros. For example, .RS .CS -\fBbinary format\fR h3h* AB def +\fBbinary format\fR H3H*H2 ab DEF 987 .CE -will return a string equivalent to \fB\exba\ex00\exed\ex0f\fR. +will return a string equivalent to \fB\exab\ex00\exde\exf0\ex98\fR. .RE -.IP \fBH\fR 5 -This form is the same as \fBh\fR except that the digits are stored in -high-to-low order within each byte. For example, +.IP \fBh\fR 5 +This form is the same as \fBH\fR except that the digits are stored in +low-to-high order within each byte. This is seldom required. For example, .RS .CS -\fBbinary format\fR H3H* ab DEF +\fBbinary format\fR h3h*h2 AB def 987 .CE -will return a string equivalent to \fB\exab\ex00\exde\exf0\fR. +will return a string equivalent to \fB\exba\ex00\exed\ex0f\ex89\fR. .RE .IP \fBc\fR 5 Stores one or more 8-bit integer values in the output string. If no @@ -534,7 +533,7 @@ scanned. For example, .CS \fBbinary scan\fR \ex07\exC6\ex05\ex1f\ex34 H3H* var1 var2 .CE -will return \fB2\fR with \fB0c8\fR stored in \fIvar1\fR and +will return \fB2\fR with \fB07c\fR stored in \fIvar1\fR and \fB051f34\fR stored in \fIvar2\fR. .RE .IP \fBh\fR 5 @@ -809,9 +808,7 @@ proc \fIreadString\fR {channel} { return [encoding convertfrom utf-8 $data] } .CE - .SH "SEE ALSO" format(n), scan(n), tclvars(n) - .SH KEYWORDS binary, format, scan @@ -5,7 +5,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: dde.n,v 1.17.12.1 2007/11/01 16:25:48 dgp Exp $ +'\" RCS: @(#) $Id: dde.n,v 1.17.12.2 2008/01/23 16:42:16 dgp Exp $ '\" .so man.macros .TH dde n 1.3 dde "Tcl Bundled Packages" @@ -48,6 +48,7 @@ The following commands are a subset of the full Dynamic Data Exchange set of commands. .TP \fBdde servername \fR?\fB\-force\fR? ?\fB\-handler \fIproc\fR? ?\fB\-\|\-\fR? ?\fItopic\fR? +. \fBdde servername\fR registers the interpreter as a DDE server with the service name \fBTclEval\fR and the topic name specified by \fItopic\fR. If no \fItopic\fR is given, \fBdde servername\fR returns the name @@ -61,14 +62,17 @@ is appended to the name to make it unique. The command's result will be the name actually used. The \fB\-force\fR option is used to force registration of precisely the given \fItopic\fR name. -.IP +.RS +.PP The \fB\-handler\fR option specifies a Tcl procedure that will be called to process calls to the dde server. If the package has been loaded into a safe interpreter then a \fB\-handler\fR procedure must be defined. The procedure is called with all the arguments provided by the remote call. +.RE .TP \fBdde execute\fR ?\fB\-async\fR? \fIservice topic data\fR +. \fBdde execute\fR takes the \fIdata\fR and sends it to the server indicated by \fIservice\fR with the topic indicated by \fItopic\fR. Typically, \fIservice\fR is the name of an application, and \fItopic\fR is a file to @@ -80,6 +84,7 @@ script did not run, unless the \fB\-async\fR flag was used, in which case the command returns immediately with no error. .TP \fBdde poke \fIservice topic item data\fR +. \fBdde poke\fR passes the \fIdata\fR to the server indicated by \fIservice\fR using the \fItopic\fR and \fIitem\fR specified. Typically, \fIservice\fR is the name of an application. \fItopic\fR is application @@ -89,6 +94,7 @@ it must always be non-null. The \fIdata\fR field is given to the remote application. .TP \fBdde request\fR ?\fB\-binary\fR? \fIservice topic item\fR +. \fBdde request\fR is typically used to get the value of something; the value of a cell in Microsoft Excel or the text of a selection in Microsoft Word. \fIservice\fR is typically the name of an application, @@ -99,6 +105,7 @@ string with terminating null. If \fB\-binary\fR is specified, the result is returned as a byte array. .TP \fBdde services \fIservice topic\fR +. \fBdde services\fR returns a list of service-topic pairs that currently exist on the machine. If \fIservice\fR and \fItopic\fR are both empty strings ({}), then all service-topic pairs currently @@ -110,6 +117,7 @@ service-topic pair currently exists, it is returned; otherwise, an empty string is returned. .TP \fBdde eval\fR ?\fB\-async\fR? \fItopic cmd \fR?\fIarg arg ...\fR? +. \fBdde eval\fR evaluates a command and its arguments using the interpreter specified by \fItopic\fR. The DDE service must be the \fBTclEval\fR service. The \fB\-async\fR option requests asynchronous invocation. The @@ -155,9 +163,7 @@ particularly important website: package require dde \fBdde execute\fR iexplore WWW_OpenURL http://www.tcl.tk/ .CE - .SH "SEE ALSO" tk(n), winfo(n), send(n) - .SH KEYWORDS application, dde, name, remote execution @@ -4,7 +4,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: dict.n,v 1.12.8.2 2007/11/21 06:44:31 dgp Exp $ +'\" RCS: @(#) $Id: dict.n,v 1.12.8.3 2008/01/23 16:42:16 dgp Exp $ '\" .so man.macros .TH dict n 8.5 Tcl "Tcl Built-In Commands" @@ -15,7 +15,6 @@ dict \- Manipulate dictionaries .SH SYNOPSIS \fBdict \fIoption arg \fR?\fIarg ...\fR? .BE - .SH DESCRIPTION .PP Performs one of several operations on dictionary values or variables @@ -214,6 +213,7 @@ when \fIbody\fR terminates. .SH "DICTIONARY VALUES" Dictionaries are values that contain an efficient, order-preserving mapping from arbitrary keys to arbitrary values. +Each key in the dictionary maps to a single value. They have a textual format that is exactly that of any list with an even number of elements, with each mapping in the dictionary being represented as two items in the list. When a command takes a @@ -221,6 +221,13 @@ dictionary and produces a new dictionary based on it (either returning it or writing it back into the variable that the starting dictionary was read from) the new dictionary will have the same order of keys, modulo any deleted keys and with new keys added on to the end. +When a string is interpreted as a dictionary and it would otherwise +have duplicate keys, only the last value for a particular key is used; +the others are ignored, meaning that, +.QW "apple banana" +and +.QW "apple carrot apple banana" +are equivalent dictionaries (with different string representations). .SH EXAMPLES Constructing and using nested dictionaries: .CS @@ -254,7 +261,7 @@ foreach id [\fBdict keys\fR $employeeInfo] { puts "Hello, [\fBdict get\fR $employeeInfo $id forenames]!" } .CE - +.PP A localizable version of \fBstring toupper\fR: .CS # Set up the basic C locale @@ -274,9 +281,7 @@ foreach c [split {abcdefghijklmnopqrstuvwxyz} ""] { set upperCaseMap [\fBdict get\fR $capital $env(LANG)] set upperCase [string map $upperCaseMap $string] .CE - .SH "SEE ALSO" append(n), array(n), foreach(n), incr(n), list(n), lappend(n), set(n) - .SH KEYWORDS dictionary, create, update, lookup, iterate, filter diff --git a/doc/memory.n b/doc/memory.n index 63e3cd2..c433504 100644 --- a/doc/memory.n +++ b/doc/memory.n @@ -3,7 +3,7 @@ '\" Copyright (c) 2000 by Scriptics Corporation. '\" All rights reserved. '\" -'\" RCS: @(#) $Id: memory.n,v 1.6.12.1 2007/11/01 16:25:49 dgp Exp $ +'\" RCS: @(#) $Id: memory.n,v 1.6.12.2 2008/01/23 16:42:16 dgp Exp $ '\" .so man.macros .TH memory n 8.1 Tcl "Tcl Built-In Commands" @@ -13,7 +13,6 @@ memory \- Control Tcl memory debugging capabilities .SH SYNOPSIS \fBmemory \fIoption \fR?\fIarg arg ...\fR? .BE - .SH DESCRIPTION .PP The \fBmemory\fR command gives the Tcl developer control of Tcl's memory @@ -23,9 +22,11 @@ memory debugging enabled (when \fBTCL_MEM_DEBUG\fR is defined at compile time), and after \fBTcl_InitMemory\fR has been called. .TP \fBmemory active\fR \fIfile\fR +. Write a list of all currently allocated memory to the specified \fIfile\fR. .TP \fBmemory break_on_malloc\fR \fIcount\fR +. After the \fIcount\fR allocations have been performed, \fBckalloc\fR outputs a message to this effect and that it is now attempting to enter the C debugger. Tcl will then issue a \fISIGINT\fR signal against itself. @@ -33,22 +34,26 @@ If you are running Tcl under a C debugger, it should then enter the debugger command mode. .TP \fBmemory info\fR +. Returns a report containing the total allocations and frees since Tcl began, the current packets allocated (the current number of calls to \fBckalloc\fR not met by a corresponding call to \fBckfree\fR), the current bytes allocated, and the maximum number of packets and bytes allocated. .TP -\fB memory init [on|off]\fR +\fB memory init \fR[\fBon\fR|\fBoff\fR] +. Turn on or off the pre-initialization of all allocated memory with bogus bytes. Useful for detecting the use of uninitialized values. .TP \fBmemory onexit\fR \fIfile\fR +. Causes a list of all allocated memory to be written to the specified \fIfile\fR during the finalization of Tcl's memory subsystem. Useful for checking that memory is properly cleaned up during process exit. .TP \fBmemory tag\fR \fIstring\fR +. Each packet of memory allocated by \fBckalloc\fR can have associated with it a string-valued tag. In the lists of allocated memory generated by \fBmemory active\fR and \fBmemory onexit\fR, the tag for each packet @@ -56,7 +61,7 @@ is printed along with other information about the packet. The \fBmemory tag\fR command sets the tag value for subsequent calls to \fBckalloc\fR to be \fIstring\fR. .TP -\fBmemory trace [on|off]\fR +\fBmemory trace \fR[\fBon\fR|\fBoff\fR] . Turns memory tracing on or off. When memory tracing is on, every call to \fBckalloc\fR causes a line of trace information to be written to @@ -71,6 +76,7 @@ Calls to \fBckfree\fR are traced in the same manner. .RE .TP \fBmemory trace_on_at_malloc\fR \fIcount\fR +. Enable memory tracing after \fIcount\fR \fBckalloc\fRs have been performed. For example, if you enter \fBmemory trace_on_at_malloc 100\fR, after the 100th call to \fBckalloc\fR, memory trace information will begin @@ -81,7 +87,8 @@ produced), if you can identify a number of allocations that occur before the problem sets in. The current number of memory allocations that have occurred since Tcl started is printed on a guard zone failure. .TP -\fBmemory validate [on|off]\fR +\fBmemory validate \fR[\fBon\fR|\fBoff\fR] +. Turns memory validation on or off. When memory validation is enabled, on every call to \fBckalloc\fR or \fBckfree\fR, the guard zones are checked for every piece of memory currently in existence that was @@ -92,9 +99,7 @@ overwrite can be detected on the first call to \fBckalloc\fR or \fBckfree\fR after the overwrite occurred, rather than when the specific memory with the overwritten guard zone(s) is freed, which may occur long after the overwrite occurred. - .SH "SEE ALSO" ckalloc, ckfree, Tcl_ValidateAllMemory, Tcl_DumpActiveMemory, TCL_MEM_DEBUG - .SH KEYWORDS memory, debug @@ -5,7 +5,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: proc.n,v 1.5.12.1 2007/11/01 16:25:50 dgp Exp $ +'\" RCS: @(#) $Id: proc.n,v 1.5.12.2 2008/01/23 16:42:17 dgp Exp $ '\" .so man.macros .TH proc n "" Tcl "Tcl Built-In Commands" @@ -35,17 +35,25 @@ elements specifies one argument. Each argument specifier is also a list with either one or two fields. If there is only a single field in the specifier then it is the name of the argument; if there are two fields, then -the first is the argument name and the second is its default value. +the first is the argument name and the second is its default value. +Arguments with default values that are followed by non-defaulted +arguments become required arguments. In 8.6 this will be considered an +error. .PP When \fIname\fR is invoked a local variable will be created for each of the formal arguments to the procedure; its value will be the value of corresponding argument in the invoking command or the argument's default value. +Actual arguments are assigned to formal arguments strictly in order. Arguments with default values need not be specified in a procedure invocation. However, there must be enough actual arguments for all the formal arguments that do not have defaults, and there must not be any extra -actual arguments. There is one special case to permit procedures with +actual arguments. +Arguments with default values that are followed by non-defaulted +arguments become required arguments (in 8.6 it will be considered an +error). +There is one special case to permit procedures with variable numbers of arguments. If the last formal argument has the name \fBargs\fR, then a call to the procedure may contain more actual arguments than the procedure has formals. In this case, all of the actual arguments @@ -57,10 +65,8 @@ When \fIbody\fR is being executed, variable names normally refer to local variables, which are created automatically when referenced and deleted when the procedure returns. One local variable is automatically created for each of the procedure's arguments. -Global variables can only be accessed by invoking -the \fBglobal\fR command or the \fBupvar\fR command. -Namespace variables can only be accessed by invoking -the \fBvariable\fR command or the \fBupvar\fR command. +Other variables can only be accessed by invoking one of the \fBglobal\fR, +\fBvariable\fR, \fBupvar\fR or \fBnamespace upvar\fR commands. .PP The \fBproc\fR command returns an empty string. When a procedure is invoked, the procedure's return value is the value specified in a diff --git a/doc/registry.n b/doc/registry.n index 3a45d67..93bd953 100644 --- a/doc/registry.n +++ b/doc/registry.n @@ -5,7 +5,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: registry.n,v 1.14.8.2 2007/11/01 16:25:54 dgp Exp $ +'\" RCS: @(#) $Id: registry.n,v 1.14.8.3 2008/01/23 16:42:17 dgp Exp $ '\" .so man.macros .TH registry n 1.1 registry "Tcl Bundled Packages" @@ -29,12 +29,14 @@ as a corrupted registry can leave your system in an unusable state. .PP \fIKeyName\fR is the name of a registry key. Registry keys must be one of the following forms: -.IP +.RS +.PP \fB\e\e\fIhostname\fB\e\fIrootname\fB\e\fIkeypath\fR -.IP +.PP \fIrootname\fB\e\fIkeypath\fR -.IP +.PP \fIrootname\fR +.RE .PP \fIHostname\fR specifies the name of any valid Windows host that exports its registry. The \fIrootname\fR component must be @@ -4,7 +4,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: tm.n,v 1.6.2.1 2007/11/01 16:25:56 dgp Exp $ +'\" RCS: @(#) $Id: tm.n,v 1.6.2.2 2008/01/23 16:42:17 dgp Exp $ '\" .so man.macros .TH tm n 8.5 Tcl "Tcl Built-In Commands" @@ -25,6 +25,7 @@ This document describes the facilities for locating and loading Tcl Modules. The following commands are supported: .TP \fB::tcl::tm::path\fR \fBadd\fR \fIpath\fR... +. The paths are added at the head to the list of module paths, in order of appearance. This means that the last argument ends up as the new head of the list. @@ -46,14 +47,17 @@ looked at first. .RE .TP \fB::tcl::tm::path\fR \fBremove\fR \fIpath\fR... +. Removes the paths from the list of module paths. The command silently ignores all paths which are not on the list. .TP \fB::tcl::tm::path\fR \fBlist\fR +. Returns a list containing all registered module paths, in the order that they are searched for modules. .TP \fB::tcl::tm::roots\fR \fIpath\fR... +. Similar to \fBpath add\fR, and layered on top of it. This command takes a list of paths, extends each with .QW "\fBtcl\fIX\fB/site-tcl\fR" , @@ -109,9 +113,11 @@ of the command \fB::tcl::tm::path list\fR. This is called the \fIModule path\fR. Neither the \fBauto_path\fR nor the \fBtcl_pkgPath\fR variables are used. All directories on the module path have to obey one restriction: -.IP +.RS +.PP For any two directories, neither is an ancestor directory of the other. +.RE .PP This is required to avoid ambiguities in package naming. If for example the two directories @@ -125,19 +131,23 @@ obscuring a package named \fBice\fR, unqualified. .PP Before the search is started, the name of the requested package is translated into a partial path, using the following algorithm: -.IP +.RS +.PP All occurrences of .QW "\fB::\fR" in the package name are replaced by the appropriate directory separator character for the platform we are on. On Unix, for example, this is .QW "\fB/\fR" . +.RE .PP Example: -.IP +.RS +.PP The requested package is \fBencoding::base64\fR. The generated partial path is .QW "\fIencoding/base64\fR" . +.RE .PP After this translation the package is looked for in all module paths, by combining them one-by-one, first to last with the partial path to @@ -207,6 +217,7 @@ are found in the variable. .SS "SYSTEM SPECIFIC PATHS" .TP \fBfile normalize [info library]/../tcl\fIX\fB/\fIX\fB.\fIy\fR +. In other words, the interpreter will look into a directory specified by its major version and whose minor versions are less than or equal to the minor version of the interpreter. @@ -227,6 +238,7 @@ can also be used by all interpreters which have the same major number .RE .TP \fBfile normalize EXEC/tcl\fIX\fB/\fIX\fB.\fIy\fR +. Where \fBEXEC\fR is \fBfile normalize [info nameofexecutable]/../lib\fR or \fBfile normalize [::tcl::pkgconfig get libdir,runtime]\fR .RS @@ -239,11 +251,13 @@ identical. .SS "SITE SPECIFIC PATHS" .TP \fBfile normalize [info library]/../tcl\fIX\fB/site-tcl\fR +. Note that this is always a single entry because \fIX\fR is always a specific value (the current major version of Tcl). .SS "USER SPECIFIC PATHS" .TP \fB$::env(TCL\fIX\fB.\fIy\fB_TM_PATH)\fR +. A list of paths, separated by either \fB:\fR (Unix) or \fB;\fR (Windows). This is user and site specific as this environment variable can be set not only by the user's profile, but by system configuration diff --git a/doc/vwait.n b/doc/vwait.n index 568f23a..98007f5 100644 --- a/doc/vwait.n +++ b/doc/vwait.n @@ -4,7 +4,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: vwait.n,v 1.6 2004/10/27 14:43:54 dkf Exp $ +'\" RCS: @(#) $Id: vwait.n,v 1.6.12.1 2008/01/23 16:42:17 dgp Exp $ '\" .so man.macros .TH vwait n 8.0 Tcl "Tcl Built-In Commands" @@ -23,7 +23,7 @@ the application if no events are ready. It continues processing events until some event handler sets the value of variable \fIvarName\fR. Once \fIvarName\fR has been set, the \fBvwait\fR command will return as soon as the event handler that modified -\fIvarName\fR completes. \fIvarName\fR must globally scoped +\fIvarName\fR completes. \fIvarName\fR must be globally scoped (either with a call to \fBglobal\fR for the \fIvarName\fR, or with the full namespace path specification). .PP diff --git a/generic/regc_color.c b/generic/regc_color.c index 003f5fc..ba1f668 100644 --- a/generic/regc_color.c +++ b/generic/regc_color.c @@ -611,12 +611,9 @@ okcolors( scd->sub = NOSUB; while ((a = cd->arcs) != NULL) { assert(a->co == co); - /* uncolorchain(cm, a); */ - cd->arcs = a->colorchain; + uncolorchain(cm, a); a->co = sco; - /* colorchain(cm, a); */ - a->colorchain = scd->arcs; - scd->arcs = a; + colorchain(cm, a); } freecolor(cm, co); } else { @@ -648,7 +645,11 @@ colorchain( { struct colordesc *cd = &cm->cd[a->co]; + if (cd->arcs != NULL) { + cd->arcs->colorchainRev = a; + } a->colorchain = cd->arcs; + a->colorchainRev = NULL; cd->arcs = a; } @@ -662,20 +663,20 @@ uncolorchain( struct arc *a) { struct colordesc *cd = &cm->cd[a->co]; - struct arc *aa; + struct arc *aa = a->colorchainRev; - aa = cd->arcs; - if (aa == a) { /* easy case */ + if (aa == NULL) { + assert(cd->arcs == a); cd->arcs = a->colorchain; } else { - assert(aa != NULL); - for (; aa->colorchain!=a ; aa=aa->colorchain) { - assert(aa->colorchain != NULL); - continue; - } + assert(aa->colorchain == a); aa->colorchain = a->colorchain; } + if (a->colorchain != NULL) { + a->colorchain->colorchainRev = aa; + } a->colorchain = NULL; /* paranoia */ + a->colorchainRev = NULL; } /* diff --git a/generic/regc_nfa.c b/generic/regc_nfa.c index 741887f..19dbe63 100644 --- a/generic/regc_nfa.c +++ b/generic/regc_nfa.c @@ -58,13 +58,14 @@ newnfa( nfa->nstates = 0; nfa->cm = cm; nfa->v = v; + nfa->size = 0; nfa->bos[0] = nfa->bos[1] = COLORLESS; nfa->eos[0] = nfa->eos[1] = COLORLESS; + nfa->parent = parent; /* Precedes newfstate so parent is valid. */ nfa->post = newfstate(nfa, '@'); /* number 0 */ nfa->pre = newfstate(nfa, '>'); /* number 1 */ - nfa->parent = parent; - nfa->init = newstate(nfa); /* may become invalid later */ + nfa->init = newstate(nfa); /* May become invalid later. */ nfa->final = newstate(nfa); if (ISERR()) { freenfa(nfa); @@ -85,6 +86,61 @@ newnfa( } /* + - TooManyStates - checks if the max states exceeds the compile-time value + ^ static int TooManyStates(struct nfa *); + */ +static int +TooManyStates( + struct nfa *nfa) +{ + struct nfa *parent = nfa->parent; + size_t sz = nfa->size; + + while (parent != NULL) { + sz = parent->size; + parent = parent->parent; + } + if (sz > REG_MAX_STATES) { + return 1; + } + return 0; +} + +/* + - IncrementSize - increases the tracked size of the NFA and its parents. + ^ static void IncrementSize(struct nfa *); + */ +static void +IncrementSize( + struct nfa *nfa) +{ + struct nfa *parent = nfa->parent; + + nfa->size++; + while (parent != NULL) { + parent->size++; + parent = parent->parent; + } +} + +/* + - DecrementSize - increases the tracked size of the NFA and its parents. + ^ static void DecrementSize(struct nfa *); + */ +static void +DecrementSize( + struct nfa *nfa) +{ + struct nfa *parent = nfa->parent; + + nfa->size--; + while (parent != NULL) { + parent->size--; + parent = parent->parent; + } +} + +/* - freenfa - free an entire NFA ^ static VOID freenfa(struct nfa *); */ @@ -120,6 +176,11 @@ newstate( { struct state *s; + if (TooManyStates(nfa)) { + /* XXX: add specific error for this */ + NERR(REG_ETOOBIG); + return NULL; + } if (nfa->free != NULL) { s = nfa->free; nfa->free = s->next; @@ -152,6 +213,12 @@ newstate( } s->prev = nfa->slast; nfa->slast = s; + + /* + * Track the current size and the parent size. + */ + + IncrementSize(nfa); return s; } @@ -222,6 +289,7 @@ freestate( s->prev = NULL; s->next = nfa->free; /* don't delete it, put it on the free list */ nfa->free = s; + DecrementSize(nfa); } /* @@ -688,6 +756,9 @@ duptraverse( for (a=s->outs ; a!=NULL && !NISERR() ; a=a->outchain) { duptraverse(nfa, a->to, NULL); + if (NISERR()) { + break; + } assert(a->to->tmp != NULL); cparc(nfa, a, s->tmp, a->to->tmp); } diff --git a/generic/regerrs.h b/generic/regerrs.h index a3d98b6..259c0cb 100644 --- a/generic/regerrs.h +++ b/generic/regerrs.h @@ -16,3 +16,4 @@ { REG_INVARG, "REG_INVARG", "invalid argument to regex function" }, { REG_MIXED, "REG_MIXED", "character widths of regex and string differ" }, { REG_BADOPT, "REG_BADOPT", "invalid embedded option" }, +{ REG_ETOOBIG, "REG_ETOOBIG", "nfa has too many states" }, diff --git a/generic/regex.h b/generic/regex.h index b8498ab..fa86092 100644 --- a/generic/regex.h +++ b/generic/regex.h @@ -277,6 +277,7 @@ typedef struct { #define REG_INVARG 16 /* invalid argument to regex function */ #define REG_MIXED 17 /* character widths of regex and string differ */ #define REG_BADOPT 18 /* invalid embedded option */ +#define REG_ETOOBIG 19 /* nfa has too many states */ /* two specials for debugging and testing */ #define REG_ATOI 101 /* convert error-code name to number */ #define REG_ITOA 102 /* convert error-code number to name */ diff --git a/generic/regguts.h b/generic/regguts.h index cbf6615..67e3d03 100644 --- a/generic/regguts.h +++ b/generic/regguts.h @@ -267,6 +267,7 @@ struct arc { #define freechain outchain struct arc *inchain; /* *to's ins chain */ struct arc *colorchain; /* color's arc chain */ + struct arc *colorchainRev; /* back-link in color's arc chain */ }; struct arcbatch { /* for bulk allocation of arcs */ @@ -303,6 +304,9 @@ struct nfa { struct colormap *cm; /* the color map */ color bos[2]; /* colors, if any, assigned to BOS and BOL */ color eos[2]; /* colors, if any, assigned to EOS and EOL */ + size_t size; /* Current NFA size; differs from nstates as + * it also counts the number of states created + * by children of this state. */ struct vars *v; /* simplifies compile error reporting */ struct nfa *parent; /* parent NFA, if any */ }; @@ -332,6 +336,14 @@ struct cnfa { #define NULLCNFA(cnfa) ((cnfa).nstates == 0) /* + * Used to limit the maximum NFA size to something sane. [Bug 1810264] + */ + +#ifndef REG_MAX_STATES +# define REG_MAX_STATES 100000 +#endif + +/* * subexpression tree */ diff --git a/generic/tcl.h b/generic/tcl.h index 36083d0..8a07897 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tcl.h,v 1.231.2.13 2007/12/11 16:19:54 dgp Exp $ + * RCS: @(#) $Id: tcl.h,v 1.231.2.14 2008/01/23 16:42:17 dgp Exp $ */ #ifndef _TCL @@ -60,10 +60,10 @@ extern "C" { #define TCL_MAJOR_VERSION 8 #define TCL_MINOR_VERSION 5 #define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE -#define TCL_RELEASE_SERIAL 0 +#define TCL_RELEASE_SERIAL 1 #define TCL_VERSION "8.5" -#define TCL_PATCH_LEVEL "8.5.0" +#define TCL_PATCH_LEVEL "8.5.1b1" /* * The following definitions set up the proper options for Windows compilers. diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c index 3d34113..ba5c181 100644 --- a/generic/tclAlloc.c +++ b/generic/tclAlloc.c @@ -15,7 +15,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclAlloc.c,v 1.24.2.1 2007/07/01 17:31:22 dgp Exp $ + * RCS: @(#) $Id: tclAlloc.c,v 1.24.2.2 2008/01/23 16:42:17 dgp Exp $ */ /* @@ -44,16 +44,6 @@ typedef unsigned long caddr_t; #endif /* - * Alignment for allocated memory. - */ - -#if defined(__APPLE__) -#define ALLOCALIGN 16 -#else -#define ALLOCALIGN 8 -#endif - -/* * The overhead on a block is at least 8 bytes. When free, this space contains * a pointer to the next free block, and the bottom two bits must be zero. * When in use, the first byte is set to MAGIC, and the second byte is the @@ -66,7 +56,7 @@ typedef unsigned long caddr_t; union overhead { union overhead *next; /* when free */ - unsigned char padding[ALLOCALIGN]; /* align struct to ALLOCALIGN bytes */ + unsigned char padding[TCL_ALLOCALIGN]; /* align struct to TCL_ALLOCALIGN bytes */ struct { unsigned char magic0; /* magic number */ unsigned char index; /* bucket # */ @@ -110,7 +100,7 @@ union overhead { * precedes the data area returned to the user. */ -#define MINBLOCK ((sizeof(union overhead) + (ALLOCALIGN-1)) & ~(ALLOCALIGN-1)) +#define MINBLOCK ((sizeof(union overhead) + (TCL_ALLOCALIGN-1)) & ~(TCL_ALLOCALIGN-1)) #define NBUCKETS (13 - (MINBLOCK >> 4)) #define MAXMALLOC (1<<(NBUCKETS+2)) static union overhead *nextf[NBUCKETS]; diff --git a/generic/tclBasic.c b/generic/tclBasic.c index deee6b4..30ca044 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.244.2.20 2007/12/10 18:32:55 dgp Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.244.2.21 2008/01/23 16:42:17 dgp Exp $ */ #include "tclInt.h" @@ -738,7 +738,7 @@ Tcl_CreateInterp(void) TclOpCmdClientData *occdPtr = (TclOpCmdClientData *) ckalloc(sizeof(TclOpCmdClientData)); - occdPtr->operator = opcmdInfoPtr->name; + occdPtr->op = opcmdInfoPtr->name; occdPtr->i.numArgs = opcmdInfoPtr->i.numArgs; occdPtr->expected = opcmdInfoPtr->expected; strcpy(mathFuncName + MATH_OP_PREFIX_LEN, opcmdInfoPtr->name); diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 4f63892..00b1e55 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -16,7 +16,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdIL.c,v 1.115.2.12 2007/12/05 18:09:52 dgp Exp $ + * RCS: @(#) $Id: tclCmdIL.c,v 1.115.2.13 2008/01/23 16:42:18 dgp Exp $ */ #include "tclInt.h" @@ -29,8 +29,13 @@ */ typedef struct SortElement { - Tcl_Obj *objPtr; /* Object being sorted. */ - int count; /* Number of same elements in list. */ + union { + char *strValuePtr; + long intValue; + double doubleValue; + Tcl_Obj *objValuePtr; + } index; + Tcl_Obj *objPtr; /* Object being sorted, or its index. */ struct SortElement *nextPtr;/* Next element in the list, or NULL for end * of list. */ } SortElement; @@ -54,8 +59,6 @@ typedef struct SortInfo { int isIncreasing; /* Nonzero means sort in increasing order. */ int sortMode; /* The sort mode. One of SORTMODE_* values * defined below. */ - SortStrCmpFn_t strCmpFn; /* Basic string compare command (used with - * ASCII mode). */ Tcl_Obj *compareCmdPtr; /* The Tcl comparison command when sortMode is * SORTMODE_COMMAND. Pre-initialized to hold * base of command. */ @@ -67,6 +70,8 @@ typedef struct SortInfo { * supplied. */ int indexc; /* Number of indexes in indexv array. */ int singleIndex; /* Static space for common index case. */ + int unique; + int numElements; Tcl_Interp *interp; /* The interpreter in which the sort is being * done. */ int resultCode; /* Completion code for the lsort command. If @@ -84,6 +89,7 @@ typedef struct SortInfo { #define SORTMODE_REAL 2 #define SORTMODE_COMMAND 3 #define SORTMODE_DICTIONARY 4 +#define SORTMODE_ASCII_NC 8 /* * Magic values for the index field of the SortInfo structure. Note that the @@ -136,10 +142,9 @@ static int InfoSharedlibCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); static int InfoTclVersionCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]); -static SortElement * MergeSort(SortElement *headPt, SortInfo *infoPtr); static SortElement * MergeLists(SortElement *leftPtr, SortElement *rightPtr, SortInfo *infoPtr); -static int SortCompare(Tcl_Obj *firstPtr, Tcl_Obj *second, +static int SortCompare(SortElement *firstPtr, SortElement *second, SortInfo *infoPtr); static Tcl_Obj * SelectObjFromSublist(Tcl_Obj *firstPtr, SortInfo *infoPtr); @@ -2604,6 +2609,15 @@ Tcl_LreverseObjCmd( return TCL_ERROR; } + /* + * If the list is empty, just return it [Bug 1876793] + */ + + if (!elemc) { + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; + } + if (Tcl_IsShared(objv[1])) { Tcl_Obj *resultObj, **dataArray; List *listPtr; @@ -2714,7 +2728,7 @@ Tcl_LsearchObjCmd( offset = 0; noCase = 0; sortInfo.compareCmdPtr = NULL; - sortInfo.isIncreasing = 0; + sortInfo.isIncreasing = 1; sortInfo.sortMode = 0; sortInfo.interp = interp; sortInfo.resultCode = TCL_OK; @@ -2746,6 +2760,7 @@ Tcl_LsearchObjCmd( break; case LSEARCH_DECREASING: /* -decreasing */ isIncreasing = 0; + sortInfo.isIncreasing = 0; break; case LSEARCH_DICTIONARY: /* -dictionary */ dataType = DICTIONARY; @@ -2758,6 +2773,7 @@ Tcl_LsearchObjCmd( break; case LSEARCH_INCREASING: /* -increasing */ isIncreasing = 1; + sortInfo.isIncreasing = 1; break; case LSEARCH_INLINE: /* -inline */ inlineReturn = 1; @@ -3042,12 +3058,16 @@ Tcl_LsearchObjCmd( upper = listc; while (lower + 1 != upper && sortInfo.resultCode == TCL_OK) { i = (lower + upper)/2; - itemPtr = SelectObjFromSublist(listv[i], &sortInfo); - if (sortInfo.resultCode != TCL_OK) { - if (sortInfo.indexc > 1) { - ckfree((char *) sortInfo.indexv); + if (sortInfo.indexc != 0) { + itemPtr = SelectObjFromSublist(listv[i], &sortInfo); + if (sortInfo.resultCode != TCL_OK) { + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); + } + return sortInfo.resultCode; } - return sortInfo.resultCode; + } else { + itemPtr = listv[i]; } switch ((enum datatypes) dataType) { case ASCII: @@ -3136,16 +3156,21 @@ Tcl_LsearchObjCmd( } for (i = offset; i < listc; i++) { match = 0; - itemPtr = SelectObjFromSublist(listv[i], &sortInfo); - if (sortInfo.resultCode != TCL_OK) { - if (listPtr != NULL) { - Tcl_DecrRefCount(listPtr); - } - if (sortInfo.indexc > 1) { - ckfree((char *) sortInfo.indexv); + if (sortInfo.indexc != 0) { + itemPtr = SelectObjFromSublist(listv[i], &sortInfo); + if (sortInfo.resultCode != TCL_OK) { + if (listPtr != NULL) { + Tcl_DecrRefCount(listPtr); + } + if (sortInfo.indexc > 1) { + ckfree((char *) sortInfo.indexv); + } + return sortInfo.resultCode; } - return sortInfo.resultCode; + } else { + itemPtr = listv[i]; } + switch ((enum modes) mode) { case SORTED: case EXACT: @@ -3240,7 +3265,7 @@ Tcl_LsearchObjCmd( * Note that these appends are not expected to fail. */ - if (returnSubindices) { + if (returnSubindices && (sortInfo.indexc != 0)) { itemPtr = SelectObjFromSublist(listv[i], &sortInfo); } else { itemPtr = listv[i]; @@ -3410,8 +3435,8 @@ Tcl_LsortObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *CONST objv[]) /* Argument values. */ { - int i, index, unique, indices, length; - Tcl_Obj *resultPtr, *cmdPtr, **listObjPtrs, *listObj; + int i, j, index, unique, indices, length, nocase = 0, sortMode, indexc; + Tcl_Obj *resultPtr, *cmdPtr, **listObjPtrs, *listObj, *indexPtr; SortElement *elementArray, *elementPtr; SortInfo sortInfo; /* Information about this sort that needs to * be passed to the comparison function. */ @@ -3425,6 +3450,13 @@ Tcl_LsortObjCmd( LSORT_NOCASE, LSORT_REAL, LSORT_UNIQUE }; + /* + * The subList array below holds pointers to temporary lists built during + * the merge sort. Element i of the array holds a list of length 2**i. + */ +# define NUM_LISTS 30 + SortElement *subList[NUM_LISTS+1]; + if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "?options? list"); return TCL_ERROR; @@ -3436,11 +3468,11 @@ Tcl_LsortObjCmd( sortInfo.isIncreasing = 1; sortInfo.sortMode = SORTMODE_ASCII; - sortInfo.strCmpFn = strcmp; sortInfo.indexv = NULL; sortInfo.indexc = 0; + sortInfo.unique = 0; sortInfo.interp = interp; - sortInfo.resultCode = TCL_OK; + sortInfo.resultCode = TCL_OK; cmdPtr = NULL; unique = 0; indices = 0; @@ -3477,7 +3509,6 @@ Tcl_LsortObjCmd( sortInfo.isIncreasing = 1; break; case LSORT_INDEX: { - int j; Tcl_Obj **indices; if (sortInfo.indexc > 1) { @@ -3533,19 +3564,24 @@ Tcl_LsortObjCmd( sortInfo.sortMode = SORTMODE_INTEGER; break; case LSORT_NOCASE: - sortInfo.strCmpFn = strcasecmp; + nocase = 1; break; case LSORT_REAL: sortInfo.sortMode = SORTMODE_REAL; break; case LSORT_UNIQUE: unique = 1; + sortInfo.unique = 1; break; case LSORT_INDICES: indices = 1; break; } } + if (nocase && (sortInfo.sortMode == SORTMODE_ASCII)) { + sortInfo.sortMode = SORTMODE_ASCII_NC; + } + listObj = objv[objc-1]; if (sortInfo.sortMode == SORTMODE_COMMAND) { @@ -3594,46 +3630,138 @@ Tcl_LsortObjCmd( if (sortInfo.resultCode != TCL_OK || length <= 0) { goto done; } + sortInfo.numElements = length; + + indexc = sortInfo.indexc; + sortMode = sortInfo.sortMode; + if ((sortMode == SORTMODE_ASCII_NC) + || (sortMode == SORTMODE_DICTIONARY)) { + /* + * For this function's purpose all string-based modes are equivalent + */ + + sortMode = SORTMODE_ASCII; + } + + /* + * Initialize the sublists. After the following loop, subList[i] will + * contain a sorted sublist of length 2**i. Use one extra subList at the + * end, always at NULL, to indicate the end of the lists. + */ + + for (j=0 ; j<=NUM_LISTS ; j++) { + subList[j] = NULL; + } + + /* + * The following loop creates a SortElement for each list element and + * begins sorting it into the sublists as it appears. + */ elementArray = (SortElement *) TclStackAlloc(interp, length * sizeof(SortElement)); + for (i=0; i < length; i++){ - elementArray[i].objPtr = listObjPtrs[i]; - elementArray[i].count = 0; - elementArray[i].nextPtr = &elementArray[i+1]; + if (indexc) { + /* + * If this is an indexed sort, retrieve the corresponding element + */ + indexPtr = SelectObjFromSublist(listObjPtrs[i], &sortInfo); + if (sortInfo.resultCode != TCL_OK) { + goto done1; + } + } else { + indexPtr = listObjPtrs[i]; + } + + /* + * Determine the "value" of this object for sorting purposes + */ + + if (sortMode == SORTMODE_ASCII) { + elementArray[i].index.strValuePtr = TclGetString(indexPtr); + } else if (sortMode == SORTMODE_INTEGER) { + long a; + if (TclGetLongFromObj(sortInfo.interp, indexPtr, &a) != TCL_OK) { + sortInfo.resultCode = TCL_ERROR; + goto done1; + } + elementArray[i].index.intValue = a; + } else if (sortInfo.sortMode == SORTMODE_REAL) { + double a; + if (Tcl_GetDoubleFromObj(sortInfo.interp, indexPtr, &a) != TCL_OK) { + sortInfo.resultCode = TCL_ERROR; + goto done1; + } + elementArray[i].index.doubleValue = a; + } else { + elementArray[i].index.objValuePtr = indexPtr; + } + + /* + * Determine the representation of this element in the result: either + * the objPtr itself, or its index in the original list. + */ + + elementArray[i].objPtr = (indices ? INT2PTR(i) : listObjPtrs[i]); + + /* + * Merge this element in the pre-existing sublists (and merge together + * sublists when we have two of the same size). + */ + + elementArray[i].nextPtr = NULL; + elementPtr = &elementArray[i]; + for (j=0 ; subList[j] ; j++) { + elementPtr = MergeLists(subList[j], elementPtr, &sortInfo); + subList[j] = NULL; + } + if (j >= NUM_LISTS) { + j = NUM_LISTS-1; + } + subList[j] = elementPtr; } - elementArray[length-1].nextPtr = NULL; - elementPtr = MergeSort(elementArray, &sortInfo); + + /* + * Merge all sublists + */ + + elementPtr = subList[0]; + for (j=1 ; j<NUM_LISTS ; j++) { + elementPtr = MergeLists(subList[j], elementPtr, &sortInfo); + } + + + /* + * Now store the sorted elements in the result list. + */ + if (sortInfo.resultCode == TCL_OK) { - resultPtr = Tcl_NewObj(); - if (unique) { - if (indices) { - for (; elementPtr != NULL ; elementPtr = elementPtr->nextPtr){ - if (elementPtr->count == 0) { - Tcl_ListObjAppendElement(NULL, resultPtr, - Tcl_NewIntObj(elementPtr - &elementArray[0])); - } - } - } else { - for (; elementPtr != NULL; elementPtr = elementPtr->nextPtr) { - if (elementPtr->count == 0) { - Tcl_ListObjAppendElement(NULL, resultPtr, - elementPtr->objPtr); - } - } - } - } else if (indices) { - for (; elementPtr != NULL ; elementPtr = elementPtr->nextPtr) { - Tcl_ListObjAppendElement(NULL, resultPtr, - Tcl_NewIntObj(elementPtr - &elementArray[0])); + List *listRepPtr; + Tcl_Obj **newArray, *objPtr; + int i; + + resultPtr = Tcl_NewListObj(sortInfo.numElements, NULL); + listRepPtr = (List *) resultPtr->internalRep.twoPtrValue.ptr1; + newArray = &listRepPtr->elements; + if (indices) { + for (i = 0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr){ + objPtr = Tcl_NewIntObj(PTR2INT(elementPtr->objPtr)); + newArray[i++] = objPtr; + Tcl_IncrRefCount(objPtr); } } else { - for (; elementPtr != NULL; elementPtr = elementPtr->nextPtr) { - Tcl_ListObjAppendElement(NULL, resultPtr, elementPtr->objPtr); + for (i = 0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr){ + objPtr = elementPtr->objPtr; + newArray[i++] = objPtr; + Tcl_IncrRefCount(objPtr); } } + listRepPtr->elemCount = i; Tcl_SetObjResult(interp, resultPtr); } + + done1: TclStackFree(interp, elementArray); done: @@ -3651,62 +3779,6 @@ Tcl_LsortObjCmd( /* *---------------------------------------------------------------------- * - * MergeSort - - * - * This procedure sorts a linked list of SortElement structures use the - * merge-sort algorithm. - * - * Results: - * A pointer to the head of the list after sorting is returned. - * - * Side effects: - * None, unless a user-defined comparison command does something weird. - * - *---------------------------------------------------------------------- - */ - -static SortElement * -MergeSort( - SortElement *headPtr, /* First element on the list. */ - SortInfo *infoPtr) /* Information needed by the comparison - * operator. */ -{ - /* - * The subList array below holds pointers to temporary lists built during - * the merge sort. Element i of the array holds a list of length 2**i. - */ - -# define NUM_LISTS 30 - SortElement *subList[NUM_LISTS]; - SortElement *elementPtr; - int i; - - for (i=0 ; i<NUM_LISTS ; i++) { - subList[i] = NULL; - } - while (headPtr != NULL) { - elementPtr = headPtr; - headPtr = headPtr->nextPtr; - elementPtr->nextPtr = 0; - for (i=0 ; i<NUM_LISTS && subList[i]!=NULL ; i++) { - elementPtr = MergeLists(subList[i], elementPtr, infoPtr); - subList[i] = NULL; - } - if (i >= NUM_LISTS) { - i = NUM_LISTS-1; - } - subList[i] = elementPtr; - } - elementPtr = NULL; - for (i=0 ; i<NUM_LISTS ; i++) { - elementPtr = MergeLists(subList[i], elementPtr, infoPtr); - } - return elementPtr; -} - -/* - *---------------------------------------------------------------------- - * * MergeLists - * * This procedure combines two sorted lists of SortElement structures @@ -3716,8 +3788,21 @@ MergeSort( * The unified list of SortElement structures. * * Side effects: - * None, unless a user-defined comparison command does something weird. + * If infoPtr->unique is set then infoPtr->numElements may be updated. + * Possibly others, if a user-defined comparison command does something + * weird. * + * Note: + * If infoPtr->unique is set, the merge assumes that there are no + * "repeated" elements in each of the left and right lists. In that case, + * if any element of the left list is equivalent to one in the right list + * it is omitted from the merged list. + * This simplified mechanism works because of the special way + * our MergeSort creates the sublists to be merged and will fail to + * eliminate all repeats in the general case where they are already + * present in either the left or right list. A general code would need to + * skip adjacent initial repeats in the left and right lists before + * comparing their initial elements, at each step. *---------------------------------------------------------------------- */ @@ -3737,31 +3822,48 @@ MergeLists( if (rightPtr == NULL) { return leftPtr; } - cmp = SortCompare(leftPtr->objPtr, rightPtr->objPtr, infoPtr); - if (cmp > 0) { + cmp = SortCompare(leftPtr, rightPtr, infoPtr); + if (cmp > 0 || (cmp == 0 && infoPtr->unique)) { + if (cmp == 0) { + infoPtr->numElements--; + leftPtr = leftPtr->nextPtr; + } tailPtr = rightPtr; rightPtr = rightPtr->nextPtr; } else { - if (cmp == 0) { - leftPtr->count++; - } tailPtr = leftPtr; leftPtr = leftPtr->nextPtr; } headPtr = tailPtr; - while ((leftPtr != NULL) && (rightPtr != NULL)) { - cmp = SortCompare(leftPtr->objPtr, rightPtr->objPtr, infoPtr); - if (cmp > 0) { - tailPtr->nextPtr = rightPtr; - tailPtr = rightPtr; - rightPtr = rightPtr->nextPtr; - } else { - if (cmp == 0) { - leftPtr->count++; + if (!infoPtr->unique) { + while ((leftPtr != NULL) && (rightPtr != NULL)) { + cmp = SortCompare(leftPtr, rightPtr, infoPtr); + if (cmp > 0) { + tailPtr->nextPtr = rightPtr; + tailPtr = rightPtr; + rightPtr = rightPtr->nextPtr; + } else { + tailPtr->nextPtr = leftPtr; + tailPtr = leftPtr; + leftPtr = leftPtr->nextPtr; + } + } + } else { + while ((leftPtr != NULL) && (rightPtr != NULL)) { + cmp = SortCompare(leftPtr, rightPtr, infoPtr); + if (cmp >= 0) { + if (cmp == 0) { + infoPtr->numElements--; + leftPtr = leftPtr->nextPtr; + } + tailPtr->nextPtr = rightPtr; + tailPtr = rightPtr; + rightPtr = rightPtr->nextPtr; + } else { + tailPtr->nextPtr = leftPtr; + tailPtr = leftPtr; + leftPtr = leftPtr->nextPtr; } - tailPtr->nextPtr = leftPtr; - tailPtr = leftPtr; - leftPtr = leftPtr->nextPtr; } } if (leftPtr != NULL) { @@ -3794,69 +3896,52 @@ MergeLists( static int SortCompare( - Tcl_Obj *objPtr1, Tcl_Obj *objPtr2, + SortElement *elemPtr1, SortElement *elemPtr2, /* Values to be compared. */ SortInfo *infoPtr) /* Information passed from the top-level * "lsort" command. */ { - int order; - - order = 0; - if (infoPtr->resultCode != TCL_OK) { - /* - * Once an error has occurred, skip any future comparisons so as to - * preserve the error message in sortInterp->result. - */ - - return order; - } - - objPtr1 = SelectObjFromSublist(objPtr1, infoPtr); - if (infoPtr->resultCode != TCL_OK) { - return order; - } - objPtr2 = SelectObjFromSublist(objPtr2, infoPtr); - if (infoPtr->resultCode != TCL_OK) { - return order; - } + int order = 0; if (infoPtr->sortMode == SORTMODE_ASCII) { - order = infoPtr->strCmpFn(TclGetString(objPtr1), - TclGetString(objPtr2)); + order = strcmp(elemPtr1->index.strValuePtr, + elemPtr2->index.strValuePtr); + } else if (infoPtr->sortMode == SORTMODE_ASCII_NC) { + order = strcasecmp(elemPtr1->index.strValuePtr, + elemPtr2->index.strValuePtr); } else if (infoPtr->sortMode == SORTMODE_DICTIONARY) { - order = DictionaryCompare( - TclGetString(objPtr1), TclGetString(objPtr2)); + order = DictionaryCompare(elemPtr1->index.strValuePtr, + elemPtr2->index.strValuePtr); } else if (infoPtr->sortMode == SORTMODE_INTEGER) { long a, b; - if ((TclGetLongFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK) - || (TclGetLongFromObj(infoPtr->interp, objPtr2, &b) - != TCL_OK)) { - infoPtr->resultCode = TCL_ERROR; - return order; - } - if (a > b) { - order = 1; - } else if (b > a) { - order = -1; - } + a = elemPtr1->index.intValue; + b = elemPtr2->index.intValue; + order = ((a >= b) - (a <= b)); } else if (infoPtr->sortMode == SORTMODE_REAL) { double a, b; - if (Tcl_GetDoubleFromObj(infoPtr->interp, objPtr1, &a) != TCL_OK || - Tcl_GetDoubleFromObj(infoPtr->interp, objPtr2, &b) != TCL_OK){ - infoPtr->resultCode = TCL_ERROR; - return order; - } - if (a > b) { - order = 1; - } else if (b > a) { - order = -1; - } + a = elemPtr1->index.doubleValue; + b = elemPtr2->index.doubleValue; + order = ((a >= b) - (a <= b)); } else { Tcl_Obj **objv, *paramObjv[2]; int objc; + Tcl_Obj *objPtr1, *objPtr2; + + if (infoPtr->resultCode != TCL_OK) { + /* + * Once an error has occurred, skip any future comparisons so as + * to preserve the error message in sortInterp->result. + */ + + return 0; + } + + objPtr1 = elemPtr1->index.objValuePtr; + objPtr2 = elemPtr2->index.objValuePtr; + paramObjv[0] = objPtr1; paramObjv[1] = objPtr2; @@ -3876,7 +3961,7 @@ SortCompare( if (infoPtr->resultCode != TCL_OK) { Tcl_AddErrorInfo(infoPtr->interp, "\n (-compare command)"); - return order; + return 0; } /* @@ -3889,7 +3974,7 @@ SortCompare( Tcl_AppendResult(infoPtr->interp, "-compare command returned non-integer result", NULL); infoPtr->resultCode = TCL_ERROR; - return order; + return 0; } } if (!infoPtr->isIncreasing) { diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 24d72d2..d66f672 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompCmds.c,v 1.109.2.17 2007/12/10 18:32:55 dgp Exp $ + * RCS: @(#) $Id: tclCompCmds.c,v 1.109.2.18 2008/01/23 16:42:18 dgp Exp $ */ #include "tclInt.h" @@ -3134,6 +3134,7 @@ TclCompileRegexpCmd( /* * Get the regexp string. If it is not a simple string or can't be * converted to a glob pattern, push the word for the INST_REGEXP. + * Keep changes here in sync with TclCompileSwitchCmd Switch_Regexp. */ varTokenPtr = TokenAfter(varTokenPtr); @@ -3194,10 +3195,9 @@ TclCompileRegexpCmd( /* * Pass correct RE compile flags. We use only Int1 (8-bit), but * that handles all the flags we want to pass. - * Use TCL_REG_NOSUB as we don't have capture vars. + * Don't use TCL_REG_NOSUB as we may have backrefs. */ - int cflags = TCL_REG_ADVANCED | TCL_REG_NOSUB - | (nocase ? TCL_REG_NOCASE : 0); + int cflags = TCL_REG_ADVANCED | (nocase ? TCL_REG_NOCASE : 0); TclEmitInstInt1(INST_REGEXP, cflags, envPtr); } @@ -4397,6 +4397,9 @@ TclCompileSwitchCmd( case Switch_Regexp: { int simple = 0, exact = 0; + /* + * Keep in sync with TclCompileRegexpCmd. + */ if (bodyToken[i]->type == TCL_TOKEN_TEXT) { Tcl_DString ds; @@ -4435,7 +4438,15 @@ TclCompileSwitchCmd( TclEmitInstInt1(INST_STR_MATCH, noCase, envPtr); } } else { - TclEmitInstInt1(INST_REGEXP, noCase, envPtr); + /* + * Pass correct RE compile flags. We use only Int1 + * (8-bit), but that handles all the flags we want to + * pass. Don't use TCL_REG_NOSUB as we may have backrefs + * or capture vars. + */ + int cflags = TCL_REG_ADVANCED + | (noCase ? TCL_REG_NOCASE : 0); + TclEmitInstInt1(INST_REGEXP, cflags, envPtr); } break; } diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 4500b29..13075d7 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompExpr.c,v 1.53.2.12 2007/11/12 19:18:15 dgp Exp $ + * RCS: @(#) $Id: tclCompExpr.c,v 1.53.2.13 2008/01/23 16:42:18 dgp Exp $ */ #include "tclInt.h" @@ -833,47 +833,29 @@ ParseExpr( switch (lexeme) { case NUMBER: - case BOOLEAN: { - if (interp) { - int new; - /* LiteralEntry *lePtr; */ - Tcl_Obj *objPtr = TclCreateLiteral((Interp *)interp, - (char *)start, scanned, - /* hash */ (unsigned int) -1, &new, - /* nsPtr */ NULL, /* flags */ 0, - NULL /* &lePtr */); - if (objPtr->typePtr != literal->typePtr) { - /* - * What we would like to do is this: - * - * lePtr->objPtr = literal; - * Tcl_IncrRefCount(literal); - * Tcl_DecrRefCount(objPtr); - * - * However, the design of the "global" and "local" - * LiteralTable does not permit the value of - * lePtr->objPtr to be changed. So rather than - * replace lePtr->objPtr, we do surgery to transfer - * the intrep of literal into it. Ugly stuff here - * that's generally unsafe, but ok here since we know - * the Tcl_ObjTypes literal might possibly have. - */ - Tcl_Obj *toFree = literal; - literal = objPtr; - TclFreeIntRep(literal); - literal->typePtr = toFree->typePtr; - literal->internalRep = toFree->internalRep; - toFree->typePtr = NULL; - Tcl_DecrRefCount(toFree); - } - } - + case BOOLEAN: + /* + * TODO: Consider using a dict or hash to collapse all + * duplicate literals into a single representative value. + * (Like what is done with [split $s {}]). + * Pro: ~75% memory saving on expressions like + * {1+1+1+1+1+.....+1} (Convert "pointer + Tcl_Obj" cost + * to "pointer" cost only) + * Con: Cost of the dict store/retrieve on every literal + * in every expression when expressions like the above + * tend to be uncommon. + * The memory savings is temporary; Compiling to bytecode + * will collapse things as literals are registered + * anyway, so the savings applies only to the time + * between parsing and compiling. Possibly important + * due to high-water mark nature of memory allocation. + */ Tcl_ListObjAppendElement(NULL, litList, literal); complete = lastParsed = OT_LITERAL; start += scanned; numBytes -= scanned; continue; - } + default: break; } @@ -2034,7 +2016,8 @@ TclCompileExpr( Tcl_Interp *interp, /* Used for error reporting. */ const char *script, /* The source script to compile. */ int numBytes, /* Number of bytes in script. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ + CompileEnv *envPtr, /* Holds resulting instructions. */ + int optimize) /* 0 for one-off expressions */ { OpNode *opTree = NULL; /* Will point to the tree of operators */ Tcl_Obj *litList = Tcl_NewObj(); /* List to hold the literals */ @@ -2060,7 +2043,7 @@ TclCompileExpr( TclListObjGetElements(NULL, litList, &objc, (Tcl_Obj ***)&litObjv); TclListObjGetElements(NULL, funcList, &objc, &funcObjv); CompileExprTree(interp, opTree, 0, &litObjv, funcObjv, - parsePtr->tokenPtr, envPtr, 1 /* optimize */); + parsePtr->tokenPtr, envPtr, optimize); } else { TclCompileSyntaxError(interp, envPtr); } @@ -2345,10 +2328,46 @@ CompileExprTree( case OT_LITERAL: { Tcl_Obj *const *litObjv = *litObjvPtr; Tcl_Obj *literal = *litObjv; - int length; - const char *bytes = TclGetStringFromObj(literal, &length); - TclEmitPush(TclRegisterNewLiteral(envPtr, bytes, length), envPtr); + if (optimize) { + int length, index; + const char *bytes = TclGetStringFromObj(literal, &length); + LiteralEntry *lePtr; + Tcl_Obj *objPtr; + + index = TclRegisterNewLiteral(envPtr, bytes, length); + lePtr = envPtr->literalArrayPtr + index; + objPtr = lePtr->objPtr; + if ((objPtr->typePtr == NULL) && (literal->typePtr != NULL)) { + /* + * Would like to do this: + * + * lePtr->objPtr = literal; + * Tcl_IncrRefCount(literal); + * Tcl_DecrRefCount(objPtr); + * + * However, the design of the "global" and "local" + * LiteralTable does not permit the value of lePtr->objPtr + * to change. So rather than replace lePtr->objPtr, we + * do surgery to transfer our desired intrep into it. + * + */ + objPtr->typePtr = literal->typePtr; + objPtr->internalRep = literal->internalRep; + literal->typePtr = NULL; + } + TclEmitPush(index, envPtr); + } else { + /* + * When optimize==0, we know the expression is a one-off + * and there's nothing to be gained from sharing literals + * when they won't live long, and the copies we have already + * have an appropriate intrep. In this case, skip literal + * registration that would enable sharing, and use the routine + * that preserves intreps. + */ + TclEmitPush(TclAddLiteralObj(envPtr, literal, NULL), envPtr); + } (*litObjvPtr)++; break; } @@ -2411,7 +2430,7 @@ TclSingleOpCmd( return TCL_ERROR; } - ParseLexeme(occdPtr->operator, strlen(occdPtr->operator), &lexeme, NULL); + ParseLexeme(occdPtr->op, strlen(occdPtr->op), &lexeme, NULL); nodes[0].lexeme = START; nodes[0].mark = MARK_RIGHT; nodes[0].right = 1; @@ -2467,8 +2486,7 @@ TclSortingOpCmd( int i, lastAnd = 1; Tcl_Obj *const *litObjPtrPtr = litObjv; - ParseLexeme(occdPtr->operator, strlen(occdPtr->operator), - &lexeme, NULL); + ParseLexeme(occdPtr->op, strlen(occdPtr->op), &lexeme, NULL); litObjv[0] = objv[1]; nodes[0].lexeme = START; @@ -2544,7 +2562,7 @@ TclVariadicOpCmd( return TCL_OK; } - ParseLexeme(occdPtr->operator, strlen(occdPtr->operator), &lexeme, NULL); + ParseLexeme(occdPtr->op, strlen(occdPtr->op), &lexeme, NULL); lexeme |= BINARY; if (objc == 2) { diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 77623c2..9a97dfb 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompile.c,v 1.117.2.15 2007/11/21 06:30:49 dgp Exp $ + * RCS: @(#) $Id: tclCompile.c,v 1.117.2.16 2008/01/23 16:42:18 dgp Exp $ */ #include "tclInt.h" @@ -1823,7 +1823,7 @@ TclCompileExprWords( */ if ((numWords == 1) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) { - TclCompileExpr(interp, tokenPtr[1].start, tokenPtr[1].size, envPtr); + TclCompileExpr(interp, tokenPtr[1].start, tokenPtr[1].size, envPtr, 1); return; } diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 8d94530..44367c9 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompile.h,v 1.70.2.12 2007/11/16 07:20:53 dgp Exp $ + * RCS: @(#) $Id: tclCompile.h,v 1.70.2.13 2008/01/23 16:42:18 dgp Exp $ */ #ifndef _TCLCOMPILATION @@ -817,7 +817,7 @@ MODULE_SCOPE AuxDataType tclDictUpdateInfoType; */ typedef struct { - const char *operator; + const char *op; /* Do not call it 'operator': C++ reserved */ const char *expected; union { int numArgs; @@ -858,7 +858,7 @@ MODULE_SCOPE void TclCompileCmdWord(Tcl_Interp *interp, Tcl_Token *tokenPtr, int count, CompileEnv *envPtr); MODULE_SCOPE void TclCompileExpr(Tcl_Interp *interp, CONST char *script, - int numBytes, CompileEnv *envPtr); + int numBytes, CompileEnv *envPtr, int optimize); MODULE_SCOPE void TclCompileExprWords(Tcl_Interp *interp, Tcl_Token *tokenPtr, int numWords, CompileEnv *envPtr); diff --git a/generic/tclExecute.c b/generic/tclExecute.c index f0d74c1..a2d1310 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclExecute.c,v 1.285.2.27 2007/12/11 16:19:54 dgp Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.285.2.28 2008/01/23 16:42:18 dgp Exp $ */ #include "tclInt.h" @@ -836,6 +836,36 @@ TclFinalizeExecution(void) } /* + * Auxiliary code to insure that GrowEvaluationStack always returns correctly + * aligned memory. This assumes that TCL_ALLOCALIGN is a multiple of the + * wordsize 'sizeof(Tcl_Obj *)'. + */ + +#define WALLOCALIGN \ + (TCL_ALLOCALIGN/sizeof(Tcl_Obj *)) + +static inline int +OFFSET( + Tcl_Obj **markerPtr) +{ + /* + * Note that we are only interested in the low bits of the address, so + * that the fact that PTR2INT may lose the high bits is irrelevant. + */ + + int mask, base, new; + + mask = WALLOCALIGN-1; + base = (PTR2INT(markerPtr) & mask); + new = ((base + 1) + mask) & ~mask; + return (new - base); +} + +#define MEMSTART(markerPtr) \ + ((markerPtr) + OFFSET(markerPtr)) + + +/* *---------------------------------------------------------------------- * * GrowEvaluationStack -- @@ -865,36 +895,44 @@ GrowEvaluationStack( ExecStack *esPtr = eePtr->execStackPtr, *oldPtr = NULL; int newBytes, newElems, currElems; int needed = growth - (esPtr->endPtr - esPtr->tosPtr); - Tcl_Obj **markerPtr = esPtr->markerPtr; + Tcl_Obj **markerPtr = esPtr->markerPtr, **memStart; if (move) { if (!markerPtr) { Tcl_Panic("STACK: Reallocating with no previous alloc"); } if (needed <= 0) { - return markerPtr + 1; + return MEMSTART(markerPtr); } - } else if (needed < 0) { - /* - * Put a marker pointing to the previous marker in this stack, and - * store it in esPtr as the current marker. Return a pointer to one - * word past the marker. - */ + } else { + Tcl_Obj **tmpMarkerPtr = esPtr->tosPtr + 1; + int offset = OFFSET(tmpMarkerPtr); - esPtr->markerPtr = ++esPtr->tosPtr; - *esPtr->markerPtr = (Tcl_Obj *) markerPtr; - return esPtr->markerPtr + 1; + if (needed + offset < 0) { + /* + * Put a marker pointing to the previous marker in this stack, and + * store it in esPtr as the current marker. Return a pointer to + * the start of aligned memory. + */ + + esPtr->markerPtr = tmpMarkerPtr; + memStart = tmpMarkerPtr + offset; + esPtr->tosPtr = memStart - 1; + *esPtr->markerPtr = (Tcl_Obj *) markerPtr; + return memStart; + } } /* * Reset move to hold the number of words to be moved to new stack (if - * any) and growth to hold the complete stack requirements. + * any) and growth to hold the complete stack requirements: add the marker + * and maximal possible offset. */ if (move) { - move = esPtr->tosPtr - markerPtr; + move = esPtr->tosPtr - MEMSTART(markerPtr) + 1; } - needed = growth + move + 1; /* Add the marker. */ + needed = growth + move + WALLOCALIGN - 1; /* * Check if there is enough room in the next stack (if there is one, it @@ -949,10 +987,12 @@ GrowEvaluationStack( */ esPtr->stackWords[0] = NULL; - esPtr->markerPtr = esPtr->tosPtr = &esPtr->stackWords[0]; - + esPtr->markerPtr = &esPtr->stackWords[0]; + memStart = MEMSTART(esPtr->markerPtr); + esPtr->tosPtr = memStart - 1; + if (move) { - memcpy(&esPtr->stackWords[1], (markerPtr+1), move*sizeof(Tcl_Obj *)); + memcpy(memStart, MEMSTART(markerPtr), move*sizeof(Tcl_Obj *)); esPtr->tosPtr += move; oldPtr->markerPtr = (Tcl_Obj **) *markerPtr; oldPtr->tosPtr = markerPtr-1; @@ -966,7 +1006,7 @@ GrowEvaluationStack( DeleteExecStack(oldPtr); } - return &esPtr->stackWords[1]; + return memStart; } /* @@ -1043,7 +1083,7 @@ TclStackFree( esPtr = eePtr->execStackPtr; markerPtr = esPtr->markerPtr; - if ((markerPtr+1) != (Tcl_Obj **)freePtr) { + if (MEMSTART(markerPtr) != (Tcl_Obj **)freePtr) { Tcl_Panic("TclStackFree: incorrect freePtr. Call out of sequence?"); } @@ -1104,7 +1144,7 @@ TclStackRealloc( esPtr = eePtr->execStackPtr; markerPtr = esPtr->markerPtr; - if ((markerPtr+1) != (Tcl_Obj **)ptr) { + if (MEMSTART(markerPtr) != (Tcl_Obj **)ptr) { Tcl_Panic("TclStackRealloc: incorrect ptr. Call out of sequence?"); } @@ -1188,7 +1228,7 @@ Tcl_ExprObj( const char *string = TclGetStringFromObj(objPtr, &length); TclInitCompileEnv(interp, &compEnv, string, length, NULL, 0); - TclCompileExpr(interp, string, length, &compEnv); + TclCompileExpr(interp, string, length, &compEnv, 0); /* * Successful compilation. If the expression yielded no instructions, diff --git a/generic/tclIO.c b/generic/tclIO.c index af0055e..d9f2d39 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIO.c,v 1.121.2.8 2007/12/10 18:32:56 dgp Exp $ + * RCS: @(#) $Id: tclIO.c,v 1.121.2.9 2008/01/23 16:42:18 dgp Exp $ */ #include "tclInt.h" @@ -3953,12 +3953,6 @@ Tcl_GetsObj( char *dst, *dstEnd, *eol, *eof; Tcl_EncodingState oldState; - /* - * This operation should occur at the top of a channel stack. - */ - - chanPtr = statePtr->topChanPtr; - if (CheckChannelErrors(statePtr, TCL_READABLE) != 0) { copiedTotal = -1; goto done; @@ -3976,6 +3970,12 @@ Tcl_GetsObj( return TclGetsObjBinary(chan, objPtr); } + /* + * This operation should occur at the top of a channel stack. + */ + + chanPtr = statePtr->topChanPtr; + bufPtr = statePtr->inQueueHead; encoding = statePtr->encoding; @@ -4316,6 +4316,12 @@ TclGetsObjBinary( int rawLen, byteLen, eolChar; unsigned char *dst, *dstEnd, *eol, *eof, *byteArray; + /* + * This operation should occur at the top of a channel stack. + */ + + chanPtr = statePtr->topChanPtr; + bufPtr = statePtr->inQueueHead; /* diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index e32578d..43be6fb 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -17,7 +17,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclIOUtil.c,v 1.145.2.2 2007/11/12 19:18:17 dgp Exp $ + * RCS: @(#) $Id: tclIOUtil.c,v 1.145.2.3 2008/01/23 16:42:19 dgp Exp $ */ #include "tclInt.h" @@ -1236,10 +1236,8 @@ FsAddMountsToGlobResult( } } if (!found && dir) { - int len, mlen; - const char *path; - const char *mount; Tcl_Obj *norm; + int len, mlen; /* * We know mElt is absolute normalized and lies inside pathPtr, so @@ -1247,9 +1245,11 @@ FsAddMountsToGlobResult( * i.e. the representation which is relative to pathPtr. */ - mount = Tcl_GetStringFromObj(mElt, &mlen); norm = Tcl_FSGetNormalizedPath(NULL, pathPtr); if (norm != NULL) { + const char *path, *mount; + + mount = Tcl_GetStringFromObj(mElt, &mlen); path = Tcl_GetStringFromObj(norm, &len); if (path[len-1] == '/') { /* @@ -1258,7 +1258,8 @@ FsAddMountsToGlobResult( len--; } - mElt = TclNewFSPathObj(pathPtr, mount + len + 1, mlen - len); + len++; /* account for '/' in the mElt [Bug 1602539] */ + mElt = TclNewFSPathObj(pathPtr, mount + len, mlen - len); Tcl_ListObjAppendElement(NULL, resultPtr, mElt); } /* diff --git a/generic/tclInt.h b/generic/tclInt.h index e0f716d..3ea4415 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -13,7 +13,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.310.2.23 2007/12/11 16:19:55 dgp Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.310.2.24 2008/01/23 16:42:19 dgp Exp $ */ #ifndef _TCLINT @@ -2034,6 +2034,17 @@ struct LimitHandler { #define UCHAR(c) ((unsigned char) (c)) /* + * This macro is used to properly align the memory allocated by Tcl, giving + * the same alignment as the native malloc + */ + +#if defined(__APPLE__) +#define TCL_ALLOCALIGN 16 +#else +#define TCL_ALLOCALIGN (2*sizeof(void *)) +#endif + +/* * This macro is used to determine the offset needed to safely allocate any * data structure in memory. Given a starting offset or size, it "rounds up" * or "aligns" the offset to the next 8-byte boundary so that any data diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index c085e36..23fdcfd 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -33,7 +33,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclStringObj.c,v 1.65.2.2 2007/11/21 06:30:54 dgp Exp $ */ + * RCS: @(#) $Id: tclStringObj.c,v 1.65.2.3 2008/01/23 16:42:19 dgp Exp $ */ #include "tclInt.h" #include "tommath.h" @@ -2105,7 +2105,7 @@ Tcl_AppendFormatToObj( numDigits++; uw /= base; } - } else if (useBig) { + } else if (useBig && big.used) { int leftover = (big.used * DIGIT_BIT) % numBits; mp_digit mask = (~(mp_digit)0) << (DIGIT_BIT-leftover); @@ -2114,7 +2114,7 @@ Tcl_AppendFormatToObj( numDigits--; mask >>= numBits; } - } else { + } else if (!useBig) { unsigned long int ul = (unsigned long int) l; bits = (Tcl_WideUInt) ul; @@ -2138,7 +2138,7 @@ Tcl_AppendFormatToObj( while (numDigits--) { int digitOffset; - if (useBig) { + if (useBig && big.used) { if ((size_t) shift < CHAR_BIT*sizeof(Tcl_WideUInt) - DIGIT_BIT) { bits |= (((Tcl_WideUInt)big.dp[index++]) <<shift); diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c index 2a77ea6..eaf1b7d 100755 --- a/generic/tclThreadAlloc.c +++ b/generic/tclThreadAlloc.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclThreadAlloc.c,v 1.21.6.2 2007/11/21 06:30:54 dgp Exp $ + * RCS: @(#) $Id: tclThreadAlloc.c,v 1.21.6.3 2008/01/23 16:42:19 dgp Exp $ */ #include "tclInt.h" @@ -40,16 +40,6 @@ #define NOBJHIGH 1200 /* - * Alignment for allocated memory. - */ - -#if defined(__APPLE__) -#define ALLOCALIGN 16 -#else -#define ALLOCALIGN 8 -#endif - -/* * The following union stores accounting information for each block including * two small magic numbers and a bucket number when in use or a next pointer * when free. The original requested size (not including the Block overhead) @@ -69,7 +59,7 @@ typedef union Block { } u; size_t reqSize; /* Requested allocation size. */ } b; - unsigned char padding[ALLOCALIGN]; + unsigned char padding[TCL_ALLOCALIGN]; } Block; #define nextBlock b.u.next #define sourceBucket b.u.s.bucket @@ -83,7 +73,7 @@ typedef union Block { * of buckets in the bucket cache. */ -#define MINALLOC ((sizeof(Block) + 8 + (ALLOCALIGN-1)) & ~(ALLOCALIGN-1)) +#define MINALLOC ((sizeof(Block) + 8 + (TCL_ALLOCALIGN-1)) & ~(TCL_ALLOCALIGN-1)) #define NBUCKETS (11 - (MINALLOC >> 5)) #define MAXALLOC (MINALLOC << (NBUCKETS - 1)) diff --git a/generic/tclTimer.c b/generic/tclTimer.c index d4970b7..b21a17a 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclTimer.c,v 1.28.2.1 2007/09/06 18:20:31 dgp Exp $ + * RCS: @(#) $Id: tclTimer.c,v 1.28.2.2 2008/01/23 16:42:19 dgp Exp $ */ #include "tclInt.h" @@ -1121,8 +1121,6 @@ AfterProc( AfterInfo *prevPtr; int result; Tcl_Interp *interp; - char *script; - int numBytes; /* * First remove the callback from our list of callbacks; otherwise someone @@ -1146,13 +1144,7 @@ AfterProc( interp = assocPtr->interp; Tcl_Preserve((ClientData) interp); -#if 0 - /* DKF: Why not just do this? */ result = Tcl_EvalObjEx(interp, afterPtr->commandPtr, TCL_EVAL_GLOBAL); -#else - script = Tcl_GetStringFromObj(afterPtr->commandPtr, &numBytes); - result = Tcl_EvalEx(interp, script, numBytes, TCL_EVAL_GLOBAL); -#endif if (result != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (\"after\" script)"); TclBackgroundException(interp, result); diff --git a/library/init.tcl b/library/init.tcl index e6b848c..caaa88e 100644 --- a/library/init.tcl +++ b/library/init.tcl @@ -3,7 +3,7 @@ # Default system startup file for Tcl-based applications. Defines # "unknown" procedure and auto-load facilities. # -# RCS: @(#) $Id: init.tcl,v 1.91.2.7 2007/12/06 16:27:46 dgp Exp $ +# RCS: @(#) $Id: init.tcl,v 1.91.2.8 2008/01/23 16:42:19 dgp Exp $ # # Copyright (c) 1991-1993 The Regents of the University of California. # Copyright (c) 1994-1996 Sun Microsystems, Inc. @@ -17,7 +17,7 @@ if {[info commands package] == ""} { error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]" } -package require -exact Tcl 8.5.0 +package require -exact Tcl 8.5.1b1 # Compute the auto path to use in this interpreter. # The values on the path come from several locations: diff --git a/tests/cmdIL.test b/tests/cmdIL.test index 0987244..78dcb0a 100644 --- a/tests/cmdIL.test +++ b/tests/cmdIL.test @@ -8,7 +8,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: cmdIL.test,v 1.33.2.1 2007/10/16 03:50:32 dgp Exp $ +# RCS: @(#) $Id: cmdIL.test,v 1.33.2.2 2008/01/23 16:42:20 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -175,6 +175,9 @@ test cmdIL-3.3 {SortCompare procedure, -index option} { } {1 {element 2 missing from sublist "20 10"}} test cmdIL-3.4 {SortCompare procedure, -index option} { list [catch {lsort -integer -index 2 "{a b c} \\\{"} msg] $msg +} {1 {expected integer but got "c"}} +test cmdIL-3.4.1 {SortCompare procedure, -index option} { + list [catch {lsort -integer -index 2 "{1 2 3} \\\{"} msg] $msg } {1 {unmatched open brace in list}} test cmdIL-3.5 {SortCompare procedure, -index option} { list [catch {lsort -integer -index 2 {{20 10 13} {15}}} msg] $msg @@ -747,6 +750,9 @@ test cmdIL-7.5 {lreverse command - unshared object} { test cmdIL-7.6 {lreverse command - unshared object [Bug 1672585]} { lreverse [set x {1 2 3}][unset x] } {3 2 1} +test cmdIL-7.7 {lreverse command - empty object [Bug 1876793]} { + lreverse [list] +} {} testConstraint testobj [llength [info commands testobj]] test cmdIL-7.7 {lreverse command - shared intrep [Bug 1675044]} -setup { diff --git a/tests/compExpr.test b/tests/compExpr.test index fad8a43..150a63d 100644 --- a/tests/compExpr.test +++ b/tests/compExpr.test @@ -8,7 +8,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: compExpr.test,v 1.13.6.2 2007/10/16 03:50:32 dgp Exp $ +# RCS: @(#) $Id: compExpr.test,v 1.13.6.3 2008/01/23 16:42:20 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -342,6 +342,25 @@ test compExpr-7.1 {Memory Leak} -constraints memory -setup { rename getbytes {} } -result 0 +test compExpr-7.2 {[Bug 1869989]: expr parser memleak} -constraints memory -setup { + proc getbytes {} { + set lines [split [memory info] \n] + lindex $lines 3 3 + } +} -body { + set i 5 + set end [getbytes] + while {[incr i -1]} { + expr ${i}000 + set tmp $end + set end [getbytes] + } + set leakedBytes [expr {$end - $tmp}] +} -cleanup { + unset end i tmp + rename getbytes {} +} -result 0 + # cleanup catch {unset a} catch {unset b} diff --git a/tests/format.test b/tests/format.test index 321f52f..ecefa73 100644 --- a/tests/format.test +++ b/tests/format.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: format.test,v 1.24 2006/03/21 11:12:29 dkf Exp $ +# RCS: @(#) $Id: format.test,v 1.24.6.1 2008/01/23 16:42:20 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -553,6 +553,10 @@ test format-19.1 { list [expr { ~ $x }] [format %08x [expr { ~$x }]] } -match regexp -result {-2414724693 f*701239ab} +test format-19.2 {Bug 1867855} { + format %llx 0 +} 0 + # cleanup catch {unset a} catch {unset b} diff --git a/tests/reg.test b/tests/reg.test index 40b8766..e54aa88 100644 --- a/tests/reg.test +++ b/tests/reg.test @@ -9,7 +9,7 @@ # # Copyright (c) 1998, 1999 Henry Spencer. All rights reserved. # -# RCS: @(#) $Id: reg.test,v 1.23 2006/11/03 00:34:53 hobbs Exp $ +# RCS: @(#) $Id: reg.test,v 1.23.2.1 2008/01/23 16:42:20 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -1057,6 +1057,15 @@ test reg-33.11 {Bug 840258} { regsub {(^|[\n\r]+)\.*\?<.*?(\n|\r)+} \ "TQ\r\n.?<5000267>Test already stopped\r\n" {} tmp } 1 +test reg-33.12 {Bug 1810264 - bad read} { + regexp {\3161573148} {\3161573148} +} 0 +test reg-33.13 {Bug 1810264 - infinite loop} { + regexp {($|^)*} {x} +} 1 +test reg-33.14 {Bug 1810264 - super-expensive expression} { + regexp {(x{200}){200}$y} {x} +} 0 # cleanup ::tcltest::cleanupTests diff --git a/tests/regexp.test b/tests/regexp.test index c540c6f..e885a73 100644 --- a/tests/regexp.test +++ b/tests/regexp.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: regexp.test,v 1.27.8.1 2007/11/16 07:20:56 dgp Exp $ +# RCS: @(#) $Id: regexp.test,v 1.27.8.2 2008/01/23 16:42:20 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -659,6 +659,9 @@ test regexp-22.1 {Bug 1810038} { regexp ($|^X)* {} } 1 +test regexp-22.2 {regexp compile and backrefs, Bug 1857126} { + regexp -- {([bc])\1} bb +} 1 # cleanup ::tcltest::cleanupTests diff --git a/tests/regexpComp.test b/tests/regexpComp.test index 8460006..c104a69 100644 --- a/tests/regexpComp.test +++ b/tests/regexpComp.test @@ -802,6 +802,18 @@ test regexpComp-21.11 {regexp command compiling tests} { } } {0 {}} +test regexpComp-22.1 {Bug 1810038} { + evalInProc { + regexp ($|^X)* {} + } +} 1 + +test regexpComp-22.2 {regexp compile and backrefs, Bug 1857126} { + evalInProc { + regexp -- {([bc])\1} bb + } +} 1 + set i 0 foreach {str exp result} { foo ^foo 1 diff --git a/tests/switch.test b/tests/switch.test index 5304835..612131d 100644 --- a/tests/switch.test +++ b/tests/switch.test @@ -11,7 +11,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: switch.test,v 1.16.4.1 2007/12/04 16:55:54 dgp Exp $ +# RCS: @(#) $Id: switch.test,v 1.16.4.2 2008/01/23 16:42:21 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -595,6 +595,41 @@ test switch-13.6 {-indexvar -matchvar combinations} { } msg] $x $y $msg } {1 {{0 1}} - {can't set "y(y)": variable isn't array}} +test switch-14.1 {-regexp -- compilation [Bug 1854399]} { + switch -regexp -- 0 { + {[0-9]+} {return yes} + default {return no} + } + foo +} yes +test switch-14.2 {-regexp -- compilation [Bug 1854399]} { + proc foo {} { + switch -regexp -- 0 { + {[0-9]+} {return yes} + default {return no} + } + } + foo +} yes +test switch-14.3 {-regexp -- compilation [Bug 1854399]} { + proc foo {} { + switch -regexp -- 0 { + {\d+} {return yes} + default {return no} + } + } + foo +} yes +test switch-14.4 {-regexp -- compilation [Bug 1854399]} { + proc foo {} { + switch -regexp -- 0 { + {0} {return yes} + default {return no} + } + } + foo +} yes + # cleanup ::tcltest::cleanupTests return diff --git a/tests/winFile.test b/tests/winFile.test index c08cc20..13d48a1 100644 --- a/tests/winFile.test +++ b/tests/winFile.test @@ -10,7 +10,7 @@ # See the file "license.terms" for information on usage and redistribution of # this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: winFile.test,v 1.19 2006/10/01 09:51:05 patthoyts Exp $ +# RCS: @(#) $Id: winFile.test,v 1.19.6.1 2008/01/23 16:42:21 dgp Exp $ if {[catch {package require tcltest 2.0.2}]} { puts stderr "Skipping tests in [info script]. tcltest 2.0.2 required." @@ -95,6 +95,9 @@ proc cacls {fname args} { # dir/q output: # 2003-11-03 20:36 598 OCTAVIAN\benny filename.txt +# Note this output from a german win2k machine: +# 14.12.2007 14:26 30 VORDEFINIERT\Administratest.dat +# # Modified to cope with Msys environment and use ls -l. proc getuser {fname} { global env @@ -112,7 +115,7 @@ proc getuser {fname} { } else { set dirtext [exec cmd /c dir /q [file nativename $fname]] foreach line [split $dirtext "\n"] { - if {[string match -nocase "* $tail" $line]} { + if {[string match -nocase "*$tail" $line]} { set attrs [string range $line \ 0 end-[string length $tail]] regexp { [^ \\]+\\.*$} $attrs owner diff --git a/tools/tcltk-man2html.tcl b/tools/tcltk-man2html.tcl index c12b643..21f70d4 100755 --- a/tools/tcltk-man2html.tcl +++ b/tools/tcltk-man2html.tcl @@ -1731,7 +1731,7 @@ proc make-man-pages {html args} { set manual($manual(name)-title) \ "[lrange $rest 1 end] [lindex $rest 0] manual page" } elseif {[next-op-is .TH rest]} { - set manual($manual(name)-title) "[lrange $rest 4 end] - [lindex $rest 0] manual page" + set manual($manual(name)-title) "[lindex $rest 0] manual page - [lrange $rest 4 end]" } else { set haserror 1 manerror "no .HS or .TH record found" diff --git a/unix/README b/unix/README index 5ab2263..2c92bf4 100644 --- a/unix/README +++ b/unix/README @@ -1,7 +1,7 @@ Tcl UNIX README --------------- -RCS: @(#) $Id: README,v 1.26.8.2 2007/12/10 18:33:38 dgp Exp $ +RCS: @(#) $Id: README,v 1.26.8.3 2008/01/23 16:42:21 dgp Exp $ This is the directory where you configure, compile, test, and install UNIX versions of Tcl. This directory also contains source files for Tcl @@ -93,7 +93,7 @@ How To Compile And Install Tcl: using naked fork (i.e. not followed by execve). Note: by default gcc will be used if it can be located on the PATH. - if you want to use cc instead of gcc, set the CC environment variable + If you want to use cc instead of gcc, set the CC environment variable to "cc" before running configure. It is not safe to edit the Makefile to use gcc after configure is run. Also note that you should use the same compiler when building extensions. @@ -112,8 +112,8 @@ How To Compile And Install Tcl: for your site or possibly modify the distribution in other ways. First check the porting Web page above to see if there are hints for compiling on your system. If you need to modify Makefile, - are comments at the beginning of it that describe the things you - might want to change and how to change them. + there are comments at the beginning of it that describe the things + you might want to change and how to change them. (f) Type "make install" to install Tcl binaries and script files in standard places. You'll need write permission on the installation diff --git a/unix/configure b/unix/configure index c266e59..5133e09 100755 --- a/unix/configure +++ b/unix/configure @@ -1335,7 +1335,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu TCL_VERSION=8.5 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=5 -TCL_PATCH_LEVEL=".0" +TCL_PATCH_LEVEL=".1b1" VERSION=${TCL_VERSION} #------------------------------------------------------------------------ diff --git a/unix/configure.in b/unix/configure.in index 1f37674..8114f5f 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -3,7 +3,7 @@ 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. # -# RCS: @(#) $Id: configure.in,v 1.157.2.11 2007/11/21 06:31:00 dgp Exp $ +# RCS: @(#) $Id: configure.in,v 1.157.2.12 2008/01/23 16:42:25 dgp Exp $ AC_INIT([tcl],[8.5]) AC_PREREQ(2.59) @@ -27,7 +27,7 @@ m4_ifdef([SC_USE_CONFIG_HEADERS], [ TCL_VERSION=8.5 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=5 -TCL_PATCH_LEVEL=".0" +TCL_PATCH_LEVEL=".1b1" VERSION=${TCL_VERSION} #------------------------------------------------------------------------ diff --git a/unix/tcl.spec b/unix/tcl.spec index f833a14..3efc3b0 100644 --- a/unix/tcl.spec +++ b/unix/tcl.spec @@ -1,11 +1,11 @@ -# $Id: tcl.spec,v 1.27.2.4 2007/11/21 06:31:01 dgp Exp $ +# $Id: tcl.spec,v 1.27.2.5 2008/01/23 16:42:25 dgp Exp $ # This file is the basis for a binary Tcl RPM for Linux. %{!?directory:%define directory /usr/local} Name: tcl Summary: Tcl scripting language development environment -Version: 8.5.0 +Version: 8.5.1b1 Release: 2 License: BSD Group: Development/Languages diff --git a/unix/tclUnixThrd.c b/unix/tclUnixThrd.c index 3ac1140..8da1967 100644 --- a/unix/tclUnixThrd.c +++ b/unix/tclUnixThrd.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclUnixThrd.c,v 1.51.2.3 2007/11/26 19:43:17 dgp Exp $ + * RCS: @(#) $Id: tclUnixThrd.c,v 1.51.2.4 2008/01/23 16:42:25 dgp Exp $ */ #include "tclInt.h" @@ -223,16 +223,13 @@ TclpThreadGetStackSize(void) #if defined(HAVE_PTHREAD_ATTR_SETSTACKSIZE) && defined(TclpPthreadGetAttrs) pthread_attr_t threadAttr; /* This will hold the thread attributes for * the current thread. */ - static int initialized = 0; - +#ifdef __GLIBC__ /* * Fix for [Bug 1815573] * * DESCRIPTION: * On linux TclpPthreadGetAttrs (which is pthread_attr_get_np) may return - * bogus values on the initial thread. We have a choice: either use the - * default thread stack (first branch in the #if below), or return 0 and - * let getrlimit do its thing. + * bogus values on the initial thread. * * ASSUMPTIONS: * There seems to be no api to determine if we are on the initial @@ -247,20 +244,23 @@ TclpThreadGetStackSize(void) * second Tcl interp will be created only after the first call to * Tcl_CreateInterp returns. * - * These assumptions are satisfied by tclsh. Embedders may want to check - * their validity, and possibly adapt the code on failing to meet them. + * These assumptions are satisfied by tclsh. Embedders on linux may want + * to check their validity, and possibly adapt the code on failing to meet + * them. */ + static int initialized = 0; + if (!initialized) { initialized = 1; -#if 0 - if (pthread_attr_init(&threadAttr) != 0) { - return 0; - } -#else return 0; -#endif } else { +#else + { +#endif + if (pthread_attr_init(&threadAttr) != 0) { + return -1; + } if (TclpPthreadGetAttrs(pthread_self(), &threadAttr) != 0) { pthread_attr_destroy(&threadAttr); return (size_t)-1; @@ -1,6 +1,6 @@ Tcl 8.5 for Windows -RCS: @(#) $Id: README,v 1.34 2005/07/29 03:47:36 mdejong Exp $ +RCS: @(#) $Id: README,v 1.34.8.1 2008/01/23 16:42:26 dgp Exp $ 1. Introduction --------------- @@ -10,6 +10,7 @@ version of Tcl. This directory also contains source files for Tcl that are specific to Microsoft Windows. The information in this file is maintained on the web at: + http://www.tcl.tk/doc/howto/compile.html#win The above URL includes a lengthy discussion of compiler macros necessary @@ -24,69 +25,60 @@ In order to compile Tcl for Windows, you need the following: and - Visual C++ 5 or newer + Visual C++ 6 or newer or - Msys + Mingw + Msys + Mingw [http://www.mingw.org/download.shtml] http://prdownloads.sourceforge.net/tcl/msys_mingw8.zip - This Msys + Mingw download is the minimal environment - needed to build Tcl/Tk under Windows. It includes a - shell environment and gcc. The release is designed to - make it as easy a possible to build Tcl/Tk. To install, - you just download the zip file and extract the files - into a directory. The README.TXT file describes how - to launch the msys shell, you then run the configure - script in the tcl/win directory. + This Msys + Mingw download above is the minimal environment needed + to build Tcl/Tk under Windows. It includes a shell environment and + gcc. The release is designed to make it as easy a possible to build + Tcl/Tk. To install, you just download the zip file and extract the + files into a directory. The README.TXT file describes how to launch + the msys shell, you then run the configure script in the tcl/win + directory. In practice, this release is built with Visual C++ 6.0 and the TEA Makefile. If you are building with Visual C++, in the "win" subdirectory of the -source release, you will find "makefile.vc". This is the makefile for -the Visual C++ compiler and uses the stock NMAKE tool. Detailed -directions for using it, are in the comments of "makefile.vc". A quick -example would be: +source release, you will find "makefile.vc". This is the makefile for the +Visual C++ compiler and uses the stock NMAKE tool. Detailed directions for +using it, are in the comments of "makefile.vc". A quick example would be: + C:\tcl_source\win\>nmake -f makefile.vc There is also a Developer Studio workspace and project file, too, if you would like to use them. -If you are building with Msys or Cygwin, you can use the configure script -that lives in the win subdirectory. The Msys or Cygwin based configure/build -process works just like the UNIX one, so you will want to refer to -../unix/README for available configure options. An error will be -generated by the configure script if you try to compile Tcl with -the Cygwin version of gcc instead of the Mingw version. Check your -PATH if you get this error. Be aware that gcc will generate -lots of compile time warnings when building Tcl. Warnings are -not errors, so please don't file a bug report about them. - -In order to use the binaries generated by these makefiles, you will -need to place the Tcl script library files someplace where Tcl can -find them. Tcl looks in one of following places for the library files: +If you are building with Msys, you can use the configure script that lives +in the win subdirectory. The Msys based configure/build process works just +like the UNIX one, so you will want to refer to ../unix/README for +available configure options. An error will be generated by the configure +script if you try to compile Tcl with the Cygwin version of gcc instead of +the Mingw version. Check your PATH if you get this error. - 1) The path specified in the environment variable "TCL_LIBRARY". +Use the Makefile "install" target to install Tcl. It will install it +according to the prefix options you provided in the correct directory +structure. - 2) Relative to the directory containing the current .exe. - Tcl will look for a directory "..\lib\tcl8.5" relative to the - directory containing the currently running .exe. - -Note that in order to run tclsh85.exe, you must ensure that tcl85.dll -and tclpip85.dll are on your path, in the system directory, or in the -directory containing tclsh84.exe. +Note that in order to run tclsh85.exe, you must ensure that tcl85.dll is on +your path, in the system directory, or in the directory containing +tclsh85.exe. Note: Tcl no longer provides support for Win32s. 3. Test suite ------------- -This distribution contains an extensive test suite for Tcl. Some of -the tests are timing dependent and will fail from time to time. If a -test is failing consistently, please send us a bug report with as much -detail as you can manage. Please use the online database at +This distribution contains an extensive test suite for Tcl. Some of the +tests are timing dependent and will fail from time to time. If a test is +failing consistently, please send us a bug report with as much detail as +you can manage. Please use the online database at + http://tcl.sourceforge.net/ In order to run the test suite, you build the "test" target using the diff --git a/win/configure b/win/configure index 5dbcca8..0de0b45 100755 --- a/win/configure +++ b/win/configure @@ -1267,7 +1267,7 @@ SHELL=/bin/sh TCL_VERSION=8.5 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=5 -TCL_PATCH_LEVEL=".0" +TCL_PATCH_LEVEL=".1b1" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.3 diff --git a/win/configure.in b/win/configure.in index 8585602..749db30 100644 --- a/win/configure.in +++ b/win/configure.in @@ -3,7 +3,7 @@ # generate the file "configure", which is run during Tcl installation # to configure the system for the local environment. # -# RCS: @(#) $Id: configure.in,v 1.92.2.5 2007/11/21 06:31:02 dgp Exp $ +# RCS: @(#) $Id: configure.in,v 1.92.2.6 2008/01/23 16:42:26 dgp Exp $ AC_INIT(../generic/tcl.h) AC_PREREQ(2.59) @@ -16,7 +16,7 @@ SHELL=/bin/sh TCL_VERSION=8.5 TCL_MAJOR_VERSION=8 TCL_MINOR_VERSION=5 -TCL_PATCH_LEVEL=".0" +TCL_PATCH_LEVEL=".1b1" VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION TCL_DDE_VERSION=1.3 diff --git a/win/makefile.vc b/win/makefile.vc index 760e3f7..3fda014 100644 --- a/win/makefile.vc +++ b/win/makefile.vc @@ -12,7 +12,7 @@ # Copyright (c) 2001-2004 David Gravereaux. # #------------------------------------------------------------------------------ -# RCS: @(#) $Id: makefile.vc,v 1.160.2.8 2007/12/04 16:55:55 dgp Exp $ +# RCS: @(#) $Id: makefile.vc,v 1.160.2.9 2008/01/23 16:42:26 dgp Exp $ #------------------------------------------------------------------------------ # Check to see we are configured to build with MSVC (MSDEVDIR or MSVCDIR) @@ -480,8 +480,10 @@ baselibs = kernel32.lib user32.lib ws2_32.lib # Avoid 'unresolved external symbol __security_cookie' errors. # c.f. http://support.microsoft.com/?id=894573 !if "$(MACHINE)" == "IA64" || "$(MACHINE)" == "AMD64" +!if $(VCVERSION) > 1399 && $(VCVERSION) < 1500 baselibs = $(baselibs) bufferoverflowU.lib !endif +!endif #--------------------------------------------------------------------- # TclTest flags diff --git a/win/nmakehlp.c b/win/nmakehlp.c index a5eb1c4..4403748 100644 --- a/win/nmakehlp.c +++ b/win/nmakehlp.c @@ -11,7 +11,7 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. * * ---------------------------------------------------------------------------- - * RCS: @(#) $Id: nmakehlp.c,v 1.17.2.2 2007/10/15 18:38:09 dgp Exp $ + * RCS: @(#) $Id: nmakehlp.c,v 1.17.2.3 2008/01/23 16:42:26 dgp Exp $ * ---------------------------------------------------------------------------- */ @@ -21,9 +21,15 @@ #pragma comment (lib, "kernel32.lib") #include <stdio.h> #include <math.h> + +/* + * This library is required for x64 builds with _some_ versions + */ #if defined(_M_IA64) || defined(_M_AMD64) +#if _MSC_FULL_VER > 140000000 && _MSC_FULL_VER <= 140040310 #pragma comment(lib, "bufferoverflowU") #endif +#endif /* ISO hack for dumb VC++ */ #ifdef _MSC_VER diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c index 7a4ee94..7c002ac 100644 --- a/win/tclWinSerial.c +++ b/win/tclWinSerial.c @@ -11,7 +11,7 @@ * * Serial functionality implemented by Rolf.Schroedter@dlr.de * - * RCS: @(#) $Id: tclWinSerial.c,v 1.35 2007/04/20 06:11:00 kennykb Exp $ + * RCS: @(#) $Id: tclWinSerial.c,v 1.35.2.1 2008/01/23 16:42:26 dgp Exp $ */ #include "tclWinInt.h" @@ -662,7 +662,6 @@ SerialCloseProc( CloseHandle(serialPtr->writeThread); CloseHandle(serialPtr->osWrite.hEvent); - DeleteCriticalSection(&serialPtr->csWrite); CloseHandle(serialPtr->evWritable); CloseHandle(serialPtr->evStartWriter); CloseHandle(serialPtr->evStopWriter); @@ -672,6 +671,8 @@ SerialCloseProc( } serialPtr->validMask &= ~TCL_WRITABLE; + DeleteCriticalSection(&serialPtr->csWrite); + /* * Don't close the Win32 handle if the handle is a standard channel during * the thread exit process. Otherwise, one thread may kill the stdio of @@ -1520,6 +1521,7 @@ TclWinOpenSerialChannel( SetCommTimeouts(handle, &no_timeout); + InitializeCriticalSection(&infoPtr->csWrite); if (permissions & TCL_READABLE) { infoPtr->osRead.hEvent = CreateEvent(NULL, TRUE, FALSE, NULL); } @@ -1532,7 +1534,6 @@ TclWinOpenSerialChannel( infoPtr->evWritable = CreateEvent(NULL, TRUE, TRUE, NULL); infoPtr->evStartWriter = CreateEvent(NULL, FALSE, FALSE, NULL); infoPtr->evStopWriter = CreateEvent(NULL, FALSE, FALSE, NULL); - InitializeCriticalSection(&infoPtr->csWrite); infoPtr->writeThread = CreateThread(NULL, 256, SerialWriterThread, infoPtr, 0, &id); } |