summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2018-03-15 14:06:52 (GMT)
committerdgp <dgp@users.sourceforge.net>2018-03-15 14:06:52 (GMT)
commit47152d94c197241698dc4fd03322b6694b25d2d4 (patch)
tree2ac7affdbbf5610b73d47d78435e28789065a723
parent1dd89810eb1cba2b78eeeb42df4c3e966a55102e (diff)
parentaa199edba612a516e6309290fb6dc4442a49a5ee (diff)
downloadtcl-47152d94c197241698dc4fd03322b6694b25d2d4.zip
tcl-47152d94c197241698dc4fd03322b6694b25d2d4.tar.gz
tcl-47152d94c197241698dc4fd03322b6694b25d2d4.tar.bz2
merge 8.7
-rw-r--r--changes5
-rw-r--r--doc/Encoding.34
-rw-r--r--doc/Eval.38
-rw-r--r--doc/IntObj.32
-rw-r--r--doc/Interp.32
-rw-r--r--doc/NRE.3260
-rw-r--r--doc/format.n33
-rw-r--r--doc/lsearch.n20
-rw-r--r--doc/msgcat.n205
-rw-r--r--generic/tcl.decls96
-rw-r--r--generic/tcl.h146
-rw-r--r--generic/tclAlloc.c10
-rw-r--r--generic/tclAssembly.c25
-rw-r--r--generic/tclBasic.c74
-rw-r--r--generic/tclCkalloc.c28
-rw-r--r--generic/tclCmdAH.c2
-rw-r--r--generic/tclCmdIL.c275
-rw-r--r--generic/tclCmdMZ.c110
-rw-r--r--generic/tclCompCmdsGR.c423
-rw-r--r--generic/tclCompCmdsSZ.c308
-rw-r--r--generic/tclCompile.h2
-rw-r--r--generic/tclDecls.h229
-rw-r--r--generic/tclDictObj.c9
-rw-r--r--generic/tclDisassemble.c14
-rw-r--r--generic/tclEncoding.c2
-rw-r--r--generic/tclEvent.c1
-rw-r--r--generic/tclExecute.c1002
-rw-r--r--generic/tclGet.c2
-rw-r--r--generic/tclIO.c22
-rw-r--r--generic/tclIOCmd.c6
-rw-r--r--generic/tclIOUtil.c9
-rw-r--r--generic/tclInt.decls12
-rw-r--r--generic/tclInt.h197
-rw-r--r--generic/tclIntDecls.h18
-rw-r--r--generic/tclIntPlatDecls.h16
-rw-r--r--generic/tclListObj.c14
-rw-r--r--generic/tclLoad.c13
-rw-r--r--generic/tclOO.c821
-rw-r--r--generic/tclOOBasic.c13
-rw-r--r--generic/tclOOCall.c13
-rw-r--r--generic/tclOODefineCmds.c99
-rw-r--r--generic/tclOOInt.h46
-rw-r--r--generic/tclObj.c261
-rw-r--r--generic/tclPipe.c78
-rw-r--r--generic/tclPkg.c745
-rw-r--r--generic/tclProc.c4
-rw-r--r--generic/tclProcess.c952
-rw-r--r--generic/tclResult.c17
-rw-r--r--generic/tclScan.c29
-rw-r--r--generic/tclStrToD.c52
-rw-r--r--generic/tclStringObj.c495
-rw-r--r--generic/tclStubInit.c82
-rw-r--r--generic/tclTest.c169
-rw-r--r--generic/tclTestObj.c8
-rw-r--r--generic/tclThreadTest.c4
-rw-r--r--generic/tclTimer.c35
-rw-r--r--generic/tclTomMath.h48
-rw-r--r--generic/tclUtf.c24
-rw-r--r--generic/tclUtil.c486
-rw-r--r--generic/tclVar.c4
-rw-r--r--generic/tclZlib.c2
-rw-r--r--library/http1.0/http.tcl377
-rw-r--r--library/http1.0/pkgIndex.tcl11
-rw-r--r--library/msgcat/msgcat.tcl300
-rw-r--r--library/msgcat/pkgIndex.tcl4
-rw-r--r--library/tzdata/Africa/Sao_Tome9
-rw-r--r--library/tzdata/America/Campo_Grande164
-rw-r--r--library/tzdata/America/Cuiaba164
-rw-r--r--library/tzdata/America/La_Paz2
-rw-r--r--library/tzdata/America/Sao_Paulo164
-rw-r--r--library/tzdata/Asia/Tokyo16
-rw-r--r--libtommath/README.md14
-rw-r--r--libtommath/bn_error.c4
-rw-r--r--libtommath/bn_fast_mp_invmod.c10
-rw-r--r--libtommath/bn_fast_mp_montgomery_reduce.c14
-rw-r--r--libtommath/bn_fast_s_mp_mul_digs.c8
-rw-r--r--libtommath/bn_fast_s_mp_mul_high_digs.c6
-rw-r--r--libtommath/bn_fast_s_mp_sqr.c10
-rw-r--r--libtommath/bn_mp_2expt.c2
-rw-r--r--libtommath/bn_mp_clamp.c2
-rw-r--r--libtommath/bn_mp_clear_multi.c1
-rw-r--r--libtommath/bn_mp_cnt_lsb.c8
-rw-r--r--libtommath/bn_mp_count_bits.c4
-rw-r--r--libtommath/bn_mp_div.c30
-rw-r--r--libtommath/bn_mp_div_2.c2
-rw-r--r--libtommath/bn_mp_div_2d.c8
-rw-r--r--libtommath/bn_mp_div_3.c14
-rw-r--r--libtommath/bn_mp_div_d.c14
-rw-r--r--libtommath/bn_mp_dr_reduce.c2
-rw-r--r--libtommath/bn_mp_dr_setup.c2
-rw-r--r--libtommath/bn_mp_export.c20
-rw-r--r--libtommath/bn_mp_expt_d_ex.c12
-rw-r--r--libtommath/bn_mp_exptmod_fast.c6
-rw-r--r--libtommath/bn_mp_exteuclid.c40
-rw-r--r--libtommath/bn_mp_fread.c22
-rw-r--r--libtommath/bn_mp_fwrite.c4
-rw-r--r--libtommath/bn_mp_get_int.c2
-rw-r--r--libtommath/bn_mp_get_long.c2
-rw-r--r--libtommath/bn_mp_get_long_long.c2
-rw-r--r--libtommath/bn_mp_grow.c2
-rw-r--r--libtommath/bn_mp_import.c16
-rw-r--r--libtommath/bn_mp_init.c2
-rw-r--r--libtommath/bn_mp_init_multi.c1
-rw-r--r--libtommath/bn_mp_init_size.c2
-rw-r--r--libtommath/bn_mp_invmod.c6
-rw-r--r--libtommath/bn_mp_invmod_slow.c8
-rw-r--r--libtommath/bn_mp_is_square.c20
-rw-r--r--libtommath/bn_mp_jacobi.c18
-rw-r--r--libtommath/bn_mp_lshd.c4
-rw-r--r--libtommath/bn_mp_mod_2d.c4
-rw-r--r--libtommath/bn_mp_montgomery_calc_normalization.c2
-rw-r--r--libtommath/bn_mp_montgomery_reduce.c13
-rw-r--r--libtommath/bn_mp_montgomery_setup.c14
-rw-r--r--libtommath/bn_mp_mul.c4
-rw-r--r--libtommath/bn_mp_mul_2.c6
-rw-r--r--libtommath/bn_mp_mul_2d.c12
-rw-r--r--libtommath/bn_mp_mul_d.c4
-rw-r--r--libtommath/bn_mp_n_root_ex.c8
-rw-r--r--libtommath/bn_mp_prime_fermat.c2
-rw-r--r--libtommath/bn_mp_prime_is_divisible.c2
-rw-r--r--libtommath/bn_mp_prime_miller_rabin.c8
-rw-r--r--libtommath/bn_mp_prime_next_prime.c20
-rw-r--r--libtommath/bn_mp_prime_random_ex.c16
-rw-r--r--libtommath/bn_mp_radix_smap.c14
-rw-r--r--libtommath/bn_mp_rand.c8
-rw-r--r--libtommath/bn_mp_read_radix.c26
-rw-r--r--libtommath/bn_mp_read_signed_bin.c2
-rw-r--r--libtommath/bn_mp_read_unsigned_bin.c2
-rw-r--r--libtommath/bn_mp_reduce.c6
-rw-r--r--libtommath/bn_mp_reduce_2k.c2
-rw-r--r--libtommath/bn_mp_reduce_is_2k.c2
-rw-r--r--libtommath/bn_mp_set.c2
-rw-r--r--libtommath/bn_mp_set_int.c2
-rw-r--r--libtommath/bn_mp_shrink.c2
-rw-r--r--libtommath/bn_mp_sqr.c4
-rw-r--r--libtommath/bn_mp_sqrtmod_prime.c28
-rw-r--r--libtommath/bn_mp_sub_d.c4
-rw-r--r--libtommath/bn_mp_to_signed_bin_n.c2
-rw-r--r--libtommath/bn_mp_to_unsigned_bin.c4
-rw-r--r--libtommath/bn_mp_to_unsigned_bin_n.c2
-rw-r--r--libtommath/bn_mp_toom_mul.c2
-rw-r--r--libtommath/bn_mp_toom_sqr.c2
-rw-r--r--libtommath/bn_mp_unsigned_bin_size.c2
-rw-r--r--libtommath/bn_prime_tab.c1
-rw-r--r--libtommath/bn_s_mp_add.c4
-rw-r--r--libtommath/bn_s_mp_exptmod.c5
-rw-r--r--libtommath/bn_s_mp_mul_digs.c8
-rw-r--r--libtommath/bn_s_mp_mul_high_digs.c8
-rw-r--r--libtommath/bn_s_mp_sqr.c20
-rw-r--r--libtommath/bn_s_mp_sub.c4
-rw-r--r--libtommath/makefile8
-rw-r--r--libtommath/makefile_include.mk3
-rw-r--r--libtommath/tommath.h33
-rw-r--r--libtommath/tommath_private.h4
-rw-r--r--tests/assemble.test6
-rw-r--r--tests/basic.test10
-rw-r--r--tests/chanio.test11
-rw-r--r--tests/cmdIL.test33
-rw-r--r--tests/compExpr-old.test22
-rw-r--r--tests/compExpr.test12
-rw-r--r--tests/coroutine.test2
-rw-r--r--tests/exec.test1
-rw-r--r--tests/expr-old.test17
-rw-r--r--tests/expr.test48
-rw-r--r--tests/foreach.test6
-rw-r--r--tests/format.test34
-rw-r--r--tests/httpold.test300
-rw-r--r--tests/info.test2
-rw-r--r--tests/io.test9
-rw-r--r--tests/ioCmd.test9
-rw-r--r--tests/ioTrans.test2
-rw-r--r--tests/join.test5
-rw-r--r--tests/lindex.test9
-rw-r--r--tests/lrange.test18
-rw-r--r--tests/lreplace.test14
-rw-r--r--tests/lsearch.test196
-rw-r--r--tests/msgcat.test292
-rw-r--r--tests/obj.test47
-rw-r--r--tests/oo.test239
-rw-r--r--tests/package.test12
-rw-r--r--tests/process.test31
-rw-r--r--tests/safe.test8
-rw-r--r--tests/scan.test4
-rw-r--r--tests/string.test10
-rw-r--r--tests/unixFCmd.test14
-rw-r--r--unix/Makefile.in19
-rwxr-xr-xunix/configure42
-rw-r--r--unix/tcl.m49
-rw-r--r--unix/tclConfig.h.in2
-rw-r--r--unix/tclUnixInit.c6
-rw-r--r--unix/tclUnixPort.h4
-rw-r--r--win/Makefile.in12
-rw-r--r--win/buildall.vc.bat4
-rw-r--r--win/makefile.vc6
-rw-r--r--win/nmakehlp.c29
-rw-r--r--win/rules-ext.vc2
-rw-r--r--win/rules.vc8
-rw-r--r--win/tcl.dsp4
-rw-r--r--win/tclWin32Dll.c140
-rw-r--r--win/tclWinChan.c2
-rw-r--r--win/tclWinConsole.c2
-rw-r--r--win/tclWinDde.c7
-rw-r--r--win/tclWinInit.c7
-rw-r--r--win/tclWinInt.h6
-rw-r--r--win/tclWinPipe.c8
-rw-r--r--win/tclWinSerial.c2
206 files changed, 6313 insertions, 5408 deletions
diff --git a/changes b/changes
index f89704b..01d4c7a 100644
--- a/changes
+++ b/changes
@@ -8879,3 +8879,8 @@ in this changeset (new minor version) rather than bug fixes:
2017-09-02 (bug)[0e4d88] replace command, delete trace kills namespace (porter)
--- Released 8.7a1, September 8, 2017 --- http://core.tcl.tk/tcl/ for details
+
+2018-03-12 (TIP 490) add oo support for msgcat => msgcat 1.7.0 (oehlmann)
+
+2018-03-12 (TIP 499) custom locale preference list (oehlmann)
+=> msgcat 1.7.0
diff --git a/doc/Encoding.3 b/doc/Encoding.3
index 81ef508..79fca0f 100644
--- a/doc/Encoding.3
+++ b/doc/Encoding.3
@@ -260,10 +260,6 @@ Windows-only convenience
functions for converting between UTF-8 and Windows strings
based on the TCHAR type which is by convention
a Unicode character on Windows NT.
-These functions are essentially wrappers around
-\fBTcl_UtfToExternalDString\fR and
-\fBTcl_ExternalToUtfDString\fR that convert to and from the
-Unicode encoding.
.PP
\fBTcl_GetEncodingName\fR is roughly the inverse of \fBTcl_GetEncoding\fR.
Given an \fIencoding\fR, the return value is the \fIname\fR argument that
diff --git a/doc/Eval.3 b/doc/Eval.3
index 191bace..e241794 100644
--- a/doc/Eval.3
+++ b/doc/Eval.3
@@ -176,10 +176,10 @@ it is faster to execute the script directly.
.TP 23
\fBTCL_EVAL_GLOBAL\fR
.
-If this flag is set, the script is processed at global level. This
-means that it is evaluated in the global namespace and its variable
-context consists of global variables only (it ignores any Tcl
-procedures that are active).
+If this flag is set, the script is evaluated in the global namespace instead of
+the current namespace and its variable context consists of global variables
+only (it ignores any Tcl procedures that are active).
+.\" TODO: document TCL_EVAL_INVOKE and TCL_EVAL_NOERR.
.SH "MISCELLANEOUS DETAILS"
.PP
diff --git a/doc/IntObj.3 b/doc/IntObj.3
index 2acb446..6d5ee69 100644
--- a/doc/IntObj.3
+++ b/doc/IntObj.3
@@ -97,7 +97,7 @@ are provided by the C language standard. The \fBTcl_WideInt\fR type is a
typedef defined to be whatever signed integral type covers at least the
64-bit integer range (-9223372036854775808 to 9223372036854775807). Depending
on the platform and the C compiler, the actual type might be
-\fBlong int\fR, \fBlong long int\fR, \fB__int64\fR, or something else.
+\fBlong long int\fR, \fB__int64\fR, or something else.
The \fBmp_int\fR type is a multiple-precision integer type defined
by the LibTomMath multiple-precision integer library.
.PP
diff --git a/doc/Interp.3 b/doc/Interp.3
index 731007b..4ccff21 100644
--- a/doc/Interp.3
+++ b/doc/Interp.3
@@ -101,7 +101,7 @@ the command. The \fIfreeProc\fR field will be initialized to zero,
and \fIinterp->result\fR will point to an empty string. Commands that
do not return any value can simply leave the fields alone.
Furthermore, the empty string pointed to by \fIresult\fR is actually
-part of an array of \fBTCL_RESULT_SIZE\fR characters (approximately 200).
+part of an array of approximately 200 characters.
If a command wishes to return a short string, it can simply copy
it to the area pointed to by \fIinterp->result\fR. Or, it can use
the sprintf procedure to generate a short result string at the location
diff --git a/doc/NRE.3 b/doc/NRE.3
index ff0d108..6078a53 100644
--- a/doc/NRE.3
+++ b/doc/NRE.3
@@ -1,5 +1,6 @@
.\"
.\" Copyright (c) 2008 by Kevin B. Kenny.
+.\" Copyright (c) 2018 by Nathan Coulter.
.\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -38,43 +39,39 @@ void
.SH ARGUMENTS
.AS Tcl_CmdDeleteProc *interp in
.AP Tcl_Interp *interp in
-Interpreter in which to create or evaluate a command.
+The relevant Interpreter.
.AP char *cmdName in
-Name of a new command to create.
+Name of the command to create.
.AP Tcl_ObjCmdProc *proc in
-Implementation of a command that will be called whenever \fIcmdName\fR
-is invoked as a command in the unoptimized way.
+Called in order to evaluate a command. Is often just a small wrapper that uses
+\fBTcl_NRCallObjProc\fR to call \fInreProc\fR using a new trampoline. Behaves
+in the same way as the \fIproc\fR argument to \fBTcl_CreateObjCommand\fR(3)
+(\fIq.v.\fR).
.AP Tcl_ObjCmdProc *nreProc in
-Implementation of a command that will be called whenever \fIcmdName\fR
-is invoked and requested to conserve the C stack.
+Called instead of \fIproc\fR when a trampoline is already in use.
.AP ClientData clientData in
-Arbitrary one-word value that will be passed to \fIproc\fR, \fInreProc\fR,
-\fIdeleteProc\fR and \fIobjProc\fR.
+Arbitrary one-word value passed to \fIproc\fR, \fInreProc\fR, \fIdeleteProc\fR
+and \fIobjProc\fR.
.AP Tcl_CmdDeleteProc *deleteProc in/out
-Procedure to call before \fIcmdName\fR is deleted from the interpreter.
-This procedure allows for command-specific cleanup. If \fIdeleteProc\fR
-is \fBNULL\fR, then no procedure is called before the command is deleted.
+Called before \fIcmdName\fR is deleted from the interpreter, allowing for
+command-specific cleanup. May be NULL.
.AP int objc in
-Count of parameters provided to the implementation of a command.
+Number of items in \fIobjv\fR.
.AP Tcl_Obj **objv in
-Pointer to an array of Tcl values. Each value holds the value of a
-single word in the command to execute.
+Words in the command.
.AP Tcl_Obj *objPtr in
-Pointer to a Tcl_Obj whose value is a script or expression to execute.
+A script or expression to evaluate.
.AP int flags in
-ORed combination of flag bits that specify additional options.
-\fBTCL_EVAL_GLOBAL\fR is the only flag that is currently supported.
-.\" TODO: This is a lie. But kbk didn't grasp TCL_EVAL_INVOKE and
-.\" TCL_EVAL_NOERR well enough to document them.
+As described for \fITcl_EvalObjv\fR.
+.PP
.AP Tcl_Command cmd in
-Token for a command that is to be used instead of the currently
-executing command.
+Token to use instead of one derived from the first word of \fIobjv\fR in order
+to evaluate a command.
.AP Tcl_Obj *resultPtr out
-Pointer to an unshared Tcl_Obj where the result of expression
-evaluation is written.
+Pointer to an unshared Tcl_Obj where the result of the evaluation is stored if
+the return code is TCL_OK.
.AP Tcl_NRPostProc *postProcPtr in
-Pointer to a function that will be invoked when the command currently
-executing in the interpreter designated by \fIinterp\fR completes.
+A function to push.
.AP ClientData data0 in
.AP ClientData data1 in
.AP ClientData data2 in
@@ -84,98 +81,51 @@ to the function designated by \fIpostProcPtr\fR when it is invoked.
.BE
.SH DESCRIPTION
.PP
-This series of C functions provides an interface whereby commands that
-are implemented in C can be evaluated, and invoke Tcl commands scripts
-and scripts, without consuming space on the C stack. The non-recursive
-evaluation is done by installing a \fItrampoline\fR, a small piece of
-code that invokes a command or script, and then executes a series of
-callbacks when the command or script returns.
-.PP
-The \fBTcl_NRCreateCommand\fR function creates a Tcl command in the
-interpreter designated by \fIinterp\fR that is prepared to handle
-nonrecursive evaluation with a trampoline. The \fIcmdName\fR argument
-gives the name of the new command. If \fIcmdName\fR contains any
-namespace qualifiers, then the new command is added to the specified
-namespace; otherwise, it is added to the global namespace. \fIproc\fR
-gives the procedure that will be called when the interpreter wishes to
-evaluate the command in an unoptimized manner, and \fInreProc\fR is
-the procedure that will be called when the interpreter wishes to
-evaluate the command using a trampoline. \fIdeleteProc\fR is a
-function that will be called before the command is deleted from the
-interpreter. When any of the three functions is invoked, it is passed
-the \fIclientData\fR parameter.
-.PP
-\fBTcl_NRCreateCommand\fR deletes any existing command
-\fIname\fR already associated with the interpreter
-(however see below for an exception where the existing command
-is not deleted).
-It returns a token that may be used to refer
-to the command in subsequent calls to \fBTcl_GetCommandName\fR.
-If \fBTcl_NRCreateCommand\fR is called for an interpreter that is in
-the process of being deleted, then it does not create a new command,
-does not delete any existing command of the same name, and returns NULL.
-.PP
-The \fIproc\fR and \fInreProc\fR function are expected to conform to
-all the rules set forth for the \fIproc\fR argument to
-\fBTcl_CreateObjCommand\fR(3) (\fIq.v.\fR).
-.PP
-When a command that is written to cope with evaluation via trampoline
-is invoked without a trampoline on the stack, it will usually respond
-to the invocation by creating a trampoline and calling the
-trampoline-enabled implementation of the same command. This call is done by
-means of \fBTcl_NRCallObjProc\fR. In the call to
-\fBTcl_NRCallObjProc\fR, the \fIinterp\fR, \fIclientData\fR,
-\fIobjc\fR and \fIobjv\fR parameters should be the same ones that were
-passed to \fIproc\fR. The \fInreProc\fR parameter should designate the
-trampoline-enabled implementation of the command.
-.PP
-\fBTcl_NREvalObj\fR arranges for the script contained in \fIobjPtr\fR
-to be evaluated in the interpreter designated by \fIinterp\fR after
-the current command (which must be trampoline-enabled) returns. It is
-the method by which a command may invoke a script without consuming
-space on the C stack. Similarly, \fBTcl_NREvalObjv\fR arranges to
-invoke a single Tcl command whose words have already been separated
-and substituted. The \fIobjc\fR and \fIobjv\fR parameters give the
-words of the command to be evaluated when execution reaches the
-trampoline.
-.PP
-\fBTcl_NRCmdSwap\fR allows for trampoline evaluation of a command whose
-resolution is already known. The \fIcmd\fR parameter gives a
-\fBTcl_Command\fR token (returned from \fBTcl_CreateObjCommand\fR or
-\fBTcl_GetCommandFromObj\fR) identifying the command to be invoked in
-the trampoline; this command must match the word in \fIobjv[0]\fR.
-The remaining arguments are as for \fBTcl_NREvalObjv\fR.
-.PP
-\fBTcl_NREvalObj\fR, \fBTcl_NREvalObjv\fR and \fBTcl_NRCmdSwap\fR
-all accept a \fIflags\fR parameter, which is an OR-ed-together set of
-bits to control evaluation. At the present time, the only supported flag
-available to callers is \fBTCL_EVAL_GLOBAL\fR.
-.\" TODO: Again, this is a lie. Do we want to explain TCL_EVAL_INVOKE
-.\" and TCL_EVAL_NOERR?
-If the \fBTCL_EVAL_GLOBAL\fR flag is set, the script or command is
-evaluated in the global namespace. If it is not set, it is evaluated
-in the current namespace.
-.PP
-\fBTcl_NRExprObj\fR arranges for the expression contained in \fIobjPtr\fR
-to be evaluated in the interpreter designated by \fIinterp\fR after
-the current command (which must be trampoline-enabled) returns. It is
-the method by which a command may evaluate a Tcl expression without consuming
-space on the C stack. The argument \fIresultPtr\fR is a pointer to an
-unshared Tcl_Obj where the result of expression evaluation is to be written.
-If expression evaluation returns any code other than TCL_OK, the
-\fIresultPtr\fR value is left untouched.
-.PP
-All of the routines return \fBTCL_OK\fR if command or expression invocation
-has been scheduled successfully. If for any reason the scheduling cannot
-be completed (for example, if the interpreter is unable to find
-the requested command), they return \fBTCL_ERROR\fR with an
-appropriate message left in the interpreter's result.
-.PP
-\fBTcl_NRAddCallback\fR arranges to have a C function called when the
-current trampoline-enabled command in the Tcl interpreter designated
-by \fIinterp\fR returns. The \fIpostProcPtr\fR argument is a pointer
-to the callback function, which must have arguments and return value
-consistent with the \fBTcl_NRPostProc\fR data type:
+These functions provide an interface to the function stack that an interpreter
+iterates through to evaluate commands. The routine behind a command is
+implemented by an initial function and any additional functions that the
+routine pushes onto the stack as it progresses. The interpreter itself pushes
+functions onto the stack to react to the end of a routine and to exercise other
+forms of control such as switching between in-progress stacks and the
+evaluation of other scripts at additional levels without adding frames to the C
+stack. To execute a routine, the initial function for the routine is called
+and then a small bit of code called a \fItrampoline\fR iteratively takes
+functions off the stack and calls them, using the value of the last call as the
+value of the routine.
+.PP
+\fBTcl_NRCallObjProc\fR calls \fInreProc\fR using a new trampoline.
+.PP
+\fBTcl_NRCreateCommand\fR, an alternative to \fBTcl_CreateObjCommand\fR,
+resolves \fIcmdName\fR, which may contain namespace qualifiers, relative to the
+current namespace, creates a command by that name, and returns a token for the
+command which may be used in subsequent calls to \fBTcl_GetCommandName\fR.
+Except for a few cases noted below any existing command by the same name is
+first deleted. If \fIinterp\fR is in the process of being deleted
+\fBTcl_NRCreateCommand\fR does not create any command, does not delete any
+command, and returns NULL.
+.PP
+\fBTcl_NREvalObj\fR pushes a function that is like \fBTcl_EvalObjEx\fR but
+consumes no space on the C stack.
+.PP
+\fBTcl_NREvalObjv\fR pushes a function that is like \fBTcl_EvalObjv\fR but
+consumes no space on the C stack.
+.PP
+\fBTcl_NRCmdSwap\fR is like \fBTcl_NREvalObjv\fR, but uses \fIcmd\fR, a token
+previously returned by \fBTcl_CreateObjCommand\fR or
+\fBTcl_GetCommandFromObj\fR, instead of resolving the first word of \fIobjv\fR.
+. The name of this command must be the same as \fIobjv[0]\fR.
+.PP
+\fBTcl_NRExprObj\fR pushes a function that evaluates \fIobjPtr\fR as an
+expression in the same manner as \fBTcl_ExprObj\fR but without consuming space
+on the C stack.
+.PP
+All of the functions return \fBTCL_OK\fR if the evaluation of the script,
+command, or expression has been scheduled successfully. Otherwise (for example
+if the command name cannot be resolved), they return \fBTCL_ERROR\fR and store
+a message as the interpreter's result.
+.PP
+\fBTcl_NRAddCallback\fR pushes \fIpostProcPtr\fR. The signature for
+\fBTcl_NRPostProc\fR is:
.PP
.CS
typedef int
@@ -185,25 +135,13 @@ typedef int
int \fIresult\fR);
.CE
.PP
-When the trampoline invokes the callback function, the \fIdata\fR
-parameter will point to an array containing the four one-word
-quantities that were passed to \fBTcl_NRAddCallback\fR in the
-\fIdata0\fR through \fIdata3\fR parameters. The Tcl interpreter will
-be designated by the \fIinterp\fR parameter, and the \fIresult\fR
-parameter will contain the result (\fBTCL_OK\fR, \fBTCL_ERROR\fR,
-\fBTCL_RETURN\fR, \fBTCL_BREAK\fR or \fBTCL_CONTINUE\fR) that was
-returned by the command evaluation. The callback function is expected,
-in turn, either to return a \fIresult\fR to control further evaluation.
-.PP
-Multiple \fBTcl_NRAddCallback\fR invocations may request multiple
-callbacks, which may be to the same or different callback
-functions. If multiple callbacks are requested, they are executed in
-last-in, first-out order, that is, the most recently requested
-callback is executed first.
+\fIdata\fR is a pointer to an array containing \fIdata0\fR through \fIdata3\fR.
+\fIresult\fR is the value returned by the previous function implementing part
+the routine.
.SH EXAMPLE
.PP
-The usual pattern for Tcl commands that invoke other Tcl commands
-is something like:
+The following command uses \fBTcl_EvalObjEx\fR, which consumes space on the C
+stack, to evalute a script:
.PP
.CS
int
@@ -228,28 +166,17 @@ int
\fITheCmdOldObjProc\fR, clientData, TheCmdDeleteProc);
.CE
.PP
-To enable a command like this one for trampoline-based evaluation,
-it must be split into three pieces:
-.IP \(bu
-A non-trampoline implementation, \fITheCmdNewObjProc\fR,
-which will simply create a trampoline
-and invoke the trampoline-based implementation.
-.IP \(bu
-A trampoline-enabled implementation, \fITheCmdNRObjProc\fR. This
-function will perform the initialization, request that the trampoline
-call the postprocessing routine after command evaluation, and finally,
-request that the trampoline call the inner command.
-.IP \(bu
-A postprocessing routine, \fITheCmdPostProc\fR. This function will
-perform the postprocessing formerly done after the return from the
-inner command in \fITheCmdObjProc\fR.
-.PP
-The non-trampoline implementation is simple and stylized, containing
-a single statement:
+To avoid consuming space on the C stack, \fITheCmdOldObjProc\fR is renamed to
+\fITheCmdNRObjProc\fR and the postprocessing step is split into a separate
+function, \fITheCmdPostProc\fR, which is pushed onto the function stack.
+\fITcl_EvalObjEx\fR is replaced with \fITcl_NREvalObj\fR, which uses a
+trampoline instead of consuming space on the C stack. A new version of
+\fITheCmdOldObjProc\fR is just a a wrapper that uses \fBTcl_NRCallObjProc\fR to
+call \fITheCmdNRObjProc\fR:
.PP
.CS
int
-\fITheCmdNewObjProc\fR(
+\fITheCmdOldObjProc\fR(
ClientData clientData,
Tcl_Interp *interp,
int objc,
@@ -260,9 +187,6 @@ int
}
.CE
.PP
-The trampoline-enabled implementation requests postprocessing,
-and returns to the trampoline requesting command evaluation.
-.PP
.CS
int
\fITheCmdNRObjProc\fR
@@ -284,9 +208,6 @@ int
}
.CE
.PP
-The postprocessing procedure does whatever the original command did
-upon return from the inner evaluation.
-.PP
.CS
int
\fITheCmdNRPostProc\fR(
@@ -303,26 +224,13 @@ int
}
.CE
.PP
-If \fItheCommand\fR is a command that results in multiple commands or
-scripts being evaluated, its postprocessing routine may schedule
-additional postprocessing and then request another command evaluation
-by means of \fBTcl_NREvalObj\fR or one of the other evaluation
-routines. Looping and sequencing constructs may be implemented in this way.
-.PP
-Finally, to install a trampoline-enabled command in the interpreter,
-\fBTcl_NRCreateCommand\fR is used in place of
-\fBTcl_CreateObjCommand\fR. It accepts two command procedures instead
-of one. The first is for use when no trampoline is yet on the stack,
-and the second is for use when there is already a trampoline in place.
+Any function comprising a routine can push other functions, making it possible
+implement looping and sequencing constructs using the function stack.
.PP
-.CS
-\fBTcl_NRCreateCommand\fR(interp, "theCommand",
- \fITheCmdNewObjProc\fR, \fITheCmdNRObjProc\fR, clientData,
- TheCmdDeleteProc);
-.CE
.SH "SEE ALSO"
Tcl_CreateCommand(3), Tcl_CreateObjCommand(3), Tcl_EvalObjEx(3), Tcl_GetCommandFromObj(3), Tcl_ExprObj(3)
.SH KEYWORDS
stackless, nonrecursive, execute, command, global, value, result, script
.SH COPYRIGHT
-Copyright (c) 2008 by Kevin B. Kenny
+Copyright (c) 2008 by Kevin B. Kenny.
+Copyright (c) 2018 by Nathan Coulter.
diff --git a/doc/format.n b/doc/format.n
index 4eb566d..eb64491 100644
--- a/doc/format.n
+++ b/doc/format.n
@@ -83,14 +83,15 @@ Specifies that the number should be padded on the left with
zeroes instead of spaces.
.TP 10
\fB#\fR
-Requests an alternate output form. For \fBo\fR and \fBO\fR
-conversions it guarantees that the first digit is always \fB0\fR.
-For \fBx\fR or \fBX\fR conversions, \fB0x\fR or \fB0X\fR (respectively)
+Requests an alternate output form. For \fBo\fR conversions,
+\fB0o\fR will be added to the beginning of the result unless
+it is zero. For \fBx\fR or \fBX\fR conversions, \fB0x\fR
will be added to the beginning of the result unless it is zero.
For \fBb\fR conversions, \fB0b\fR
will be added to the beginning of the result unless it is zero.
-For \fBd\fR conversions, \fB0d\fR will be added to the beginning
-of the result unless it is zero.
+For \fBd\fR conversions, \fB0d\fR there is no effect unless
+the \fB0\fR specifier is used as well: In that case, \fB0d\fR
+will be added to the beginning.
For all floating-point conversions (\fBe\fR, \fBE\fR, \fBf\fR,
\fBg\fR, and \fBG\fR) it guarantees that the result always
has a decimal point.
@@ -132,7 +133,7 @@ it must be a numeric string.
.SS "OPTIONAL SIZE MODIFIER"
.PP
The fifth part of a conversion specifier is a size modifier,
-which must be \fBll\fR, \fBh\fR, or \fBl\fR.
+which must be \fBll\fR, \fBh\fR, \fBl\fR, or \fBL\fR.
If it is \fBll\fR it specifies that an integer value is taken
without truncation for conversion to a formatted substring.
If it is \fBh\fR it specifies that an integer value is
@@ -140,7 +141,9 @@ truncated to a 16-bit range before converting. This option is rarely useful.
If it is \fBl\fR it specifies that the integer value is
truncated to the same range as that produced by the \fBwide()\fR
function of the \fBexpr\fR command (at least a 64-bit range).
-If neither \fBh\fR nor \fBl\fR are present, the integer value is
+If it is \fBL\fR it specifies that an integer or double value is taken
+without truncation for conversion to a formatted substring.
+If neither \fBh\fR nor \fBl\fR nor \fBL\fR are present, the integer value is
truncated to the same range as that produced by the \fBint()\fR
function of the \fBexpr\fR command (at least a 32-bit range, but
determined by the value of the \fBwordSize\fR element of the
@@ -171,7 +174,7 @@ for \fBx\fR and
for \fBX\fR).
.TP 10
\fBb\fR
-Convert integer to binary string, using digits 0 and 1.
+Convert integer to unsigned binary string, using digits 0 and 1.
.TP 10
\fBc\fR
Convert integer to the Unicode character it represents.
@@ -200,8 +203,19 @@ precision, then convert number as for \fB%e\fR or
Otherwise convert as for \fB%f\fR.
Trailing zeroes and a trailing decimal point are omitted.
.TP 10
+\fBa\fR or \fBA\fR
+Convert double to hexadecimal notation in the form
+\fI0x1.yyy\fBp\(+-\fIzz\fR, where the number of \fIy\fR's is
+determined by the precision (default: 13).
+If the \fBA\fR form is used then the hex characters
+are printed in uppercase.
+.TP 10
\fB%\fR
No conversion: just insert \fB%\fR.
+.TP 10
+\fBp\fR
+Shorthand form for \fB0x%zx\fR, so it outputs the integer in
+hexadecimal form with \fB0x\fR prefix.
.SH "DIFFERENCES FROM ANSI SPRINTF"
.PP
The behavior of the format command is the same as the
@@ -210,13 +224,12 @@ differences:
.IP [1]
Tcl guarantees that it will be working with UNICODE characters.
.IP [2]
-\fB%p\fR and \fB%n\fR specifiers are not supported.
+\fB%n\fR specifier is not supported.
.IP [3]
For \fB%c\fR conversions the argument must be an integer value,
which will then be converted to the corresponding character value.
.IP [4]
The size modifiers are ignored when formatting floating-point values.
-The \fBll\fR modifier has no \fBsprintf\fR counterpart.
The \fBb\fR specifier has no \fBsprintf\fR counterpart.
.SH EXAMPLES
.PP
diff --git a/doc/lsearch.n b/doc/lsearch.n
index c2644b8..12c2786 100644
--- a/doc/lsearch.n
+++ b/doc/lsearch.n
@@ -148,6 +148,19 @@ or \fB\-not\fR.
These options are used to search lists of lists. They may be used
with any other options.
.TP
+\fB\-stride\0\fIstrideLength\fR
+.
+If this option is specified, the list is treated as consisting of
+groups of \fIstrideLength\fR elements and the groups are searched by
+either their first element or, if the \fB\-index\fR option is used,
+by the element within each group given by the first index passed to
+\fB\-index\fR (which is then ignored by \fB\-index\fR). The resulting
+index always points to the first element in a group.
+.PP
+The list length must be an integer multiple of \fIstrideLength\fR, which
+in turn must be at least 1. A \fIstrideLength\fR of 1 is the default and
+indicates no grouping.
+.TP
\fB\-index\fR\0\fIindexList\fR
.
This option is designed for use when searching within nested lists.
@@ -208,6 +221,13 @@ It is also possible to search inside elements:
\fBlsearch\fR -index 1 -all -inline {{a abc} {b bcd} {c cde}} *bc*
\fI\(-> {a abc} {b bcd}\fR
.CE
+.PP
+The same thing for a flattened list:
+.PP
+.CS
+\fBlsearch\fR -stride 2 -index 1 -all -inline {a abc b bcd c cde} *bc*
+ \fI\(-> {a abc b bcd}\fR
+.CE
.SH "SEE ALSO"
foreach(n), list(n), lappend(n), lindex(n), linsert(n), llength(n),
lset(n), lsort(n), lrange(n), lreplace(n),
diff --git a/doc/msgcat.n b/doc/msgcat.n
index 2fc1eee..9074725 100644
--- a/doc/msgcat.n
+++ b/doc/msgcat.n
@@ -11,9 +11,9 @@
.SH NAME
msgcat \- Tcl message catalog
.SH SYNOPSIS
-\fBpackage require Tcl 8.5\fR
+\fBpackage require Tcl 8.7\fR
.sp
-\fBpackage require msgcat 1.6\fR
+\fBpackage require msgcat 1.7\fR
.sp
\fB::msgcat::mc \fIsrc-string\fR ?\fIarg arg ...\fR?
.sp
@@ -23,9 +23,15 @@ msgcat \- Tcl message catalog
\fB::msgcat::mcexists\fR ?\fB-exactnamespace\fR? ?\fB-exactlocale\fR? \fIsrc-string\fR
.VE "TIP 412"
.sp
+.VS "TIP 490"
+\fB::msgcat::mcpackagenamespaceget\fR
+.VE "TIP 490"
+.sp
\fB::msgcat::mclocale \fR?\fInewLocale\fR?
.sp
-\fB::msgcat::mcpreferences\fR
+.VS "TIP 499"
+\fB::msgcat::mcpreferences\fR ?\fIlocale preference\fR? ...
+.VE "TIP 499"
.sp
.VS "TIP 412"
\fB::msgcat::mcloadedlocales subcommand\fR ?\fIlocale\fR?
@@ -50,6 +56,10 @@ msgcat \- Tcl message catalog
.sp
\fB::msgcat::mcforgetpackage\fR
.VE "TIP 412"
+.sp
+.VS "TIP 499"
+\fB::msgcat::mcutil subcommand\fR ?\fIlocale\fR?
+.VS "TIP 499"
.BE
.SH DESCRIPTION
.PP
@@ -71,6 +81,11 @@ In \fBmsgcat\fR, there is a global locale initialized by the system locale of th
Each package may decide to use the global locale or to use a package specific locale.
.PP
The global locale may be changed on demand, for example by a user initiated language change or within a multi user application like a web server.
+.PP
+.VS tip490
+Object oriented programming is supported by the use of a package namespace.
+.VE tip490
+.PP
.SH COMMANDS
.TP
\fB::msgcat::mc \fIsrc-string\fR ?\fIarg arg ...\fR?
@@ -95,6 +110,17 @@ use the result. If an application is written for a single language in
this fashion, then it is easy to add support for additional languages
later simply by defining new message catalog entries.
.RE
+.VS "TIP 490"
+.TP
+\fB::msgcat::mcn \fInamespace\fR \fIsrc-string\fR ?\fIarg arg ...\fR?
+.
+Like \fB::msgcat::mc\fR, but with the message namespace specified as first argument.
+.PP
+.RS
+\fBmcn\fR may be used for cases where the package namespace is not the namespace of the caller.
+An example is shown within the description of the command \fB::msgcat::mcpackagenamespaceget\fR below.
+.RE
+.PP
.TP
\fB::msgcat::mcmax ?\fIsrc-string src-string ...\fR?
.
@@ -103,28 +129,68 @@ of the longest translated string. This is useful when designing
localized GUIs, which may require that all buttons, for example, be a
fixed width (which will be the width of the widest button).
.TP
-\fB::msgcat::mcexists\fR ?\fB-exactnamespace\fR? ?\fB-exactlocale\fR? \fIsrc-string\fR
-.
.VS "TIP 412"
+\fB::msgcat::mcexists\fR ?\fB-exactnamespace\fR? ?\fB-exactlocale\fR? ?\fB-namespace\fR \fInamespace\fR? \fIsrc-string\fR
+.
Return true, if there is a translation for the given \fIsrc-string\fR.
.PP
.RS
The search may be limited by the option \fB\-exactnamespace\fR to only check the current namespace and not any parent namespaces.
.PP
It may also be limited by the option \fB\-exactlocale\fR to only check the first prefered locale (e.g. first element returned by \fB::msgcat::mcpreferences\fR if global locale is used).
-.RE
+.PP
.VE "TIP 412"
+.VS "TIP 490"
+An explicit package namespace may be specified by the option \fB-namespace\fR.
+The namespace of the caller is used if not explicitly specified.
+.RE
+.PP
+.VE "TIP 490"
+.VS "TIP 490"
+.TP
+\fB::msgcat::mcpackagenamespaceget\fR
+.
+Return the package namespace of the caller.
+This command handles all cases described in section \fBOBJECT ORIENTED PROGRAMMING\fR.
+.PP
+.RS
+Example usage is a tooltip package, which saves the caller package namespace to update the translation each time the tooltip is shown:
+.CS
+proc ::tooltip::tooltip {widget message} {
+ ...
+ set messagenamespace [uplevel 1 {::msgcat::mcpackagenamespaceget}]
+ ...
+ bind $widget [list ::tooltip::show $widget $messagenamespace $message]
+}
+
+proc ::tooltip::show {widget messagenamespace message} {
+ ...
+ set message [::msgcat::mcn $messagenamespace $message]
+ ...
+}
+.CE
+.RE
+.PP
+.VE "TIP 490"
.TP
\fB::msgcat::mclocale \fR?\fInewLocale\fR?
.
-This function sets the locale to \fInewLocale\fR. If \fInewLocale\fR
-is omitted, the current locale is returned, otherwise the current locale
-is set to \fInewLocale\fR. msgcat stores and compares the locale in a
+If \fInewLocale\fR is omitted, the current locale is returned, otherwise the current locale
+is set to \fInewLocale\fR.
+.PP
+.RS
+If the new locale is set to \fInewLocale\fR, the corresponding preferences are calculated and set.
+For example, if the current locale is en_US_funky, then \fB::msgcat::mcpreferences\fR returns \fB{en_us_funky en_us en {}}\fR.
+.PP
+The same result may be acheved by \fB::msgcat::mcpreferences\fR {*}[\fB::msgcat::mcutil getpreferences\fR \fInewLocale\fR].
+.PP
+The current locale is always the first element of the list returned by \fBmcpreferences\fR.
+.PP
+msgcat stores and compares the locale in a
case-insensitive manner, and returns locales in lowercase.
The initial locale is determined by the locale specified in
the user's environment. See \fBLOCALE SPECIFICATION\fR
below for a description of the locale string format.
-.RS
.PP
.VS "TIP 412"
If the locale is set, the preference list of locales is evaluated.
@@ -132,16 +198,26 @@ Locales in this list are loaded now, if not jet loaded.
.VE "TIP 412"
.RE
.TP
-\fB::msgcat::mcpreferences\fR
+\fB::msgcat::mcpreferences\fR ?\fIlocale preference\fR? ...
.
-Returns an ordered list of the locales preferred by
-the user, based on the user's language specification.
-The list is ordered from most specific to least
-preference. The list is derived from the current
-locale set in msgcat by \fB::msgcat::mclocale\fR, and
-cannot be set independently. For example, if the
-current locale is en_US_funky, then \fB::msgcat::mcpreferences\fR
-returns \fB{en_us_funky en_us en {}}\fR.
+Without arguments, returns an ordered list of the locales preferred by
+the user.
+The list is ordered from most specific to least preference.
+.PP
+.VS "TIP 499"
+.RS
+A set of locale preferences may be given to set the list of locale preferences.
+The current locale is also set, which is the first element of the locale preferences list.
+.PP
+Locale preferences are loaded now, if not jet loaded.
+.PP
+As an example, the user may prefer French or English text. This may be configured by:
+.CS
+::msgcat::mcpreferences fr en {}
+.CE
+.RE
+.PP
+.VS "TIP 499"
.TP
\fB::msgcat:mcloadedlocales subcommand\fR ?\fIlocale\fR?
.
@@ -232,6 +308,22 @@ Note that this routine is only called if the concerned package did not set a pac
The calling package clears all its state within the \fBmsgcat\fR package including all settings and translations.
.VE "TIP 412"
.PP
+.VS "TIP 499"
+.TP
+\fB::msgcat::mcutil getpreferences\fR \fIlocale\fR
+.
+Return the preferences list of the given locale as described in section \fBLOCALE SPECIFICATION\fR.
+An example is the composition of a preference list for the bilingual region "Biel/Bienne" as a concatenation of swiss german and swiss french:
+.CS
+% concat [lrange [msgcat::mcutil getpreferences fr_CH] 0 end-1] [msgcat::mcutil getpreferences de_CH]
+fr_ch fr de_ch de {}
+.CE
+.TP
+\fB::msgcat::mcutil getsystemlocale\fR
+.
+The system locale is returned as described by the section \fBLOCALE SPECIFICATION\fR.
+.VE "TIP 499"
+.PP
.SH "LOCALE SPECIFICATION"
.PP
The locale is specified to \fBmsgcat\fR by a locale string
@@ -437,7 +529,7 @@ formatting substitution is done directly.
# human-oriented versions by \fBmsgcat::mcset\fR
.CE
.VS "TIP 412"
-.SH Package private locale
+.SH "PACKAGE PRIVATE LOCALE"
.PP
A package using \fBmsgcat\fR may choose to use its own package private
locale and its own set of loaded locales, independent to the global
@@ -461,10 +553,22 @@ This command may cause the load of locales.
.
Return the package private locale or the global locale, if no package private locale is set.
.TP
-\fB::msgcat::mcpackagelocale preferences\fR
+\fB::msgcat::mcpackagelocale preferences\fR ?\fIlocale preference\fR? ...
.
-Return the package private preferences or the global preferences,
+With no parameters, return the package private preferences or the global preferences,
if no package private locale is set.
+The package locale state (set or not) is not changed (in contrast to the command \fB::msgcat::mcpackagelocale set\fR).
+.PP
+.RS
+.VS "TIP 499"
+If a set of locale preferences is given, it is set as package locale preference list.
+The package locale is set to the first element of the preference list.
+A package locale is activated, if it was not set so far.
+.PP
+Locale preferences are loaded now for the package, if not jet loaded.
+.VE "TIP 499"
+.RE
+.PP
.TP
\fB::msgcat::mcpackagelocale loaded\fR
.
@@ -488,7 +592,7 @@ Returns true, if the given locale is loaded for the package.
.
Clear any loaded locales of the package not present in the package preferences.
.PP
-.SH Changing package options
+.SH "CHANGING PACKAGE OPTIONS"
.PP
Each package using msgcat has a set of options within \fBmsgcat\fR.
The package options are described in the next sectionPackage options.
@@ -563,7 +667,7 @@ A generic unknown handler is used if set to the empty string. This consists in r
See section \fBcallback invocation\fR below.
The appended arguments are identical to \fB::msgcat::mcunknown\fR.
.RE
-.SS Callback invocation
+.SH "Callback invocation"
A package may decide to register one or multiple callbacks, as described above.
.PP
Callbacks are invoked, if:
@@ -577,7 +681,54 @@ Callbacks are invoked, if:
If a called routine fails with an error, the \fBbgerror\fR routine for the interpreter is invoked after command completion.
Only exception is the callback \fBunknowncmd\fR, where an error causes the invoking \fBmc\fR-command to fail with that error.
.PP
-.SS Examples
+.VS tip490
+.SH "OBJECT ORIENTED PROGRAMMING"
+\fBmsgcat\fR supports packages implemented by object oriented programming.
+Objects and classes should be defined within a package namespace.
+.PP
+There are 3 supported cases where package namespace sensitive commands of msgcat (\fBmc\fR, \fBmcexists\fR, \fBmcpackagelocale\fR, \fBmcforgetpackage\fR, \fBmcpackagenamespaceget\fR, \fBmcpackageconfig\fR, \fBmcset\fR and \fBmcmset\fR) may be called:
+.PP
+.TP
+\fB1) In class definition script\fR
+.
+\fBmsgcat\fR command is called within a class definition script.
+.CS
+namespace eval ::N2 {
+ mcload $dir/msgs
+ oo::class create C1 {puts [mc Hi!]}
+}
+.CE
+.PP
+.TP
+\fB2) method defined in a class\fR
+.
+\fBmsgcat\fR command is called from a method in an object and the method is defined in a class.
+.CS
+namespace eval ::N3Class {
+ mcload $dir/msgs
+ oo::class create C1
+ oo::define C1 method m1 {
+ puts [mc Hi!]
+ }
+}
+.CE
+.PP
+.TP
+\fB3) method defined in a classless object\fR
+.
+\fBmsgcat\fR command is called from a method of a classless object.
+.CS
+namespace eval ::N4 {
+ mcload $dir/msgs
+ oo::object create O1
+ oo::objdefine O1 method m1 {} {
+ puts [mc Hi!]
+ }
+}
+.CE
+.PP
+.VE tip490
+.SH EXAMPLES
Packages which display a GUI may update their widgets when the global locale changes.
To register to a callback, use:
.CS
@@ -643,9 +794,9 @@ proc ::tcl::clock::LocalizeFormat { locale format } {
.PP
The message catalog code was developed by Mark Harrison.
.SH "SEE ALSO"
-format(n), scan(n), namespace(n), package(n)
+format(n), scan(n), namespace(n), package(n), oo::class(n), oo::object
.SH KEYWORDS
-internationalization, i18n, localization, l10n, message, text, translation
+internationalization, i18n, localization, l10n, message, text, translation, class, object
.\" Local Variables:
.\" mode: nroff
.\" End:
diff --git a/generic/tcl.decls b/generic/tcl.decls
index f2850fa..60aebfd 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -32,7 +32,7 @@ declare 0 {
const char *version, const void *clientData)
}
declare 1 {
- CONST84_RETURN char *Tcl_PkgRequireEx(Tcl_Interp *interp,
+ const char *Tcl_PkgRequireEx(Tcl_Interp *interp,
const char *name, const char *version, int exact,
void *clientDataPtr)
}
@@ -154,7 +154,7 @@ declare 35 {
}
declare 36 {
int Tcl_GetIndexFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
- CONST84 char *const *tablePtr, const char *msg, int flags, int *indexPtr)
+ const char *const *tablePtr, const char *msg, int flags, int *indexPtr)
}
declare 37 {
int Tcl_GetInt(Tcl_Interp *interp, const char *src, int *intPtr)
@@ -285,7 +285,7 @@ declare 75 {
declare 76 {
void Tcl_BackgroundError(Tcl_Interp *interp)
}
-declare 77 {
+declare 77 {deprecated {Use Tcl_UtfBackslash}} {
char Tcl_Backslash(const char *src, int *readPtr)
}
declare 78 {
@@ -306,7 +306,7 @@ declare 82 {
int Tcl_CommandComplete(const char *cmd)
}
declare 83 {
- char *Tcl_Concat(int argc, CONST84 char *const *argv)
+ char *Tcl_Concat(int argc, const char *const *argv)
}
declare 84 {
int Tcl_ConvertElement(const char *src, char *dst, int flags)
@@ -318,7 +318,7 @@ declare 85 {
declare 86 {
int Tcl_CreateAlias(Tcl_Interp *slave, const char *slaveCmd,
Tcl_Interp *target, const char *targetCmd, int argc,
- CONST84 char *const *argv)
+ const char *const *argv)
}
declare 87 {
int Tcl_CreateAliasObj(Tcl_Interp *slave, const char *slaveCmd,
@@ -352,7 +352,7 @@ declare 93 {
declare 94 {
Tcl_Interp *Tcl_CreateInterp(void)
}
-declare 95 {
+declare 95 {deprecated {}} {
void Tcl_CreateMathFunc(Tcl_Interp *interp, const char *name,
int numArgs, Tcl_ValueType *argTypes,
Tcl_MathProc *proc, ClientData clientData)
@@ -461,10 +461,10 @@ declare 126 {
int Tcl_Eof(Tcl_Channel chan)
}
declare 127 {
- CONST84_RETURN char *Tcl_ErrnoId(void)
+ const char *Tcl_ErrnoId(void)
}
declare 128 {
- CONST84_RETURN char *Tcl_ErrnoMsg(int err)
+ const char *Tcl_ErrnoMsg(int err)
}
declare 129 {
int Tcl_Eval(Tcl_Interp *interp, const char *script)
@@ -528,12 +528,12 @@ declare 147 {
}
declare 148 {
int Tcl_GetAlias(Tcl_Interp *interp, const char *slaveCmd,
- Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr,
- int *argcPtr, CONST84 char ***argvPtr)
+ Tcl_Interp **targetInterpPtr, const char **targetCmdPtr,
+ int *argcPtr, const char ***argvPtr)
}
declare 149 {
int Tcl_GetAliasObj(Tcl_Interp *interp, const char *slaveCmd,
- Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr,
+ Tcl_Interp **targetInterpPtr, const char **targetCmdPtr,
int *objcPtr, Tcl_Obj ***objv)
}
declare 150 {
@@ -558,7 +558,7 @@ declare 155 {
int Tcl_GetChannelMode(Tcl_Channel chan)
}
declare 156 {
- CONST84_RETURN char *Tcl_GetChannelName(Tcl_Channel chan)
+ const char *Tcl_GetChannelName(Tcl_Channel chan)
}
declare 157 {
int Tcl_GetChannelOption(Tcl_Interp *interp, Tcl_Channel chan,
@@ -572,14 +572,14 @@ declare 159 {
Tcl_CmdInfo *infoPtr)
}
declare 160 {
- CONST84_RETURN char *Tcl_GetCommandName(Tcl_Interp *interp,
+ const char *Tcl_GetCommandName(Tcl_Interp *interp,
Tcl_Command command)
}
declare 161 {
int Tcl_GetErrno(void)
}
declare 162 {
- CONST84_RETURN char *Tcl_GetHostName(void)
+ const char *Tcl_GetHostName(void)
}
declare 163 {
int Tcl_GetInterpPath(Tcl_Interp *askInterp, Tcl_Interp *slaveInterp)
@@ -622,14 +622,14 @@ declare 173 {
Tcl_Channel Tcl_GetStdChannel(int type)
}
declare 174 {
- CONST84_RETURN char *Tcl_GetStringResult(Tcl_Interp *interp)
+ const char *Tcl_GetStringResult(Tcl_Interp *interp)
}
declare 175 {
- CONST84_RETURN char *Tcl_GetVar(Tcl_Interp *interp, const char *varName,
+ const char *Tcl_GetVar(Tcl_Interp *interp, const char *varName,
int flags)
}
declare 176 {
- CONST84_RETURN char *Tcl_GetVar2(Tcl_Interp *interp, const char *part1,
+ const char *Tcl_GetVar2(Tcl_Interp *interp, const char *part1,
const char *part2, int flags)
}
declare 177 {
@@ -662,7 +662,7 @@ declare 185 {
}
# Obsolete, use Tcl_FSJoinPath
declare 186 {
- char *Tcl_JoinPath(int argc, CONST84 char *const *argv,
+ char *Tcl_JoinPath(int argc, const char *const *argv,
Tcl_DString *resultPtr)
}
declare 187 {
@@ -685,7 +685,7 @@ declare 191 {
Tcl_Channel Tcl_MakeTcpClientChannel(ClientData tcpSocket)
}
declare 192 {
- char *Tcl_Merge(int argc, CONST84 char *const *argv)
+ char *Tcl_Merge(int argc, const char *const *argv)
}
declare 193 {
Tcl_HashEntry *Tcl_NextHashEntry(Tcl_HashSearch *searchPtr)
@@ -703,7 +703,7 @@ declare 196 {
}
declare 197 {
Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp, int argc,
- CONST84 char **argv, int flags)
+ const char **argv, int flags)
}
# This is obsolete, use Tcl_FSOpenFileChannel
declare 198 {
@@ -729,7 +729,7 @@ declare 203 {
int Tcl_PutEnv(const char *assignment)
}
declare 204 {
- CONST84_RETURN char *Tcl_PosixError(Tcl_Interp *interp)
+ const char *Tcl_PosixError(Tcl_Interp *interp)
}
declare 205 {
void Tcl_QueueEvent(Tcl_Event *evPtr, Tcl_QueuePosition position)
@@ -765,7 +765,7 @@ declare 214 {
}
declare 215 {
void Tcl_RegExpRange(Tcl_RegExp regexp, int index,
- CONST84 char **startPtr, CONST84 char **endPtr)
+ const char **startPtr, const char **endPtr)
}
declare 216 {
void Tcl_Release(ClientData clientData)
@@ -835,29 +835,29 @@ declare 236 {
void Tcl_SetStdChannel(Tcl_Channel channel, int type)
}
declare 237 {
- CONST84_RETURN char *Tcl_SetVar(Tcl_Interp *interp, const char *varName,
+ const char *Tcl_SetVar(Tcl_Interp *interp, const char *varName,
const char *newValue, int flags)
}
declare 238 {
- CONST84_RETURN char *Tcl_SetVar2(Tcl_Interp *interp, const char *part1,
+ const char *Tcl_SetVar2(Tcl_Interp *interp, const char *part1,
const char *part2, const char *newValue, int flags)
}
declare 239 {
- CONST84_RETURN char *Tcl_SignalId(int sig)
+ const char *Tcl_SignalId(int sig)
}
declare 240 {
- CONST84_RETURN char *Tcl_SignalMsg(int sig)
+ const char *Tcl_SignalMsg(int sig)
}
declare 241 {
void Tcl_SourceRCFile(Tcl_Interp *interp)
}
declare 242 {
int Tcl_SplitList(Tcl_Interp *interp, const char *listStr, int *argcPtr,
- CONST84 char ***argvPtr)
+ const char ***argvPtr)
}
# Obsolete, use Tcl_FSSplitPath
declare 243 {
- void Tcl_SplitPath(const char *path, int *argcPtr, CONST84 char ***argvPtr)
+ void Tcl_SplitPath(const char *path, int *argcPtr, const char ***argvPtr)
}
declare 244 {
void Tcl_StaticPackage(Tcl_Interp *interp, const char *pkgName,
@@ -952,15 +952,15 @@ declare 269 {
char *Tcl_HashStats(Tcl_HashTable *tablePtr)
}
declare 270 {
- CONST84_RETURN char *Tcl_ParseVar(Tcl_Interp *interp, const char *start,
- CONST84 char **termPtr)
+ const char *Tcl_ParseVar(Tcl_Interp *interp, const char *start,
+ const char **termPtr)
}
declare 271 {
- CONST84_RETURN char *Tcl_PkgPresent(Tcl_Interp *interp, const char *name,
+ const char *Tcl_PkgPresent(Tcl_Interp *interp, const char *name,
const char *version, int exact)
}
declare 272 {
- CONST84_RETURN char *Tcl_PkgPresentEx(Tcl_Interp *interp,
+ const char *Tcl_PkgPresentEx(Tcl_Interp *interp,
const char *name, const char *version, int exact,
void *clientDataPtr)
}
@@ -970,7 +970,7 @@ declare 273 {
}
# TIP #268: The internally used new Require function is in slot 573.
declare 274 {
- CONST84_RETURN char *Tcl_PkgRequire(Tcl_Interp *interp, const char *name,
+ const char *Tcl_PkgRequire(Tcl_Interp *interp, const char *name,
const char *version, int exact)
}
declare 275 {deprecated {see TIP #422}} {
@@ -1084,7 +1084,7 @@ declare 301 {
Tcl_Encoding Tcl_GetEncoding(Tcl_Interp *interp, const char *name)
}
declare 302 {
- CONST84_RETURN char *Tcl_GetEncodingName(Tcl_Encoding encoding)
+ const char *Tcl_GetEncodingName(Tcl_Encoding encoding)
}
declare 303 {
void Tcl_GetEncodingNames(Tcl_Interp *interp)
@@ -1160,7 +1160,7 @@ declare 324 {
int Tcl_UniCharToUtf(int ch, char *buf)
}
declare 325 {
- CONST84_RETURN char *Tcl_UtfAtIndex(const char *src, int index)
+ const char *Tcl_UtfAtIndex(const char *src, int index)
}
declare 326 {
int Tcl_UtfCharComplete(const char *src, int length)
@@ -1169,16 +1169,16 @@ declare 327 {
int Tcl_UtfBackslash(const char *src, int *readPtr, char *dst)
}
declare 328 {
- CONST84_RETURN char *Tcl_UtfFindFirst(const char *src, int ch)
+ const char *Tcl_UtfFindFirst(const char *src, int ch)
}
declare 329 {
- CONST84_RETURN char *Tcl_UtfFindLast(const char *src, int ch)
+ const char *Tcl_UtfFindLast(const char *src, int ch)
}
declare 330 {
- CONST84_RETURN char *Tcl_UtfNext(const char *src)
+ const char *Tcl_UtfNext(const char *src)
}
declare 331 {
- CONST84_RETURN char *Tcl_UtfPrev(const char *src, const char *start)
+ const char *Tcl_UtfPrev(const char *src, const char *start)
}
declare 332 {
int Tcl_UtfToExternal(Tcl_Interp *interp, Tcl_Encoding encoding,
@@ -1211,10 +1211,10 @@ declare 339 {
declare 340 {
char *Tcl_GetString(Tcl_Obj *objPtr)
}
-declare 341 {
- CONST84_RETURN char *Tcl_GetDefaultEncodingDir(void)
+declare 341 {deprecated {Use Tcl_GetEncodingSearchPath}} {
+ const char *Tcl_GetDefaultEncodingDir(void)
}
-declare 342 {
+declare 342 {deprecated {Use Tcl_SetEncodingSearchPath}} {
void Tcl_SetDefaultEncodingDir(const char *path)
}
declare 343 {
@@ -1263,7 +1263,7 @@ declare 356 {
Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj,
int flags)
}
-declare 357 {
+declare 357 {deprecated {Use Tcl_EvalTokensStandard}} {
Tcl_Obj *Tcl_EvalTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr,
int count)
}
@@ -1276,7 +1276,7 @@ declare 359 {
}
declare 360 {
int Tcl_ParseBraces(Tcl_Interp *interp, const char *start, int numBytes,
- Tcl_Parse *parsePtr, int append, CONST84 char **termPtr)
+ Tcl_Parse *parsePtr, int append, const char **termPtr)
}
declare 361 {
int Tcl_ParseCommand(Tcl_Interp *interp, const char *start, int numBytes,
@@ -1289,7 +1289,7 @@ declare 362 {
declare 363 {
int Tcl_ParseQuotedString(Tcl_Interp *interp, const char *start,
int numBytes, Tcl_Parse *parsePtr, int append,
- CONST84 char **termPtr)
+ const char **termPtr)
}
declare 364 {
int Tcl_ParseVarName(Tcl_Interp *interp, const char *start, int numBytes,
@@ -1405,7 +1405,7 @@ declare 397 {
int Tcl_ChannelBuffered(Tcl_Channel chan)
}
declare 398 {
- CONST84_RETURN char *Tcl_ChannelName(const Tcl_ChannelType *chanTypePtr)
+ const char *Tcl_ChannelName(const Tcl_ChannelType *chanTypePtr)
}
declare 399 {
Tcl_ChannelTypeVersion Tcl_ChannelVersion(
@@ -1545,12 +1545,12 @@ declare 434 {
}
# TIP#15 (math function introspection) dkf
-declare 435 {
+declare 435 {deprecated {}} {
int Tcl_GetMathFuncInfo(Tcl_Interp *interp, const char *name,
int *numArgsPtr, Tcl_ValueType **argTypesPtr,
Tcl_MathProc **procPtr, ClientData *clientDataPtr)
}
-declare 436 {
+declare 436 {deprecated {}} {
Tcl_Obj *Tcl_ListMathFuncs(Tcl_Interp *interp, const char *pattern)
}
diff --git a/generic/tcl.h b/generic/tcl.h
index b7d4e90..397b3d8 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -141,7 +141,7 @@ extern "C" {
*/
#include <stdarg.h>
-#ifndef TCL_NO_DEPRECATED
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
# define TCL_VARARGS(type, name) (type name, ...)
# define TCL_VARARGS_DEF(type, name) (type name, ...)
# define TCL_VARARGS_START(type, name, list) (va_start(list, name), name)
@@ -258,10 +258,9 @@ extern "C" {
* New code should use prototypes.
*/
-#ifndef TCL_NO_DEPRECATED
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
# undef _ANSI_ARGS_
# define _ANSI_ARGS_(x) x
-#endif /* !TCL_NO_DEPRECATED */
/*
* Definitions that allow this header file to be used either with or without
@@ -271,34 +270,16 @@ extern "C" {
#ifndef INLINE
# define INLINE
#endif
-
-#ifdef NO_CONST
-# ifndef const
-# define const
-# endif
-#endif
#ifndef CONST
# define CONST const
#endif
+#define CONST84 const
+#define CONST84_RETURN const
-#ifdef USE_NON_CONST
-# ifdef USE_COMPAT_CONST
-# error define at most one of USE_NON_CONST and USE_COMPAT_CONST
-# endif
-# define CONST84
-# define CONST84_RETURN
-#else
-# ifdef USE_COMPAT_CONST
-# define CONST84
-# define CONST84_RETURN const
-# else
-# define CONST84 const
-# define CONST84_RETURN const
-# endif
-#endif
+#endif /* !TCL_NO_DEPRECATED */
#ifndef CONST86
-# define CONST86 CONST84
+# define CONST86 const
#endif
/*
@@ -322,6 +303,7 @@ extern "C" {
* VOID. This block is skipped under Cygwin and Mingw.
*/
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
#if defined(_WIN32) && !defined(HAVE_WINNT_IGNORE_VOID)
#ifndef VOID
#define VOID void
@@ -337,23 +319,16 @@ typedef long LONG;
*/
#ifndef __VXWORKS__
-# ifndef NO_VOID
-# define VOID void
-# else
-# define VOID char
-# endif
+# define VOID void
#endif
+#endif /* !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 */
/*
* Miscellaneous declarations.
*/
#ifndef _CLIENTDATA
-# ifndef NO_VOID
- typedef void *ClientData;
-# else
- typedef int *ClientData;
-# endif
+ typedef void *ClientData;
# define _CLIENTDATA
#endif
@@ -400,44 +375,40 @@ typedef long LONG;
# if defined(_WIN32)
# define TCL_WIDE_INT_TYPE __int64
# define TCL_LL_MODIFIER "I64"
+# if defined(_WIN64)
+# define TCL_Z_MODIFIER "I"
+# endif
# elif defined(__GNUC__)
-# define TCL_WIDE_INT_TYPE long long
-# define TCL_LL_MODIFIER "ll"
+# define TCL_Z_MODIFIER "z"
# else /* ! _WIN32 && ! __GNUC__ */
/*
* Don't know what platform it is and configure hasn't discovered what is
* going on for us. Try to guess...
*/
# include <limits.h>
-# if (INT_MAX < LONG_MAX)
+# if defined(LLONG_MAX) && (LLONG_MAX == LONG_MAX)
# define TCL_WIDE_INT_IS_LONG 1
-# else
-# define TCL_WIDE_INT_TYPE long long
# endif
# endif /* _WIN32 */
#endif /* !TCL_WIDE_INT_TYPE & !TCL_WIDE_INT_IS_LONG */
-#ifdef TCL_WIDE_INT_IS_LONG
-# undef TCL_WIDE_INT_TYPE
-# define TCL_WIDE_INT_TYPE long
-#endif /* TCL_WIDE_INT_IS_LONG */
+
+#ifndef TCL_WIDE_INT_TYPE
+# define TCL_WIDE_INT_TYPE long long
+#endif /* !TCL_WIDE_INT_TYPE */
typedef TCL_WIDE_INT_TYPE Tcl_WideInt;
typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt;
-#ifdef TCL_WIDE_INT_IS_LONG
-# ifndef TCL_LL_MODIFIER
-# define TCL_LL_MODIFIER "l"
-# endif /* !TCL_LL_MODIFIER */
-#else /* TCL_WIDE_INT_IS_LONG */
-/*
- * The next short section of defines are only done when not running on Windows
- * or some other strange platform.
- */
-# ifndef TCL_LL_MODIFIER
-# define TCL_LL_MODIFIER "ll"
-# endif /* !TCL_LL_MODIFIER */
-#endif /* TCL_WIDE_INT_IS_LONG */
-
+#ifndef TCL_LL_MODIFIER
+# define TCL_LL_MODIFIER "ll"
+#endif /* !TCL_LL_MODIFIER */
+#ifndef TCL_Z_MODIFIER
+# if defined(__GNUC__) && !defined(_WIN32)
+# define TCL_Z_MODIFIER "z"
+# else
+# define TCL_Z_MODIFIER ""
+# endif
+#endif /* !TCL_Z_MODIFIER */
#define Tcl_WideAsLong(val) ((long)((Tcl_WideInt)(val)))
#define Tcl_LongAsWide(val) ((Tcl_WideInt)((long)(val)))
#define Tcl_WideAsDouble(val) ((double)((Tcl_WideInt)(val)))
@@ -497,35 +468,13 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt;
*/
typedef struct Tcl_Interp
-#ifndef TCL_NO_DEPRECATED
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
{
/* TIP #330: Strongly discourage extensions from using the string
* result. */
-#ifdef USE_INTERP_RESULT
- char *result TCL_DEPRECATED_API("use Tcl_GetStringResult/Tcl_SetResult");
- /* If the last command returned a string
- * result, this points to it. */
- void (*freeProc) (char *blockPtr)
- TCL_DEPRECATED_API("use Tcl_GetStringResult/Tcl_SetResult");
- /* Zero means the string result is statically
- * allocated. TCL_DYNAMIC means it was
- * allocated with ckalloc and should be freed
- * with ckfree. Other values give the address
- * of function to invoke to free the result.
- * Tcl_Eval must free it before executing next
- * command. */
-#else
char *resultDontUse; /* Don't use in extensions! */
void (*freeProcDontUse) (char *); /* Don't use in extensions! */
-#endif
-#ifdef USE_INTERP_ERRORLINE
- int errorLine TCL_DEPRECATED_API("use Tcl_GetErrorLine/Tcl_SetErrorLine");
- /* When TCL_ERROR is returned, this gives the
- * line number within the command where the
- * error occurred (1 if first line). */
-#else
int errorLineDontUse; /* Don't use in extensions! */
-#endif
}
#endif /* !TCL_NO_DEPRECATED */
Tcl_Interp;
@@ -677,7 +626,9 @@ typedef struct stat *Tcl_OldStat_;
#define TCL_BREAK 3
#define TCL_CONTINUE 4
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
#define TCL_RESULT_SIZE 200
+#endif
/*
*----------------------------------------------------------------------------
@@ -693,6 +644,7 @@ typedef struct stat *Tcl_OldStat_;
* Argument descriptors for math function callbacks in expressions:
*/
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
typedef enum {
TCL_INT, TCL_DOUBLE, TCL_EITHER, TCL_WIDE_INT
} Tcl_ValueType;
@@ -704,6 +656,10 @@ typedef struct Tcl_Value {
double doubleValue; /* Double-precision floating value. */
Tcl_WideInt wideValue; /* Wide (min. 64-bit) integer value. */
} Tcl_Value;
+#else
+#define Tcl_ValueType void /* Just enough to prevent compilation error in Tcl */
+#define Tcl_Value void /* Just enough to prevent compilation error in Tcl */
+#endif
/*
* Forward declaration of Tcl_Obj to prevent an error when the forward
@@ -724,10 +680,10 @@ typedef void (Tcl_ChannelProc) (ClientData clientData, int mask);
typedef void (Tcl_CloseProc) (ClientData data);
typedef void (Tcl_CmdDeleteProc) (ClientData clientData);
typedef int (Tcl_CmdProc) (ClientData clientData, Tcl_Interp *interp,
- int argc, CONST84 char *argv[]);
+ int argc, const char *argv[]);
typedef void (Tcl_CmdTraceProc) (ClientData clientData, Tcl_Interp *interp,
int level, char *command, Tcl_CmdProc *proc,
- ClientData cmdClientData, int argc, CONST84 char *argv[]);
+ ClientData cmdClientData, int argc, const char *argv[]);
typedef int (Tcl_CmdObjTraceProc) (ClientData clientData, Tcl_Interp *interp,
int level, const char *command, Tcl_Command commandInfo, int objc,
struct Tcl_Obj *const *objv);
@@ -764,7 +720,7 @@ typedef void (Tcl_TimerProc) (ClientData clientData);
typedef int (Tcl_SetFromAnyProc) (Tcl_Interp *interp, struct Tcl_Obj *objPtr);
typedef void (Tcl_UpdateStringProc) (struct Tcl_Obj *objPtr);
typedef char * (Tcl_VarTraceProc) (ClientData clientData, Tcl_Interp *interp,
- CONST84 char *part1, CONST84 char *part2, int flags);
+ const char *part1, const char *part2, int flags);
typedef void (Tcl_CommandTraceProc) (ClientData clientData, Tcl_Interp *interp,
const char *oldName, const char *newName, int flags);
typedef void (Tcl_CreateFileHandlerProc) (int fd, int mask, Tcl_FileProc *proc,
@@ -875,7 +831,7 @@ typedef struct Tcl_SavedResult {
char *appendResult;
int appendAvl;
int appendUsed;
- char resultSpace[TCL_RESULT_SIZE+1];
+ char resultSpace[200+1];
} Tcl_SavedResult;
/*
@@ -1001,7 +957,7 @@ typedef struct Tcl_DString {
#define Tcl_DStringLength(dsPtr) ((dsPtr)->length)
#define Tcl_DStringValue(dsPtr) ((dsPtr)->string)
-#ifndef TCL_NO_DEPRECATED
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
# define Tcl_DStringTrunc Tcl_DStringSetLength
#endif /* !TCL_NO_DEPRECATED */
@@ -1129,7 +1085,7 @@ typedef struct Tcl_DString {
* give the flag)
*/
-#ifndef TCL_NO_DEPRECATED
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
# define TCL_PARSE_PART1 0x400
#endif /* !TCL_NO_DEPRECATED */
@@ -1482,14 +1438,14 @@ typedef int (Tcl_DriverClose2Proc) (ClientData instanceData,
typedef int (Tcl_DriverInputProc) (ClientData instanceData, char *buf,
int toRead, int *errorCodePtr);
typedef int (Tcl_DriverOutputProc) (ClientData instanceData,
- CONST84 char *buf, int toWrite, int *errorCodePtr);
+ const char *buf, int toWrite, int *errorCodePtr);
typedef int (Tcl_DriverSeekProc) (ClientData instanceData, long offset,
int mode, int *errorCodePtr);
typedef int (Tcl_DriverSetOptionProc) (ClientData instanceData,
Tcl_Interp *interp, const char *optionName,
const char *value);
typedef int (Tcl_DriverGetOptionProc) (ClientData instanceData,
- Tcl_Interp *interp, CONST84 char *optionName,
+ Tcl_Interp *interp, const char *optionName,
Tcl_DString *dsPtr);
typedef void (Tcl_DriverWatchProc) (ClientData instanceData, int mask);
typedef int (Tcl_DriverGetHandleProc) (ClientData instanceData,
@@ -1982,7 +1938,7 @@ typedef struct Tcl_Token {
* TCL_TOKEN_OPERATOR - The token describes one expression operator.
* An operator might be the name of a math
* function such as "abs". A TCL_TOKEN_OPERATOR
- * token is always preceeded by one
+ * token is always preceded by one
* TCL_TOKEN_SUB_EXPR token for the operator's
* subexpression, and is followed by zero or more
* TCL_TOKEN_SUB_EXPR tokens for the operator's
@@ -2561,15 +2517,9 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
# undef Tcl_NewDoubleObj
# define Tcl_NewDoubleObj(val) \
Tcl_DbNewDoubleObj(val, __FILE__, __LINE__)
-# undef Tcl_NewIntObj
-# define Tcl_NewIntObj(val) \
- Tcl_DbNewLongObj(val, __FILE__, __LINE__)
# undef Tcl_NewListObj
# define Tcl_NewListObj(objc, objv) \
Tcl_DbNewListObj(objc, objv, __FILE__, __LINE__)
-# undef Tcl_NewLongObj
-# define Tcl_NewLongObj(val) \
- Tcl_DbNewLongObj(val, __FILE__, __LINE__)
# undef Tcl_NewObj
# define Tcl_NewObj() \
Tcl_DbNewObj(__FILE__, __LINE__)
@@ -2632,10 +2582,10 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
* Deprecated Tcl functions:
*/
-#ifndef TCL_NO_DEPRECATED
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
/*
* These function have been renamed. The old names are deprecated, but we
- * define these macros for backwards compatibilty.
+ * define these macros for backwards compatibility.
*/
# define Tcl_Ckalloc Tcl_Alloc
diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c
index 64df1a2..8a4b1c8 100644
--- a/generic/tclAlloc.c
+++ b/generic/tclAlloc.c
@@ -661,14 +661,14 @@ mstats(
fprintf(stderr, "\nused:\t");
for (i = 0; i < NBUCKETS; i++) {
- fprintf(stderr, " %" TCL_LL_MODIFIER "d", (Tcl_WideInt)numMallocs[i]);
+ fprintf(stderr, " %" TCL_Z_MODIFIER "u", numMallocs[i]);
totalUsed += numMallocs[i] * (1 << (i + 3));
}
- fprintf(stderr, "\n\tTotal small in use: %" TCL_LL_MODIFIER "d, total free: %" TCL_LL_MODIFIER "d\n",
- (Tcl_WideInt)totalUsed, (Tcl_WideInt)totalFree);
- fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %" TCL_LL_MODIFIER "d\n",
- MAXMALLOC, (Tcl_WideInt)numMallocs[NBUCKETS]);
+ fprintf(stderr, "\n\tTotal small in use: %" TCL_Z_MODIFIER "u, total free: %" TCL_Z_MODIFIER "u\n",
+ totalUsed, totalFree);
+ fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %" TCL_Z_MODIFIER "u\n",
+ MAXMALLOC, numMallocs[NBUCKETS]);
Tcl_MutexUnlock(allocMutexPtr);
}
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 4c5ae68..7368f97 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -2246,23 +2246,24 @@ GetListIndexOperand(
Tcl_Token* tokenPtr = *tokenPtrPtr;
/* INOUT: Pointer to the next token in the
* source code */
- Tcl_Obj* intObj; /* Integer from the source code */
- int status; /* Tcl status return */
-
- /*
- * Extract the next token as a string.
- */
+ Tcl_Obj *value;
+ int status;
- if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &intObj) != TCL_OK) {
+ /* General operand validity check */
+ if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &value) != TCL_OK) {
return TCL_ERROR;
}
-
+
+ /* Convert to an integer, advance to the next token and return. */
/*
- * Convert to an integer, advance to the next token and return.
+ * NOTE: Indexing a list with an index before it yields the
+ * same result as indexing after it, and might be more easily portable
+ * when list size limits grow.
*/
+ status = TclIndexEncode(interp, value,
+ TCL_INDEX_BEFORE,TCL_INDEX_BEFORE, result);
- status = TclGetIntForIndex(interp, intObj, -2, result);
- Tcl_DecrRefCount(intObj);
+ Tcl_DecrRefCount(value);
*tokenPtrPtr = TokenAfter(tokenPtr);
return status;
}
@@ -4266,7 +4267,7 @@ AddBasicBlockRangeToErrorInfo(
Tcl_AppendObjToErrorInfo(interp, lineNo);
Tcl_AddErrorInfo(interp, " and ");
if (bbPtr->successor1 != NULL) {
- TclSetLongObj(lineNo, bbPtr->successor1->startLine);
+ TclSetIntObj(lineNo, bbPtr->successor1->startLine);
Tcl_AppendObjToErrorInfo(interp, lineNo);
} else {
Tcl_AddErrorInfo(interp, "end of assembly code");
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 3ed3447..16d7f7c 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -132,8 +132,10 @@ static Tcl_NRPostProc NRCoroutineCallerCallback;
static Tcl_NRPostProc NRCoroutineExitCallback;
static Tcl_NRPostProc NRCommand;
+#if !defined(TCL_NO_DEPRECATED)
static Tcl_ObjCmdProc OldMathFuncProc;
static void OldMathFuncDeleteProc(ClientData clientData);
+#endif /* !defined(TCL_NO_DEPRECATED) */
static void ProcessUnexpectedResult(Tcl_Interp *interp,
int returnCode);
static int RewindCoroutine(CoroutineData *corPtr, int result);
@@ -205,7 +207,7 @@ static const CmdInfo builtInCmds[] = {
{"append", Tcl_AppendObjCmd, TclCompileAppendCmd, NULL, CMD_IS_SAFE},
{"apply", Tcl_ApplyObjCmd, NULL, TclNRApplyObjCmd, CMD_IS_SAFE},
{"break", Tcl_BreakObjCmd, TclCompileBreakCmd, NULL, CMD_IS_SAFE},
-#ifndef TCL_NO_DEPRECATED
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
{"case", Tcl_CaseObjCmd, NULL, NULL, CMD_IS_SAFE},
#endif
{"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, TclNRCatchObjCmd, CMD_IS_SAFE},
@@ -236,7 +238,7 @@ static const CmdInfo builtInCmds[] = {
{"lsearch", Tcl_LsearchObjCmd, NULL, NULL, CMD_IS_SAFE},
{"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, CMD_IS_SAFE},
{"lsort", Tcl_LsortObjCmd, NULL, NULL, CMD_IS_SAFE},
- {"package", Tcl_PackageObjCmd, NULL, NULL, CMD_IS_SAFE},
+ {"package", Tcl_PackageObjCmd, NULL, TclNRPackageObjCmd, CMD_IS_SAFE},
{"proc", Tcl_ProcObjCmd, NULL, NULL, CMD_IS_SAFE},
{"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, CMD_IS_SAFE},
{"regsub", Tcl_RegsubObjCmd, TclCompileRegsubCmd, NULL, CMD_IS_SAFE},
@@ -817,6 +819,7 @@ Tcl_CreateInterp(void)
TclInitNamespaceCmd(interp);
TclInitStringCmd(interp);
TclInitPrefixCmd(interp);
+ TclInitProcessCmd(interp);
/*
* Register "clock" subcommands. These *do* go through
@@ -2626,10 +2629,6 @@ TclRenameCommand(
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", oldName, NULL);
return TCL_ERROR;
}
- cmdNsPtr = cmdPtr->nsPtr;
- oldFullName = Tcl_NewObj();
- Tcl_IncrRefCount(oldFullName);
- Tcl_GetCommandFullName(interp, cmd, oldFullName);
/*
* If the new command name is NULL or empty, delete the command. Do this
@@ -2638,10 +2637,14 @@ TclRenameCommand(
if ((newName == NULL) || (*newName == '\0')) {
Tcl_DeleteCommandFromToken(interp, cmd);
- result = TCL_OK;
- goto done;
+ return TCL_OK;
}
+ cmdNsPtr = cmdPtr->nsPtr;
+ oldFullName = Tcl_NewObj();
+ Tcl_IncrRefCount(oldFullName);
+ Tcl_GetCommandFullName(interp, cmd, oldFullName);
+
/*
* Make sure that the destination command does not already exist. The
* rename operation is like creating a command, so we should automatically
@@ -3154,6 +3157,7 @@ Tcl_DeleteCommandFromToken(
*/
cmdPtr->nsPtr->refCount++;
+
if (cmdPtr->tracePtr != NULL) {
CommandTrace *tracePtr;
CallCommandTraces(iPtr,cmdPtr,NULL,NULL,TCL_TRACE_DELETE);
@@ -3519,6 +3523,7 @@ TclCleanupCommand(
*----------------------------------------------------------------------
*/
+#if !defined(TCL_NO_DEPRECATED)
void
Tcl_CreateMathFunc(
Tcl_Interp *interp, /* Interpreter in which function is to be
@@ -3569,7 +3574,7 @@ Tcl_CreateMathFunc(
static int
OldMathFuncProc(
- ClientData clientData, /* Ponter to OldMathFuncData describing the
+ ClientData clientData, /* Pointer to OldMathFuncData describing the
* function being called */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Actual parameter count */
@@ -3682,7 +3687,7 @@ OldMathFuncProc(
*/
if (funcResult.type == TCL_INT) {
- TclNewLongObj(valuePtr, funcResult.intValue);
+ TclNewIntObj(valuePtr, funcResult.intValue);
} else if (funcResult.type == TCL_WIDE_INT) {
valuePtr = Tcl_NewWideIntObj(funcResult.wideValue);
} else {
@@ -3850,6 +3855,7 @@ Tcl_ListMathFuncs(
return result;
}
+#endif /* !defined(TCL_NO_DEPRECATED) */
/*
*----------------------------------------------------------------------
@@ -4457,7 +4463,9 @@ TclNRRunCallbacks(
/* All callbacks down to rootPtr not inclusive
* are to be run. */
{
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
Interp *iPtr = (Interp *) interp;
+#endif /* !defined(TCL_NO_DEPRECATED) */
NRE_callback *callbackPtr;
Tcl_NRPostProc *procPtr;
@@ -4471,9 +4479,13 @@ TclNRRunCallbacks(
* are for NR function calls, and those are Tcl_Obj based.
*/
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
if (*(iPtr->result) != 0) {
(void) Tcl_GetObjResult(interp);
}
+#endif /* !defined(TCL_NO_DEPRECATED) */
+
+ /* This is the trampoline. */
while (TOP_CB(interp) != rootPtr) {
callbackPtr = TOP_CB(interp);
@@ -4932,6 +4944,7 @@ Tcl_EvalTokensStandard(
NULL, NULL);
}
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
/*
*----------------------------------------------------------------------
*
@@ -4979,6 +4992,7 @@ Tcl_EvalTokens(
Tcl_ResetResult(interp);
return resPtr;
}
+#endif /* !TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -6497,7 +6511,6 @@ Tcl_ExprLongObj(
resultPtr = Tcl_NewBignumObj(&big);
/* FALLTHROUGH */
}
- case TCL_NUMBER_LONG:
case TCL_NUMBER_WIDE:
case TCL_NUMBER_BIG:
result = TclGetLongFromObj(interp, resultPtr, ptr);
@@ -6865,7 +6878,8 @@ Tcl_AddObjErrorInfo(
iPtr->flags |= ERR_LEGACY_COPY;
if (iPtr->errorInfo == NULL) {
- if (iPtr->result[0] != 0) {
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
+ if (*(iPtr->result) != 0) {
/*
* The interp's string result is set, apparently by some extension
* making a deprecated direct write to it. That extension may
@@ -6875,9 +6889,9 @@ Tcl_AddObjErrorInfo(
*/
iPtr->errorInfo = Tcl_NewStringObj(iPtr->result, -1);
- } else {
+ } else
+#endif /* !defined(TCL_NO_DEPRECATED) */
iPtr->errorInfo = iPtr->objResultPtr;
- }
Tcl_IncrRefCount(iPtr->errorInfo);
if (!iPtr->errorCode) {
Tcl_SetErrorCode(interp, "NONE", NULL);
@@ -7473,12 +7487,12 @@ ExprAbsFunc(
return TCL_ERROR;
}
- if (type == TCL_NUMBER_LONG) {
- long l = *((const long *) ptr);
+ if (type == TCL_NUMBER_WIDE) {
+ Tcl_WideInt l = *((const Tcl_WideInt *) ptr);
- if (l > (long)0) {
+ if (l > (Tcl_WideInt)0) {
goto unChanged;
- } else if (l == (long)0) {
+ } else if (l == (Tcl_WideInt)0) {
const char *string = objv[1]->bytes;
if (string) {
while (*string != '0') {
@@ -7490,11 +7504,11 @@ ExprAbsFunc(
}
}
goto unChanged;
- } else if (l == LONG_MIN) {
- TclInitBignumFromLong(&big, l);
+ } else if (l == LLONG_MIN) {
+ TclInitBignumFromWideInt(&big, l);
goto tooLarge;
}
- Tcl_SetObjResult(interp, Tcl_NewLongObj(-l));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-l));
return TCL_OK;
}
@@ -7518,24 +7532,8 @@ ExprAbsFunc(
return TCL_OK;
}
-#ifndef TCL_WIDE_INT_IS_LONG
- if (type == TCL_NUMBER_WIDE) {
- Tcl_WideInt w = *((const Tcl_WideInt *) ptr);
-
- if (w >= (Tcl_WideInt)0) {
- goto unChanged;
- }
- if (w == LLONG_MIN) {
- TclInitBignumFromWideInt(&big, w);
- goto tooLarge;
- }
- Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-w));
- return TCL_OK;
- }
-#endif
-
if (type == TCL_NUMBER_BIG) {
- if (mp_cmp_d((const mp_int *) ptr, 0) == MP_LT) {
+ if (mp_isneg((const mp_int *) ptr)) {
Tcl_GetBignumFromObj(NULL, objv[1], &big);
tooLarge:
mp_neg(&big, &big);
diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c
index 123d872..de767f9 100644
--- a/generic/tclCkalloc.c
+++ b/generic/tclCkalloc.c
@@ -187,15 +187,15 @@ TclDumpMemoryInfo(
"total mallocs %10u\n"
"total frees %10u\n"
"current packets allocated %10u\n"
- "current bytes allocated %10" TCL_LL_MODIFIER "u\n"
+ "current bytes allocated %10" TCL_Z_MODIFIER "u\n"
"maximum packets allocated %10u\n"
- "maximum bytes allocated %10" TCL_LL_MODIFIER "u\n",
+ "maximum bytes allocated %10" TCL_Z_MODIFIER "u\n",
total_mallocs,
total_frees,
current_malloc_packets,
- (Tcl_WideInt)current_bytes_malloced,
+ current_bytes_malloced,
maximum_malloc_packets,
- (Tcl_WideInt)maximum_bytes_malloced);
+ maximum_bytes_malloced);
if (flags == 0) {
fprintf((FILE *)clientData, "%s", buf);
} else {
@@ -254,7 +254,7 @@ ValidateMemory(
fprintf(stderr, "low guard failed at %p, %s %d\n",
memHeaderP->body, file, line);
fflush(stderr); /* In case name pointer is bad. */
- fprintf(stderr, "%" TCL_LL_MODIFIER "d bytes allocated at (%s %d)\n", (Tcl_WideInt) memHeaderP->length,
+ fprintf(stderr, "%" TCL_Z_MODIFIER "u bytes allocated at (%s %d)\n", memHeaderP->length,
memHeaderP->file, memHeaderP->line);
Tcl_Panic("Memory validation failure");
}
@@ -276,8 +276,8 @@ ValidateMemory(
fprintf(stderr, "high guard failed at %p, %s %d\n",
memHeaderP->body, file, line);
fflush(stderr); /* In case name pointer is bad. */
- fprintf(stderr, "%" TCL_LL_MODIFIER "d bytes allocated at (%s %d)\n",
- (Tcl_WideInt)memHeaderP->length, memHeaderP->file,
+ fprintf(stderr, "%" TCL_Z_MODIFIER "u bytes allocated at (%s %d)\n",
+ memHeaderP->length, memHeaderP->file,
memHeaderP->line);
Tcl_Panic("Memory validation failure");
}
@@ -359,9 +359,9 @@ Tcl_DumpActiveMemory(
Tcl_MutexLock(ckallocMutexPtr);
for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) {
address = &memScanP->body[0];
- fprintf(fileP, "%p - %p %" TCL_LL_MODIFIER "d @ %s %d %s",
+ fprintf(fileP, "%p - %p %" TCL_Z_MODIFIER "u @ %s %d %s",
address, address + memScanP->length - 1,
- (Tcl_WideInt)memScanP->length, memScanP->file, memScanP->line,
+ memScanP->length, memScanP->file, memScanP->line,
(memScanP->tagPtr == NULL) ? "" : memScanP->tagPtr->string);
(void) fputc('\n', fileP);
}
@@ -611,8 +611,8 @@ Tcl_DbCkfree(
memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET);
if (alloc_tracing) {
- fprintf(stderr, "ckfree %p %" TCL_LL_MODIFIER "d %s %d\n",
- memp->body, (Tcl_WideInt) memp->length, file, line);
+ fprintf(stderr, "ckfree %p %" TCL_Z_MODIFIER "u %s %d\n",
+ memp->body, memp->length, file, line);
}
if (validate_memory) {
@@ -859,12 +859,12 @@ MemoryCmd(
}
if (strcmp(argv[1],"info") == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "%-25s %10u\n%-25s %10u\n%-25s %10u\n%-25s %10" TCL_LL_MODIFIER"d\n%-25s %10u\n%-25s %10" TCL_LL_MODIFIER "d\n",
+ "%-25s %10u\n%-25s %10u\n%-25s %10u\n%-25s %10" TCL_Z_MODIFIER"u\n%-25s %10u\n%-25s %10" TCL_Z_MODIFIER "u\n",
"total mallocs", total_mallocs, "total frees", total_frees,
"current packets allocated", current_malloc_packets,
- "current bytes allocated", (Tcl_WideInt)current_bytes_malloced,
+ "current bytes allocated", current_bytes_malloced,
"maximum packets allocated", maximum_malloc_packets,
- "maximum bytes allocated", (Tcl_WideInt)maximum_bytes_malloced));
+ "maximum bytes allocated", maximum_bytes_malloced));
return TCL_OK;
}
if (strcmp(argv[1], "init") == 0) {
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 807a1ac..49c8c56 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -164,7 +164,7 @@ Tcl_BreakObjCmd(
*
*----------------------------------------------------------------------
*/
-#ifndef TCL_NO_DEPRECATED
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
/* ARGSUSED */
int
Tcl_CaseObjCmd(
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index b41d312..d628e80 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -64,8 +64,9 @@ typedef struct SortInfo {
* SORTMODE_COMMAND. Pre-initialized to hold
* base of command. */
int *indexv; /* If the -index option was specified, this
- * holds the indexes contained in the list
- * supplied as an argument to that option.
+ * holds an encoding of the indexes contained
+ * in the list supplied as an argument to
+ * that option.
* NULL if no indexes supplied, and points to
* singleIndex field when only one
* supplied. */
@@ -93,14 +94,6 @@ typedef struct SortInfo {
#define SORTMODE_ASCII_NC 8
/*
- * Magic values for the index field of the SortInfo structure. Note that the
- * index "end-1" will be translated to SORTIDX_END-1, etc.
- */
-
-#define SORTIDX_NONE -1 /* Not indexed; use whole value. */
-#define SORTIDX_END -2 /* Indexed from end. */
-
-/*
* Forward declarations for procedures defined in this file:
*/
@@ -2160,7 +2153,7 @@ Tcl_JoinObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
- int listLen;
+ int length, listLen;
Tcl_Obj *resObjPtr = NULL, *joinObjPtr, **elemPtrs;
if ((objc < 2) || (objc > 3)) {
@@ -2191,9 +2184,9 @@ Tcl_JoinObjCmd(
joinObjPtr = (objc == 2) ? Tcl_NewStringObj(" ", 1) : objv[2];
Tcl_IncrRefCount(joinObjPtr);
- if (Tcl_GetCharLength(joinObjPtr) == 0) {
- TclStringCatObjv(interp, /* inPlace */ 0, listLen, elemPtrs,
- &resObjPtr);
+ (void) Tcl_GetStringFromObj(joinObjPtr, &length);
+ if (length == 0) {
+ resObjPtr = TclStringCat(interp, listLen, elemPtrs, 0);
} else {
int i;
@@ -2787,7 +2780,7 @@ Tcl_LreplaceObjCmd(
* (to allow for replacing the last elem).
*/
- if ((first > listLen) && (listLen > 0)) {
+ if ((first >= listLen) && (listLen > 0)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"list doesn't contain element %s", TclGetString(objv[2])));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LREPLACE", "BADIDX",
@@ -2938,8 +2931,9 @@ Tcl_LsearchObjCmd(
Tcl_Obj *const objv[]) /* Argument values. */
{
const char *bytes, *patternBytes;
- int i, match, index, result, listc, length, elemLen, bisect;
- int dataType, isIncreasing, lower, upper, offset;
+ int i, match, index, result=TCL_OK, listc, length, elemLen, bisect;
+ int allocatedIndexVector = 0;
+ int dataType, isIncreasing, lower, upper, start, groupSize, groupOffset;
Tcl_WideInt patWide, objWide;
int allMatches, inlineReturn, negatedMatch, returnSubindices, noCase;
double patDouble, objDouble;
@@ -2951,7 +2945,7 @@ Tcl_LsearchObjCmd(
"-all", "-ascii", "-bisect", "-decreasing", "-dictionary",
"-exact", "-glob", "-increasing", "-index",
"-inline", "-integer", "-nocase", "-not",
- "-real", "-regexp", "-sorted", "-start",
+ "-real", "-regexp", "-sorted", "-start", "-stride",
"-subindices", NULL
};
enum options {
@@ -2959,7 +2953,7 @@ Tcl_LsearchObjCmd(
LSEARCH_DICTIONARY, LSEARCH_EXACT, LSEARCH_GLOB, LSEARCH_INCREASING,
LSEARCH_INDEX, LSEARCH_INLINE, LSEARCH_INTEGER, LSEARCH_NOCASE,
LSEARCH_NOT, LSEARCH_REAL, LSEARCH_REGEXP, LSEARCH_SORTED,
- LSEARCH_START, LSEARCH_SUBINDICES
+ LSEARCH_START, LSEARCH_STRIDE, LSEARCH_SUBINDICES
};
enum datatypes {
ASCII, DICTIONARY, INTEGER, REAL
@@ -2979,7 +2973,9 @@ Tcl_LsearchObjCmd(
bisect = 0;
listPtr = NULL;
startPtr = NULL;
- offset = 0;
+ groupSize = 1;
+ groupOffset = 0;
+ start = 0;
noCase = 0;
sortInfo.compareCmdPtr = NULL;
sortInfo.isIncreasing = 1;
@@ -2997,9 +2993,6 @@ Tcl_LsearchObjCmd(
for (i = 1; i < objc-2; i++) {
if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index)
!= TCL_OK) {
- if (startPtr != NULL) {
- Tcl_DecrRefCount(startPtr);
- }
result = TCL_ERROR;
goto done;
}
@@ -3064,6 +3057,7 @@ Tcl_LsearchObjCmd(
if (startPtr != NULL) {
Tcl_DecrRefCount(startPtr);
+ startPtr = NULL;
}
if (i > objc-4) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
@@ -3084,25 +3078,47 @@ Tcl_LsearchObjCmd(
startPtr = Tcl_DuplicateObj(objv[i]);
} else {
startPtr = objv[i];
- Tcl_IncrRefCount(startPtr);
}
+ Tcl_IncrRefCount(startPtr);
+ break;
+ case LSEARCH_STRIDE: /* -stride */
+ if (i > objc-4) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "\"-stride\" option must be "
+ "followed by stride length", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
+ result = TCL_ERROR;
+ goto done;
+ }
+ if (Tcl_GetIntFromObj(interp, objv[i+1], &groupSize) != TCL_OK) {
+ result = TCL_ERROR;
+ goto done;
+ }
+ if (groupSize < 1) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "stride length must be at least 1", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT",
+ "BADSTRIDE", NULL);
+ result = TCL_ERROR;
+ goto done;
+ }
+ i++;
break;
case LSEARCH_INDEX: { /* -index */
Tcl_Obj **indices;
int j;
- if (sortInfo.indexc > 1) {
+ if (allocatedIndexVector) {
TclStackFree(interp, sortInfo.indexv);
+ allocatedIndexVector = 0;
}
if (i > objc-4) {
- if (startPtr != NULL) {
- Tcl_DecrRefCount(startPtr);
- }
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-index\" option must be followed by list index",
-1));
Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
- return TCL_ERROR;
+ result = TCL_ERROR;
+ goto done;
}
/*
@@ -3114,10 +3130,8 @@ Tcl_LsearchObjCmd(
i++;
if (TclListObjGetElements(interp, objv[i],
&sortInfo.indexc, &indices) != TCL_OK) {
- if (startPtr != NULL) {
- Tcl_DecrRefCount(startPtr);
- }
- return TCL_ERROR;
+ result = TCL_ERROR;
+ goto done;
}
switch (sortInfo.indexc) {
case 0:
@@ -3129,6 +3143,8 @@ Tcl_LsearchObjCmd(
default:
sortInfo.indexv =
TclStackAlloc(interp, sizeof(int) * sortInfo.indexc);
+ allocatedIndexVector = 1; /* Cannot use indexc field, as it
+ * might be decreased by 1 later. */
}
/*
@@ -3138,13 +3154,26 @@ Tcl_LsearchObjCmd(
*/
for (j=0 ; j<sortInfo.indexc ; j++) {
- if (TclGetIntForIndexM(interp, indices[j], SORTIDX_END,
- &sortInfo.indexv[j]) != TCL_OK) {
+ int encoded = 0;
+ if (TclIndexEncode(interp, indices[j], TCL_INDEX_BEFORE,
+ TCL_INDEX_AFTER, &encoded) != TCL_OK) {
+ result = TCL_ERROR;
+ }
+ if ((encoded == TCL_INDEX_BEFORE)
+ || (encoded == TCL_INDEX_AFTER)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "index \"%s\" cannot select an element "
+ "from any list", Tcl_GetString(indices[j])));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX"
+ "OUTOFRANGE", NULL);
+ result = TCL_ERROR;
+ }
+ if (result == TCL_ERROR) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (-index option item number %d)", j));
- result = TCL_ERROR;
goto done;
}
+ sortInfo.indexv[j] = encoded;
}
break;
}
@@ -3156,14 +3185,12 @@ Tcl_LsearchObjCmd(
*/
if (returnSubindices && sortInfo.indexc==0) {
- if (startPtr != NULL) {
- Tcl_DecrRefCount(startPtr);
- }
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"-subindices cannot be used without -index option", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
"BAD_OPTION_MIX", NULL);
- return TCL_ERROR;
+ result = TCL_ERROR;
+ goto done;
}
if (bisect && (allMatches || negatedMatch)) {
@@ -3171,7 +3198,8 @@ Tcl_LsearchObjCmd(
"-bisect is not compatible with -all or -not", -1));
Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
"BAD_OPTION_MIX", NULL);
- return TCL_ERROR;
+ result = TCL_ERROR;
+ goto done;
}
if (mode == REGEXP) {
@@ -3197,9 +3225,6 @@ Tcl_LsearchObjCmd(
}
if (regexp == NULL) {
- if (startPtr != NULL) {
- Tcl_DecrRefCount(startPtr);
- }
result = TCL_ERROR;
goto done;
}
@@ -3212,24 +3237,64 @@ Tcl_LsearchObjCmd(
result = TclListObjGetElements(interp, objv[objc - 2], &listc, &listv);
if (result != TCL_OK) {
- if (startPtr != NULL) {
- Tcl_DecrRefCount(startPtr);
- }
goto done;
}
/*
+ * Check for sanity when grouping elements of the overall list together
+ * because of the -stride option. [TIP #351]
+ */
+
+ if (groupSize > 1) {
+ if (listc % groupSize) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "list size must be a multiple of the stride length",
+ -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", "BADSTRIDE",
+ NULL);
+ result = TCL_ERROR;
+ goto done;
+ }
+ if (sortInfo.indexc > 0) {
+ /*
+ * Use the first value in the list supplied to -index as the
+ * offset of the element within each group by which to sort.
+ */
+
+ groupOffset = TclIndexDecode(sortInfo.indexv[0], groupSize - 1);
+ if (groupOffset < 0 || groupOffset >= groupSize) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "when used with \"-stride\", the leading \"-index\""
+ " value must be within the group", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
+ "BADINDEX", NULL);
+ result = TCL_ERROR;
+ goto done;
+ }
+ if (sortInfo.indexc == 1) {
+ sortInfo.indexc = 0;
+ sortInfo.indexv = NULL;
+ } else {
+ sortInfo.indexc--;
+
+ for (i = 0; i < sortInfo.indexc; i++) {
+ sortInfo.indexv[i] = sortInfo.indexv[i+1];
+ }
+ }
+ }
+ }
+
+ /*
* Get the user-specified start offset.
*/
if (startPtr) {
- result = TclGetIntForIndexM(interp, startPtr, listc-1, &offset);
- Tcl_DecrRefCount(startPtr);
+ result = TclGetIntForIndexM(interp, startPtr, listc-1, &start);
if (result != TCL_OK) {
goto done;
}
- if (offset < 0) {
- offset = 0;
+ if (start < 0) {
+ start = 0;
}
/*
@@ -3237,16 +3302,21 @@ Tcl_LsearchObjCmd(
* "did not match anything at all" result straight away. [Bug 1374778]
*/
- if (offset > listc-1) {
- if (sortInfo.indexc > 1) {
- TclStackFree(interp, sortInfo.indexv);
- }
+ if (start > listc-1) {
if (allMatches || inlineReturn) {
Tcl_ResetResult(interp);
} else {
Tcl_SetObjResult(interp, Tcl_NewIntObj(-1));
}
- return TCL_OK;
+ goto done;
+ }
+
+ /*
+ * If start points within a group, it points to the start of the group.
+ */
+
+ if (groupSize > 1) {
+ start -= (start % groupSize);
}
}
@@ -3305,18 +3375,23 @@ Tcl_LsearchObjCmd(
* sense in doing this when the match sense is inverted.
*/
- lower = offset - 1;
+ /*
+ * With -stride, lower, upper and i are kept as multiples of groupSize.
+ */
+
+ lower = start - groupSize;
upper = listc;
- while (lower + 1 != upper && sortInfo.resultCode == TCL_OK) {
+ while (lower + groupSize != upper && sortInfo.resultCode == TCL_OK) {
i = (lower + upper)/2;
+ i -= i % groupSize;
if (sortInfo.indexc != 0) {
- itemPtr = SelectObjFromSublist(listv[i], &sortInfo);
+ itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo);
if (sortInfo.resultCode != TCL_OK) {
result = sortInfo.resultCode;
goto done;
}
} else {
- itemPtr = listv[i];
+ itemPtr = listv[i+groupOffset];
}
switch ((enum datatypes) dataType) {
case ASCII:
@@ -3405,10 +3480,10 @@ Tcl_LsearchObjCmd(
if (allMatches) {
listPtr = Tcl_NewListObj(0, NULL);
}
- for (i = offset; i < listc; i++) {
+ for (i = start; i < listc; i += groupSize) {
match = 0;
if (sortInfo.indexc != 0) {
- itemPtr = SelectObjFromSublist(listv[i], &sortInfo);
+ itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo);
if (sortInfo.resultCode != TCL_OK) {
if (listPtr != NULL) {
Tcl_DecrRefCount(listPtr);
@@ -3417,7 +3492,7 @@ Tcl_LsearchObjCmd(
goto done;
}
} else {
- itemPtr = listv[i];
+ itemPtr = listv[i+groupOffset];
}
switch (mode) {
@@ -3507,18 +3582,23 @@ Tcl_LsearchObjCmd(
*/
if (returnSubindices && (sortInfo.indexc != 0)) {
- itemPtr = SelectObjFromSublist(listv[i], &sortInfo);
+ itemPtr = SelectObjFromSublist(listv[i+groupOffset],
+ &sortInfo);
+ Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
+ } else if (groupSize > 1) {
+ Tcl_ListObjReplace(interp, listPtr, LIST_MAX, 0,
+ groupSize, &listv[i]);
} else {
itemPtr = listv[i];
+ Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
}
- Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
} else if (returnSubindices) {
int j;
- itemPtr = Tcl_NewIntObj(i);
+ itemPtr = Tcl_NewIntObj(i+groupOffset);
for (j=0 ; j<sortInfo.indexc ; j++) {
- Tcl_ListObjAppendElement(interp, itemPtr,
- Tcl_NewIntObj(sortInfo.indexv[j]));
+ Tcl_ListObjAppendElement(interp, itemPtr, Tcl_NewIntObj(
+ TclIndexDecode(sortInfo.indexv[j], listc)));
}
Tcl_ListObjAppendElement(interp, listPtr, itemPtr);
} else {
@@ -3537,10 +3617,10 @@ Tcl_LsearchObjCmd(
if (returnSubindices) {
int j;
- itemPtr = Tcl_NewIntObj(index);
+ itemPtr = Tcl_NewIntObj(index+groupOffset);
for (j=0 ; j<sortInfo.indexc ; j++) {
- Tcl_ListObjAppendElement(interp, itemPtr,
- Tcl_NewIntObj(sortInfo.indexv[j]));
+ Tcl_ListObjAppendElement(interp, itemPtr, Tcl_NewIntObj(
+ TclIndexDecode(sortInfo.indexv[j], listc)));
}
Tcl_SetObjResult(interp, itemPtr);
} else {
@@ -3554,7 +3634,14 @@ Tcl_LsearchObjCmd(
Tcl_SetObjResult(interp, Tcl_NewObj());
} else {
- Tcl_SetObjResult(interp, listv[index]);
+ if (returnSubindices) {
+ Tcl_SetObjResult(interp, SelectObjFromSublist(listv[i+groupOffset],
+ &sortInfo));
+ } else if (groupSize > 1) {
+ Tcl_SetObjResult(interp, Tcl_NewListObj(groupSize, &listv[index]));
+ } else {
+ Tcl_SetObjResult(interp, listv[index]);
+ }
}
result = TCL_OK;
@@ -3563,7 +3650,10 @@ Tcl_LsearchObjCmd(
*/
done:
- if (sortInfo.indexc > 1) {
+ if (startPtr != NULL) {
+ Tcl_DecrRefCount(startPtr);
+ }
+ if (allocatedIndexVector) {
TclStackFree(interp, sortInfo.indexv);
}
return result;
@@ -3757,7 +3847,7 @@ Tcl_LsortObjCmd(
sortInfo.isIncreasing = 1;
break;
case LSORT_INDEX: {
- int indexc, dummy;
+ int indexc;
Tcl_Obj **indexv;
if (i == objc-2) {
@@ -3783,8 +3873,20 @@ Tcl_LsortObjCmd(
*/
for (j=0 ; j<indexc ; j++) {
- if (TclGetIntForIndexM(interp, indexv[j], SORTIDX_END,
- &dummy) != TCL_OK) {
+ int encoded = 0;
+ int result = TclIndexEncode(interp, indexv[j],
+ TCL_INDEX_BEFORE, TCL_INDEX_AFTER, &encoded);
+
+ if ((result == TCL_OK) && ((encoded == TCL_INDEX_BEFORE)
+ || (encoded == TCL_INDEX_AFTER))) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "index \"%s\" cannot select an element "
+ "from any list", Tcl_GetString(indexv[j])));
+ Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX"
+ "OUTOFRANGE", NULL);
+ result = TCL_ERROR;
+ }
+ if (result == TCL_ERROR) {
Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
"\n (-index option item number %d)", j));
sortInfo.resultCode = TCL_ERROR;
@@ -3864,8 +3966,8 @@ Tcl_LsortObjCmd(
* might be decreased by 1 later. */
}
for (j=0 ; j<sortInfo.indexc ; j++) {
- TclGetIntForIndexM(interp, indexv[j], SORTIDX_END,
- &sortInfo.indexv[j]);
+ /* Prescreened values, no errors or out of range possible */
+ TclIndexEncode(NULL, indexv[j], 0, 0, &sortInfo.indexv[j]);
}
}
@@ -3936,10 +4038,7 @@ Tcl_LsortObjCmd(
* offset of the element within each group by which to sort.
*/
- groupOffset = sortInfo.indexv[0];
- if (groupOffset <= SORTIDX_END) {
- groupOffset = (groupOffset - SORTIDX_END) + groupSize - 1;
- }
+ groupOffset = TclIndexDecode(sortInfo.indexv[0], groupSize - 1);
if (groupOffset < 0 || groupOffset >= groupSize) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"when used with \"-stride\", the leading \"-index\""
@@ -3958,6 +4057,9 @@ Tcl_LsortObjCmd(
/*
* Do not shrink the actual memory block used; that doesn't
* work with TclStackAlloc-allocated memory. [Bug 2918962]
+ *
+ * TODO: Consider a pointer increment to replace this
+ * array shift.
*/
for (i = 0; i < sortInfo.indexc; i++) {
@@ -4526,15 +4628,8 @@ SelectObjFromSublist(
infoPtr->resultCode = TCL_ERROR;
return NULL;
}
- index = infoPtr->indexv[i];
- /*
- * Adjust for end-based indexing.
- */
-
- if (index < SORTIDX_NONE) {
- index += listLen + 1;
- }
+ index = TclIndexDecode(infoPtr->indexv[i], listLen - 1);
if (Tcl_ListObjIndex(infoPtr->interp, objPtr, index,
&currentObj) != TCL_OK) {
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index a206cc5..0b65758 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -1335,16 +1335,8 @@ StringFirstCmd(
if (TCL_OK != TclGetIntForIndexM(interp, objv[3], size - 1, &start)) {
return TCL_ERROR;
}
-
- if (start < 0) {
- start = 0;
- }
- if (start >= size) {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(-1));
- return TCL_OK;
- }
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(TclStringFind(objv[1],
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(TclStringFirst(objv[1],
objv[2], start)));
return TCL_OK;
}
@@ -1388,14 +1380,6 @@ StringLastCmd(
if (TCL_OK != TclGetIntForIndexM(interp, objv[3], size - 1, &last)) {
return TCL_ERROR;
}
-
- if (last < 0) {
- Tcl_SetObjResult(interp, Tcl_NewIntObj(-1));
- return TCL_OK;
- }
- if (last >= size) {
- last = size - 1;
- }
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(TclStringLast(objv[1],
objv[2], last)));
@@ -1588,11 +1572,11 @@ StringIsCmd(
string1 = TclGetStringFromObj(objPtr, &length1);
result = length1 == 0;
}
- } else if (((index == STR_IS_TRUE) &&
- objPtr->internalRep.longValue == 0)
- || ((index == STR_IS_FALSE) &&
- objPtr->internalRep.longValue != 0)) {
- result = 0;
+ } else if (index != STR_IS_BOOL) {
+ TclGetBooleanFromObj(NULL, objPtr, &i);
+ if ((index == STR_IS_TRUE) ^ i) {
+ result = 0;
+ }
}
break;
case STR_IS_CONTROL:
@@ -1605,9 +1589,6 @@ StringIsCmd(
/* TODO */
if ((objPtr->typePtr == &tclDoubleType) ||
(objPtr->typePtr == &tclIntType) ||
-#ifndef TCL_WIDE_INT_IS_LONG
- (objPtr->typePtr == &tclWideIntType) ||
-#endif
(objPtr->typePtr == &tclBignumType)) {
break;
}
@@ -1642,9 +1623,6 @@ StringIsCmd(
goto failedIntParse;
case STR_IS_ENTIER:
if ((objPtr->typePtr == &tclIntType) ||
-#ifndef TCL_WIDE_INT_IS_LONG
- (objPtr->typePtr == &tclWideIntType) ||
-#endif
(objPtr->typePtr == &tclBignumType)) {
break;
}
@@ -2294,11 +2272,12 @@ StringReptCmd(
return TCL_OK;
}
- if (TCL_OK != TclStringRepeat(interp, objv[1], count, &resultPtr)) {
- return TCL_ERROR;
+ resultPtr = TclStringRepeat(interp, objv[1], count, TCL_STRING_IN_PLACE);
+ if (resultPtr) {
+ Tcl_SetObjResult(interp, resultPtr);
+ return TCL_OK;
}
- Tcl_SetObjResult(interp, resultPtr);
- return TCL_OK;
+ return TCL_ERROR;
}
/*
@@ -2326,42 +2305,50 @@ StringRplcCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- Tcl_UniChar *ustring;
- int first, last, length;
+ int first, last, length, end;
if (objc < 4 || objc > 5) {
Tcl_WrongNumArgs(interp, 1, objv, "string first last ?string?");
return TCL_ERROR;
}
- ustring = Tcl_GetUnicodeFromObj(objv[1], &length);
- length--;
+ length = Tcl_GetCharLength(objv[1]);
+ end = length - 1;
- if (TclGetIntForIndexM(interp, objv[2], length, &first) != TCL_OK ||
- TclGetIntForIndexM(interp, objv[3], length, &last) != TCL_OK){
+ if (TclGetIntForIndexM(interp, objv[2], end, &first) != TCL_OK ||
+ TclGetIntForIndexM(interp, objv[3], end, &last) != TCL_OK){
return TCL_ERROR;
}
- if ((last < first) || (last < 0) || (first > length)) {
+ /*
+ * The following test screens out most empty substrings as
+ * candidates for replacement. When they are detected, no
+ * replacement is done, and the result is the original string,
+ */
+ if ((last < 0) || /* Range ends before start of string */
+ (first > end) || /* Range begins after end of string */
+ (last < first)) { /* Range begins after it starts */
+
+ /*
+ * BUT!!! when (end < 0) -- an empty original string -- we can
+ * have (first <= end < 0 <= last) and an empty string is permitted
+ * to be replaced.
+ */
Tcl_SetObjResult(interp, objv[1]);
} else {
Tcl_Obj *resultPtr;
- ustring = Tcl_GetUnicodeFromObj(objv[1], &length);
- length--;
-
if (first < 0) {
first = 0;
}
-
- resultPtr = Tcl_NewUnicodeObj(ustring, first);
- if (objc == 5) {
- Tcl_AppendObjToObj(resultPtr, objv[4]);
- }
- if (last < length) {
- Tcl_AppendUnicodeToObj(resultPtr, ustring + last + 1,
- length - last);
+ if (last > end) {
+ last = end;
}
+
+ resultPtr = TclStringReplace(interp, objv[1], first,
+ last + 1 - first, (objc == 5) ? objv[4] : NULL,
+ TCL_STRING_IN_PLACE);
+
Tcl_SetObjResult(interp, resultPtr);
}
return TCL_OK;
@@ -2397,7 +2384,7 @@ StringRevCmd(
return TCL_ERROR;
}
- Tcl_SetObjResult(interp, TclStringObjReverse(objv[1]));
+ Tcl_SetObjResult(interp, TclStringReverse(objv[1], TCL_STRING_IN_PLACE));
return TCL_OK;
}
@@ -2846,7 +2833,6 @@ StringCatCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int code;
Tcl_Obj *objResultPtr;
if (objc < 2) {
@@ -2856,23 +2842,15 @@ StringCatCmd(
*/
return TCL_OK;
}
- if (objc == 2) {
- /*
- * Other trivial case, single arg, just return it.
- */
- Tcl_SetObjResult(interp, objv[1]);
- return TCL_OK;
- }
- code = TclStringCatObjv(interp, /* inPlace */ 1, objc-1, objv+1,
- &objResultPtr);
+ objResultPtr = TclStringCat(interp, objc-1, objv+1, TCL_STRING_IN_PLACE);
- if (code == TCL_OK) {
+ if (objResultPtr) {
Tcl_SetObjResult(interp, objResultPtr);
return TCL_OK;
}
- return code;
+ return TCL_ERROR;
}
/*
@@ -2893,7 +2871,6 @@ StringCatCmd(
*
*----------------------------------------------------------------------
*/
-
static int
StringBytesCmd(
ClientData dummy, /* Not used. */
@@ -3241,8 +3218,7 @@ StringTrimCmd(
}
string1 = TclGetStringFromObj(objv[1], &length1);
- triml = TclTrimLeft(string1, length1, string2, length2);
- trimr = TclTrimRight(string1 + triml, length1 - triml, string2, length2);
+ triml = TclTrim(string1, length1, string2, length2, &trimr);
Tcl_SetObjResult(interp,
Tcl_NewStringObj(string1 + triml, length1 - triml - trimr));
@@ -4310,7 +4286,7 @@ TclNRTryObjCmd(
}
info[0] = objv[i]; /* type */
- TclNewLongObj(info[1], code); /* returnCode */
+ TclNewIntObj(info[1], code); /* returnCode */
if (info[2] == NULL) { /* errorCodePrefix */
TclNewObj(info[2]);
}
diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c
index ff5495c..3781b9a 100644
--- a/generic/tclCompCmdsGR.c
+++ b/generic/tclCompCmdsGR.c
@@ -28,56 +28,39 @@ static void CompileReturnInternal(CompileEnv *envPtr,
static int IndexTailVarIfKnown(Tcl_Interp *interp,
Tcl_Token *varTokenPtr, CompileEnv *envPtr);
-#define INDEX_END (-2)
/*
*----------------------------------------------------------------------
*
- * GetIndexFromToken --
+ * TclGetIndexFromToken --
*
- * Parse a token and get the encoded version of the index (as understood
- * by TEBC), assuming it is at all knowable at compile time. Only handles
- * indices that are integers or 'end' or 'end-integer'.
+ * Parse a token to determine if an index value is known at
+ * compile time.
*
* Returns:
* TCL_OK if parsing succeeded, and TCL_ERROR if it failed.
*
* Side effects:
- * Sets *index to the index value if successful.
+ * When TCL_OK is returned, the encoded index value is written
+ * to *index.
*
*----------------------------------------------------------------------
*/
-static inline int
-GetIndexFromToken(
+int
+TclGetIndexFromToken(
Tcl_Token *tokenPtr,
- int *index)
+ int before,
+ int after,
+ int *indexPtr)
{
Tcl_Obj *tmpObj = Tcl_NewObj();
- int result, idx;
+ int result = TCL_ERROR;
- if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)) {
- Tcl_DecrRefCount(tmpObj);
- return TCL_ERROR;
- }
-
- result = TclGetIntFromObj(NULL, tmpObj, &idx);
- if (result == TCL_OK) {
- if (idx < 0) {
- result = TCL_ERROR;
- }
- } else {
- result = TclGetIntForIndexM(NULL, tmpObj, INDEX_END, &idx);
- if (result == TCL_OK && idx > INDEX_END) {
- result = TCL_ERROR;
- }
+ if (TclWordKnownAtCompileTime(tokenPtr, tmpObj)) {
+ result = TclIndexEncode(NULL, tmpObj, before, after, indexPtr);
}
Tcl_DecrRefCount(tmpObj);
-
- if (result == TCL_OK) {
- *index = idx;
- }
-
return result;
}
@@ -144,7 +127,7 @@ TclCompileGlobalCmd(
return TCL_ERROR;
}
- /* TODO: Consider what value can pass throug the
+ /* TODO: Consider what value can pass through the
* IndexTailVarIfKnown() screen. Full CompileWord()
* likely does not apply here. Push known value instead. */
CompileWord(envPtr, varTokenPtr, interp, i);
@@ -1053,7 +1036,7 @@ TclCompileLassignCmd(
*/
TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr);
- TclEmitInt4( INDEX_END, envPtr);
+ TclEmitInt4( TCL_INDEX_END, envPtr);
return TCL_OK;
}
@@ -1104,14 +1087,14 @@ TclCompileLindexCmd(
}
idxTokenPtr = TokenAfter(valTokenPtr);
- if (GetIndexFromToken(idxTokenPtr, &idx) == TCL_OK) {
+ if (TclGetIndexFromToken(idxTokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_BEFORE,
+ &idx) == TCL_OK) {
/*
- * All checks have been completed, and we have exactly one of these
- * constructs:
- * lindex <arbitraryValue> <posInt>
- * lindex <arbitraryValue> end-<posInt>
- * This is best compiled as a push of the arbitrary value followed by
- * an "immediate lindex" which is the most efficient variety.
+ * The idxTokenPtr parsed as a valid index value and was
+ * encoded as expected by INST_LIST_INDEX_IMM.
+ *
+ * NOTE: that we rely on indexing before a list producing the
+ * same result as indexing after a list.
*/
CompileWord(envPtr, valTokenPtr, interp, 1);
@@ -1258,7 +1241,7 @@ TclCompileListCmd(
if (concat && numWords == 2) {
TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr);
- TclEmitInt4( INDEX_END, envPtr);
+ TclEmitInt4( TCL_INDEX_END, envPtr);
}
return TCL_OK;
}
@@ -1332,21 +1315,25 @@ TclCompileLrangeCmd(
}
listTokenPtr = TokenAfter(parsePtr->tokenPtr);
- /*
- * Parse the indices. Will only compile if both are constants and not an
- * _integer_ less than zero (since we reserve negative indices here for
- * end-relative indexing) or an end-based index greater than 'end' itself.
- */
-
tokenPtr = TokenAfter(listTokenPtr);
- if (GetIndexFromToken(tokenPtr, &idx1) != TCL_OK) {
+ if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_AFTER,
+ &idx1) != TCL_OK) {
return TCL_ERROR;
}
+ /*
+ * Token was an index value, and we treat all "first" indices
+ * before the list same as the start of the list.
+ */
tokenPtr = TokenAfter(tokenPtr);
- if (GetIndexFromToken(tokenPtr, &idx2) != TCL_OK) {
+ if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_END,
+ &idx2) != TCL_OK) {
return TCL_ERROR;
}
+ /*
+ * Token was an index value, and we treat all "last" indices
+ * after the list same as the end of the list.
+ */
/*
* Issue instructions. It's not safe to skip doing the LIST_RANGE, as
@@ -1396,21 +1383,30 @@ TclCompileLinsertCmd(
*/
tokenPtr = TokenAfter(listTokenPtr);
- if (GetIndexFromToken(tokenPtr, &idx) != TCL_OK) {
+
+ /*
+ * NOTE: This command treats all inserts at indices before the list
+ * the same as inserts at the start of the list, and all inserts
+ * after the list the same as inserts at the end of the list. We
+ * make that transformation here so we can use the optimized bytecode
+ * as much as possible.
+ */
+ if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_END,
+ &idx) != TCL_OK) {
return TCL_ERROR;
}
/*
* There are four main cases. If there are no values to insert, this is
* just a confirm-listiness check. If the index is '0', this is a prepend.
- * If the index is 'end' (== INDEX_END), this is an append. Otherwise,
+ * If the index is 'end' (== TCL_INDEX_END), this is an append. Otherwise,
* this is a splice (== split, insert values as list, concat-3).
*/
CompileWord(envPtr, listTokenPtr, interp, 1);
if (parsePtr->numWords == 3) {
TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr);
- TclEmitInt4( INDEX_END, envPtr);
+ TclEmitInt4( TCL_INDEX_END, envPtr);
return TCL_OK;
}
@@ -1420,13 +1416,25 @@ TclCompileLinsertCmd(
}
TclEmitInstInt4( INST_LIST, i-3, envPtr);
- if (idx == 0 /*start*/) {
+ if (idx == TCL_INDEX_START) {
TclEmitInstInt4( INST_REVERSE, 2, envPtr);
TclEmitOpcode( INST_LIST_CONCAT, envPtr);
- } else if (idx == INDEX_END /*end*/) {
+ } else if (idx == TCL_INDEX_END) {
TclEmitOpcode( INST_LIST_CONCAT, envPtr);
} else {
- if (idx < 0) {
+ /*
+ * Here we handle two ranges for idx. First when idx > 0, we
+ * want the first half of the split to end at index idx-1 and
+ * the second half to start at index idx.
+ * Second when idx < TCL_INDEX_END, indicating "end-N" indexing,
+ * we want the first half of the split to end at index end-N and
+ * the second half to start at index end-N+1. We accomplish this
+ * with a pre-adjustment of the end-N value.
+ * The root of this is that the commands [lrange] and [linsert]
+ * differ in their interpretation of the "end" index.
+ */
+
+ if (idx < TCL_INDEX_END) {
idx++;
}
TclEmitInstInt4( INST_OVER, 1, envPtr);
@@ -1434,7 +1442,7 @@ TclCompileLinsertCmd(
TclEmitInt4( idx-1, envPtr);
TclEmitInstInt4( INST_REVERSE, 3, envPtr);
TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr);
- TclEmitInt4( INDEX_END, envPtr);
+ TclEmitInt4( TCL_INDEX_END, envPtr);
TclEmitOpcode( INST_LIST_CONCAT, envPtr);
TclEmitOpcode( INST_LIST_CONCAT, envPtr);
}
@@ -1464,250 +1472,167 @@ TclCompileLreplaceCmd(
{
Tcl_Token *tokenPtr, *listTokenPtr;
DefineLineInformation; /* TIP #280 */
- Tcl_Obj *tmpObj;
int idx1, idx2, i, offset, offset2;
+ int emptyPrefix=1, suffixStart = 0;
if (parsePtr->numWords < 4) {
return TCL_ERROR;
}
listTokenPtr = TokenAfter(parsePtr->tokenPtr);
- /*
- * Parse the indices. Will only compile if both are constants and not an
- * _integer_ less than zero (since we reserve negative indices here for
- * end-relative indexing) or an end-based index greater than 'end' itself.
- */
-
tokenPtr = TokenAfter(listTokenPtr);
- if (GetIndexFromToken(tokenPtr, &idx1) != TCL_OK) {
+ if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_AFTER,
+ &idx1) != TCL_OK) {
return TCL_ERROR;
}
tokenPtr = TokenAfter(tokenPtr);
- if (GetIndexFromToken(tokenPtr, &idx2) != TCL_OK) {
+ if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_END,
+ &idx2) != TCL_OK) {
return TCL_ERROR;
}
/*
- * idx1, idx2 are now in canonical form:
- *
- * - integer: [0,len+1]
- * - end index: INDEX_END
- * - -ive offset: INDEX_END-[len-1,0]
- * - +ive offset: INDEX_END+1
- */
-
- /*
- * Compilation fails when one index is end-based but the other isn't.
- * Fixing this will require more bytecodes, but this is a workaround for
- * now. [Bug 47ac84309b]
+ * idx1, idx2 are the conventional encoded forms of the tokens parsed
+ * as all forms of index values. Values of idx1 that come before the
+ * list are treated the same as if they were the start of the list.
+ * Values of idx2 that come after the list are treated the same as if
+ * they were the end of the list.
*/
- if ((idx1 <= INDEX_END) != (idx2 <= INDEX_END)) {
+ if (idx1 == TCL_INDEX_AFTER) {
+ /*
+ * [lreplace] treats idx1 value end+1 differently from end+2, etc.
+ * The operand encoding cannot distinguish them, so we must bail
+ * out to direct evaluation.
+ */
return TCL_ERROR;
}
- if (idx2 != INDEX_END && idx2 >= 0 && idx2 < idx1) {
- idx2 = idx1 - 1;
- }
-
/*
- * Work out what this [lreplace] is actually doing.
- */
+ * General structure of the [lreplace] result is
+ * prefix replacement suffix
+ * In a few cases we can predict various parts will be empty and
+ * take advantage.
+ *
+ * The proper suffix begins with the greater of indices idx1 or
+ * idx2 + 1. If we cannot tell at compile time which is greater,
+ * we must defer to direct evaluation.
+ */
+
+ if (idx2 == TCL_INDEX_BEFORE) {
+ suffixStart = idx1;
+ } else if (idx2 == TCL_INDEX_END) {
+ suffixStart = TCL_INDEX_AFTER;
+ } else if (((idx2 < TCL_INDEX_END) && (idx1 <= TCL_INDEX_END))
+ || ((idx2 >= TCL_INDEX_START) && (idx1 >= TCL_INDEX_START))) {
+ suffixStart = (idx1 > idx2 + 1) ? idx1 : idx2 + 1;
+ } else {
+ return TCL_ERROR;
+ }
- tmpObj = NULL;
+ /* All paths start with computing/pushing the original value. */
CompileWord(envPtr, listTokenPtr, interp, 1);
- if (parsePtr->numWords == 4) {
- if (idx1 == 0) {
- if (idx2 == INDEX_END) {
- goto dropAll;
- }
- idx1 = idx2 + 1;
- idx2 = INDEX_END;
- goto dropEnd;
- } else if (idx2 == INDEX_END) {
- idx2 = idx1 - 1;
- idx1 = 0;
- goto dropEnd;
- } else {
- if (idx2 < idx1) {
- idx2 = idx1 - 1;
- }
- if (idx1 > 0) {
- tmpObj = Tcl_NewIntObj(idx1);
- Tcl_IncrRefCount(tmpObj);
- }
- goto dropRange;
- }
- }
- tokenPtr = TokenAfter(tokenPtr);
- for (i=4 ; i<parsePtr->numWords ; i++) {
- CompileWord(envPtr, tokenPtr, interp, i);
+ /*
+ * Push all the replacement values next so any errors raised in
+ * creating them get raised first.
+ */
+ if (parsePtr->numWords > 4) {
+ /* Push the replacement arguments */
tokenPtr = TokenAfter(tokenPtr);
- }
- TclEmitInstInt4( INST_LIST, i - 4, envPtr);
- TclEmitInstInt4( INST_REVERSE, 2, envPtr);
- if (idx1 == 0) {
- if (idx2 == INDEX_END) {
- goto replaceAll;
- }
- idx1 = idx2 + 1;
- idx2 = INDEX_END;
- goto replaceHead;
- } else if (idx2 == INDEX_END) {
- idx2 = idx1 - 1;
- idx1 = 0;
- goto replaceTail;
- } else {
- if (idx2 < idx1) {
- idx2 = idx1 - 1;
- }
- if (idx1 > 0) {
- tmpObj = Tcl_NewIntObj(idx1);
- Tcl_IncrRefCount(tmpObj);
+ for (i=4 ; i<parsePtr->numWords ; i++) {
+ CompileWord(envPtr, tokenPtr, interp, i);
+ tokenPtr = TokenAfter(tokenPtr);
}
- goto replaceRange;
- }
+ /* Make a list of them... */
+ TclEmitInstInt4( INST_LIST, i - 4, envPtr);
+
+ emptyPrefix = 0;
+ }
+
/*
- * Issue instructions to perform the operations relating to configurations
- * that just drop. The only argument pushed on the stack is the list to
- * operate on.
+ * [lreplace] raises an error when idx1 points after the list, but
+ * only when the list is not empty. This is maximum stupidity.
+ *
+ * TODO: TIP this nonsense away!
*/
-
- dropAll: /* This just ensures the arg is a list. */
- TclEmitOpcode( INST_LIST_LENGTH, envPtr);
- TclEmitOpcode( INST_POP, envPtr);
- PushStringLiteral(envPtr, "");
- goto done;
-
- dropEnd:
- TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr);
- TclEmitInt4( idx2, envPtr);
- goto done;
-
- dropRange:
- if (tmpObj != NULL) {
- /*
- * Emit bytecode to check the list length.
- */
-
- TclEmitOpcode( INST_DUP, envPtr);
+ if (idx1 >= TCL_INDEX_START) {
+ if (emptyPrefix) {
+ TclEmitOpcode( INST_DUP, envPtr);
+ } else {
+ TclEmitInstInt4( INST_OVER, 1, envPtr);
+ }
TclEmitOpcode( INST_LIST_LENGTH, envPtr);
- TclEmitPush(TclAddLiteralObj(envPtr, tmpObj, NULL), envPtr);
- TclEmitOpcode( INST_GE, envPtr);
+ TclEmitOpcode( INST_DUP, envPtr);
offset = CurrentOffset(envPtr);
- TclEmitInstInt1( INST_JUMP_TRUE1, 0, envPtr);
-
- /*
- * Emit an error if we've been given an empty list.
- */
+ TclEmitInstInt1( INST_JUMP_FALSE1, 0, envPtr);
- TclEmitOpcode( INST_DUP, envPtr);
- TclEmitOpcode( INST_LIST_LENGTH, envPtr);
+ /* List is not empty */
+ TclEmitPush(TclAddLiteralObj(envPtr, Tcl_NewIntObj(idx1),
+ NULL), envPtr);
+ TclEmitOpcode( INST_GT, envPtr);
offset2 = CurrentOffset(envPtr);
- TclEmitInstInt1( INST_JUMP_FALSE1, 0, envPtr);
+ TclEmitInstInt1( INST_JUMP_TRUE1, 0, envPtr);
+
+ /* Idx1 >= list length ===> raise an error */
TclEmitPush(TclAddLiteralObj(envPtr, Tcl_ObjPrintf(
"list doesn't contain element %d", idx1), NULL), envPtr);
CompileReturnInternal(envPtr, INST_RETURN_IMM, TCL_ERROR, 0,
Tcl_ObjPrintf("-errorcode {TCL OPERATION LREPLACE BADIDX}"));
TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset,
envPtr->codeStart + offset + 1);
+ TclEmitOpcode( INST_POP, envPtr);
TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset2,
envPtr->codeStart + offset2 + 1);
- TclAdjustStackDepth(-1, envPtr);
}
- TclEmitOpcode( INST_DUP, envPtr);
- TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr);
- TclEmitInt4( idx1 - 1, envPtr);
- TclEmitInstInt4( INST_REVERSE, 2, envPtr);
- TclEmitInstInt4( INST_LIST_RANGE_IMM, idx2 + 1, envPtr);
- TclEmitInt4( INDEX_END, envPtr);
- TclEmitOpcode( INST_LIST_CONCAT, envPtr);
- goto done;
-
- /*
- * Issue instructions to perform the operations relating to configurations
- * that do real replacement. All arguments are pushed and assembled into a
- * pair: the list of values to replace with, and the list to do the
- * surgery on.
- */
-
- replaceAll:
- TclEmitOpcode( INST_LIST_LENGTH, envPtr);
- TclEmitOpcode( INST_POP, envPtr);
- goto done;
-
- replaceHead:
- TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr);
- TclEmitInt4( idx2, envPtr);
- TclEmitOpcode( INST_LIST_CONCAT, envPtr);
- goto done;
-
- replaceTail:
- TclEmitInstInt4( INST_LIST_RANGE_IMM, idx1, envPtr);
- TclEmitInt4( idx2, envPtr);
- TclEmitInstInt4( INST_REVERSE, 2, envPtr);
- TclEmitOpcode( INST_LIST_CONCAT, envPtr);
- goto done;
-
- replaceRange:
- if (tmpObj != NULL) {
- /*
- * Emit bytecode to check the list length.
- */
-
- TclEmitOpcode( INST_DUP, envPtr);
- TclEmitOpcode( INST_LIST_LENGTH, envPtr);
-
- /*
- * Check the list length vs idx1.
- */
-
- TclEmitPush(TclAddLiteralObj(envPtr, tmpObj, NULL), envPtr);
- TclEmitOpcode( INST_GE, envPtr);
- offset = CurrentOffset(envPtr);
- TclEmitInstInt1( INST_JUMP_TRUE1, 0, envPtr);
+ if ((idx1 == suffixStart) && (parsePtr->numWords == 4)) {
/*
- * Emit an error if we've been given an empty list.
+ * This is a "no-op". Example: [lreplace {a b c} 2 0]
+ * We still do a list operation to get list-verification
+ * and canonicalization side effects.
*/
+ TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr);
+ TclEmitInt4( TCL_INDEX_END, envPtr);
+ return TCL_OK;
+ }
- TclEmitOpcode( INST_DUP, envPtr);
- TclEmitOpcode( INST_LIST_LENGTH, envPtr);
- offset2 = CurrentOffset(envPtr);
- TclEmitInstInt1( INST_JUMP_FALSE1, 0, envPtr);
- TclEmitPush(TclAddLiteralObj(envPtr, Tcl_ObjPrintf(
- "list doesn't contain element %d", idx1), NULL), envPtr);
- CompileReturnInternal(envPtr, INST_RETURN_IMM, TCL_ERROR, 0,
- Tcl_ObjPrintf("-errorcode {TCL OPERATION LREPLACE BADIDX}"));
- TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset,
- envPtr->codeStart + offset + 1);
- TclStoreInt1AtPtr(CurrentOffset(envPtr) - offset2,
- envPtr->codeStart + offset2 + 1);
- TclAdjustStackDepth(-1, envPtr);
+ if (idx1 != TCL_INDEX_START) {
+ /* Prefix may not be empty; generate bytecode to push it */
+ if (emptyPrefix) {
+ TclEmitOpcode( INST_DUP, envPtr);
+ } else {
+ TclEmitInstInt4( INST_OVER, 1, envPtr);
+ }
+ TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr);
+ TclEmitInt4( idx1 - 1, envPtr);
+ if (!emptyPrefix) {
+ TclEmitInstInt4( INST_REVERSE, 2, envPtr);
+ TclEmitOpcode( INST_LIST_CONCAT, envPtr);
+ }
+ emptyPrefix = 0;
}
- TclEmitOpcode( INST_DUP, envPtr);
- TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr);
- TclEmitInt4( idx1 - 1, envPtr);
- TclEmitInstInt4( INST_REVERSE, 2, envPtr);
- TclEmitInstInt4( INST_LIST_RANGE_IMM, idx2 + 1, envPtr);
- TclEmitInt4( INDEX_END, envPtr);
- TclEmitInstInt4( INST_REVERSE, 3, envPtr);
- TclEmitOpcode( INST_LIST_CONCAT, envPtr);
- TclEmitInstInt4( INST_REVERSE, 2, envPtr);
- TclEmitOpcode( INST_LIST_CONCAT, envPtr);
- goto done;
- /*
- * Clean up the allocated memory.
- */
+ if (!emptyPrefix) {
+ TclEmitInstInt4( INST_REVERSE, 2, envPtr);
+ }
- done:
- if (tmpObj != NULL) {
- Tcl_DecrRefCount(tmpObj);
+ if (suffixStart == TCL_INDEX_AFTER) {
+ TclEmitOpcode( INST_POP, envPtr);
+ if (emptyPrefix) {
+ PushStringLiteral(envPtr, "");
+ }
+ } else {
+ /* Suffix may not be empty; generate bytecode to push it */
+ TclEmitInstInt4( INST_LIST_RANGE_IMM, suffixStart, envPtr);
+ TclEmitInt4( TCL_INDEX_END, envPtr);
+ if (!emptyPrefix) {
+ TclEmitOpcode( INST_LIST_CONCAT, envPtr);
+ }
}
+
return TCL_OK;
}
@@ -2933,7 +2858,7 @@ TclCompileVariableCmd(
return TCL_ERROR;
}
- /* TODO: Consider what value can pass throug the
+ /* TODO: Consider what value can pass through the
* IndexTailVarIfKnown() screen. Full CompileWord()
* likely does not apply here. Push known value instead. */
CompileWord(envPtr, varTokenPtr, interp, i);
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 25d10d6..cf088bb 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -107,58 +107,6 @@ const AuxDataType tclJumptableInfoType = {
#define INVOKE(name) \
TclEmitInvoke(envPtr,INST_##name)
-#define INDEX_END (-2)
-
-/*
- *----------------------------------------------------------------------
- *
- * GetIndexFromToken --
- *
- * Parse a token and get the encoded version of the index (as understood
- * by TEBC), assuming it is at all knowable at compile time. Only handles
- * indices that are integers or 'end' or 'end-integer'.
- *
- * Returns:
- * TCL_OK if parsing succeeded, and TCL_ERROR if it failed.
- *
- * Side effects:
- * Sets *index to the index value if successful.
- *
- *----------------------------------------------------------------------
- */
-
-static inline int
-GetIndexFromToken(
- Tcl_Token *tokenPtr,
- int *index)
-{
- Tcl_Obj *tmpObj = Tcl_NewObj();
- int result, idx;
-
- if (!TclWordKnownAtCompileTime(tokenPtr, tmpObj)) {
- Tcl_DecrRefCount(tmpObj);
- return TCL_ERROR;
- }
-
- result = TclGetIntFromObj(NULL, tmpObj, &idx);
- if (result == TCL_OK) {
- if (idx < 0) {
- result = TCL_ERROR;
- }
- } else {
- result = TclGetIntForIndexM(NULL, tmpObj, INDEX_END, &idx);
- if (result == TCL_OK && idx > INDEX_END) {
- result = TCL_ERROR;
- }
- }
- Tcl_DecrRefCount(tmpObj);
-
- if (result == TCL_OK) {
- *index = idx;
- }
-
- return result;
-}
/*
*----------------------------------------------------------------------
@@ -982,22 +930,48 @@ TclCompileStringRangeCmd(
fromTokenPtr = TokenAfter(stringTokenPtr);
toTokenPtr = TokenAfter(fromTokenPtr);
+ /* Every path must push the string argument */
+ CompileWord(envPtr, stringTokenPtr, interp, 1);
+
/*
* Parse the two indices.
*/
- if (GetIndexFromToken(fromTokenPtr, &idx1) != TCL_OK) {
+ if (TclGetIndexFromToken(fromTokenPtr, TCL_INDEX_START, TCL_INDEX_AFTER,
+ &idx1) != TCL_OK) {
goto nonConstantIndices;
}
- if (GetIndexFromToken(toTokenPtr, &idx2) != TCL_OK) {
+ /*
+ * Token parsed as an index expression. We treat all indices before
+ * the string the same as the start of the string.
+ */
+
+ if (idx1 == TCL_INDEX_AFTER) {
+ /* [string range $s end+1 $last] must be empty string */
+ OP( POP);
+ PUSH( "");
+ return TCL_OK;
+ }
+
+ if (TclGetIndexFromToken(toTokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_END,
+ &idx2) != TCL_OK) {
goto nonConstantIndices;
}
+ /*
+ * Token parsed as an index expression. We treat all indices after
+ * the string the same as the end of the string.
+ */
+ if (idx2 == TCL_INDEX_BEFORE) {
+ /* [string range $s $first -1] must be empty string */
+ OP( POP);
+ PUSH( "");
+ return TCL_OK;
+ }
/*
* Push the operand onto the stack and then the substring operation.
*/
- CompileWord(envPtr, stringTokenPtr, interp, 1);
OP44( STR_RANGE_IMM, idx1, idx2);
return TCL_OK;
@@ -1006,7 +980,6 @@ TclCompileStringRangeCmd(
*/
nonConstantIndices:
- CompileWord(envPtr, stringTokenPtr, interp, 1);
CompileWord(envPtr, fromTokenPtr, interp, 2);
CompileWord(envPtr, toTokenPtr, interp, 3);
OP( STR_RANGE);
@@ -1022,124 +995,197 @@ TclCompileStringReplaceCmd(
* compiled. */
CompileEnv *envPtr) /* Holds the resulting instructions. */
{
- Tcl_Token *tokenPtr, *valueTokenPtr, *replacementTokenPtr = NULL;
+ Tcl_Token *tokenPtr, *valueTokenPtr;
DefineLineInformation; /* TIP #280 */
- int idx1, idx2;
+ int first, last;
if (parsePtr->numWords < 4 || parsePtr->numWords > 5) {
return TCL_ERROR;
}
+
+ /* Bytecode to compute/push string argument being replaced */
valueTokenPtr = TokenAfter(parsePtr->tokenPtr);
- if (parsePtr->numWords == 5) {
- tokenPtr = TokenAfter(valueTokenPtr);
- tokenPtr = TokenAfter(tokenPtr);
- replacementTokenPtr = TokenAfter(tokenPtr);
- }
+ CompileWord(envPtr, valueTokenPtr, interp, 1);
/*
- * Parse the indices. Will only compile special cases if both are
- * constants and not an _integer_ less than zero (since we reserve
- * negative indices here for end-relative indexing) or an end-based index
- * greater than 'end' itself.
+ * Check for first index known and useful at compile time.
*/
-
tokenPtr = TokenAfter(valueTokenPtr);
- if (GetIndexFromToken(tokenPtr, &idx1) != TCL_OK) {
+ if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_AFTER,
+ &first) != TCL_OK) {
goto genericReplace;
}
+ /*
+ * Check for last index known and useful at compile time.
+ */
tokenPtr = TokenAfter(tokenPtr);
- if (GetIndexFromToken(tokenPtr, &idx2) != TCL_OK) {
+ if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_AFTER,
+ &last) != TCL_OK) {
goto genericReplace;
}
- /*
- * We handle these replacements specially: first character (where
- * idx1=idx2=0) and last character (where idx1=idx2=INDEX_END). Anything
- * else and the semantics get rather screwy.
+ /*
+ * [string replace] is an odd bird. For many arguments it is
+ * a conventional substring replacer. However it also goes out
+ * of its way to become a no-op for many cases where it would be
+ * replacing an empty substring. Precisely, it is a no-op when
+ *
+ * (last < first) OR
+ * (last < 0) OR
+ * (end < first)
+ *
+ * For some compile-time values we can detect these cases, and
+ * compile direct to bytecode implementing the no-op.
*/
- if (idx1 == 0 && idx2 == 0) {
- int notEq, end;
+ if ((last == TCL_INDEX_BEFORE) /* Know (last < 0) */
+ || (first == TCL_INDEX_AFTER) /* Know (first > end) */
/*
- * Just working with the first character.
+ * Tricky to determine when runtime (last < first) can be
+ * certainly known based on the encoded values. Consider the
+ * cases...
+ *
+ * (first <= TCL_INDEX_END) &&
+ * (last == TCL_INDEX_AFTER) => cannot tell REJECT
+ * (last <= TCL_INDEX END) && (last < first) => ACCEPT
+ * else => cannot tell REJECT
*/
-
- CompileWord(envPtr, valueTokenPtr, interp, 1);
- if (replacementTokenPtr == NULL) {
- /* Drop first */
- OP44( STR_RANGE_IMM, 1, INDEX_END);
- return TCL_OK;
+ || ((first <= TCL_INDEX_END) && (last <= TCL_INDEX_END)
+ && (last < first)) /* Know (last < first) */
+ /*
+ * (first == TCL_INDEX_BEFORE) &&
+ * (last == TCL_INDEX_AFTER) => (first < last) REJECT
+ * (last <= TCL_INDEX_END) => cannot tell REJECT
+ * else => (first < last) REJECT
+ *
+ * else [[first >= TCL_INDEX_START]] &&
+ * (last == TCL_INDEX_AFTER) => cannot tell REJECT
+ * (last <= TCL_INDEX_END) => cannot tell REJECT
+ * else [[last >= TCL_INDEX START]] && (last < first) => ACCEPT
+ */
+ || ((first >= TCL_INDEX_START) && (last >= TCL_INDEX_START)
+ && (last < first))) { /* Know (last < first) */
+ if (parsePtr->numWords == 5) {
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 4);
+ OP( POP); /* Pop newString */
}
- /* Replace first */
- CompileWord(envPtr, replacementTokenPtr, interp, 4);
- OP4( OVER, 1);
- PUSH( "");
- OP( STR_EQ);
- JUMP1( JUMP_FALSE, notEq);
- OP( POP);
- JUMP1( JUMP, end);
- FIXJUMP1(notEq);
- TclAdjustStackDepth(1, envPtr);
- OP4( REVERSE, 2);
- OP44( STR_RANGE_IMM, 1, INDEX_END);
- OP1( STR_CONCAT1, 2);
- FIXJUMP1(end);
+ /* Original string argument now on TOS as result */
return TCL_OK;
+ }
- } else if (idx1 == INDEX_END && idx2 == INDEX_END) {
- int notEq, end;
-
- /*
- * Just working with the last character.
- */
+ if (parsePtr->numWords == 5) {
+ /*
+ * When we have a string replacement, we have to take care about
+ * not replacing empty substrings that [string replace] promises
+ * not to replace
+ *
+ * The remaining index values might be suitable for conventional
+ * string replacement, but only if they cannot possibly meet the
+ * conditions described above at runtime. If there's a chance they
+ * might, we would have to emit bytecode to check and at that point
+ * we're paying more in bytecode execution time than would make
+ * things worthwhile. Trouble is we are very limited in
+ * how much we can detect that at compile time. After decoding,
+ * we need, first:
+ *
+ * (first <= end)
+ *
+ * The encoded indices (first <= TCL_INDEX END) and
+ * (first == TCL_INDEX_BEFORE) always meets this condition, but
+ * any other encoded first index has some list for which it fails.
+ *
+ * We also need, second:
+ *
+ * (last >= 0)
+ *
+ * The encoded indices (last >= TCL_INDEX_START) and
+ * (last == TCL_INDEX_AFTER) always meet this condition but any
+ * other encoded last index has some list for which it fails.
+ *
+ * Finally we need, third:
+ *
+ * (first <= last)
+ *
+ * Considered in combination with the constraints we already have,
+ * we see that we can proceed when (first == TCL_INDEX_BEFORE)
+ * or (last == TCL_INDEX_AFTER). These also permit simplification
+ * of the prefix|replace|suffix construction. The other constraints,
+ * though, interfere with getting a guarantee that first <= last.
+ */
- CompileWord(envPtr, valueTokenPtr, interp, 1);
- if (replacementTokenPtr == NULL) {
- /* Drop last */
- OP44( STR_RANGE_IMM, 0, INDEX_END-1);
- return TCL_OK;
- }
- /* Replace last */
- CompileWord(envPtr, replacementTokenPtr, interp, 4);
- OP4( OVER, 1);
- PUSH( "");
- OP( STR_EQ);
- JUMP1( JUMP_FALSE, notEq);
- OP( POP);
- JUMP1( JUMP, end);
- FIXJUMP1(notEq);
- TclAdjustStackDepth(1, envPtr);
- OP4( REVERSE, 2);
- OP44( STR_RANGE_IMM, 0, INDEX_END-1);
+ if ((first == TCL_INDEX_BEFORE) && (last >= TCL_INDEX_START)) {
+ /* empty prefix */
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 4);
OP4( REVERSE, 2);
+ if (last == TCL_INDEX_AFTER) {
+ OP( POP); /* Pop original */
+ } else {
+ OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END);
+ OP1( STR_CONCAT1, 2);
+ }
+ return TCL_OK;
+ }
+
+ if ((last == TCL_INDEX_AFTER) && (first <= TCL_INDEX_END)) {
+ OP44( STR_RANGE_IMM, 0, first-1);
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 4);
OP1( STR_CONCAT1, 2);
- FIXJUMP1(end);
return TCL_OK;
+ }
+
+ /* FLOW THROUGH TO genericReplace */
} else {
- /*
- * Need to process indices at runtime. This could be because the
- * indices are not constants, or because we need to resolve them to
- * absolute indices to work out if a replacement is going to happen.
- * In any case, to runtime it is.
+ /*
+ * When we have no replacement string to worry about, we may
+ * have more luck, because the forbidden empty string replacements
+ * are harmless when they are replaced by another empty string.
*/
+ if ((first == TCL_INDEX_BEFORE) || (first == TCL_INDEX_START)) {
+ /* empty prefix - build suffix only */
+
+ if ((last == TCL_INDEX_END) || (last == TCL_INDEX_AFTER)) {
+ /* empty suffix too => empty result */
+ OP( POP); /* Pop original */
+ PUSH ( "");
+ return TCL_OK;
+ }
+ OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END);
+ return TCL_OK;
+ } else {
+ if ((last == TCL_INDEX_END) || (last == TCL_INDEX_AFTER)) {
+ /* empty suffix - build prefix only */
+ OP44( STR_RANGE_IMM, 0, first-1);
+ return TCL_OK;
+ }
+ OP( DUP);
+ OP44( STR_RANGE_IMM, 0, first-1);
+ OP4( REVERSE, 2);
+ OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END);
+ OP1( STR_CONCAT1, 2);
+ return TCL_OK;
+ }
+ }
+
genericReplace:
- CompileWord(envPtr, valueTokenPtr, interp, 1);
tokenPtr = TokenAfter(valueTokenPtr);
CompileWord(envPtr, tokenPtr, interp, 2);
tokenPtr = TokenAfter(tokenPtr);
CompileWord(envPtr, tokenPtr, interp, 3);
- if (replacementTokenPtr != NULL) {
- CompileWord(envPtr, replacementTokenPtr, interp, 4);
+ if (parsePtr->numWords == 5) {
+ tokenPtr = TokenAfter(tokenPtr);
+ CompileWord(envPtr, tokenPtr, interp, 4);
} else {
PUSH( "");
}
OP( STR_REPLACE);
return TCL_OK;
- }
}
int
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index f20ecfd..8746afc 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -1120,6 +1120,8 @@ MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr,
int distThreshold);
MODULE_SCOPE void TclFreeCompileEnv(CompileEnv *envPtr);
MODULE_SCOPE void TclFreeJumpFixupArray(JumpFixupArray *fixupArrayPtr);
+MODULE_SCOPE int TclGetIndexFromToken(Tcl_Token *tokenPtr,
+ int before, int after, int *indexPtr);
MODULE_SCOPE ByteCode * TclInitByteCode(CompileEnv *envPtr);
MODULE_SCOPE ByteCode * TclInitByteCodeObj(Tcl_Obj *objPtr,
const Tcl_ObjType *typePtr, CompileEnv *envPtr);
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index be3dc80..49f34e8 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -53,7 +53,7 @@ EXTERN int Tcl_PkgProvideEx(Tcl_Interp *interp,
const char *name, const char *version,
const void *clientData);
/* 1 */
-EXTERN CONST84_RETURN char * Tcl_PkgRequireEx(Tcl_Interp *interp,
+EXTERN const char * Tcl_PkgRequireEx(Tcl_Interp *interp,
const char *name, const char *version,
int exact, void *clientDataPtr);
/* 2 */
@@ -159,8 +159,7 @@ EXTERN int Tcl_GetDoubleFromObj(Tcl_Interp *interp,
Tcl_Obj *objPtr, double *doublePtr);
/* 36 */
EXTERN int Tcl_GetIndexFromObj(Tcl_Interp *interp,
- Tcl_Obj *objPtr,
- CONST84 char *const *tablePtr,
+ Tcl_Obj *objPtr, const char *const *tablePtr,
const char *msg, int flags, int *indexPtr);
/* 37 */
EXTERN int Tcl_GetInt(Tcl_Interp *interp, const char *src,
@@ -263,7 +262,8 @@ EXTERN int Tcl_AsyncReady(void);
/* 76 */
EXTERN void Tcl_BackgroundError(Tcl_Interp *interp);
/* 77 */
-EXTERN char Tcl_Backslash(const char *src, int *readPtr);
+TCL_DEPRECATED("Use Tcl_UtfBackslash")
+char Tcl_Backslash(const char *src, int *readPtr);
/* 78 */
EXTERN int Tcl_BadChannelOption(Tcl_Interp *interp,
const char *optionName,
@@ -280,7 +280,7 @@ EXTERN int Tcl_Close(Tcl_Interp *interp, Tcl_Channel chan);
/* 82 */
EXTERN int Tcl_CommandComplete(const char *cmd);
/* 83 */
-EXTERN char * Tcl_Concat(int argc, CONST84 char *const *argv);
+EXTERN char * Tcl_Concat(int argc, const char *const *argv);
/* 84 */
EXTERN int Tcl_ConvertElement(const char *src, char *dst,
int flags);
@@ -291,7 +291,7 @@ EXTERN int Tcl_ConvertCountedElement(const char *src,
EXTERN int Tcl_CreateAlias(Tcl_Interp *slave,
const char *slaveCmd, Tcl_Interp *target,
const char *targetCmd, int argc,
- CONST84 char *const *argv);
+ const char *const *argv);
/* 87 */
EXTERN int Tcl_CreateAliasObj(Tcl_Interp *slave,
const char *slaveCmd, Tcl_Interp *target,
@@ -322,7 +322,8 @@ EXTERN void Tcl_CreateExitHandler(Tcl_ExitProc *proc,
/* 94 */
EXTERN Tcl_Interp * Tcl_CreateInterp(void);
/* 95 */
-EXTERN void Tcl_CreateMathFunc(Tcl_Interp *interp,
+TCL_DEPRECATED("")
+void Tcl_CreateMathFunc(Tcl_Interp *interp,
const char *name, int numArgs,
Tcl_ValueType *argTypes, Tcl_MathProc *proc,
ClientData clientData);
@@ -412,9 +413,9 @@ EXTERN void Tcl_DStringStartSublist(Tcl_DString *dsPtr);
/* 126 */
EXTERN int Tcl_Eof(Tcl_Channel chan);
/* 127 */
-EXTERN CONST84_RETURN char * Tcl_ErrnoId(void);
+EXTERN const char * Tcl_ErrnoId(void);
/* 128 */
-EXTERN CONST84_RETURN char * Tcl_ErrnoMsg(int err);
+EXTERN const char * Tcl_ErrnoMsg(int err);
/* 129 */
EXTERN int Tcl_Eval(Tcl_Interp *interp, const char *script);
/* 130 */
@@ -469,13 +470,13 @@ EXTERN void Tcl_FreeResult(Tcl_Interp *interp);
EXTERN int Tcl_GetAlias(Tcl_Interp *interp,
const char *slaveCmd,
Tcl_Interp **targetInterpPtr,
- CONST84 char **targetCmdPtr, int *argcPtr,
- CONST84 char ***argvPtr);
+ const char **targetCmdPtr, int *argcPtr,
+ const char ***argvPtr);
/* 149 */
EXTERN int Tcl_GetAliasObj(Tcl_Interp *interp,
const char *slaveCmd,
Tcl_Interp **targetInterpPtr,
- CONST84 char **targetCmdPtr, int *objcPtr,
+ const char **targetCmdPtr, int *objcPtr,
Tcl_Obj ***objv);
/* 150 */
EXTERN ClientData Tcl_GetAssocData(Tcl_Interp *interp,
@@ -494,7 +495,7 @@ EXTERN ClientData Tcl_GetChannelInstanceData(Tcl_Channel chan);
/* 155 */
EXTERN int Tcl_GetChannelMode(Tcl_Channel chan);
/* 156 */
-EXTERN CONST84_RETURN char * Tcl_GetChannelName(Tcl_Channel chan);
+EXTERN const char * Tcl_GetChannelName(Tcl_Channel chan);
/* 157 */
EXTERN int Tcl_GetChannelOption(Tcl_Interp *interp,
Tcl_Channel chan, const char *optionName,
@@ -505,12 +506,12 @@ EXTERN CONST86 Tcl_ChannelType * Tcl_GetChannelType(Tcl_Channel chan);
EXTERN int Tcl_GetCommandInfo(Tcl_Interp *interp,
const char *cmdName, Tcl_CmdInfo *infoPtr);
/* 160 */
-EXTERN CONST84_RETURN char * Tcl_GetCommandName(Tcl_Interp *interp,
+EXTERN const char * Tcl_GetCommandName(Tcl_Interp *interp,
Tcl_Command command);
/* 161 */
EXTERN int Tcl_GetErrno(void);
/* 162 */
-EXTERN CONST84_RETURN char * Tcl_GetHostName(void);
+EXTERN const char * Tcl_GetHostName(void);
/* 163 */
EXTERN int Tcl_GetInterpPath(Tcl_Interp *askInterp,
Tcl_Interp *slaveInterp);
@@ -546,14 +547,13 @@ EXTERN Tcl_Interp * Tcl_GetSlave(Tcl_Interp *interp,
/* 173 */
EXTERN Tcl_Channel Tcl_GetStdChannel(int type);
/* 174 */
-EXTERN CONST84_RETURN char * Tcl_GetStringResult(Tcl_Interp *interp);
+EXTERN const char * Tcl_GetStringResult(Tcl_Interp *interp);
/* 175 */
-EXTERN CONST84_RETURN char * Tcl_GetVar(Tcl_Interp *interp,
- const char *varName, int flags);
-/* 176 */
-EXTERN CONST84_RETURN char * Tcl_GetVar2(Tcl_Interp *interp,
- const char *part1, const char *part2,
+EXTERN const char * Tcl_GetVar(Tcl_Interp *interp, const char *varName,
int flags);
+/* 176 */
+EXTERN const char * Tcl_GetVar2(Tcl_Interp *interp, const char *part1,
+ const char *part2, int flags);
/* 177 */
EXTERN int Tcl_GlobalEval(Tcl_Interp *interp,
const char *command);
@@ -578,7 +578,7 @@ EXTERN int Tcl_InterpDeleted(Tcl_Interp *interp);
/* 185 */
EXTERN int Tcl_IsSafe(Tcl_Interp *interp);
/* 186 */
-EXTERN char * Tcl_JoinPath(int argc, CONST84 char *const *argv,
+EXTERN char * Tcl_JoinPath(int argc, const char *const *argv,
Tcl_DString *resultPtr);
/* 187 */
EXTERN int Tcl_LinkVar(Tcl_Interp *interp, const char *varName,
@@ -591,7 +591,7 @@ EXTERN int Tcl_MakeSafe(Tcl_Interp *interp);
/* 191 */
EXTERN Tcl_Channel Tcl_MakeTcpClientChannel(ClientData tcpSocket);
/* 192 */
-EXTERN char * Tcl_Merge(int argc, CONST84 char *const *argv);
+EXTERN char * Tcl_Merge(int argc, const char *const *argv);
/* 193 */
EXTERN Tcl_HashEntry * Tcl_NextHashEntry(Tcl_HashSearch *searchPtr);
/* 194 */
@@ -605,7 +605,7 @@ EXTERN Tcl_Obj * Tcl_ObjSetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
int flags);
/* 197 */
EXTERN Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp, int argc,
- CONST84 char **argv, int flags);
+ const char **argv, int flags);
/* 198 */
EXTERN Tcl_Channel Tcl_OpenFileChannel(Tcl_Interp *interp,
const char *fileName, const char *modeString,
@@ -627,7 +627,7 @@ EXTERN void Tcl_PrintDouble(Tcl_Interp *interp, double value,
/* 203 */
EXTERN int Tcl_PutEnv(const char *assignment);
/* 204 */
-EXTERN CONST84_RETURN char * Tcl_PosixError(Tcl_Interp *interp);
+EXTERN const char * Tcl_PosixError(Tcl_Interp *interp);
/* 205 */
EXTERN void Tcl_QueueEvent(Tcl_Event *evPtr,
Tcl_QueuePosition position);
@@ -657,8 +657,7 @@ EXTERN int Tcl_RegExpMatch(Tcl_Interp *interp, const char *text,
const char *pattern);
/* 215 */
EXTERN void Tcl_RegExpRange(Tcl_RegExp regexp, int index,
- CONST84 char **startPtr,
- CONST84 char **endPtr);
+ const char **startPtr, const char **endPtr);
/* 216 */
EXTERN void Tcl_Release(ClientData clientData);
/* 217 */
@@ -714,26 +713,25 @@ EXTERN void Tcl_SetObjResult(Tcl_Interp *interp,
/* 236 */
EXTERN void Tcl_SetStdChannel(Tcl_Channel channel, int type);
/* 237 */
-EXTERN CONST84_RETURN char * Tcl_SetVar(Tcl_Interp *interp,
- const char *varName, const char *newValue,
- int flags);
-/* 238 */
-EXTERN CONST84_RETURN char * Tcl_SetVar2(Tcl_Interp *interp,
- const char *part1, const char *part2,
+EXTERN const char * Tcl_SetVar(Tcl_Interp *interp, const char *varName,
const char *newValue, int flags);
+/* 238 */
+EXTERN const char * Tcl_SetVar2(Tcl_Interp *interp, const char *part1,
+ const char *part2, const char *newValue,
+ int flags);
/* 239 */
-EXTERN CONST84_RETURN char * Tcl_SignalId(int sig);
+EXTERN const char * Tcl_SignalId(int sig);
/* 240 */
-EXTERN CONST84_RETURN char * Tcl_SignalMsg(int sig);
+EXTERN const char * Tcl_SignalMsg(int sig);
/* 241 */
EXTERN void Tcl_SourceRCFile(Tcl_Interp *interp);
/* 242 */
EXTERN int Tcl_SplitList(Tcl_Interp *interp,
const char *listStr, int *argcPtr,
- CONST84 char ***argvPtr);
+ const char ***argvPtr);
/* 243 */
EXTERN void Tcl_SplitPath(const char *path, int *argcPtr,
- CONST84 char ***argvPtr);
+ const char ***argvPtr);
/* 244 */
EXTERN void Tcl_StaticPackage(Tcl_Interp *interp,
const char *pkgName,
@@ -824,23 +822,21 @@ void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr,
/* 269 */
EXTERN char * Tcl_HashStats(Tcl_HashTable *tablePtr);
/* 270 */
-EXTERN CONST84_RETURN char * Tcl_ParseVar(Tcl_Interp *interp,
- const char *start, CONST84 char **termPtr);
+EXTERN const char * Tcl_ParseVar(Tcl_Interp *interp, const char *start,
+ const char **termPtr);
/* 271 */
-EXTERN CONST84_RETURN char * Tcl_PkgPresent(Tcl_Interp *interp,
- const char *name, const char *version,
- int exact);
+EXTERN const char * Tcl_PkgPresent(Tcl_Interp *interp, const char *name,
+ const char *version, int exact);
/* 272 */
-EXTERN CONST84_RETURN char * Tcl_PkgPresentEx(Tcl_Interp *interp,
+EXTERN const char * Tcl_PkgPresentEx(Tcl_Interp *interp,
const char *name, const char *version,
int exact, void *clientDataPtr);
/* 273 */
EXTERN int Tcl_PkgProvide(Tcl_Interp *interp, const char *name,
const char *version);
/* 274 */
-EXTERN CONST84_RETURN char * Tcl_PkgRequire(Tcl_Interp *interp,
- const char *name, const char *version,
- int exact);
+EXTERN const char * Tcl_PkgRequire(Tcl_Interp *interp, const char *name,
+ const char *version, int exact);
/* 275 */
TCL_DEPRECATED("see TIP #422")
void Tcl_SetErrorCodeVA(Tcl_Interp *interp,
@@ -917,7 +913,7 @@ EXTERN Tcl_ThreadId Tcl_GetCurrentThread(void);
/* 301 */
EXTERN Tcl_Encoding Tcl_GetEncoding(Tcl_Interp *interp, const char *name);
/* 302 */
-EXTERN CONST84_RETURN char * Tcl_GetEncodingName(Tcl_Encoding encoding);
+EXTERN const char * Tcl_GetEncodingName(Tcl_Encoding encoding);
/* 303 */
EXTERN void Tcl_GetEncodingNames(Tcl_Interp *interp);
/* 304 */
@@ -976,20 +972,20 @@ EXTERN Tcl_UniChar Tcl_UniCharToUpper(int ch);
/* 324 */
EXTERN int Tcl_UniCharToUtf(int ch, char *buf);
/* 325 */
-EXTERN CONST84_RETURN char * Tcl_UtfAtIndex(const char *src, int index);
+EXTERN const char * Tcl_UtfAtIndex(const char *src, int index);
/* 326 */
EXTERN int Tcl_UtfCharComplete(const char *src, int length);
/* 327 */
EXTERN int Tcl_UtfBackslash(const char *src, int *readPtr,
char *dst);
/* 328 */
-EXTERN CONST84_RETURN char * Tcl_UtfFindFirst(const char *src, int ch);
+EXTERN const char * Tcl_UtfFindFirst(const char *src, int ch);
/* 329 */
-EXTERN CONST84_RETURN char * Tcl_UtfFindLast(const char *src, int ch);
+EXTERN const char * Tcl_UtfFindLast(const char *src, int ch);
/* 330 */
-EXTERN CONST84_RETURN char * Tcl_UtfNext(const char *src);
+EXTERN const char * Tcl_UtfNext(const char *src);
/* 331 */
-EXTERN CONST84_RETURN char * Tcl_UtfPrev(const char *src, const char *start);
+EXTERN const char * Tcl_UtfPrev(const char *src, const char *start);
/* 332 */
EXTERN int Tcl_UtfToExternal(Tcl_Interp *interp,
Tcl_Encoding encoding, const char *src,
@@ -1017,9 +1013,11 @@ EXTERN int Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr);
/* 340 */
EXTERN char * Tcl_GetString(Tcl_Obj *objPtr);
/* 341 */
-EXTERN CONST84_RETURN char * Tcl_GetDefaultEncodingDir(void);
+TCL_DEPRECATED("Use Tcl_GetEncodingSearchPath")
+const char * Tcl_GetDefaultEncodingDir(void);
/* 342 */
-EXTERN void Tcl_SetDefaultEncodingDir(const char *path);
+TCL_DEPRECATED("Use Tcl_SetEncodingSearchPath")
+void Tcl_SetDefaultEncodingDir(const char *path);
/* 343 */
EXTERN void Tcl_AlertNotifier(ClientData clientData);
/* 344 */
@@ -1054,7 +1052,8 @@ EXTERN Tcl_UniChar * Tcl_UtfToUniCharDString(const char *src, int length,
EXTERN Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp,
Tcl_Obj *patObj, int flags);
/* 357 */
-EXTERN Tcl_Obj * Tcl_EvalTokens(Tcl_Interp *interp,
+TCL_DEPRECATED("Use Tcl_EvalTokensStandard")
+Tcl_Obj * Tcl_EvalTokens(Tcl_Interp *interp,
Tcl_Token *tokenPtr, int count);
/* 358 */
EXTERN void Tcl_FreeParse(Tcl_Parse *parsePtr);
@@ -1066,7 +1065,7 @@ EXTERN void Tcl_LogCommandInfo(Tcl_Interp *interp,
EXTERN int Tcl_ParseBraces(Tcl_Interp *interp,
const char *start, int numBytes,
Tcl_Parse *parsePtr, int append,
- CONST84 char **termPtr);
+ const char **termPtr);
/* 361 */
EXTERN int Tcl_ParseCommand(Tcl_Interp *interp,
const char *start, int numBytes, int nested,
@@ -1078,7 +1077,7 @@ EXTERN int Tcl_ParseExpr(Tcl_Interp *interp, const char *start,
EXTERN int Tcl_ParseQuotedString(Tcl_Interp *interp,
const char *start, int numBytes,
Tcl_Parse *parsePtr, int append,
- CONST84 char **termPtr);
+ const char **termPtr);
/* 364 */
EXTERN int Tcl_ParseVarName(Tcl_Interp *interp,
const char *start, int numBytes,
@@ -1168,8 +1167,7 @@ EXTERN Tcl_Channel Tcl_GetTopChannel(Tcl_Channel chan);
/* 397 */
EXTERN int Tcl_ChannelBuffered(Tcl_Channel chan);
/* 398 */
-EXTERN CONST84_RETURN char * Tcl_ChannelName(
- const Tcl_ChannelType *chanTypePtr);
+EXTERN const char * Tcl_ChannelName(const Tcl_ChannelType *chanTypePtr);
/* 399 */
EXTERN Tcl_ChannelTypeVersion Tcl_ChannelVersion(
const Tcl_ChannelType *chanTypePtr);
@@ -1275,13 +1273,15 @@ EXTERN Tcl_ThreadId Tcl_GetChannelThread(Tcl_Channel channel);
EXTERN Tcl_UniChar * Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr,
int *lengthPtr);
/* 435 */
-EXTERN int Tcl_GetMathFuncInfo(Tcl_Interp *interp,
+TCL_DEPRECATED("")
+int Tcl_GetMathFuncInfo(Tcl_Interp *interp,
const char *name, int *numArgsPtr,
Tcl_ValueType **argTypesPtr,
Tcl_MathProc **procPtr,
ClientData *clientDataPtr);
/* 436 */
-EXTERN Tcl_Obj * Tcl_ListMathFuncs(Tcl_Interp *interp,
+TCL_DEPRECATED("")
+Tcl_Obj * Tcl_ListMathFuncs(Tcl_Interp *interp,
const char *pattern);
/* 437 */
EXTERN Tcl_Obj * Tcl_SubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
@@ -1850,7 +1850,7 @@ typedef struct TclStubs {
const TclStubHooks *hooks;
int (*tcl_PkgProvideEx) (Tcl_Interp *interp, const char *name, const char *version, const void *clientData); /* 0 */
- CONST84_RETURN char * (*tcl_PkgRequireEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 1 */
+ const char * (*tcl_PkgRequireEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 1 */
TCL_NORETURN1 void (*tcl_Panic) (const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 2 */
char * (*tcl_Alloc) (unsigned int size); /* 3 */
void (*tcl_Free) (char *ptr); /* 4 */
@@ -1901,7 +1901,7 @@ typedef struct TclStubs {
unsigned char * (*tcl_GetByteArrayFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 33 */
int (*tcl_GetDouble) (Tcl_Interp *interp, const char *src, double *doublePtr); /* 34 */
int (*tcl_GetDoubleFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr); /* 35 */
- int (*tcl_GetIndexFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, CONST84 char *const *tablePtr, const char *msg, int flags, int *indexPtr); /* 36 */
+ int (*tcl_GetIndexFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, const char *const *tablePtr, const char *msg, int flags, int *indexPtr); /* 36 */
int (*tcl_GetInt) (Tcl_Interp *interp, const char *src, int *intPtr); /* 37 */
int (*tcl_GetIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr); /* 38 */
int (*tcl_GetLongFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr); /* 39 */
@@ -1942,16 +1942,16 @@ typedef struct TclStubs {
void (*tcl_AsyncMark) (Tcl_AsyncHandler async); /* 74 */
int (*tcl_AsyncReady) (void); /* 75 */
void (*tcl_BackgroundError) (Tcl_Interp *interp); /* 76 */
- char (*tcl_Backslash) (const char *src, int *readPtr); /* 77 */
+ TCL_DEPRECATED_API("Use Tcl_UtfBackslash") char (*tcl_Backslash) (const char *src, int *readPtr); /* 77 */
int (*tcl_BadChannelOption) (Tcl_Interp *interp, const char *optionName, const char *optionList); /* 78 */
void (*tcl_CallWhenDeleted) (Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, ClientData clientData); /* 79 */
void (*tcl_CancelIdleCall) (Tcl_IdleProc *idleProc, ClientData clientData); /* 80 */
int (*tcl_Close) (Tcl_Interp *interp, Tcl_Channel chan); /* 81 */
int (*tcl_CommandComplete) (const char *cmd); /* 82 */
- char * (*tcl_Concat) (int argc, CONST84 char *const *argv); /* 83 */
+ char * (*tcl_Concat) (int argc, const char *const *argv); /* 83 */
int (*tcl_ConvertElement) (const char *src, char *dst, int flags); /* 84 */
int (*tcl_ConvertCountedElement) (const char *src, int length, char *dst, int flags); /* 85 */
- int (*tcl_CreateAlias) (Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int argc, CONST84 char *const *argv); /* 86 */
+ int (*tcl_CreateAlias) (Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int argc, const char *const *argv); /* 86 */
int (*tcl_CreateAliasObj) (Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int objc, Tcl_Obj *const objv[]); /* 87 */
Tcl_Channel (*tcl_CreateChannel) (const Tcl_ChannelType *typePtr, const char *chanName, ClientData instanceData, int mask); /* 88 */
void (*tcl_CreateChannelHandler) (Tcl_Channel chan, int mask, Tcl_ChannelProc *proc, ClientData clientData); /* 89 */
@@ -1960,7 +1960,7 @@ typedef struct TclStubs {
void (*tcl_CreateEventSource) (Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, ClientData clientData); /* 92 */
void (*tcl_CreateExitHandler) (Tcl_ExitProc *proc, ClientData clientData); /* 93 */
Tcl_Interp * (*tcl_CreateInterp) (void); /* 94 */
- void (*tcl_CreateMathFunc) (Tcl_Interp *interp, const char *name, int numArgs, Tcl_ValueType *argTypes, Tcl_MathProc *proc, ClientData clientData); /* 95 */
+ TCL_DEPRECATED_API("") void (*tcl_CreateMathFunc) (Tcl_Interp *interp, const char *name, int numArgs, Tcl_ValueType *argTypes, Tcl_MathProc *proc, ClientData clientData); /* 95 */
Tcl_Command (*tcl_CreateObjCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 96 */
Tcl_Interp * (*tcl_CreateSlave) (Tcl_Interp *interp, const char *slaveName, int isSafe); /* 97 */
Tcl_TimerToken (*tcl_CreateTimerHandler) (int milliseconds, Tcl_TimerProc *proc, ClientData clientData); /* 98 */
@@ -1992,8 +1992,8 @@ typedef struct TclStubs {
void (*tcl_DStringSetLength) (Tcl_DString *dsPtr, int length); /* 124 */
void (*tcl_DStringStartSublist) (Tcl_DString *dsPtr); /* 125 */
int (*tcl_Eof) (Tcl_Channel chan); /* 126 */
- CONST84_RETURN char * (*tcl_ErrnoId) (void); /* 127 */
- CONST84_RETURN char * (*tcl_ErrnoMsg) (int err); /* 128 */
+ const char * (*tcl_ErrnoId) (void); /* 127 */
+ const char * (*tcl_ErrnoMsg) (int err); /* 128 */
int (*tcl_Eval) (Tcl_Interp *interp, const char *script); /* 129 */
int (*tcl_EvalFile) (Tcl_Interp *interp, const char *fileName); /* 130 */
int (*tcl_EvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 131 */
@@ -2013,21 +2013,21 @@ typedef struct TclStubs {
Tcl_HashEntry * (*tcl_FirstHashEntry) (Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); /* 145 */
int (*tcl_Flush) (Tcl_Channel chan); /* 146 */
void (*tcl_FreeResult) (Tcl_Interp *interp); /* 147 */
- int (*tcl_GetAlias) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *argcPtr, CONST84 char ***argvPtr); /* 148 */
- int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 149 */
+ int (*tcl_GetAlias) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *argcPtr, const char ***argvPtr); /* 148 */
+ int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 149 */
ClientData (*tcl_GetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc **procPtr); /* 150 */
Tcl_Channel (*tcl_GetChannel) (Tcl_Interp *interp, const char *chanName, int *modePtr); /* 151 */
int (*tcl_GetChannelBufferSize) (Tcl_Channel chan); /* 152 */
int (*tcl_GetChannelHandle) (Tcl_Channel chan, int direction, ClientData *handlePtr); /* 153 */
ClientData (*tcl_GetChannelInstanceData) (Tcl_Channel chan); /* 154 */
int (*tcl_GetChannelMode) (Tcl_Channel chan); /* 155 */
- CONST84_RETURN char * (*tcl_GetChannelName) (Tcl_Channel chan); /* 156 */
+ const char * (*tcl_GetChannelName) (Tcl_Channel chan); /* 156 */
int (*tcl_GetChannelOption) (Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, Tcl_DString *dsPtr); /* 157 */
CONST86 Tcl_ChannelType * (*tcl_GetChannelType) (Tcl_Channel chan); /* 158 */
int (*tcl_GetCommandInfo) (Tcl_Interp *interp, const char *cmdName, Tcl_CmdInfo *infoPtr); /* 159 */
- CONST84_RETURN char * (*tcl_GetCommandName) (Tcl_Interp *interp, Tcl_Command command); /* 160 */
+ const char * (*tcl_GetCommandName) (Tcl_Interp *interp, Tcl_Command command); /* 160 */
int (*tcl_GetErrno) (void); /* 161 */
- CONST84_RETURN char * (*tcl_GetHostName) (void); /* 162 */
+ const char * (*tcl_GetHostName) (void); /* 162 */
int (*tcl_GetInterpPath) (Tcl_Interp *askInterp, Tcl_Interp *slaveInterp); /* 163 */
Tcl_Interp * (*tcl_GetMaster) (Tcl_Interp *interp); /* 164 */
const char * (*tcl_GetNameOfExecutable) (void); /* 165 */
@@ -2047,9 +2047,9 @@ typedef struct TclStubs {
int (*tcl_GetServiceMode) (void); /* 171 */
Tcl_Interp * (*tcl_GetSlave) (Tcl_Interp *interp, const char *slaveName); /* 172 */
Tcl_Channel (*tcl_GetStdChannel) (int type); /* 173 */
- CONST84_RETURN char * (*tcl_GetStringResult) (Tcl_Interp *interp); /* 174 */
- CONST84_RETURN char * (*tcl_GetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 175 */
- CONST84_RETURN char * (*tcl_GetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 176 */
+ const char * (*tcl_GetStringResult) (Tcl_Interp *interp); /* 174 */
+ const char * (*tcl_GetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 175 */
+ const char * (*tcl_GetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 176 */
int (*tcl_GlobalEval) (Tcl_Interp *interp, const char *command); /* 177 */
int (*tcl_GlobalEvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 178 */
int (*tcl_HideCommand) (Tcl_Interp *interp, const char *cmdName, const char *hiddenCmdToken); /* 179 */
@@ -2059,25 +2059,25 @@ typedef struct TclStubs {
int (*tcl_InputBuffered) (Tcl_Channel chan); /* 183 */
int (*tcl_InterpDeleted) (Tcl_Interp *interp); /* 184 */
int (*tcl_IsSafe) (Tcl_Interp *interp); /* 185 */
- char * (*tcl_JoinPath) (int argc, CONST84 char *const *argv, Tcl_DString *resultPtr); /* 186 */
+ char * (*tcl_JoinPath) (int argc, const char *const *argv, Tcl_DString *resultPtr); /* 186 */
int (*tcl_LinkVar) (Tcl_Interp *interp, const char *varName, char *addr, int type); /* 187 */
void (*reserved188)(void);
Tcl_Channel (*tcl_MakeFileChannel) (ClientData handle, int mode); /* 189 */
int (*tcl_MakeSafe) (Tcl_Interp *interp); /* 190 */
Tcl_Channel (*tcl_MakeTcpClientChannel) (ClientData tcpSocket); /* 191 */
- char * (*tcl_Merge) (int argc, CONST84 char *const *argv); /* 192 */
+ char * (*tcl_Merge) (int argc, const char *const *argv); /* 192 */
Tcl_HashEntry * (*tcl_NextHashEntry) (Tcl_HashSearch *searchPtr); /* 193 */
void (*tcl_NotifyChannel) (Tcl_Channel channel, int mask); /* 194 */
Tcl_Obj * (*tcl_ObjGetVar2) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 195 */
Tcl_Obj * (*tcl_ObjSetVar2) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags); /* 196 */
- Tcl_Channel (*tcl_OpenCommandChannel) (Tcl_Interp *interp, int argc, CONST84 char **argv, int flags); /* 197 */
+ Tcl_Channel (*tcl_OpenCommandChannel) (Tcl_Interp *interp, int argc, const char **argv, int flags); /* 197 */
Tcl_Channel (*tcl_OpenFileChannel) (Tcl_Interp *interp, const char *fileName, const char *modeString, int permissions); /* 198 */
Tcl_Channel (*tcl_OpenTcpClient) (Tcl_Interp *interp, int port, const char *address, const char *myaddr, int myport, int async); /* 199 */
Tcl_Channel (*tcl_OpenTcpServer) (Tcl_Interp *interp, int port, const char *host, Tcl_TcpAcceptProc *acceptProc, ClientData callbackData); /* 200 */
void (*tcl_Preserve) (ClientData data); /* 201 */
void (*tcl_PrintDouble) (Tcl_Interp *interp, double value, char *dst); /* 202 */
int (*tcl_PutEnv) (const char *assignment); /* 203 */
- CONST84_RETURN char * (*tcl_PosixError) (Tcl_Interp *interp); /* 204 */
+ const char * (*tcl_PosixError) (Tcl_Interp *interp); /* 204 */
void (*tcl_QueueEvent) (Tcl_Event *evPtr, Tcl_QueuePosition position); /* 205 */
int (*tcl_Read) (Tcl_Channel chan, char *bufPtr, int toRead); /* 206 */
void (*tcl_ReapDetachedProcs) (void); /* 207 */
@@ -2088,7 +2088,7 @@ typedef struct TclStubs {
Tcl_RegExp (*tcl_RegExpCompile) (Tcl_Interp *interp, const char *pattern); /* 212 */
int (*tcl_RegExpExec) (Tcl_Interp *interp, Tcl_RegExp regexp, const char *text, const char *start); /* 213 */
int (*tcl_RegExpMatch) (Tcl_Interp *interp, const char *text, const char *pattern); /* 214 */
- void (*tcl_RegExpRange) (Tcl_RegExp regexp, int index, CONST84 char **startPtr, CONST84 char **endPtr); /* 215 */
+ void (*tcl_RegExpRange) (Tcl_RegExp regexp, int index, const char **startPtr, const char **endPtr); /* 215 */
void (*tcl_Release) (ClientData clientData); /* 216 */
void (*tcl_ResetResult) (Tcl_Interp *interp); /* 217 */
int (*tcl_ScanElement) (const char *src, int *flagPtr); /* 218 */
@@ -2110,13 +2110,13 @@ typedef struct TclStubs {
void (*tcl_SetObjErrorCode) (Tcl_Interp *interp, Tcl_Obj *errorObjPtr); /* 234 */
void (*tcl_SetObjResult) (Tcl_Interp *interp, Tcl_Obj *resultObjPtr); /* 235 */
void (*tcl_SetStdChannel) (Tcl_Channel channel, int type); /* 236 */
- CONST84_RETURN char * (*tcl_SetVar) (Tcl_Interp *interp, const char *varName, const char *newValue, int flags); /* 237 */
- CONST84_RETURN char * (*tcl_SetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, const char *newValue, int flags); /* 238 */
- CONST84_RETURN char * (*tcl_SignalId) (int sig); /* 239 */
- CONST84_RETURN char * (*tcl_SignalMsg) (int sig); /* 240 */
+ const char * (*tcl_SetVar) (Tcl_Interp *interp, const char *varName, const char *newValue, int flags); /* 237 */
+ const char * (*tcl_SetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, const char *newValue, int flags); /* 238 */
+ const char * (*tcl_SignalId) (int sig); /* 239 */
+ const char * (*tcl_SignalMsg) (int sig); /* 240 */
void (*tcl_SourceRCFile) (Tcl_Interp *interp); /* 241 */
- int (*tcl_SplitList) (Tcl_Interp *interp, const char *listStr, int *argcPtr, CONST84 char ***argvPtr); /* 242 */
- void (*tcl_SplitPath) (const char *path, int *argcPtr, CONST84 char ***argvPtr); /* 243 */
+ int (*tcl_SplitList) (Tcl_Interp *interp, const char *listStr, int *argcPtr, const char ***argvPtr); /* 242 */
+ void (*tcl_SplitPath) (const char *path, int *argcPtr, const char ***argvPtr); /* 243 */
void (*tcl_StaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 244 */
int (*tcl_StringMatch) (const char *str, const char *pattern); /* 245 */
TCL_DEPRECATED_API("") int (*tcl_TellOld) (Tcl_Channel chan); /* 246 */
@@ -2143,11 +2143,11 @@ typedef struct TclStubs {
TCL_DEPRECATED_API("see TIP #422") void (*tcl_AppendResultVA) (Tcl_Interp *interp, va_list argList); /* 267 */
TCL_DEPRECATED_API("see TIP #422") void (*tcl_AppendStringsToObjVA) (Tcl_Obj *objPtr, va_list argList); /* 268 */
char * (*tcl_HashStats) (Tcl_HashTable *tablePtr); /* 269 */
- CONST84_RETURN char * (*tcl_ParseVar) (Tcl_Interp *interp, const char *start, CONST84 char **termPtr); /* 270 */
- CONST84_RETURN char * (*tcl_PkgPresent) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 271 */
- CONST84_RETURN char * (*tcl_PkgPresentEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 272 */
+ const char * (*tcl_ParseVar) (Tcl_Interp *interp, const char *start, const char **termPtr); /* 270 */
+ const char * (*tcl_PkgPresent) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 271 */
+ const char * (*tcl_PkgPresentEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 272 */
int (*tcl_PkgProvide) (Tcl_Interp *interp, const char *name, const char *version); /* 273 */
- CONST84_RETURN char * (*tcl_PkgRequire) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 274 */
+ const char * (*tcl_PkgRequire) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 274 */
TCL_DEPRECATED_API("see TIP #422") void (*tcl_SetErrorCodeVA) (Tcl_Interp *interp, va_list argList); /* 275 */
TCL_DEPRECATED_API("see TIP #422") int (*tcl_VarEvalVA) (Tcl_Interp *interp, va_list argList); /* 276 */
Tcl_Pid (*tcl_WaitPid) (Tcl_Pid pid, int *statPtr, int options); /* 277 */
@@ -2175,7 +2175,7 @@ typedef struct TclStubs {
void (*tcl_FreeEncoding) (Tcl_Encoding encoding); /* 299 */
Tcl_ThreadId (*tcl_GetCurrentThread) (void); /* 300 */
Tcl_Encoding (*tcl_GetEncoding) (Tcl_Interp *interp, const char *name); /* 301 */
- CONST84_RETURN char * (*tcl_GetEncodingName) (Tcl_Encoding encoding); /* 302 */
+ const char * (*tcl_GetEncodingName) (Tcl_Encoding encoding); /* 302 */
void (*tcl_GetEncodingNames) (Tcl_Interp *interp); /* 303 */
int (*tcl_GetIndexFromObjStruct) (Tcl_Interp *interp, Tcl_Obj *objPtr, const void *tablePtr, int offset, const char *msg, int flags, int *indexPtr); /* 304 */
void * (*tcl_GetThreadData) (Tcl_ThreadDataKey *keyPtr, int size); /* 305 */
@@ -2198,13 +2198,13 @@ typedef struct TclStubs {
Tcl_UniChar (*tcl_UniCharToTitle) (int ch); /* 322 */
Tcl_UniChar (*tcl_UniCharToUpper) (int ch); /* 323 */
int (*tcl_UniCharToUtf) (int ch, char *buf); /* 324 */
- CONST84_RETURN char * (*tcl_UtfAtIndex) (const char *src, int index); /* 325 */
+ const char * (*tcl_UtfAtIndex) (const char *src, int index); /* 325 */
int (*tcl_UtfCharComplete) (const char *src, int length); /* 326 */
int (*tcl_UtfBackslash) (const char *src, int *readPtr, char *dst); /* 327 */
- CONST84_RETURN char * (*tcl_UtfFindFirst) (const char *src, int ch); /* 328 */
- CONST84_RETURN char * (*tcl_UtfFindLast) (const char *src, int ch); /* 329 */
- CONST84_RETURN char * (*tcl_UtfNext) (const char *src); /* 330 */
- CONST84_RETURN char * (*tcl_UtfPrev) (const char *src, const char *start); /* 331 */
+ const char * (*tcl_UtfFindFirst) (const char *src, int ch); /* 328 */
+ const char * (*tcl_UtfFindLast) (const char *src, int ch); /* 329 */
+ const char * (*tcl_UtfNext) (const char *src); /* 330 */
+ const char * (*tcl_UtfPrev) (const char *src, const char *start); /* 331 */
int (*tcl_UtfToExternal) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 332 */
char * (*tcl_UtfToExternalDString) (Tcl_Encoding encoding, const char *src, int srcLen, Tcl_DString *dsPtr); /* 333 */
int (*tcl_UtfToLower) (char *src); /* 334 */
@@ -2214,8 +2214,8 @@ typedef struct TclStubs {
int (*tcl_WriteChars) (Tcl_Channel chan, const char *src, int srcLen); /* 338 */
int (*tcl_WriteObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 339 */
char * (*tcl_GetString) (Tcl_Obj *objPtr); /* 340 */
- CONST84_RETURN char * (*tcl_GetDefaultEncodingDir) (void); /* 341 */
- void (*tcl_SetDefaultEncodingDir) (const char *path); /* 342 */
+ TCL_DEPRECATED_API("Use Tcl_GetEncodingSearchPath") const char * (*tcl_GetDefaultEncodingDir) (void); /* 341 */
+ TCL_DEPRECATED_API("Use Tcl_SetEncodingSearchPath") void (*tcl_SetDefaultEncodingDir) (const char *path); /* 342 */
void (*tcl_AlertNotifier) (ClientData clientData); /* 343 */
void (*tcl_ServiceModeHook) (int mode); /* 344 */
int (*tcl_UniCharIsAlnum) (int ch); /* 345 */
@@ -2230,13 +2230,13 @@ typedef struct TclStubs {
char * (*tcl_UniCharToUtfDString) (const Tcl_UniChar *uniStr, int uniLength, Tcl_DString *dsPtr); /* 354 */
Tcl_UniChar * (*tcl_UtfToUniCharDString) (const char *src, int length, Tcl_DString *dsPtr); /* 355 */
Tcl_RegExp (*tcl_GetRegExpFromObj) (Tcl_Interp *interp, Tcl_Obj *patObj, int flags); /* 356 */
- Tcl_Obj * (*tcl_EvalTokens) (Tcl_Interp *interp, Tcl_Token *tokenPtr, int count); /* 357 */
+ TCL_DEPRECATED_API("Use Tcl_EvalTokensStandard") Tcl_Obj * (*tcl_EvalTokens) (Tcl_Interp *interp, Tcl_Token *tokenPtr, int count); /* 357 */
void (*tcl_FreeParse) (Tcl_Parse *parsePtr); /* 358 */
void (*tcl_LogCommandInfo) (Tcl_Interp *interp, const char *script, const char *command, int length); /* 359 */
- int (*tcl_ParseBraces) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, CONST84 char **termPtr); /* 360 */
+ int (*tcl_ParseBraces) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr); /* 360 */
int (*tcl_ParseCommand) (Tcl_Interp *interp, const char *start, int numBytes, int nested, Tcl_Parse *parsePtr); /* 361 */
int (*tcl_ParseExpr) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr); /* 362 */
- int (*tcl_ParseQuotedString) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, CONST84 char **termPtr); /* 363 */
+ int (*tcl_ParseQuotedString) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr); /* 363 */
int (*tcl_ParseVarName) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append); /* 364 */
char * (*tcl_GetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 365 */
int (*tcl_Chdir) (const char *dirName); /* 366 */
@@ -2271,7 +2271,7 @@ typedef struct TclStubs {
int (*tcl_WriteRaw) (Tcl_Channel chan, const char *src, int srcLen); /* 395 */
Tcl_Channel (*tcl_GetTopChannel) (Tcl_Channel chan); /* 396 */
int (*tcl_ChannelBuffered) (Tcl_Channel chan); /* 397 */
- CONST84_RETURN char * (*tcl_ChannelName) (const Tcl_ChannelType *chanTypePtr); /* 398 */
+ const char * (*tcl_ChannelName) (const Tcl_ChannelType *chanTypePtr); /* 398 */
Tcl_ChannelTypeVersion (*tcl_ChannelVersion) (const Tcl_ChannelType *chanTypePtr); /* 399 */
Tcl_DriverBlockModeProc * (*tcl_ChannelBlockModeProc) (const Tcl_ChannelType *chanTypePtr); /* 400 */
Tcl_DriverCloseProc * (*tcl_ChannelCloseProc) (const Tcl_ChannelType *chanTypePtr); /* 401 */
@@ -2308,8 +2308,8 @@ typedef struct TclStubs {
int (*tcl_AttemptSetObjLength) (Tcl_Obj *objPtr, int length); /* 432 */
Tcl_ThreadId (*tcl_GetChannelThread) (Tcl_Channel channel); /* 433 */
Tcl_UniChar * (*tcl_GetUnicodeFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 434 */
- int (*tcl_GetMathFuncInfo) (Tcl_Interp *interp, const char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, ClientData *clientDataPtr); /* 435 */
- Tcl_Obj * (*tcl_ListMathFuncs) (Tcl_Interp *interp, const char *pattern); /* 436 */
+ TCL_DEPRECATED_API("") int (*tcl_GetMathFuncInfo) (Tcl_Interp *interp, const char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, ClientData *clientDataPtr); /* 435 */
+ TCL_DEPRECATED_API("") Tcl_Obj * (*tcl_ListMathFuncs) (Tcl_Interp *interp, const char *pattern); /* 436 */
Tcl_Obj * (*tcl_SubstObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 437 */
int (*tcl_DetachChannel) (Tcl_Interp *interp, Tcl_Channel channel); /* 438 */
int (*tcl_IsStandardChannel) (Tcl_Channel channel); /* 439 */
@@ -3934,20 +3934,14 @@ extern const TclStubs *tclStubsPtr;
* possible. Tcl 9 must find a better solution, but that cannot be done
* without introducing a binary incompatibility.
*/
-# undef Tcl_DbNewLongObj
# undef Tcl_GetLongFromObj
-# undef Tcl_NewLongObj
-# undef Tcl_SetLongObj
# undef Tcl_ExprLong
# undef Tcl_ExprLongObj
# undef Tcl_UniCharNcmp
# undef Tcl_UtfNcmp
# undef Tcl_UtfNcasecmp
# undef Tcl_UniCharNcasecmp
-# define Tcl_DbNewLongObj ((Tcl_Obj*(*)(long,const char*,int))Tcl_DbNewWideIntObj)
# define Tcl_GetLongFromObj ((int(*)(Tcl_Interp*,Tcl_Obj*,long*))Tcl_GetWideIntFromObj)
-# define Tcl_NewLongObj ((Tcl_Obj*(*)(long))Tcl_NewWideIntObj)
-# define Tcl_SetLongObj ((void(*)(Tcl_Obj*,long))Tcl_SetWideIntObj)
# define Tcl_ExprLong TclExprLong
static inline int TclExprLong(Tcl_Interp *interp, const char *string, long *ptr){
int intValue;
@@ -3973,6 +3967,17 @@ extern const TclStubs *tclStubsPtr;
# endif
#endif
+#undef Tcl_NewLongObj
+#define Tcl_NewLongObj(value) Tcl_NewWideIntObj((long)(value))
+#undef Tcl_NewIntObj
+#define Tcl_NewIntObj(value) Tcl_NewWideIntObj((int)(value))
+#undef Tcl_DbNewLongObj
+#define Tcl_DbNewLongObj(value, file, line) Tcl_DbNewWideIntObj((long)(value), file, line)
+#undef Tcl_SetIntObj
+#define Tcl_SetIntObj(objPtr, value) Tcl_SetWideIntObj(objPtr, (int)(value))
+#undef Tcl_SetLongObj
+#define Tcl_SetLongObj(objPtr, value) Tcl_SetWideIntObj(objPtr, (long)(value))
+
/*
* Deprecated Tcl procedures:
*/
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index 3b983e3..a0f6491 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -2309,9 +2309,12 @@ DictAppendCmd(
if (objc == 4) {
appendObjPtr = objv[3];
- } else if (TCL_OK != TclStringCatObjv(interp, /* inPlace */ 1,
- objc-3, objv+3, &appendObjPtr)) {
- return TCL_ERROR;
+ } else {
+ appendObjPtr = TclStringCat(interp, objc-3, objv+3,
+ TCL_STRING_IN_PLACE);
+ if (appendObjPtr == NULL) {
+ return TCL_ERROR;
+ }
}
}
diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c
index e07080a..e9aaec4 100644
--- a/generic/tclDisassemble.c
+++ b/generic/tclDisassemble.c
@@ -797,7 +797,7 @@ TclNewInstNameObj(
Tcl_Obj *objPtr = Tcl_NewObj();
objPtr->typePtr = &tclInstNameType;
- objPtr->internalRep.longValue = (long) inst;
+ objPtr->internalRep.wideValue = (long) inst;
objPtr->bytes = NULL;
return objPtr;
@@ -817,17 +817,17 @@ static void
UpdateStringOfInstName(
Tcl_Obj *objPtr)
{
- int inst = objPtr->internalRep.longValue;
- char *s, buf[20];
- int len;
+ size_t len, inst = (size_t)objPtr->internalRep.wideValue;
+ char *s, buf[TCL_INTEGER_SPACE + 5];
- if ((inst < 0) || (inst > LAST_INST_OPCODE)) {
- sprintf(buf, "inst_%d", inst);
+ if (inst > LAST_INST_OPCODE) {
+ sprintf(buf, "inst_%" TCL_Z_MODIFIER "d", inst);
s = buf;
} else {
- s = (char *) tclInstructionTable[objPtr->internalRep.longValue].name;
+ s = (char *) tclInstructionTable[inst].name;
}
len = strlen(s);
+ /* assert (len < UINT_MAX) */
objPtr->bytes = ckalloc(len + 1);
memcpy(objPtr->bytes, s, len + 1);
objPtr->length = len;
diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c
index 46db12c..3d892b7 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.c
@@ -693,6 +693,7 @@ TclFinalizeEncodingSubsystem(void)
*-------------------------------------------------------------------------
*/
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
const char *
Tcl_GetDefaultEncodingDir(void)
{
@@ -736,6 +737,7 @@ Tcl_SetDefaultEncodingDir(
Tcl_ListObjReplace(NULL, searchPath, 0, 0, 1, &directory);
Tcl_SetEncodingSearchPath(searchPath);
}
+#endif
/*
*-------------------------------------------------------------------------
diff --git a/generic/tclEvent.c b/generic/tclEvent.c
index 49fd2ae..93cf983 100644
--- a/generic/tclEvent.c
+++ b/generic/tclEvent.c
@@ -1057,7 +1057,6 @@ TclInitSubsystems(void)
* mutexes. */
TclInitIOSubsystem(); /* Inits a tsd key (noop). */
TclInitEncodingSubsystem(); /* Process wide encoding init. */
- TclpSetInterfaces();
TclInitNamespaceSubsystem();/* Register ns obj type (mutexed). */
subsystemsInitialized = 1;
}
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index f2cda0c..f294272 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -325,7 +325,7 @@ VarHashCreateVar(
NEXT_INST_F(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \
default: \
if ((condition) < 0) { \
- TclNewLongObj(objResultPtr, -1); \
+ TclNewIntObj(objResultPtr, -1); \
} else { \
objResultPtr = TCONST((condition) > 0); \
} \
@@ -346,7 +346,7 @@ VarHashCreateVar(
NEXT_INST_V(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \
default: \
if ((condition) < 0) { \
- TclNewLongObj(objResultPtr, -1); \
+ TclNewIntObj(objResultPtr, -1); \
} else { \
objResultPtr = TCONST((condition) > 0); \
} \
@@ -357,7 +357,7 @@ VarHashCreateVar(
#define JUMP_PEEPHOLE_F(condition, pcAdjustment, cleanup) \
do{ \
if ((condition) < 0) { \
- TclNewLongObj(objResultPtr, -1); \
+ TclNewIntObj(objResultPtr, -1); \
} else { \
objResultPtr = TCONST((condition) > 0); \
} \
@@ -366,7 +366,7 @@ VarHashCreateVar(
#define JUMP_PEEPHOLE_V(condition, pcAdjustment, cleanup) \
do{ \
if ((condition) < 0) { \
- TclNewLongObj(objResultPtr, -1); \
+ TclNewIntObj(objResultPtr, -1); \
} else { \
objResultPtr = TCONST((condition) > 0); \
} \
@@ -498,28 +498,8 @@ VarHashCreateVar(
* ClientData *ptrPtr, int *tPtr);
*/
-#ifdef TCL_WIDE_INT_IS_LONG
#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \
(((objPtr)->typePtr == &tclIntType) \
- ? (*(tPtr) = TCL_NUMBER_LONG, \
- *(ptrPtr) = (ClientData) \
- (&((objPtr)->internalRep.longValue)), TCL_OK) : \
- ((objPtr)->typePtr == &tclDoubleType) \
- ? (((TclIsNaN((objPtr)->internalRep.doubleValue)) \
- ? (*(tPtr) = TCL_NUMBER_NAN) \
- : (*(tPtr) = TCL_NUMBER_DOUBLE)), \
- *(ptrPtr) = (ClientData) \
- (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \
- (((objPtr)->bytes != NULL) && ((objPtr)->length == 0)) \
- ? TCL_ERROR : \
- TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr)))
-#else /* !TCL_WIDE_INT_IS_LONG */
-#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \
- (((objPtr)->typePtr == &tclIntType) \
- ? (*(tPtr) = TCL_NUMBER_LONG, \
- *(ptrPtr) = (ClientData) \
- (&((objPtr)->internalRep.longValue)), TCL_OK) : \
- ((objPtr)->typePtr == &tclWideIntType) \
? (*(tPtr) = TCL_NUMBER_WIDE, \
*(ptrPtr) = (ClientData) \
(&((objPtr)->internalRep.wideValue)), TCL_OK) : \
@@ -532,21 +512,6 @@ VarHashCreateVar(
(((objPtr)->bytes != NULL) && ((objPtr)->length == 0)) \
? TCL_ERROR : \
TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr)))
-#endif /* TCL_WIDE_INT_IS_LONG */
-
-/*
- * Macro used in this file to save a function call for common uses of
- * Tcl_GetBooleanFromObj(). The ANSI C "prototype" is:
- *
- * MODULE_SCOPE int TclGetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
- * int *boolPtr);
- */
-
-#define TclGetBooleanFromObj(interp, objPtr, boolPtr) \
- ((((objPtr)->typePtr == &tclIntType) \
- || ((objPtr)->typePtr == &tclBooleanType)) \
- ? (*(boolPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \
- : Tcl_GetBooleanFromObj((interp), (objPtr), (boolPtr)))
/*
* Macro used to make the check for type overflow more mnemonic. This works by
@@ -576,40 +541,6 @@ VarHashCreateVar(
* Auxiliary tables used to compute powers of small integers.
*/
-#if (LONG_MAX == 0x7fffffff)
-
-/*
- * Maximum base that, when raised to powers 2, 3, ... 8, fits in a 32-bit
- * signed integer.
- */
-
-static const long MaxBase32[] = {46340, 1290, 215, 73, 35, 21, 14};
-static const size_t MaxBase32Size = sizeof(MaxBase32)/sizeof(long);
-
-/*
- * Table giving 3, 4, ..., 11, raised to the powers 9, 10, ..., as far as they
- * fit in a 32-bit signed integer. Exp32Index[i] gives the starting index of
- * powers of i+3; Exp32Value[i] gives the corresponding powers.
- */
-
-static const unsigned short Exp32Index[] = {
- 0, 11, 18, 23, 26, 29, 31, 32, 33
-};
-static const size_t Exp32IndexSize =
- sizeof(Exp32Index) / sizeof(unsigned short);
-static const long Exp32Value[] = {
- 19683, 59049, 177147, 531441, 1594323, 4782969, 14348907, 43046721,
- 129140163, 387420489, 1162261467, 262144, 1048576, 4194304,
- 16777216, 67108864, 268435456, 1073741824, 1953125, 9765625,
- 48828125, 244140625, 1220703125, 10077696, 60466176, 362797056,
- 40353607, 282475249, 1977326743, 134217728, 1073741824, 387420489,
- 1000000000
-};
-static const size_t Exp32ValueSize = sizeof(Exp32Value)/sizeof(long);
-#endif /* LONG_MAX == 0x7fffffff -- 32 bit machine */
-
-#if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG)
-
/*
* Maximum base that, when raised to powers 2, 3, ..., 16, fits in a
* Tcl_WideInt.
@@ -713,7 +644,6 @@ static const Tcl_WideInt Exp64Value[] = {
(Tcl_WideInt)371293*371293*371293*13*13
};
static const size_t Exp64ValueSize = sizeof(Exp64Value) / sizeof(Tcl_WideInt);
-#endif /* (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG) */
/*
* Markers for ExecuteExtendedBinaryMathOp.
@@ -906,9 +836,9 @@ TclCreateExecEnv(
+ (size_t) (size-1) * sizeof(Tcl_Obj *));
eePtr->execStackPtr = esPtr;
- TclNewLongObj(eePtr->constants[0], 0);
+ TclNewIntObj(eePtr->constants[0], 0);
Tcl_IncrRefCount(eePtr->constants[0]);
- TclNewLongObj(eePtr->constants[1], 1);
+ TclNewIntObj(eePtr->constants[1], 1);
Tcl_IncrRefCount(eePtr->constants[1]);
eePtr->interp = interp;
eePtr->callbackPtr = NULL;
@@ -1875,37 +1805,6 @@ TclIncrObj(
return TCL_ERROR;
}
- if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) {
- long augend = *((const long *) ptr1);
- long addend = *((const long *) ptr2);
- long sum = augend + addend;
-
- /*
- * Overflow when (augend and sum have different sign) and (augend and
- * addend have the same sign). This is encapsulated in the Overflowing
- * macro.
- */
-
- if (!Overflowing(augend, addend, sum)) {
- TclSetLongObj(valuePtr, sum);
- return TCL_OK;
- }
-#ifndef TCL_WIDE_INT_IS_LONG
- {
- Tcl_WideInt w1 = (Tcl_WideInt) augend;
- Tcl_WideInt w2 = (Tcl_WideInt) addend;
-
- /*
- * We know the sum value is outside the long range, so we use the
- * macro form that doesn't range test again.
- */
-
- TclSetWideIntObj(valuePtr, w1 + w2);
- return TCL_OK;
- }
-#endif
- }
-
if ((type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN)) {
/*
* Produce error message (reparse?!)
@@ -1923,7 +1822,6 @@ TclIncrObj(
return TCL_ERROR;
}
-#ifndef TCL_WIDE_INT_IS_LONG
if ((type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) {
Tcl_WideInt w1, w2, sum;
@@ -1936,11 +1834,10 @@ TclIncrObj(
*/
if (!Overflowing(w1, w2, sum)) {
- Tcl_SetWideIntObj(valuePtr, sum);
+ TclSetIntObj(valuePtr, sum);
return TCL_OK;
}
}
-#endif
Tcl_TakeBignumFromObj(interp, valuePtr, &value);
Tcl_GetBignumFromObj(interp, incrPtr, &incr);
@@ -2682,9 +2579,9 @@ TEBCresume(
case INST_STR_CONCAT1:
opnd = TclGetUInt1AtPtr(pc+1);
-
- if (TCL_OK != TclStringCatObjv(interp, /* inPlace */ 1,
- opnd, &OBJ_AT_DEPTH(opnd-1), &objResultPtr)) {
+ objResultPtr = TclStringCat(interp, opnd, &OBJ_AT_DEPTH(opnd-1),
+ TCL_STRING_IN_PLACE);
+ if (objResultPtr == NULL) {
TRACE_ERROR(interp);
goto gotError;
}
@@ -3624,9 +3521,7 @@ TEBCresume(
{
Tcl_Obj *incrPtr;
-#ifndef TCL_WIDE_INT_IS_LONG
Tcl_WideInt w;
-#endif
long increment;
case INST_INCR_SCALAR1:
@@ -3725,9 +3620,9 @@ TEBCresume(
objPtr = varPtr->value.objPtr;
if (GetNumberFromObj(NULL, objPtr, &ptr, &type) == TCL_OK) {
- if (type == TCL_NUMBER_LONG) {
- long augend = *((const long *)ptr);
- long sum = augend + increment;
+ if (type == TCL_NUMBER_WIDE) {
+ Tcl_WideInt augend = *((const Tcl_WideInt *)ptr);
+ Tcl_WideInt sum = augend + increment;
/*
* Overflow when (augend and sum have different sign) and
@@ -3739,16 +3634,15 @@ TEBCresume(
TRACE(("%u %ld => ", opnd, increment));
if (Tcl_IsShared(objPtr)) {
objPtr->refCount--; /* We know it's shared. */
- TclNewLongObj(objResultPtr, sum);
+ TclNewIntObj(objResultPtr, sum);
Tcl_IncrRefCount(objResultPtr);
varPtr->value.objPtr = objResultPtr;
} else {
objResultPtr = objPtr;
- TclSetLongObj(objPtr, sum);
+ TclSetIntObj(objPtr, sum);
}
goto doneIncr;
}
-#ifndef TCL_WIDE_INT_IS_LONG
w = (Tcl_WideInt)augend;
TRACE(("%u %ld => ", opnd, increment));
@@ -3765,44 +3659,10 @@ TEBCresume(
* use macro form that doesn't range test again.
*/
- TclSetWideIntObj(objPtr, w+increment);
+ TclSetIntObj(objPtr, w+increment);
}
goto doneIncr;
-#endif
- } /* end if (type == TCL_NUMBER_LONG) */
-#ifndef TCL_WIDE_INT_IS_LONG
- if (type == TCL_NUMBER_WIDE) {
- Tcl_WideInt sum;
-
- w = *((const Tcl_WideInt *) ptr);
- sum = w + increment;
-
- /*
- * Check for overflow.
- */
-
- if (!Overflowing(w, increment, sum)) {
- TRACE(("%u %ld => ", opnd, increment));
- if (Tcl_IsShared(objPtr)) {
- objPtr->refCount--; /* We know it's shared. */
- objResultPtr = Tcl_NewWideIntObj(sum);
- Tcl_IncrRefCount(objResultPtr);
- varPtr->value.objPtr = objResultPtr;
- } else {
- objResultPtr = objPtr;
-
- /*
- * We *do not* know the sum value is outside the
- * long range (wide + long can yield long); use
- * the function call that checks range.
- */
-
- Tcl_SetWideIntObj(objPtr, sum);
- }
- goto doneIncr;
- }
- }
-#endif
+ } /* end if (type == TCL_NUMBER_WIDE) */
}
if (Tcl_IsShared(objPtr)) {
objPtr->refCount--; /* We know it's shared */
@@ -3812,7 +3672,7 @@ TEBCresume(
} else {
objResultPtr = objPtr;
}
- TclNewLongObj(incrPtr, increment);
+ TclNewIntObj(incrPtr, increment);
if (TclIncrObj(interp, objResultPtr, incrPtr) != TCL_OK) {
Tcl_DecrRefCount(incrPtr);
TRACE_ERROR(interp);
@@ -3826,7 +3686,7 @@ TEBCresume(
* All other cases, flow through to generic handling.
*/
- TclNewLongObj(incrPtr, increment);
+ TclNewIntObj(incrPtr, increment);
Tcl_IncrRefCount(incrPtr);
doIncrScalar:
@@ -4524,7 +4384,7 @@ TEBCresume(
NEXT_INST_F(1, 0, 1);
}
case INST_INFO_LEVEL_NUM:
- TclNewLongObj(objResultPtr, iPtr->varFramePtr->level);
+ TclNewIntObj(objResultPtr, iPtr->varFramePtr->level);
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(1, 0, 1);
case INST_INFO_LEVEL_ARGS: {
@@ -4893,7 +4753,7 @@ TEBCresume(
TRACE_ERROR(interp);
goto gotError;
}
- TclNewLongObj(objResultPtr, length);
+ TclNewIntObj(objResultPtr, length);
TRACE_APPEND(("%d\n", length));
NEXT_INST_F(1, 1, 1);
@@ -4950,16 +4810,9 @@ TEBCresume(
goto gotError;
}
- /*
- * Select the list item based on the index. Negative operand means
- * end-based indexing.
- */
+ /* Decode end-offset index values. */
- if (opnd < -1) {
- index = opnd+1 + objc;
- } else {
- index = opnd;
- }
+ index = TclIndexDecode(opnd, objc - 1);
pcAdjustment = 5;
lindexFastPath:
@@ -5107,47 +4960,64 @@ TEBCresume(
}
#endif
- /*
- * Adjust the indices for end-based handling.
+ /* Every range of an empty list is an empty list */
+ if (objc == 0) {
+ TRACE_APPEND(("\n"));
+ NEXT_INST_F(9, 0, 0);
+ }
+
+ /* Decode index value operands. */
+
+ /*
+ assert ( toIdx != TCL_INDEX_AFTER);
+ *
+ * Extra safety for legacy bytecodes:
*/
+ if (toIdx == TCL_INDEX_AFTER) {
+ toIdx = TCL_INDEX_END;
+ }
- if (fromIdx < -1) {
- fromIdx += 1+objc;
- if (fromIdx < -1) {
- fromIdx = -1;
- }
- } else if (fromIdx > objc) {
- fromIdx = objc;
+ if ((toIdx == TCL_INDEX_BEFORE) || (fromIdx == TCL_INDEX_AFTER)) {
+ goto emptyList;
}
- if (toIdx < -1) {
- toIdx += 1 + objc;
- if (toIdx < -1) {
- toIdx = -1;
- }
- } else if (toIdx > objc) {
- toIdx = objc;
+ toIdx = TclIndexDecode(toIdx, objc - 1);
+ if (toIdx < 0) {
+ goto emptyList;
+ } else if (toIdx >= objc) {
+ toIdx = objc - 1;
}
+ assert ( toIdx >= 0 && toIdx < objc);
/*
- * Check if we are referring to a valid, non-empty list range, and if
- * so, build the list of elements in that range.
+ assert ( fromIdx != TCL_INDEX_BEFORE );
+ *
+ * Extra safety for legacy bytecodes:
*/
+ if (fromIdx == TCL_INDEX_BEFORE) {
+ fromIdx = TCL_INDEX_START;
+ }
- if (fromIdx<=toIdx && fromIdx<objc && toIdx>=0) {
- if (fromIdx < 0) {
- fromIdx = 0;
- }
- if (toIdx >= objc) {
- toIdx = objc-1;
- }
- if (fromIdx == 0 && toIdx != objc-1 && !Tcl_IsShared(valuePtr)) {
- Tcl_ListObjReplace(interp, valuePtr,
- toIdx + 1, LIST_MAX, 0, NULL);
+ fromIdx = TclIndexDecode(fromIdx, objc - 1);
+ if (fromIdx < 0) {
+ fromIdx = 0;
+ }
+
+ if (fromIdx <= toIdx) {
+ /* Construct the subsquence list */
+ /* unshared optimization */
+ if (Tcl_IsShared(valuePtr)) {
+ objResultPtr = Tcl_NewListObj(toIdx-fromIdx+1, objv+fromIdx);
+ } else {
+ if (toIdx != objc - 1) {
+ Tcl_ListObjReplace(NULL, valuePtr, toIdx + 1, LIST_MAX,
+ 0, NULL);
+ }
+ Tcl_ListObjReplace(NULL, valuePtr, 0, fromIdx, 0, NULL);
TRACE_APPEND(("%.30s\n", O2S(valuePtr)));
NEXT_INST_F(9, 0, 0);
}
- objResultPtr = Tcl_NewListObj(toIdx-fromIdx+1, objv+fromIdx);
} else {
+ emptyList:
TclNewObj(objResultPtr);
}
@@ -5364,7 +5234,7 @@ TEBCresume(
case INST_STR_LEN:
valuePtr = OBJ_AT_TOS;
length = Tcl_GetCharLength(valuePtr);
- TclNewLongObj(objResultPtr, length);
+ TclNewIntObj(objResultPtr, length);
TRACE(("\"%.20s\" => %d\n", O2S(valuePtr), length));
NEXT_INST_F(1, 1, 1);
@@ -5493,31 +5363,58 @@ TEBCresume(
length = Tcl_GetCharLength(valuePtr);
TRACE(("\"%.20s\" %d %d => ", O2S(valuePtr), fromIdx, toIdx));
+ /* Every range of an empty value is an empty value */
+ if (length == 0) {
+ TRACE_APPEND(("\n"));
+ NEXT_INST_F(9, 0, 0);
+ }
+
+ /* Decode index operands. */
+
/*
- * Adjust indices for end-based indexing.
+ assert ( toIdx != TCL_INDEX_BEFORE );
+ assert ( toIdx != TCL_INDEX_AFTER);
+ *
+ * Extra safety for legacy bytecodes:
*/
-
- if (fromIdx < -1) {
- fromIdx += 1 + length;
- if (fromIdx < 0) {
- fromIdx = 0;
- }
- } else if (fromIdx >= length) {
- fromIdx = length;
+ if (toIdx == TCL_INDEX_BEFORE) {
+ goto emptyRange;
}
- if (toIdx < -1) {
- toIdx += 1 + length;
+ if (toIdx == TCL_INDEX_AFTER) {
+ toIdx = TCL_INDEX_END;
+ }
+
+ toIdx = TclIndexDecode(toIdx, length - 1);
+ if (toIdx < 0) {
+ goto emptyRange;
} else if (toIdx >= length) {
toIdx = length - 1;
}
+ assert ( toIdx >= 0 && toIdx < length );
+
/*
- * Check if we can do a sane substring.
+ assert ( fromIdx != TCL_INDEX_BEFORE );
+ assert ( fromIdx != TCL_INDEX_AFTER);
+ *
+ * Extra safety for legacy bytecodes:
*/
+ if (fromIdx == TCL_INDEX_BEFORE) {
+ fromIdx = TCL_INDEX_START;
+ }
+ if (fromIdx == TCL_INDEX_AFTER) {
+ goto emptyRange;
+ }
+
+ fromIdx = TclIndexDecode(fromIdx, length - 1);
+ if (fromIdx < 0) {
+ fromIdx = 0;
+ }
if (fromIdx <= toIdx) {
objResultPtr = Tcl_GetRange(valuePtr, fromIdx, toIdx);
} else {
+ emptyRange:
TclNewObj(objResultPtr);
}
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
@@ -5525,18 +5422,18 @@ TEBCresume(
{
Tcl_UniChar *ustring1, *ustring2, *ustring3, *end, *p;
- int length3;
+ int length3, endIdx;
Tcl_Obj *value3Ptr;
case INST_STR_REPLACE:
value3Ptr = POP_OBJECT();
valuePtr = OBJ_AT_DEPTH(2);
- length = Tcl_GetCharLength(valuePtr) - 1;
+ endIdx = Tcl_GetCharLength(valuePtr) - 1;
TRACE(("\"%.20s\" %s %s \"%.20s\" => ", O2S(valuePtr),
O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(value3Ptr)));
- if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, length,
+ if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, endIdx,
&fromIdx) != TCL_OK
- || TclGetIntForIndexM(interp, OBJ_AT_TOS, length,
+ || TclGetIntForIndexM(interp, OBJ_AT_TOS, endIdx,
&toIdx) != TCL_OK) {
TclDecrRefCount(value3Ptr);
TRACE_ERROR(interp);
@@ -5546,103 +5443,33 @@ TEBCresume(
(void) POP_OBJECT();
TclDecrRefCount(OBJ_AT_TOS);
(void) POP_OBJECT();
- if (fromIdx < 0) {
- fromIdx = 0;
- }
- if (fromIdx > toIdx || fromIdx > length) {
+ if ((toIdx < 0) ||
+ (fromIdx > endIdx) ||
+ (toIdx < fromIdx)) {
TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr)));
TclDecrRefCount(value3Ptr);
NEXT_INST_F(1, 0, 0);
}
- if (toIdx > length) {
- toIdx = length;
+ if (fromIdx < 0) {
+ fromIdx = 0;
+ }
+
+ if (toIdx > endIdx) {
+ toIdx = endIdx;
}
- if (fromIdx == 0 && toIdx == length) {
+ if (fromIdx == 0 && toIdx == endIdx) {
TclDecrRefCount(OBJ_AT_TOS);
OBJ_AT_TOS = value3Ptr;
TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr)));
NEXT_INST_F(1, 0, 0);
}
- length3 = Tcl_GetCharLength(value3Ptr);
-
- /*
- * See if we can splice in place. This happens when the number of
- * characters being replaced is the same as the number of characters
- * in the string to be inserted.
- */
-
- if (length3 - 1 == toIdx - fromIdx) {
- unsigned char *bytes1, *bytes2;
-
- if (Tcl_IsShared(valuePtr)) {
- objResultPtr = Tcl_DuplicateObj(valuePtr);
- } else {
- objResultPtr = valuePtr;
- }
- if (TclIsPureByteArray(objResultPtr)
- && TclIsPureByteArray(value3Ptr)) {
- bytes1 = Tcl_GetByteArrayFromObj(objResultPtr, NULL);
- bytes2 = Tcl_GetByteArrayFromObj(value3Ptr, NULL);
- memcpy(bytes1 + fromIdx, bytes2, length3);
- } else {
- ustring1 = Tcl_GetUnicodeFromObj(objResultPtr, NULL);
- ustring2 = Tcl_GetUnicodeFromObj(value3Ptr, NULL);
- memcpy(ustring1 + fromIdx, ustring2,
- length3 * sizeof(Tcl_UniChar));
- }
- Tcl_InvalidateStringRep(objResultPtr);
- TclDecrRefCount(value3Ptr);
- TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
- if (objResultPtr == valuePtr) {
- NEXT_INST_F(1, 0, 0);
- } else {
- NEXT_INST_F(1, 1, 1);
- }
- }
-
- /*
- * Get the unicode representation; this is where we guarantee to lose
- * bytearrays.
- */
-
- ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length);
- length--;
-
- /*
- * Remove substring using copying.
- */
+ objResultPtr = TclStringReplace(interp, valuePtr, fromIdx,
+ toIdx - fromIdx + 1, value3Ptr, TCL_STRING_IN_PLACE);
- objResultPtr = NULL;
- if (fromIdx > 0) {
- objResultPtr = Tcl_NewUnicodeObj(ustring1, fromIdx);
- }
- if (length3 > 0) {
- if (objResultPtr) {
- Tcl_AppendObjToObj(objResultPtr, value3Ptr);
- } else if (Tcl_IsShared(value3Ptr)) {
- objResultPtr = Tcl_DuplicateObj(value3Ptr);
- } else {
- objResultPtr = value3Ptr;
- }
- }
- if (toIdx < length) {
- if (objResultPtr) {
- Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1,
- length - toIdx);
- } else {
- objResultPtr = Tcl_NewUnicodeObj(ustring1 + toIdx + 1,
- length - toIdx);
- }
- }
- if (objResultPtr == NULL) {
- /* This has to be the case [string replace $s 0 end {}] */
- /* which has result {} which is same as value3Ptr. */
- objResultPtr = value3Ptr;
- }
if (objResultPtr == value3Ptr) {
/* See [Bug 82e7f67325] */
TclDecrRefCount(OBJ_AT_TOS);
@@ -5715,11 +5542,11 @@ TEBCresume(
NEXT_INST_V(1, 3, 1);
case INST_STR_FIND:
- match = TclStringFind(OBJ_UNDER_TOS, OBJ_AT_TOS, 0);
+ match = TclStringFirst(OBJ_UNDER_TOS, OBJ_AT_TOS, 0);
TRACE(("%.20s %.20s => %d\n",
O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match));
- TclNewLongObj(objResultPtr, match);
+ TclNewIntObj(objResultPtr, match);
NEXT_INST_F(1, 2, 1);
case INST_STR_FIND_LAST:
@@ -5727,7 +5554,7 @@ TEBCresume(
TRACE(("%.20s %.20s => %d\n",
O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match));
- TclNewLongObj(objResultPtr, match);
+ TclNewIntObj(objResultPtr, match);
NEXT_INST_F(1, 2, 1);
case INST_STR_CLASS:
@@ -5817,12 +5644,7 @@ TEBCresume(
value2Ptr = OBJ_AT_TOS; /* TrimSet */
string2 = TclGetStringFromObj(value2Ptr, &length2);
string1 = TclGetStringFromObj(valuePtr, &length);
- trim1 = TclTrimLeft(string1, length, string2, length2);
- if (trim1 < length) {
- trim2 = TclTrimRight(string1, length, string2, length2);
- } else {
- trim2 = 0;
- }
+ trim1 = TclTrim(string1, length, string2, length2, &trim2);
createTrimmedString:
/*
* Careful here; trim set often contains non-ASCII characters so we
@@ -5900,38 +5722,30 @@ TEBCresume(
{
ClientData ptr1, ptr2;
int type1, type2;
- long l1, l2, lResult;
+ Tcl_WideInt w1, w2, wResult;
case INST_NUM_TYPE:
if (GetNumberFromObj(NULL, OBJ_AT_TOS, &ptr1, &type1) != TCL_OK) {
type1 = 0;
- } else if (type1 == TCL_NUMBER_LONG) {
- /* value is between LONG_MIN and LONG_MAX */
+ } else if (type1 == TCL_NUMBER_WIDE) {
+ /* value is between LLONG_MIN and LLONG_MAX */
/* [string is integer] is -UINT_MAX to UINT_MAX range */
+ /* [string is wideinteger] is -ULLONG_MAX to ULLONG_MAX range */
int i;
- if (Tcl_GetIntFromObj(NULL, OBJ_AT_TOS, &i) != TCL_OK) {
- type1 = TCL_NUMBER_WIDE;
- }
-#ifndef TCL_WIDE_INT_IS_LONG
- } else if (type1 == TCL_NUMBER_WIDE) {
- /* value is between WIDE_MIN and WIDE_MAX */
- /* [string is wideinteger] is -UWIDE_MAX to UWIDE_MAX range */
- int i;
if (Tcl_GetIntFromObj(NULL, OBJ_AT_TOS, &i) == TCL_OK) {
type1 = TCL_NUMBER_LONG;
}
-#endif
} else if (type1 == TCL_NUMBER_BIG) {
- /* value is an integer outside the WIDE_MIN to WIDE_MAX range */
- /* [string is wideinteger] is -UWIDE_MAX to UWIDE_MAX range */
+ /* value is an integer outside the LLONG_MIN to LLONG_MAX range */
+ /* [string is wideinteger] is -ULLONG_MAX to ULLONG_MAX range */
Tcl_WideInt w;
if (Tcl_GetWideIntFromObj(NULL, OBJ_AT_TOS, &w) == TCL_OK) {
type1 = TCL_NUMBER_WIDE;
}
}
- TclNewLongObj(objResultPtr, type1);
+ TclNewIntObj(objResultPtr, type1);
TRACE(("\"%.20s\" => %d\n", O2S(OBJ_AT_TOS), type1));
NEXT_INST_F(1, 1, 1);
@@ -5966,10 +5780,10 @@ TEBCresume(
compare = MP_EQ;
goto convertComparison;
}
- if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) {
- l1 = *((const long *)ptr1);
- l2 = *((const long *)ptr2);
- compare = (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ);
+ if ((type1 == TCL_NUMBER_WIDE) && (type2 == TCL_NUMBER_WIDE)) {
+ w1 = *((const Tcl_WideInt *)ptr1);
+ w2 = *((const Tcl_WideInt *)ptr2);
+ compare = (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ);
} else {
compare = TclCompareTwoNumbers(valuePtr, value2Ptr);
}
@@ -6045,17 +5859,17 @@ TEBCresume(
* Check for common, simple case.
*/
- if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) {
- l1 = *((const long *)ptr1);
- l2 = *((const long *)ptr2);
+ if ((type1 == TCL_NUMBER_WIDE) && (type2 == TCL_NUMBER_WIDE)) {
+ w1 = *((const Tcl_WideInt *)ptr1);
+ w2 = *((const Tcl_WideInt *)ptr2);
switch (*pc) {
case INST_MOD:
- if (l2 == 0) {
+ if (w2 == 0) {
TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr),
O2S(value2Ptr)));
goto divideByZero;
- } else if ((l2 == 1) || (l2 == -1)) {
+ } else if ((w2 == 1) || (w2 == -1)) {
/*
* Div. by |1| always yields remainder of 0.
*/
@@ -6064,7 +5878,7 @@ TEBCresume(
objResultPtr = TCONST(0);
TRACE(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
- } else if (l1 == 0) {
+ } else if (w1 == 0) {
/*
* 0 % (non-zero) always yields remainder of 0.
*/
@@ -6074,24 +5888,24 @@ TEBCresume(
TRACE(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
} else {
- lResult = l1 / l2;
+ wResult = w1 / w2;
/*
* Force Tcl's integer division rules.
* TODO: examine for logic simplification
*/
- if ((lResult < 0 || (lResult == 0 &&
- ((l1 < 0 && l2 > 0) || (l1 > 0 && l2 < 0)))) &&
- (lResult * l2 != l1)) {
- lResult -= 1;
+ if ((wResult < 0 || (wResult == 0 &&
+ ((w1 < 0 && w2 > 0) || (w1 > 0 && w2 < 0)))) &&
+ (wResult * w2 != w1)) {
+ wResult -= 1;
}
- lResult = l1 - l2*lResult;
- goto longResultOfArithmetic;
+ wResult = w1 - w2*wResult;
+ goto wideResultOfArithmetic;
}
case INST_RSHIFT:
- if (l2 < 0) {
+ if (w2 < 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"negative shift argument", -1));
#ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR
@@ -6102,7 +5916,7 @@ TEBCresume(
CACHE_STACK_INFO();
#endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */
goto gotError;
- } else if (l1 == 0) {
+ } else if (w1 == 0) {
TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
objResultPtr = TCONST(0);
TRACE(("%s\n", O2S(objResultPtr)));
@@ -6112,7 +5926,7 @@ TEBCresume(
* Quickly force large right shifts to 0 or -1.
*/
- if (l2 >= (long)(CHAR_BIT*sizeof(long))) {
+ if (w2 >= (Tcl_WideInt)(CHAR_BIT*sizeof(long))) {
/*
* We assume that INT_MAX is much larger than the
* number of bits in a long. This is a pretty safe
@@ -6121,10 +5935,10 @@ TEBCresume(
*/
TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- if (l1 > 0L) {
+ if (w1 > 0L) {
objResultPtr = TCONST(0);
} else {
- TclNewLongObj(objResultPtr, -1);
+ TclNewIntObj(objResultPtr, -1);
}
TRACE(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
@@ -6134,12 +5948,12 @@ TEBCresume(
* Handle shifts within the native long range.
*/
- lResult = l1 >> ((int) l2);
- goto longResultOfArithmetic;
+ wResult = w1 >> ((int) w2);
+ goto wideResultOfArithmetic;
}
case INST_LSHIFT:
- if (l2 < 0) {
+ if (w2 < 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"negative shift argument", -1));
#ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR
@@ -6150,12 +5964,12 @@ TEBCresume(
CACHE_STACK_INFO();
#endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */
goto gotError;
- } else if (l1 == 0) {
+ } else if (w1 == 0) {
TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
objResultPtr = TCONST(0);
TRACE(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
- } else if (l2 > (long) INT_MAX) {
+ } else if (w2 > INT_MAX) {
/*
* Technically, we could hold the value (1 << (INT_MAX+1))
* in an mp_int, but since we're using mp_mul_2d() to do
@@ -6173,17 +5987,17 @@ TEBCresume(
#endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */
goto gotError;
} else {
- int shift = (int) l2;
+ int shift = (int) w2;
/*
* Handle shifts within the native long range.
*/
- if ((size_t) shift < CHAR_BIT*sizeof(long) && (l1 != 0)
- && !((l1>0 ? l1 : ~l1) &
+ if ((size_t) shift < CHAR_BIT*sizeof(long) && (w1 != 0)
+ && !((w1>0 ? w1 : ~w1) &
-(1L<<(CHAR_BIT*sizeof(long) - 1 - shift)))) {
- lResult = l1 << shift;
- goto longResultOfArithmetic;
+ wResult = w1 << shift;
+ goto wideResultOfArithmetic;
}
}
@@ -6195,23 +6009,14 @@ TEBCresume(
break;
case INST_BITAND:
- lResult = l1 & l2;
- goto longResultOfArithmetic;
+ wResult = w1 & w2;
+ goto wideResultOfArithmetic;
case INST_BITOR:
- lResult = l1 | l2;
- goto longResultOfArithmetic;
+ wResult = w1 | w2;
+ goto wideResultOfArithmetic;
case INST_BITXOR:
- lResult = l1 ^ l2;
- longResultOfArithmetic:
- TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
- if (Tcl_IsShared(valuePtr)) {
- TclNewLongObj(objResultPtr, lResult);
- TRACE(("%s\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
- }
- TclSetLongObj(valuePtr, lResult);
- TRACE(("%s\n", O2S(valuePtr)));
- NEXT_INST_F(1, 1, 0);
+ wResult = w1 ^ w2;
+ goto wideResultOfArithmetic;
}
}
@@ -6294,18 +6099,13 @@ TEBCresume(
* an external function.
*/
- if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) {
- Tcl_WideInt w1, w2, wResult;
-
- l1 = *((const long *)ptr1);
- l2 = *((const long *)ptr2);
+ if ((type1 == TCL_NUMBER_WIDE) && (type2 == TCL_NUMBER_WIDE)) {
+ w1 = *((const Tcl_WideInt *)ptr1);
+ w2 = *((const Tcl_WideInt *)ptr2);
switch (*pc) {
case INST_ADD:
- w1 = (Tcl_WideInt) l1;
- w2 = (Tcl_WideInt) l2;
wResult = w1 + w2;
-#ifdef TCL_WIDE_INT_IS_LONG
/*
* Check for overflow.
*/
@@ -6313,14 +6113,10 @@ TEBCresume(
if (Overflowing(w1, w2, wResult)) {
goto overflow;
}
-#endif
goto wideResultOfArithmetic;
case INST_SUB:
- w1 = (Tcl_WideInt) l1;
- w2 = (Tcl_WideInt) l2;
wResult = w1 - w2;
-#ifdef TCL_WIDE_INT_IS_LONG
/*
* Must check for overflow. The macro tests for overflows in
* sums by looking at the sign bits. As we have a subtraction
@@ -6334,7 +6130,6 @@ TEBCresume(
if (Overflowing(w1, ~w2, wResult)) {
goto overflow;
}
-#endif
wideResultOfArithmetic:
TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
if (Tcl_IsShared(valuePtr)) {
@@ -6342,45 +6137,45 @@ TEBCresume(
TRACE(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
}
- Tcl_SetWideIntObj(valuePtr, wResult);
+ TclSetIntObj(valuePtr, wResult);
TRACE(("%s\n", O2S(valuePtr)));
NEXT_INST_F(1, 1, 0);
case INST_DIV:
- if (l2 == 0) {
+ if (w2 == 0) {
TRACE(("%s %s => DIVIDE BY ZERO\n",
O2S(valuePtr), O2S(value2Ptr)));
goto divideByZero;
- } else if ((l1 == LONG_MIN) && (l2 == -1)) {
+ } else if ((w1 == LLONG_MIN) && (w2 == -1)) {
/*
- * Can't represent (-LONG_MIN) as a long.
+ * Can't represent (-LLONG_MIN) as a Tcl_WideInt.
*/
goto overflow;
}
- lResult = l1 / l2;
+ wResult = w1 / w2;
/*
* Force Tcl's integer division rules.
* TODO: examine for logic simplification
*/
- if (((lResult < 0) || ((lResult == 0) &&
- ((l1 < 0 && l2 > 0) || (l1 > 0 && l2 < 0)))) &&
- ((lResult * l2) != l1)) {
- lResult -= 1;
+ if (((wResult < 0) || ((wResult == 0) &&
+ ((w1 < 0 && w2 > 0) || (w1 > 0 && w2 < 0)))) &&
+ ((wResult * w2) != w1)) {
+ wResult -= 1;
}
- goto longResultOfArithmetic;
+ goto wideResultOfArithmetic;
case INST_MULT:
- if (((sizeof(long) >= 2*sizeof(int))
- && (l1 <= INT_MAX) && (l1 >= INT_MIN)
- && (l2 <= INT_MAX) && (l2 >= INT_MIN))
- || ((sizeof(long) >= 2*sizeof(short))
- && (l1 <= SHRT_MAX) && (l1 >= SHRT_MIN)
- && (l2 <= SHRT_MAX) && (l2 >= SHRT_MIN))) {
- lResult = l1 * l2;
- goto longResultOfArithmetic;
+ if (((sizeof(Tcl_WideInt) >= 2*sizeof(int))
+ && (w1 <= INT_MAX) && (w1 >= INT_MIN)
+ && (w2 <= INT_MAX) && (w2 >= INT_MIN))
+ || ((sizeof(Tcl_WideInt) >= 2*sizeof(short))
+ && (w1 <= SHRT_MAX) && (w1 >= SHRT_MIN)
+ && (w2 <= SHRT_MAX) && (w2 >= SHRT_MIN))) {
+ wResult = w1 * w2;
+ goto wideResultOfArithmetic;
}
}
@@ -6447,14 +6242,14 @@ TEBCresume(
CACHE_STACK_INFO();
goto gotError;
}
- if (type1 == TCL_NUMBER_LONG) {
- l1 = *((const long *) ptr1);
+ if (type1 == TCL_NUMBER_WIDE) {
+ w1 = *((const Tcl_WideInt *) ptr1);
if (Tcl_IsShared(valuePtr)) {
- TclNewLongObj(objResultPtr, ~l1);
+ TclNewIntObj(objResultPtr, ~w1);
TRACE_APPEND(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 1, 1);
}
- TclSetLongObj(valuePtr, ~l1);
+ TclSetIntObj(valuePtr, ~w1);
TRACE_APPEND(("%s\n", O2S(valuePtr)));
NEXT_INST_F(1, 0, 0);
}
@@ -6484,15 +6279,15 @@ TEBCresume(
/* -NaN => NaN */
TRACE_APPEND(("%s\n", O2S(valuePtr)));
NEXT_INST_F(1, 0, 0);
- case TCL_NUMBER_LONG:
- l1 = *((const long *) ptr1);
- if (l1 != LONG_MIN) {
+ case TCL_NUMBER_WIDE:
+ w1 = *((const Tcl_WideInt *) ptr1);
+ if (w1 != LLONG_MIN) {
if (Tcl_IsShared(valuePtr)) {
- TclNewLongObj(objResultPtr, -l1);
+ TclNewIntObj(objResultPtr, -w1);
TRACE_APPEND(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 1, 1);
}
- TclSetLongObj(valuePtr, -l1);
+ TclSetIntObj(valuePtr, -w1);
TRACE_APPEND(("%s\n", O2S(valuePtr)));
NEXT_INST_F(1, 0, 0);
}
@@ -6636,7 +6431,8 @@ TEBCresume(
Var *iterVarPtr, *listVarPtr;
Tcl_Obj *oldValuePtr, *listPtr, **elements;
ForeachVarList *varListPtr;
- int numLists, iterNum, listTmpIndex, listLen, numVars;
+ int numLists, listTmpIndex, listLen, numVars;
+ size_t iterNum;
int varIndex, valIndex, continueLoop, j, iterTmpIndex;
long i;
@@ -6653,10 +6449,10 @@ TEBCresume(
oldValuePtr = iterVarPtr->value.objPtr;
if (oldValuePtr == NULL) {
- TclNewLongObj(iterVarPtr->value.objPtr, -1);
+ TclNewIntObj(iterVarPtr->value.objPtr, -1);
Tcl_IncrRefCount(iterVarPtr->value.objPtr);
} else {
- TclSetLongObj(oldValuePtr, -1);
+ TclSetIntObj(oldValuePtr, -1);
}
TRACE(("%u => loop iter count temp %d\n", opnd, iterTmpIndex));
@@ -6690,8 +6486,8 @@ TEBCresume(
iterVarPtr = LOCAL(infoPtr->loopCtTemp);
valuePtr = iterVarPtr->value.objPtr;
- iterNum = valuePtr->internalRep.longValue + 1;
- TclSetLongObj(valuePtr, iterNum);
+ iterNum = (size_t)valuePtr->internalRep.wideValue + 1;
+ TclSetIntObj(valuePtr, iterNum);
/*
* Check whether all value lists are exhausted and we should stop the
@@ -6711,7 +6507,7 @@ TEBCresume(
i, O2S(listPtr), O2S(Tcl_GetObjResult(interp))));
goto gotError;
}
- if (listLen > iterNum * numVars) {
+ if ((size_t)listLen > iterNum * numVars) {
continueLoop = 1;
}
listTmpIndex++;
@@ -6777,7 +6573,7 @@ TEBCresume(
listTmpIndex++;
}
}
- TRACE_APPEND(("%d lists, iter %d, %s loop\n",
+ TRACE_APPEND(("%d lists, iter %" TCL_Z_MODIFIER "d, %s loop\n",
numLists, iterNum, (continueLoop? "continue" : "exit")));
/*
@@ -6798,8 +6594,9 @@ TEBCresume(
ForeachInfo *infoPtr;
Tcl_Obj *listPtr, **elements, *tmpPtr;
ForeachVarList *varListPtr;
- int numLists, iterMax, listLen, numVars;
- int iterTmp, iterNum, listTmpDepth;
+ int numLists, listLen, numVars;
+ int listTmpDepth;
+ size_t iterNum, iterMax, iterTmp;
int varIndex, valIndex, j;
long i;
@@ -6850,8 +6647,8 @@ TEBCresume(
*/
TclNewObj(tmpPtr);
- tmpPtr->internalRep.twoPtrValue.ptr1 = INT2PTR(0);
- tmpPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(iterMax);
+ tmpPtr->internalRep.twoPtrValue.ptr1 = NULL;
+ tmpPtr->internalRep.twoPtrValue.ptr2 = (void *)iterMax;
PUSH_OBJECT(tmpPtr); /* iterCounts object */
/*
@@ -6883,8 +6680,8 @@ TEBCresume(
TRACE(("=> "));
tmpPtr = OBJ_AT_DEPTH(1);
- iterNum = PTR2INT(tmpPtr->internalRep.twoPtrValue.ptr1);
- iterMax = PTR2INT(tmpPtr->internalRep.twoPtrValue.ptr2);
+ iterNum = (size_t)tmpPtr->internalRep.twoPtrValue.ptr1;
+ iterMax = (size_t)tmpPtr->internalRep.twoPtrValue.ptr2;
/*
* If some list still has a remaining list element iterate one more
@@ -6896,7 +6693,7 @@ TEBCresume(
* Set the variables and jump back to run the body
*/
- tmpPtr->internalRep.twoPtrValue.ptr1 = INT2PTR(iterNum + 1);
+ tmpPtr->internalRep.twoPtrValue.ptr1 =(void *)(iterNum + 1);
listTmpDepth = numLists + 1;
@@ -7024,7 +6821,7 @@ TEBCresume(
NEXT_INST_F(1, 0, -1);
case INST_PUSH_RETURN_CODE:
- TclNewLongObj(objResultPtr, result);
+ TclNewIntObj(objResultPtr, result);
TRACE(("=> %u\n", result));
NEXT_INST_F(1, 0, 1);
@@ -7690,7 +7487,6 @@ TEBCresume(
default:
Tcl_Panic("clockRead instruction with unknown clock#");
}
- /* TclNewWideObj(objResultPtr, wval); doesn't exist */
objResultPtr = Tcl_NewWideIntObj(wval);
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(2, 0, 1);
@@ -8122,19 +7918,11 @@ ExecuteExtendedBinaryMathOp(
Tcl_Obj *valuePtr, /* The first operand on the stack. */
Tcl_Obj *value2Ptr) /* The second operand on the stack. */
{
-#define LONG_RESULT(l) \
- if (Tcl_IsShared(valuePtr)) { \
- TclNewLongObj(objResultPtr, l); \
- return objResultPtr; \
- } else { \
- Tcl_SetLongObj(valuePtr, l); \
- return NULL; \
- }
#define WIDE_RESULT(w) \
if (Tcl_IsShared(valuePtr)) { \
return Tcl_NewWideIntObj(w); \
} else { \
- Tcl_SetWideIntObj(valuePtr, w); \
+ TclSetIntObj(valuePtr, w); \
return NULL; \
}
#define BIG_RESULT(b) \
@@ -8156,7 +7944,6 @@ ExecuteExtendedBinaryMathOp(
int type1, type2;
ClientData ptr1, ptr2;
double d1, d2, dResult;
- long l1, l2, lResult;
Tcl_WideInt w1, w2, wResult;
mp_int big1, big2, bigResult, bigRemainder;
Tcl_Obj *objResultPtr;
@@ -8170,13 +7957,13 @@ ExecuteExtendedBinaryMathOp(
case INST_MOD:
/* TODO: Attempts to re-use unshared operands on stack */
- l2 = 0; /* silence gcc warning */
- if (type2 == TCL_NUMBER_LONG) {
- l2 = *((const long *)ptr2);
- if (l2 == 0) {
+ w2 = 0; /* silence gcc warning */
+ if (type2 == TCL_NUMBER_WIDE) {
+ w2 = *((const Tcl_WideInt *)ptr2);
+ if (w2 == 0) {
return DIVIDED_BY_ZERO;
}
- if ((l2 == 1) || (l2 == -1)) {
+ if ((w2 == 1) || (w2 == -1)) {
/*
* Div. by |1| always yields remainder of 0.
*/
@@ -8184,9 +7971,16 @@ ExecuteExtendedBinaryMathOp(
return constants[0];
}
}
-#ifndef TCL_WIDE_INT_IS_LONG
if (type1 == TCL_NUMBER_WIDE) {
w1 = *((const Tcl_WideInt *)ptr1);
+
+ if (w1 == 0) {
+ /*
+ * 0 % (non-zero) always yields remainder of 0.
+ */
+
+ return constants[0];
+ }
if (type2 != TCL_NUMBER_BIG) {
Tcl_WideInt wQuotient, wRemainder;
Tcl_GetWideIntFromObj(NULL, value2Ptr, &w2);
@@ -8229,7 +8023,6 @@ ExecuteExtendedBinaryMathOp(
mp_clear(&big2);
return NULL;
}
-#endif
Tcl_GetBignumFromObj(NULL, valuePtr, &big1);
Tcl_GetBignumFromObj(NULL, value2Ptr, &big2);
mp_init(&bigResult);
@@ -8256,17 +8049,12 @@ ExecuteExtendedBinaryMathOp(
*/
switch (type2) {
- case TCL_NUMBER_LONG:
- invalid = (*((const long *)ptr2) < 0L);
- break;
-#ifndef TCL_WIDE_INT_IS_LONG
case TCL_NUMBER_WIDE:
invalid = (*((const Tcl_WideInt *)ptr2) < (Tcl_WideInt)0);
break;
-#endif
case TCL_NUMBER_BIG:
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
- invalid = (mp_cmp_d(&big2, 0) == MP_LT);
+ invalid = mp_isneg(&big2);
mp_clear(&big2);
break;
default:
@@ -8283,7 +8071,7 @@ ExecuteExtendedBinaryMathOp(
* Zero shifted any number of bits is still zero.
*/
- if ((type1==TCL_NUMBER_LONG) && (*((const long *)ptr1) == (long)0)) {
+ if ((type1==TCL_NUMBER_WIDE) && (*((const Tcl_WideInt *)ptr1) == (Tcl_WideInt)0)) {
return constants[0];
}
@@ -8296,8 +8084,8 @@ ExecuteExtendedBinaryMathOp(
* counterparts, leading to incorrect results.
*/
- if ((type2 != TCL_NUMBER_LONG)
- || (*((const long *)ptr2) > (long) INT_MAX)) {
+ if ((type2 != TCL_NUMBER_WIDE)
+ || (*((const Tcl_WideInt *)ptr2) > INT_MAX)) {
/*
* Technically, we could hold the value (1 << (INT_MAX+1)) in
* an mp_int, but since we're using mp_mul_2d() to do the
@@ -8309,7 +8097,7 @@ ExecuteExtendedBinaryMathOp(
"integer value too large to represent", -1));
return GENERAL_ARITHMETIC_ERROR;
}
- shift = (int)(*((const long *)ptr2));
+ shift = (int)(*((const Tcl_WideInt *)ptr2));
/*
* Handle shifts within the native wide range.
@@ -8329,8 +8117,8 @@ ExecuteExtendedBinaryMathOp(
* Quickly force large right shifts to 0 or -1.
*/
- if ((type2 != TCL_NUMBER_LONG)
- || (*(const long *)ptr2 > INT_MAX)) {
+ if ((type2 != TCL_NUMBER_WIDE)
+ || (*(const Tcl_WideInt *)ptr2 > INT_MAX)) {
/*
* Again, technically, the value to be shifted could be an
* mp_int so huge that a right shift by (INT_MAX+1) bits could
@@ -8340,17 +8128,12 @@ ExecuteExtendedBinaryMathOp(
*/
switch (type1) {
- case TCL_NUMBER_LONG:
- zero = (*(const long *)ptr1 > 0L);
- break;
-#ifndef TCL_WIDE_INT_IS_LONG
case TCL_NUMBER_WIDE:
zero = (*(const Tcl_WideInt *)ptr1 > (Tcl_WideInt)0);
break;
-#endif
case TCL_NUMBER_BIG:
Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
- zero = (mp_cmp_d(&big1, 0) == MP_GT);
+ zero = (!mp_isneg(&big1));
mp_clear(&big1);
break;
default:
@@ -8360,11 +8143,10 @@ ExecuteExtendedBinaryMathOp(
if (zero) {
return constants[0];
}
- LONG_RESULT(-1);
+ WIDE_RESULT(-1);
}
- shift = (int)(*(const long *)ptr2);
+ shift = (int)(*(const Tcl_WideInt *)ptr2);
-#ifndef TCL_WIDE_INT_IS_LONG
/*
* Handle shifts within the native wide range.
*/
@@ -8375,11 +8157,10 @@ ExecuteExtendedBinaryMathOp(
if (w1 >= (Tcl_WideInt)0) {
return constants[0];
}
- LONG_RESULT(-1);
+ WIDE_RESULT(-1);
}
WIDE_RESULT(w1 >> shift);
}
-#endif
}
Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
@@ -8390,7 +8171,7 @@ ExecuteExtendedBinaryMathOp(
} else {
mp_init(&bigRemainder);
mp_div_2d(&big1, shift, &bigResult, &bigRemainder);
- if (mp_cmp_d(&bigRemainder, 0) == MP_LT) {
+ if (mp_isneg(&bigRemainder)) {
/*
* Convert to Tcl's integer division rules.
*/
@@ -8417,14 +8198,14 @@ ExecuteExtendedBinaryMathOp(
* arguments is negative, store it in 'Second'.
*/
- if (mp_cmp_d(&big1, 0) != MP_LT) {
- numPos = 1 + (mp_cmp_d(&big2, 0) != MP_LT);
+ if (!mp_isneg(&big1)) {
+ numPos = 1 + !mp_isneg(&big2);
First = &big1;
Second = &big2;
} else {
First = &big2;
Second = &big1;
- numPos = (mp_cmp_d(First, 0) != MP_LT);
+ numPos = (!mp_isneg(First));
}
mp_init(&bigResult);
@@ -8547,7 +8328,6 @@ ExecuteExtendedBinaryMathOp(
BIG_RESULT(&bigResult);
}
-#ifndef TCL_WIDE_INT_IS_LONG
if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) {
TclGetWideIntFromObj(NULL, valuePtr, &w1);
TclGetWideIntFromObj(NULL, value2Ptr, &w2);
@@ -8568,25 +8348,24 @@ ExecuteExtendedBinaryMathOp(
}
WIDE_RESULT(wResult);
}
-#endif
- l1 = *((const long *)ptr1);
- l2 = *((const long *)ptr2);
+ w1 = *((const Tcl_WideInt *)ptr1);
+ w2 = *((const Tcl_WideInt *)ptr2);
switch (opcode) {
case INST_BITAND:
- lResult = l1 & l2;
+ wResult = w1 & w2;
break;
case INST_BITOR:
- lResult = l1 | l2;
+ wResult = w1 | w2;
break;
case INST_BITXOR:
- lResult = l1 ^ l2;
+ wResult = w1 ^ w2;
break;
default:
/* Unused, here to silence compiler warning. */
- lResult = 0;
+ wResult = 0;
}
- LONG_RESULT(lResult);
+ WIDE_RESULT(wResult);
case INST_EXPON: {
int oddExponent = 0, negativeExponent = 0;
@@ -8602,16 +8381,16 @@ ExecuteExtendedBinaryMathOp(
dResult = pow(d1, d2);
goto doubleResult;
}
- l1 = l2 = 0;
- if (type2 == TCL_NUMBER_LONG) {
- l2 = *((const long *) ptr2);
- if (l2 == 0) {
+ w2 = 0;
+ if (type2 == TCL_NUMBER_WIDE) {
+ w2 = *((const Tcl_WideInt *) ptr2);
+ if (w2 == 0) {
/*
* Anything to the zero power is 1.
*/
return constants[1];
- } else if (l2 == 1) {
+ } else if (w2 == 1) {
/*
* Anything to the first power is itself
*/
@@ -8621,32 +8400,26 @@ ExecuteExtendedBinaryMathOp(
}
switch (type2) {
- case TCL_NUMBER_LONG:
- negativeExponent = (l2 < 0);
- oddExponent = (int) (l2 & 1);
- break;
-#ifndef TCL_WIDE_INT_IS_LONG
case TCL_NUMBER_WIDE:
w2 = *((const Tcl_WideInt *)ptr2);
negativeExponent = (w2 < 0);
oddExponent = (int) (w2 & (Tcl_WideInt)1);
break;
-#endif
case TCL_NUMBER_BIG:
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
- negativeExponent = (mp_cmp_d(&big2, 0) == MP_LT);
+ negativeExponent = mp_isneg(&big2);
mp_mod_2d(&big2, 1, &big2);
oddExponent = !mp_iszero(&big2);
mp_clear(&big2);
break;
}
- if (type1 == TCL_NUMBER_LONG) {
- l1 = *((const long *)ptr1);
+ if (type1 == TCL_NUMBER_WIDE) {
+ w1 = *((const Tcl_WideInt *)ptr1);
}
if (negativeExponent) {
- if (type1 == TCL_NUMBER_LONG) {
- switch (l1) {
+ if (type1 == TCL_NUMBER_WIDE) {
+ switch (w1) {
case 0:
/*
* Zero to a negative power is div by zero error.
@@ -8655,7 +8428,7 @@ ExecuteExtendedBinaryMathOp(
return EXPONENT_OF_ZERO;
case -1:
if (oddExponent) {
- LONG_RESULT(-1);
+ WIDE_RESULT(-1);
}
/* fallthrough */
case 1:
@@ -8675,8 +8448,8 @@ ExecuteExtendedBinaryMathOp(
return constants[0];
}
- if (type1 == TCL_NUMBER_LONG) {
- switch (l1) {
+ if (type1 == TCL_NUMBER_WIDE) {
+ switch (w1) {
case 0:
/*
* Zero to a positive power is zero.
@@ -8693,7 +8466,7 @@ ExecuteExtendedBinaryMathOp(
if (!oddExponent) {
return constants[1];
}
- LONG_RESULT(-1);
+ WIDE_RESULT(-1);
}
}
@@ -8702,141 +8475,58 @@ ExecuteExtendedBinaryMathOp(
* which means the max exponent value is 2**28-1 = 0x0fffffff =
* 268435455, which fits into a signed 32 bit int which is within the
* range of the long int type. This means any numeric Tcl_Obj value
- * not using TCL_NUMBER_LONG type must hold a value larger than we
+ * not using TCL_NUMBER_WIDE type must hold a value larger than we
* accept.
*/
- if (type2 != TCL_NUMBER_LONG) {
+ if (type2 != TCL_NUMBER_WIDE) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"exponent too large", -1));
return GENERAL_ARITHMETIC_ERROR;
}
- if (type1 == TCL_NUMBER_LONG) {
- if (l1 == 2) {
+ if (type1 == TCL_NUMBER_WIDE) {
+ if (w1 == 2) {
/*
* Reduce small powers of 2 to shifts.
*/
- if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) {
- LONG_RESULT(1L << l2);
- }
-#if !defined(TCL_WIDE_INT_IS_LONG)
- if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1) {
- WIDE_RESULT(((Tcl_WideInt) 1) << l2);
+ if ((Tcl_WideUInt) w2 < (Tcl_WideUInt) CHAR_BIT*sizeof(Tcl_WideInt) - 1) {
+ WIDE_RESULT(((Tcl_WideInt) 1) << (int)w2);
}
-#endif
goto overflowExpon;
}
- if (l1 == -2) {
+ if (w1 == -2) {
int signum = oddExponent ? -1 : 1;
/*
* Reduce small powers of 2 to shifts.
*/
- if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) {
- LONG_RESULT(signum * (1L << l2));
- }
-#if !defined(TCL_WIDE_INT_IS_LONG)
- if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1){
- WIDE_RESULT(signum * (((Tcl_WideInt) 1) << l2));
+ if ((Tcl_WideUInt)w2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1){
+ WIDE_RESULT(signum * (((Tcl_WideInt) 1) << (int) w2));
}
-#endif
goto overflowExpon;
}
-#if (LONG_MAX == 0x7fffffff)
- if (l2 - 2 < (long)MaxBase32Size
- && l1 <= MaxBase32[l2 - 2]
- && l1 >= -MaxBase32[l2 - 2]) {
- /*
- * Small powers of 32-bit integers.
- */
-
- lResult = l1 * l1; /* b**2 */
- switch (l2) {
- case 2:
- break;
- case 3:
- lResult *= l1; /* b**3 */
- break;
- case 4:
- lResult *= lResult; /* b**4 */
- break;
- case 5:
- lResult *= lResult; /* b**4 */
- lResult *= l1; /* b**5 */
- break;
- case 6:
- lResult *= l1; /* b**3 */
- lResult *= lResult; /* b**6 */
- break;
- case 7:
- lResult *= l1; /* b**3 */
- lResult *= lResult; /* b**6 */
- lResult *= l1; /* b**7 */
- break;
- case 8:
- lResult *= lResult; /* b**4 */
- lResult *= lResult; /* b**8 */
- break;
- }
- LONG_RESULT(lResult);
- }
-
- if (l1 - 3 >= 0 && l1 -2 < (long)Exp32IndexSize
- && l2 - 2 < (long)(Exp32ValueSize + MaxBase32Size)) {
- base = Exp32Index[l1 - 3]
- + (unsigned short) (l2 - 2 - MaxBase32Size);
- if (base < Exp32Index[l1 - 2]) {
- /*
- * 32-bit number raised to intermediate power, done by
- * table lookup.
- */
-
- LONG_RESULT(Exp32Value[base]);
- }
- }
- if (-l1 - 3 >= 0 && -l1 - 2 < (long)Exp32IndexSize
- && l2 - 2 < (long)(Exp32ValueSize + MaxBase32Size)) {
- base = Exp32Index[-l1 - 3]
- + (unsigned short) (l2 - 2 - MaxBase32Size);
- if (base < Exp32Index[-l1 - 2]) {
- /*
- * 32-bit number raised to intermediate power, done by
- * table lookup.
- */
-
- lResult = (oddExponent) ?
- -Exp32Value[base] : Exp32Value[base];
- LONG_RESULT(lResult);
- }
- }
-#endif
}
-#if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG)
- if (type1 == TCL_NUMBER_LONG) {
- w1 = l1;
-#ifndef TCL_WIDE_INT_IS_LONG
- } else if (type1 == TCL_NUMBER_WIDE) {
+ if (type1 == TCL_NUMBER_WIDE) {
w1 = *((const Tcl_WideInt *) ptr1);
-#endif
} else {
goto overflowExpon;
}
- if (l2 - 2 < (long)MaxBase64Size
- && w1 <= MaxBase64[l2 - 2]
- && w1 >= -MaxBase64[l2 - 2]) {
+ if (w2 - 2 < (long)MaxBase64Size
+ && w1 <= MaxBase64[w2 - 2]
+ && w1 >= -MaxBase64[w2 - 2]) {
/*
* Small powers of integers whose result is wide.
*/
wResult = w1 * w1; /* b**2 */
- switch (l2) {
+ switch (w2) {
case 2:
break;
case 3:
- wResult *= l1; /* b**3 */
+ wResult *= w1; /* b**3 */
break;
case 4:
wResult *= wResult; /* b**4 */
@@ -8913,9 +8603,9 @@ ExecuteExtendedBinaryMathOp(
*/
if (w1 - 3 >= 0 && w1 - 2 < (long)Exp64IndexSize
- && l2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) {
+ && w2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) {
base = Exp64Index[w1 - 3]
- + (unsigned short) (l2 - 2 - MaxBase64Size);
+ + (unsigned short) (w2 - 2 - MaxBase64Size);
if (base < Exp64Index[w1 - 2]) {
/*
* 64-bit number raised to intermediate power, done by
@@ -8927,9 +8617,9 @@ ExecuteExtendedBinaryMathOp(
}
if (-w1 - 3 >= 0 && -w1 - 2 < (long)Exp64IndexSize
- && l2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) {
+ && w2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) {
base = Exp64Index[-w1 - 3]
- + (unsigned short) (l2 - 2 - MaxBase64Size);
+ + (unsigned short) (w2 - 2 - MaxBase64Size);
if (base < Exp64Index[-w1 - 2]) {
/*
* 64-bit number raised to intermediate power, done by
@@ -8940,7 +8630,6 @@ ExecuteExtendedBinaryMathOp(
WIDE_RESULT(wResult);
}
}
-#endif
overflowExpon:
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
@@ -9020,9 +8709,7 @@ ExecuteExtendedBinaryMathOp(
switch (opcode) {
case INST_ADD:
wResult = w1 + w2;
-#ifndef TCL_WIDE_INT_IS_LONG
if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE))
-#endif
{
/*
* Check for overflow.
@@ -9036,9 +8723,7 @@ ExecuteExtendedBinaryMathOp(
case INST_SUB:
wResult = w1 - w2;
-#ifndef TCL_WIDE_INT_IS_LONG
if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE))
-#endif
{
/*
* Must check for overflow. The macro tests for overflows
@@ -9058,8 +8743,7 @@ ExecuteExtendedBinaryMathOp(
break;
case INST_MULT:
- if ((type1 != TCL_NUMBER_LONG) || (type2 != TCL_NUMBER_LONG)
- || (sizeof(Tcl_WideInt) < 2*sizeof(long))) {
+ if ((w1 < INT_MIN) || (w1 > INT_MAX) || (w2 < INT_MIN) || (w2 > INT_MAX)) {
goto overflowBasic;
}
wResult = w1 * w2;
@@ -9162,12 +8846,10 @@ ExecuteExtendedUnaryMathOp(
switch (opcode) {
case INST_BITNOT:
-#ifndef TCL_WIDE_INT_IS_LONG
if (type == TCL_NUMBER_WIDE) {
w = *((const Tcl_WideInt *) ptr);
WIDE_RESULT(~w);
}
-#endif
Tcl_TakeBignumFromObj(NULL, valuePtr, &big);
/* ~a = - a - 1 */
mp_neg(&big, &big);
@@ -9177,14 +8859,6 @@ ExecuteExtendedUnaryMathOp(
switch (type) {
case TCL_NUMBER_DOUBLE:
DOUBLE_RESULT(-(*((const double *) ptr)));
- case TCL_NUMBER_LONG:
- w = (Tcl_WideInt) (*((const long *) ptr));
- if (w != LLONG_MIN) {
- WIDE_RESULT(-w);
- }
- TclInitBignumFromLong(&big, *(const long *) ptr);
- break;
-#ifndef TCL_WIDE_INT_IS_LONG
case TCL_NUMBER_WIDE:
w = *((const Tcl_WideInt *) ptr);
if (w != LLONG_MIN) {
@@ -9192,7 +8866,6 @@ ExecuteExtendedUnaryMathOp(
}
TclInitBignumFromWideInt(&big, w);
break;
-#endif
default:
Tcl_TakeBignumFromObj(NULL, valuePtr, &big);
}
@@ -9203,7 +8876,6 @@ ExecuteExtendedUnaryMathOp(
Tcl_Panic("unexpected opcode");
return NULL;
}
-#undef LONG_RESULT
#undef WIDE_RESULT
#undef BIG_RESULT
#undef DOUBLE_RESULT
@@ -9235,31 +8907,22 @@ TclCompareTwoNumbers(
ClientData ptr1, ptr2;
mp_int big1, big2;
double d1, d2, tmp;
- long l1, l2;
-#ifndef TCL_WIDE_INT_IS_LONG
Tcl_WideInt w1, w2;
-#endif
(void) GetNumberFromObj(NULL, valuePtr, &ptr1, &type1);
(void) GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2);
switch (type1) {
- case TCL_NUMBER_LONG:
- l1 = *((const long *)ptr1);
+ case TCL_NUMBER_WIDE:
+ w1 = *((const Tcl_WideInt *)ptr1);
switch (type2) {
- case TCL_NUMBER_LONG:
- l2 = *((const long *)ptr2);
- longCompare:
- return (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ);
-#ifndef TCL_WIDE_INT_IS_LONG
case TCL_NUMBER_WIDE:
w2 = *((const Tcl_WideInt *)ptr2);
- w1 = (Tcl_WideInt)l1;
- goto wideCompare;
-#endif
+ wideCompare:
+ return (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ);
case TCL_NUMBER_DOUBLE:
d2 = *((const double *)ptr2);
- d1 = (double) l1;
+ d1 = (double) w1;
/*
* If the double has a fractional part, or if the long can be
@@ -9267,7 +8930,7 @@ TclCompareTwoNumbers(
* doubles.
*/
- if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) || l1 == (long) d1
+ if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt) || w1 == (Tcl_WideInt) d1
|| modf(d2, &tmp) != 0.0) {
goto doubleCompare;
}
@@ -9284,44 +8947,6 @@ TclCompareTwoNumbers(
* integer comparison can tell the difference.
*/
- if (d2 < (double)LONG_MIN) {
- return MP_GT;
- }
- if (d2 > (double)LONG_MAX) {
- return MP_LT;
- }
- l2 = (long) d2;
- goto longCompare;
- case TCL_NUMBER_BIG:
- Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
- if (mp_cmp_d(&big2, 0) == MP_LT) {
- compare = MP_GT;
- } else {
- compare = MP_LT;
- }
- mp_clear(&big2);
- return compare;
- }
-
-#ifndef TCL_WIDE_INT_IS_LONG
- case TCL_NUMBER_WIDE:
- w1 = *((const Tcl_WideInt *)ptr1);
- switch (type2) {
- case TCL_NUMBER_WIDE:
- w2 = *((const Tcl_WideInt *)ptr2);
- wideCompare:
- return (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ);
- case TCL_NUMBER_LONG:
- l2 = *((const long *)ptr2);
- w2 = (Tcl_WideInt)l2;
- goto wideCompare;
- case TCL_NUMBER_DOUBLE:
- d2 = *((const double *)ptr2);
- d1 = (double) w1;
- if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt)
- || w1 == (Tcl_WideInt) d1 || modf(d2, &tmp) != 0.0) {
- goto doubleCompare;
- }
if (d2 < (double)LLONG_MIN) {
return MP_GT;
}
@@ -9332,7 +8957,7 @@ TclCompareTwoNumbers(
goto wideCompare;
case TCL_NUMBER_BIG:
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
- if (mp_cmp_d(&big2, 0) == MP_LT) {
+ if (mp_isneg(&big2)) {
compare = MP_GT;
} else {
compare = MP_LT;
@@ -9340,7 +8965,6 @@ TclCompareTwoNumbers(
mp_clear(&big2);
return compare;
}
-#endif
case TCL_NUMBER_DOUBLE:
d1 = *((const double *)ptr1);
@@ -9349,22 +8973,6 @@ TclCompareTwoNumbers(
d2 = *((const double *)ptr2);
doubleCompare:
return (d1 < d2) ? MP_LT : ((d1 > d2) ? MP_GT : MP_EQ);
- case TCL_NUMBER_LONG:
- l2 = *((const long *)ptr2);
- d2 = (double) l2;
- if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) || l2 == (long) d2
- || modf(d1, &tmp) != 0.0) {
- goto doubleCompare;
- }
- if (d1 < (double)LONG_MIN) {
- return MP_LT;
- }
- if (d1 > (double)LONG_MAX) {
- return MP_GT;
- }
- l1 = (long) d1;
- goto longCompare;
-#ifndef TCL_WIDE_INT_IS_LONG
case TCL_NUMBER_WIDE:
w2 = *((const Tcl_WideInt *)ptr2);
d2 = (double) w2;
@@ -9380,14 +8988,13 @@ TclCompareTwoNumbers(
}
w1 = (Tcl_WideInt) d1;
goto wideCompare;
-#endif
case TCL_NUMBER_BIG:
if (TclIsInfinite(d1)) {
return (d1 > 0.0) ? MP_GT : MP_LT;
}
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
- if ((d1 < (double)LONG_MAX) && (d1 > (double)LONG_MIN)) {
- if (mp_cmp_d(&big2, 0) == MP_LT) {
+ if ((d1 < (double)LLONG_MAX) && (d1 > (double)LLONG_MIN)) {
+ if (mp_isneg(&big2)) {
compare = MP_GT;
} else {
compare = MP_LT;
@@ -9408,10 +9015,7 @@ TclCompareTwoNumbers(
case TCL_NUMBER_BIG:
Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
switch (type2) {
-#ifndef TCL_WIDE_INT_IS_LONG
case TCL_NUMBER_WIDE:
-#endif
- case TCL_NUMBER_LONG:
compare = mp_cmp_d(&big1, 0);
mp_clear(&big1);
return compare;
@@ -9422,7 +9026,7 @@ TclCompareTwoNumbers(
mp_clear(&big1);
return compare;
}
- if ((d2 < (double)LONG_MAX) && (d2 > (double)LONG_MIN)) {
+ if ((d2 < (double)LLONG_MAX) && (d2 > (double)LLONG_MIN)) {
compare = mp_cmp_d(&big1, 0);
mp_clear(&big1);
return compare;
@@ -9476,8 +9080,8 @@ PrintByteCodeInfo(
Proc *procPtr = codePtr->procPtr;
Interp *iPtr = (Interp *) *codePtr->interpHandle;
- fprintf(stdout, "\nExecuting ByteCode 0x%p, refCt %" TCL_LL_MODIFIER "u, epoch %u, interp 0x%p (epoch %u)\n",
- codePtr, (Tcl_WideInt)codePtr->refCount, codePtr->compileEpoch, iPtr,
+ fprintf(stdout, "\nExecuting ByteCode 0x%p, refCt %" TCL_Z_MODIFIER "u, epoch %u, interp 0x%p (epoch %u)\n",
+ codePtr, (size_t)codePtr->refCount, codePtr->compileEpoch, iPtr,
iPtr->compileEpoch);
fprintf(stdout, " Source: ");
diff --git a/generic/tclGet.c b/generic/tclGet.c
index 97e8c7b..12e0e79 100644
--- a/generic/tclGet.c
+++ b/generic/tclGet.c
@@ -142,7 +142,7 @@ Tcl_GetBoolean(
Tcl_Panic("invalid sharing of Tcl_Obj on C stack");
}
if (code == TCL_OK) {
- *boolPtr = obj.internalRep.longValue;
+ TclGetBooleanFromObj(NULL, &obj, boolPtr);
}
return code;
}
diff --git a/generic/tclIO.c b/generic/tclIO.c
index 81fd298..ad6c7ee 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -721,17 +721,18 @@ Tcl_SetStdChannel(
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+ int init = channel ? 1 : -1;
switch (type) {
case TCL_STDIN:
- tsdPtr->stdinInitialized = 1;
+ tsdPtr->stdinInitialized = init;
tsdPtr->stdinChannel = channel;
break;
case TCL_STDOUT:
- tsdPtr->stdoutInitialized = 1;
+ tsdPtr->stdoutInitialized = init;
tsdPtr->stdoutChannel = channel;
break;
case TCL_STDERR:
- tsdPtr->stderrInitialized = 1;
+ tsdPtr->stderrInitialized = init;
tsdPtr->stderrChannel = channel;
break;
}
@@ -768,8 +769,8 @@ Tcl_GetStdChannel(
switch (type) {
case TCL_STDIN:
if (!tsdPtr->stdinInitialized) {
+ tsdPtr->stdinInitialized = -1;
tsdPtr->stdinChannel = TclpGetDefaultStdChannel(TCL_STDIN);
- tsdPtr->stdinInitialized = 1;
/*
* Artificially bump the refcount to ensure that the channel is
@@ -781,6 +782,7 @@ Tcl_GetStdChannel(
*/
if (tsdPtr->stdinChannel != NULL) {
+ tsdPtr->stdinInitialized = 1;
Tcl_RegisterChannel(NULL, tsdPtr->stdinChannel);
}
}
@@ -788,9 +790,10 @@ Tcl_GetStdChannel(
break;
case TCL_STDOUT:
if (!tsdPtr->stdoutInitialized) {
+ tsdPtr->stdoutInitialized = -1;
tsdPtr->stdoutChannel = TclpGetDefaultStdChannel(TCL_STDOUT);
- tsdPtr->stdoutInitialized = 1;
if (tsdPtr->stdoutChannel != NULL) {
+ tsdPtr->stdoutInitialized = 1;
Tcl_RegisterChannel(NULL, tsdPtr->stdoutChannel);
}
}
@@ -798,9 +801,10 @@ Tcl_GetStdChannel(
break;
case TCL_STDERR:
if (!tsdPtr->stderrInitialized) {
+ tsdPtr->stderrInitialized = -1;
tsdPtr->stderrChannel = TclpGetDefaultStdChannel(TCL_STDERR);
- tsdPtr->stderrInitialized = 1;
if (tsdPtr->stderrChannel != NULL) {
+ tsdPtr->stderrInitialized = 1;
Tcl_RegisterChannel(NULL, tsdPtr->stderrChannel);
}
}
@@ -1068,7 +1072,7 @@ CheckForStdChannelsBeingClosed(
ChannelState *statePtr = ((Channel *) chan)->state;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
- if (tsdPtr->stdinInitialized
+ if (tsdPtr->stdinInitialized == 1
&& tsdPtr->stdinChannel != NULL
&& statePtr == ((Channel *)tsdPtr->stdinChannel)->state) {
if (statePtr->refCount < 2) {
@@ -1076,7 +1080,7 @@ CheckForStdChannelsBeingClosed(
tsdPtr->stdinChannel = NULL;
return;
}
- } else if (tsdPtr->stdoutInitialized
+ } else if (tsdPtr->stdoutInitialized == 1
&& tsdPtr->stdoutChannel != NULL
&& statePtr == ((Channel *)tsdPtr->stdoutChannel)->state) {
if (statePtr->refCount < 2) {
@@ -1084,7 +1088,7 @@ CheckForStdChannelsBeingClosed(
tsdPtr->stdoutChannel = NULL;
return;
}
- } else if (tsdPtr->stderrInitialized
+ } else if (tsdPtr->stderrInitialized == 1
&& tsdPtr->stderrChannel != NULL
&& statePtr == ((Channel *)tsdPtr->stderrChannel)->state) {
if (statePtr->refCount < 2) {
diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c
index 6e8bd09..87bf415 100644
--- a/generic/tclIOCmd.c
+++ b/generic/tclIOCmd.c
@@ -137,7 +137,7 @@ Tcl_PutsObjCmd(
chanObjPtr = objv[2];
string = objv[3];
break;
-#if TCL_MAJOR_VERSION < 9
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
} else if (strcmp(TclGetString(objv[3]), "nonewline") == 0) {
/*
* The code below provides backwards compatibility with an old
@@ -439,7 +439,7 @@ Tcl_ReadObjCmd(
if (i < objc) {
if ((TclGetIntFromObj(interp, objv[i], &toRead) != TCL_OK)
|| (toRead < 0)) {
-#if TCL_MAJOR_VERSION < 9
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
/*
* The code below provides backwards compatibility with an old
* form of the command that is no longer recommended or
@@ -454,7 +454,7 @@ Tcl_ReadObjCmd(
TclGetString(objv[i])));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL);
return TCL_ERROR;
-#if TCL_MAJOR_VERSION < 9
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
}
newline = 1;
#endif
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index 8fb3aa8..144bab0 100644
--- a/generic/tclIOUtil.c
+++ b/generic/tclIOUtil.c
@@ -830,15 +830,6 @@ TclResetFilesystem(void)
if (++theFilesystemEpoch == 0) {
++theFilesystemEpoch;
}
-
-#ifdef _WIN32
- /*
- * Cleans up the win32 API filesystem proc lookup table. This must happen
- * very late in finalization so that deleting of copied dlls can occur.
- */
-
- TclWinResetInterfaces();
-#endif
}
/*
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index 175ea9c..b38dabd 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -114,7 +114,7 @@ declare 23 {
}
# Replaced with macro (see tclInt.h) in Tcl 8.5.0, restored in 8.5.10
declare 24 {
- int TclFormatInt(char *buffer, long n)
+ int TclFormatInt(char *buffer, Tcl_WideInt n)
}
declare 25 {
void TclFreePackageInfo(Interp *iPtr)
@@ -187,7 +187,7 @@ declare 42 {
}
# Removed in 8.5a2:
#declare 43 {
-# int TclGlobalInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv,
+# int TclGlobalInvoke(Tcl_Interp *interp, int argc, const char **argv,
# int flags)
#}
declare 44 {
@@ -222,12 +222,12 @@ declare 51 {
}
# Removed in 8.5a2:
#declare 52 {
-# int TclInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv,
+# int TclInvoke(Tcl_Interp *interp, int argc, const char **argv,
# int flags)
#}
declare 53 {
int TclInvokeObjectCommand(ClientData clientData, Tcl_Interp *interp,
- int argc, CONST84 char **argv)
+ int argc, const char **argv)
}
declare 54 {
int TclInvokeStringCommand(ClientData clientData, Tcl_Interp *interp,
@@ -548,7 +548,7 @@ declare 133 {deprecated {}} {
# int TclpChdir(const char *dirName)
#}
declare 138 {
- CONST84_RETURN char *TclGetEnv(const char *name, Tcl_DString *valuePtr)
+ const char *TclGetEnv(const char *name, Tcl_DString *valuePtr)
}
#declare 139 {
# int TclpLoadFile(Tcl_Interp *interp, char *fileName, char *sym1,
@@ -560,7 +560,7 @@ declare 138 {
#}
# This is used by TclX, but should otherwise be considered private
declare 141 {
- CONST84_RETURN char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr)
+ const char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr)
}
declare 142 {
int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr,
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 1cca27e..89fe770 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -160,13 +160,13 @@ typedef struct Tcl_ResolvedVarInfo {
} Tcl_ResolvedVarInfo;
typedef int (Tcl_ResolveCompiledVarProc)(Tcl_Interp *interp,
- CONST84 char *name, int length, Tcl_Namespace *context,
+ const char *name, int length, Tcl_Namespace *context,
Tcl_ResolvedVarInfo **rPtr);
-typedef int (Tcl_ResolveVarProc)(Tcl_Interp *interp, CONST84 char *name,
+typedef int (Tcl_ResolveVarProc)(Tcl_Interp *interp, const char *name,
Tcl_Namespace *context, int flags, Tcl_Var *rPtr);
-typedef int (Tcl_ResolveCmdProc)(Tcl_Interp *interp, CONST84 char *name,
+typedef int (Tcl_ResolveCmdProc)(Tcl_Interp *interp, const char *name,
Tcl_Namespace *context, int flags, Tcl_Command *rPtr);
typedef struct Tcl_ResolverInfo {
@@ -426,7 +426,7 @@ struct NamespacePathEntry {
*/
typedef struct EnsembleConfig {
- Namespace *nsPtr; /* The namspace backing this ensemble up. */
+ Namespace *nsPtr; /* The namespace backing this ensemble up. */
Tcl_Command token; /* The token for the command that provides
* ensemble support for the namespace, or NULL
* if the command has been deleted (or never
@@ -1826,7 +1826,7 @@ typedef struct Interp {
* unused space in interp was repurposed for
* pluggable bytecode optimizers. The core
* contains one optimizer, which can be
- * selectively overriden by extensions. */
+ * selectively overridden by extensions. */
} extra;
/*
@@ -1862,7 +1862,7 @@ typedef struct Interp {
* See Tcl_AppendResult code for details.
*/
-#ifndef TCL_NO_DEPRECATED
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
char *appendResult; /* Storage space for results generated by
* Tcl_AppendResult. Ckalloc-ed. NULL means
* not yet allocated. */
@@ -1936,11 +1936,13 @@ typedef struct Interp {
* string. Returned by Tcl_ObjSetVar2 when
* variable traces change a variable in a
* gross way. */
-#ifndef TCL_NO_DEPRECATED
- char resultSpace[TCL_RESULT_SIZE+1];
+#if TCL_MAJOR_VERSION < 9
+# if !defined(TCL_NO_DEPRECATED)
+ char resultSpace[TCL_DSTRING_STATIC_SIZE+1];
/* Static space holding small results. */
-#else
- char resultSpaceDontUse[TCL_RESULT_SIZE+1];
+# else
+ char resultSpaceDontUse[TCL_DSTRING_STATIC_SIZE+1];
+# endif
#endif
Tcl_Obj *objResultPtr; /* If the last command returned an object
* result, this points to it. Should not be
@@ -2251,7 +2253,7 @@ typedef struct Interp {
* use the rand() or srand() functions.
* SAFE_INTERP: Non zero means that the current interp is a safe
* interp (i.e. it has only the safe commands installed,
- * less priviledge than a regular interp).
+ * less privilege than a regular interp).
* INTERP_DEBUG_FRAME: Used for switching on various extra interpreter
* debug/info mechanisms (e.g. info frame eval/uplevel
* tracing) which are performance intensive.
@@ -2392,7 +2394,7 @@ typedef struct List {
* be ignored if there is no string rep at
* all.*/
Tcl_Obj *elements; /* First list element; the struct is grown to
- * accomodate all elements. */
+ * accommodate all elements. */
} List;
#define LIST_MAX \
@@ -2445,40 +2447,46 @@ typedef struct List {
#define TCL_EACH_COLLECT 1 /* Collect iteration result like [lmap] */
/*
- * Macros providing a faster path to integers: Tcl_GetLongFromObj,
- * Tcl_GetIntFromObj and TclGetIntForIndex.
+ * Macros providing a faster path to booleans and integers:
+ * Tcl_GetBooleanFromObj, Tcl_GetLongFromObj, Tcl_GetIntFromObj
+ * and TclGetIntForIndex.
*
* WARNING: these macros eval their args more than once.
*/
+#define TclGetBooleanFromObj(interp, objPtr, boolPtr) \
+ (((objPtr)->typePtr == &tclIntType) \
+ ? (*(boolPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK) \
+ : ((objPtr)->typePtr == &tclBooleanType) \
+ ? (*(boolPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \
+ : Tcl_GetBooleanFromObj((interp), (objPtr), (boolPtr)))
+
+#ifdef TCL_WIDE_INT_IS_LONG
#define TclGetLongFromObj(interp, objPtr, longPtr) \
(((objPtr)->typePtr == &tclIntType) \
- ? ((*(longPtr) = (objPtr)->internalRep.longValue), TCL_OK) \
+ ? ((*(longPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \
: Tcl_GetLongFromObj((interp), (objPtr), (longPtr)))
-
-#if (LONG_MAX == INT_MAX)
-#define TclGetIntFromObj(interp, objPtr, intPtr) \
- (((objPtr)->typePtr == &tclIntType) \
- ? ((*(intPtr) = (objPtr)->internalRep.longValue), TCL_OK) \
- : Tcl_GetIntFromObj((interp), (objPtr), (intPtr)))
-#define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \
- (((objPtr)->typePtr == &tclIntType) \
- ? ((*(idxPtr) = (objPtr)->internalRep.longValue), TCL_OK) \
- : TclGetIntForIndex((interp), (objPtr), (endValue), (idxPtr)))
#else
+#define TclGetLongFromObj(interp, objPtr, longPtr) \
+ (((objPtr)->typePtr == &tclIntType \
+ && (objPtr)->internalRep.wideValue >= -(Tcl_WideInt)(ULONG_MAX) \
+ && (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(ULONG_MAX)) \
+ ? ((*(longPtr) = (long)(objPtr)->internalRep.wideValue), TCL_OK) \
+ : Tcl_GetLongFromObj((interp), (objPtr), (longPtr)))
+#endif
+
#define TclGetIntFromObj(interp, objPtr, intPtr) \
(((objPtr)->typePtr == &tclIntType \
- && (objPtr)->internalRep.longValue >= -(Tcl_WideInt)(UINT_MAX) \
- && (objPtr)->internalRep.longValue <= (Tcl_WideInt)(UINT_MAX)) \
- ? ((*(intPtr) = (objPtr)->internalRep.longValue), TCL_OK) \
+ && (objPtr)->internalRep.wideValue >= -(Tcl_WideInt)(UINT_MAX) \
+ && (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(UINT_MAX)) \
+ ? ((*(intPtr) = (int)(objPtr)->internalRep.wideValue), TCL_OK) \
: Tcl_GetIntFromObj((interp), (objPtr), (intPtr)))
#define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \
(((objPtr)->typePtr == &tclIntType \
- && (objPtr)->internalRep.longValue >= INT_MIN \
- && (objPtr)->internalRep.longValue <= INT_MAX) \
- ? ((*(idxPtr) = (objPtr)->internalRep.longValue), TCL_OK) \
+ && (objPtr)->internalRep.wideValue >= INT_MIN \
+ && (objPtr)->internalRep.wideValue <= INT_MAX) \
+ ? ((*(idxPtr) = (int)(objPtr)->internalRep.wideValue), TCL_OK) \
: TclGetIntForIndex((interp), (objPtr), (endValue), (idxPtr)))
-#endif
/*
* Macro used to save a function call for common uses of
@@ -2488,21 +2496,11 @@ typedef struct List {
* Tcl_WideInt *wideIntPtr);
*/
-#ifdef TCL_WIDE_INT_IS_LONG
#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \
(((objPtr)->typePtr == &tclIntType) \
? (*(wideIntPtr) = (Tcl_WideInt) \
- ((objPtr)->internalRep.longValue), TCL_OK) : \
+ ((objPtr)->internalRep.wideValue), TCL_OK) : \
Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr)))
-#else /* !TCL_WIDE_INT_IS_LONG */
-#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \
- (((objPtr)->typePtr == &tclWideIntType) \
- ? (*(wideIntPtr) = (objPtr)->internalRep.wideValue, TCL_OK) : \
- ((objPtr)->typePtr == &tclIntType) \
- ? (*(wideIntPtr) = (Tcl_WideInt) \
- ((objPtr)->internalRep.longValue), TCL_OK) : \
- Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr)))
-#endif /* TCL_WIDE_INT_IS_LONG */
/*
* Flag values for TclTraceDictPath().
@@ -2514,13 +2512,13 @@ typedef struct List {
* tip of the path, so duplication of shared objects should be done along the
* way.
*
- * DICT_PATH_EXISTS indicates that we are performing an existance test and a
+ * DICT_PATH_EXISTS indicates that we are performing an existence test and a
* lookup failure should therefore not be an error. If (and only if) this flag
* is set, TclTraceDictPath() will return the special value
* DICT_PATH_NON_EXISTENT if the path is not traceable.
*
* DICT_PATH_CREATE (which also requires the DICT_PATH_UPDATE bit to be set)
- * indicates that we are to create non-existant dictionaries on the path.
+ * indicates that we are to create non-existent dictionaries on the path.
*/
#define DICT_PATH_READ 0
@@ -2728,9 +2726,6 @@ MODULE_SCOPE const Tcl_ObjType tclDictType;
MODULE_SCOPE const Tcl_ObjType tclProcBodyType;
MODULE_SCOPE const Tcl_ObjType tclStringType;
MODULE_SCOPE const Tcl_ObjType tclEnsembleCmdType;
-#ifndef TCL_WIDE_INT_IS_LONG
-MODULE_SCOPE const Tcl_ObjType tclWideIntType;
-#endif
MODULE_SCOPE const Tcl_ObjType tclRegexpType;
MODULE_SCOPE Tcl_ObjType tclCmdNameType;
@@ -2780,6 +2775,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRForObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRForeachCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRIfObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRLmapCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRPackageObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRSourceObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRSubstObjCmd;
MODULE_SCOPE Tcl_ObjCmdProc TclNRSwitchObjCmd;
@@ -3157,7 +3153,6 @@ MODULE_SCOPE Tcl_Obj * TclPathPart(Tcl_Interp *interp, Tcl_Obj *pathPtr,
Tcl_PathPart portion);
MODULE_SCOPE char * TclpReadlink(const char *fileName,
Tcl_DString *linkPtr);
-MODULE_SCOPE void TclpSetInterfaces(void);
MODULE_SCOPE void TclpSetVariables(Tcl_Interp *interp);
MODULE_SCOPE void * TclThreadStorageKeyGet(Tcl_ThreadDataKey *keyPtr);
MODULE_SCOPE void TclThreadStorageKeySet(Tcl_ThreadDataKey *keyPtr,
@@ -3188,20 +3183,10 @@ MODULE_SCOPE void TclSpellFix(Tcl_Interp *interp,
Tcl_Obj *bad, Tcl_Obj *fix);
MODULE_SCOPE void * TclStackRealloc(Tcl_Interp *interp, void *ptr,
int numBytes);
-MODULE_SCOPE int TclStringCatObjv(Tcl_Interp *interp, int inPlace,
- int objc, Tcl_Obj *const objv[],
- Tcl_Obj **objPtrPtr);
-MODULE_SCOPE int TclStringFind(Tcl_Obj *needle, Tcl_Obj *haystack,
- int start);
-MODULE_SCOPE int TclStringLast(Tcl_Obj *needle, Tcl_Obj *haystack,
- int last);
MODULE_SCOPE int TclStringMatch(const char *str, int strLen,
const char *pattern, int ptnLen, int flags);
MODULE_SCOPE int TclStringMatchObj(Tcl_Obj *stringObj,
Tcl_Obj *patternObj, int flags);
-MODULE_SCOPE Tcl_Obj * TclStringObjReverse(Tcl_Obj *objPtr);
-MODULE_SCOPE int TclStringRepeat(Tcl_Interp *interp, Tcl_Obj *objPtr,
- int count, Tcl_Obj **objPtrPtr);
MODULE_SCOPE void TclSubstCompile(Tcl_Interp *interp, const char *bytes,
int numBytes, int flags, int line,
struct CompileEnv *envPtr);
@@ -3213,6 +3198,8 @@ MODULE_SCOPE void TclSubstParse(Tcl_Interp *interp, const char *bytes,
MODULE_SCOPE int TclSubstTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr,
int count, int *tokensLeftPtr, int line,
int *clNextOuter, const char *outerScript);
+MODULE_SCOPE int TclTrim(const char *bytes, int numBytes,
+ const char *trim, int numTrim, int *trimRight);
MODULE_SCOPE int TclTrimLeft(const char *bytes, int numBytes,
const char *trim, int numTrim);
MODULE_SCOPE int TclTrimRight(const char *bytes, int numBytes,
@@ -3267,7 +3254,7 @@ MODULE_SCOPE Tcl_Command TclInitBinaryCmd(Tcl_Interp *interp);
MODULE_SCOPE int Tcl_BreakObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
-#ifndef TCL_NO_DEPRECATED
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
MODULE_SCOPE int Tcl_CaseObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
@@ -4007,6 +3994,29 @@ MODULE_SCOPE int TclCompileAssembleCmd(Tcl_Interp *interp,
struct CompileEnv *envPtr);
/*
+ * Routines that provide the [string] ensemble functionality. Possible
+ * candidates for public interface.
+ */
+
+MODULE_SCOPE Tcl_Obj * TclStringCat(Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[], int flags);
+MODULE_SCOPE int TclStringFirst(Tcl_Obj *needle, Tcl_Obj *haystack,
+ int start);
+MODULE_SCOPE int TclStringLast(Tcl_Obj *needle, Tcl_Obj *haystack,
+ int last);
+MODULE_SCOPE Tcl_Obj * TclStringRepeat(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ int count, int flags);
+MODULE_SCOPE Tcl_Obj * TclStringReplace(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ int first, int count, Tcl_Obj *insertPtr,
+ int flags);
+MODULE_SCOPE Tcl_Obj * TclStringReverse(Tcl_Obj *objPtr, int flags);
+
+/* Flag values for the [string] ensemble functions. */
+
+#define TCL_STRING_MATCH_NOCASE TCL_MATCH_NOCASE /* (1<<0) in tcl.h */
+#define TCL_STRING_IN_PLACE (1<<1)
+
+/*
* Functions defined in generic/tclVar.c and currently exported only for use
* by the bytecode compiler and engine. Some of these could later be placed in
* the public interface.
@@ -4062,6 +4072,45 @@ MODULE_SCOPE TCL_HASH_TYPE TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr);
MODULE_SCOPE int TclFullFinalizationRequested(void);
/*
+ * TIP #462.
+ */
+
+/*
+ * The following enum values give the status of a spawned process.
+ */
+
+typedef enum TclProcessWaitStatus {
+ TCL_PROCESS_ERROR = -1, /* Error waiting for process to exit */
+ TCL_PROCESS_UNCHANGED = 0, /* No change since the last call. */
+ TCL_PROCESS_EXITED = 1, /* Process has exited. */
+ TCL_PROCESS_SIGNALED = 2, /* Child killed because of a signal. */
+ TCL_PROCESS_STOPPED = 3, /* Child suspended because of a signal. */
+ TCL_PROCESS_UNKNOWN_STATUS = 4
+ /* Child wait status didn't make sense. */
+} TclProcessWaitStatus;
+
+MODULE_SCOPE Tcl_Command TclInitProcessCmd(Tcl_Interp *interp);
+MODULE_SCOPE void TclProcessCreated(Tcl_Pid pid);
+MODULE_SCOPE TclProcessWaitStatus TclProcessWait(Tcl_Pid pid, int options,
+ int *codePtr, Tcl_Obj **msgObjPtr,
+ Tcl_Obj **errorObjPtr);
+
+/*
+ * Utility routines for encoding index values as integers. Used by both
+ * some of the command compilers and by [lsort] and [lsearch].
+ */
+
+MODULE_SCOPE int TclIndexEncode(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ int before, int after, int *indexPtr);
+MODULE_SCOPE int TclIndexDecode(int encoded, int endValue);
+
+/* Constants used in index value encoding routines. */
+#define TCL_INDEX_END (-2)
+#define TCL_INDEX_BEFORE (-1)
+#define TCL_INDEX_START (0)
+#define TCL_INDEX_AFTER (INT_MAX)
+
+/*
*----------------------------------------------------------------
* Macros used by the Tcl core to create and release Tcl objects.
* TclNewObj(objPtr) creates a new object denoting an empty string.
@@ -4574,30 +4623,19 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
* core. They should only be called on unshared objects. The ANSI C
* "prototypes" for these macros are:
*
- * MODULE_SCOPE void TclSetLongObj(Tcl_Obj *objPtr, long longValue);
- * MODULE_SCOPE void TclSetWideIntObj(Tcl_Obj *objPtr, Tcl_WideInt w);
+ * MODULE_SCOPE void TclSetIntObj(Tcl_Obj *objPtr, Tcl_WideInt w);
* MODULE_SCOPE void TclSetDoubleObj(Tcl_Obj *objPtr, double d);
*----------------------------------------------------------------
*/
-#define TclSetLongObj(objPtr, i) \
+#define TclSetIntObj(objPtr, i) \
do { \
TclInvalidateStringRep(objPtr); \
TclFreeIntRep(objPtr); \
- (objPtr)->internalRep.longValue = (long)(i); \
+ (objPtr)->internalRep.wideValue = (Tcl_WideInt)(i); \
(objPtr)->typePtr = &tclIntType; \
} while (0)
-#ifndef TCL_WIDE_INT_IS_LONG
-#define TclSetWideIntObj(objPtr, w) \
- do { \
- TclInvalidateStringRep(objPtr); \
- TclFreeIntRep(objPtr); \
- (objPtr)->internalRep.wideValue = (Tcl_WideInt)(w); \
- (objPtr)->typePtr = &tclWideIntType; \
- } while (0)
-#endif
-
#define TclSetDoubleObj(objPtr, d) \
do { \
TclInvalidateStringRep(objPtr); \
@@ -4612,8 +4650,7 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
* types, avoiding the corresponding function calls in time critical parts of
* the core. The ANSI C "prototypes" for these macros are:
*
- * MODULE_SCOPE void TclNewLongObj(Tcl_Obj *objPtr, long l);
- * MODULE_SCOPE void TclNewWideObj(Tcl_Obj *objPtr, Tcl_WideInt w);
+ * MODULE_SCOPE void TclNewIntObj(Tcl_Obj *objPtr, Tcl_WideInt w);
* MODULE_SCOPE void TclNewDoubleObj(Tcl_Obj *objPtr, double d);
* MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, const char *s, int len);
* MODULE_SCOPE void TclNewLiteralStringObj(Tcl_Obj*objPtr, const char *sLiteral);
@@ -4622,13 +4659,13 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
*/
#ifndef TCL_MEM_DEBUG
-#define TclNewLongObj(objPtr, i) \
+#define TclNewIntObj(objPtr, i) \
do { \
TclIncrObjsAllocated(); \
TclAllocObjStorage(objPtr); \
(objPtr)->refCount = 0; \
(objPtr)->bytes = NULL; \
- (objPtr)->internalRep.longValue = (long)(i); \
+ (objPtr)->internalRep.wideValue = (Tcl_WideInt)(i); \
(objPtr)->typePtr = &tclIntType; \
TCL_DTRACE_OBJ_CREATE(objPtr); \
} while (0)
@@ -4655,8 +4692,8 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
} while (0)
#else /* TCL_MEM_DEBUG */
-#define TclNewLongObj(objPtr, l) \
- (objPtr) = Tcl_NewLongObj(l)
+#define TclNewIntObj(objPtr, w) \
+ (objPtr) = Tcl_NewWideIntObj(w)
#define TclNewDoubleObj(objPtr, d) \
(objPtr) = Tcl_NewDoubleObj(d)
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index bc8f7b8..03a2ed2 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -114,7 +114,7 @@ EXTERN int TclFindElement(Tcl_Interp *interp,
/* 23 */
EXTERN Proc * TclFindProc(Interp *iPtr, const char *procName);
/* 24 */
-EXTERN int TclFormatInt(char *buffer, long n);
+EXTERN int TclFormatInt(char *buffer, Tcl_WideInt n);
/* 25 */
EXTERN void TclFreePackageInfo(Interp *iPtr);
/* Slot 26 is reserved */
@@ -174,7 +174,7 @@ EXTERN int TclInterpInit(Tcl_Interp *interp);
/* 53 */
EXTERN int TclInvokeObjectCommand(ClientData clientData,
Tcl_Interp *interp, int argc,
- CONST84 char **argv);
+ const char **argv);
/* 54 */
EXTERN int TclInvokeStringCommand(ClientData clientData,
Tcl_Interp *interp, int objc,
@@ -361,13 +361,11 @@ struct tm * TclpGetDate(const time_t *time, int useGMT);
/* Slot 136 is reserved */
/* Slot 137 is reserved */
/* 138 */
-EXTERN CONST84_RETURN char * TclGetEnv(const char *name,
- Tcl_DString *valuePtr);
+EXTERN const char * TclGetEnv(const char *name, Tcl_DString *valuePtr);
/* Slot 139 is reserved */
/* Slot 140 is reserved */
/* 141 */
-EXTERN CONST84_RETURN char * TclpGetCwd(Tcl_Interp *interp,
- Tcl_DString *cwdPtr);
+EXTERN const char * TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr);
/* 142 */
EXTERN int TclSetByteCodeFromAny(Tcl_Interp *interp,
Tcl_Obj *objPtr, CompileHookProc *hookProc,
@@ -680,7 +678,7 @@ typedef struct TclIntStubs {
void (*reserved21)(void);
int (*tclFindElement) (Tcl_Interp *interp, const char *listStr, int listLength, const char **elementPtr, const char **nextPtr, int *sizePtr, int *bracePtr); /* 22 */
Proc * (*tclFindProc) (Interp *iPtr, const char *procName); /* 23 */
- int (*tclFormatInt) (char *buffer, long n); /* 24 */
+ int (*tclFormatInt) (char *buffer, Tcl_WideInt n); /* 24 */
void (*tclFreePackageInfo) (Interp *iPtr); /* 25 */
void (*reserved26)(void);
void (*reserved27)(void);
@@ -709,7 +707,7 @@ typedef struct TclIntStubs {
void (*tclInitCompiledLocals) (Tcl_Interp *interp, CallFrame *framePtr, Namespace *nsPtr); /* 50 */
int (*tclInterpInit) (Tcl_Interp *interp); /* 51 */
void (*reserved52)(void);
- int (*tclInvokeObjectCommand) (ClientData clientData, Tcl_Interp *interp, int argc, CONST84 char **argv); /* 53 */
+ int (*tclInvokeObjectCommand) (ClientData clientData, Tcl_Interp *interp, int argc, const char **argv); /* 53 */
int (*tclInvokeStringCommand) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 54 */
Proc * (*tclIsProc) (Command *cmdPtr); /* 55 */
void (*reserved56)(void);
@@ -794,10 +792,10 @@ typedef struct TclIntStubs {
void (*reserved135)(void);
void (*reserved136)(void);
void (*reserved137)(void);
- CONST84_RETURN char * (*tclGetEnv) (const char *name, Tcl_DString *valuePtr); /* 138 */
+ const char * (*tclGetEnv) (const char *name, Tcl_DString *valuePtr); /* 138 */
void (*reserved139)(void);
void (*reserved140)(void);
- CONST84_RETURN char * (*tclpGetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 141 */
+ const char * (*tclpGetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 141 */
int (*tclSetByteCodeFromAny) (Tcl_Interp *interp, Tcl_Obj *objPtr, CompileHookProc *hookProc, ClientData clientData); /* 142 */
int (*tclAddLiteralObj) (struct CompileEnv *envPtr, Tcl_Obj *objPtr, LiteralEntry **litPtrPtr); /* 143 */
void (*tclHideLiteral) (Tcl_Interp *interp, struct CompileEnv *envPtr, int index); /* 144 */
diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h
index 1222cee..0e160ca 100644
--- a/generic/tclIntPlatDecls.h
+++ b/generic/tclIntPlatDecls.h
@@ -555,12 +555,18 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr;
# undef TclWinGetServByName
# undef TclWinGetSockOpt
# undef TclWinSetSockOpt
-# define TclWinNToHS ntohs
-# define TclWinGetServByName getservbyname
-# define TclWinGetSockOpt getsockopt
-# define TclWinSetSockOpt setsockopt
# undef TclWinGetPlatformId
-# define TclWinGetPlatformId() (2) /* VER_PLATFORM_WIN32_NT */
+# undef TclWinResetInterfaces
+# undef TclWinSetInterfaces
+# if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
+# define TclWinNToHS ntohs
+# define TclWinGetServByName getservbyname
+# define TclWinGetSockOpt getsockopt
+# define TclWinSetSockOpt setsockopt
+# define TclWinGetPlatformId() (2) /* VER_PLATFORM_WIN32_NT */
+# define TclWinResetInterfaces() /* nop */
+# define TclWinSetInterfaces(dummy) /* nop */
+# endif /* TCL_NO_DEPRECATED */
#else
# undef TclpGetPid
# define TclpGetPid(pid) ((unsigned long) (pid))
diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index 43d90ab..7b91d63 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -1165,17 +1165,11 @@ TclLindexList(
return TclLindexFlat(interp, listPtr, 1, &argPtr);
}
- if (indexListCopy->typePtr == &tclListType) {
- List *listRepPtr = ListRepPtr(indexListCopy);
+ {
+ int indexCount = -1; /* Size of the array of list indices. */
+ Tcl_Obj **indices = NULL; /* Array of list indices. */
- listPtr = TclLindexFlat(interp, listPtr, listRepPtr->elemCount,
- &listRepPtr->elements);
- } else {
- int indexCount = -1; /* Size of the array of list indices. */
- Tcl_Obj **indices = NULL;
- /* Array of list indices. */
-
- Tcl_ListObjGetElements(NULL, indexListCopy, &indexCount, &indices);
+ TclListObjGetElements(NULL, indexListCopy, &indexCount, &indices);
listPtr = TclLindexFlat(interp, listPtr, indexCount, indices);
}
Tcl_DecrRefCount(indexListCopy);
diff --git a/generic/tclLoad.c b/generic/tclLoad.c
index e0bb5ef..77e6425 100644
--- a/generic/tclLoad.c
+++ b/generic/tclLoad.c
@@ -470,6 +470,19 @@ Tcl_LoadObjCmd(
*/
if (code != TCL_OK) {
+#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8
+ Interp *iPtr = (Interp *) target;
+ if (iPtr->result && *(iPtr->result) && !iPtr->freeProc) {
+ /*
+ * A call to Tcl_InitStubs() determined the caller extension and
+ * this interp are incompatible in their stubs mechanisms, and
+ * recorded the error in the oldest legacy place we have to do so.
+ */
+ Tcl_SetObjResult(target, Tcl_NewStringObj(iPtr->result, -1));
+ iPtr->result = &tclEmptyString;
+ iPtr->freeProc = NULL;
+ }
+#endif /* defined(TCL_NO_DEPRECATED) */
Tcl_TransferResult(target, code, interp);
goto done;
}
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 84380e0..d68131d 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -60,8 +60,6 @@ static const struct {
static Class * AllocClass(Tcl_Interp *interp, Object *useThisObj);
static Object * AllocObject(Tcl_Interp *interp, const char *nameStr,
Namespace *nsPtr, const char *nsNameStr);
-static void ClearMixins(Class *clsPtr);
-static void ClearSuperclasses(Class *clsPtr);
static int CloneClassMethod(Tcl_Interp *interp, Class *clsPtr,
Method *mPtr, Tcl_Obj *namePtr,
Method **newMPtrPtr);
@@ -73,6 +71,9 @@ static void DeletedHelpersNamespace(ClientData clientData);
static Tcl_NRPostProc FinalizeAlloc;
static Tcl_NRPostProc FinalizeNext;
static Tcl_NRPostProc FinalizeObjectCall;
+static inline void InitClassPath(Tcl_Interp * interp, Class *clsPtr);
+static void InitClassSystemRoots(Tcl_Interp *interp,
+ Foundation *fPtr);
static int InitFoundation(Tcl_Interp *interp);
static void KillFoundation(ClientData clientData,
Tcl_Interp *interp);
@@ -82,6 +83,9 @@ static void ObjectRenamedTrace(ClientData clientData,
Tcl_Interp *interp, const char *oldName,
const char *newName, int flags);
static void ReleaseClassContents(Tcl_Interp *interp,Object *oPtr);
+static void DeleteDescendants(Tcl_Interp *interp,Object *oPtr);
+static inline void RemoveClass(Class **list, int num, int idx);
+static inline void RemoveObject(Object **list, int num, int idx);
static inline void SquelchCachedName(Object *oPtr);
static int PublicObjectCmd(ClientData clientData,
@@ -228,10 +232,52 @@ MODULE_SCOPE const TclOOStubs tclOOStubs;
* ROOT_CLASS respectively.
*/
-#define Deleted(oPtr) (((Object *)(oPtr))->command == NULL)
+#define Deleted(oPtr) ((oPtr)->flags & OBJECT_DELETED)
#define IsRootObject(ocPtr) ((ocPtr)->flags & ROOT_OBJECT)
#define IsRootClass(ocPtr) ((ocPtr)->flags & ROOT_CLASS)
#define IsRoot(ocPtr) ((ocPtr)->flags & (ROOT_OBJECT|ROOT_CLASS))
+
+#define RemoveItem(type, lst, i) \
+ do { \
+ Remove ## type ((lst).list, (lst).num, i); \
+ (lst).num--; \
+ } while (0)
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * RemoveClass, RemoveObject --
+ *
+ * Helpers for the RemoveItem macro for deleting a class or object from a
+ * list. Setting the "empty" location to NULL makes debugging a little
+ * easier.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static inline void
+RemoveClass(
+ Class **list,
+ int num,
+ int idx)
+{
+ for (; idx < num - 1; idx++) {
+ list[idx] = list[idx + 1];
+ }
+ list[idx] = NULL;
+}
+
+static inline void
+RemoveObject(
+ Object **list,
+ int num,
+ int idx)
+{
+ for (; idx < num - 1; idx++) {
+ list[idx] = list[idx + 1];
+ }
+ list[idx] = NULL;
+}
/*
* ----------------------------------------------------------------------
@@ -375,28 +421,10 @@ InitFoundation(
Tcl_CallWhenDeleted(interp, KillFoundation, NULL);
/*
- * Create the objects at the core of the object system. These need to be
- * spliced manually.
+ * Create the special objects at the core of the object system.
*/
- fPtr->objectCls = AllocClass(interp,
- AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL));
- fPtr->classCls = AllocClass(interp,
- AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL));
- fPtr->objectCls->thisPtr->selfCls = fPtr->classCls;
- fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT;
- fPtr->objectCls->flags |= ROOT_OBJECT;
- fPtr->objectCls->superclasses.num = 0;
- ckfree(fPtr->objectCls->superclasses.list);
- fPtr->objectCls->superclasses.list = NULL;
- fPtr->classCls->thisPtr->selfCls = fPtr->classCls;
- fPtr->classCls->thisPtr->flags |= ROOT_CLASS;
- fPtr->classCls->flags |= ROOT_CLASS;
- TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls);
- TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls);
- TclOOAddToSubclasses(fPtr->classCls, fPtr->objectCls);
- AddRef(fPtr->objectCls->thisPtr);
- AddRef(fPtr->objectCls);
+ InitClassSystemRoots(interp, fPtr);
/*
* Basic method declarations for the core classes.
@@ -463,6 +491,80 @@ InitFoundation(
}
return Tcl_EvalEx(interp, slotScript, -1, 0);
}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InitClassSystemRoots --
+ *
+ * Creates the objects at the core of the object system. These need to be
+ * spliced manually.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+InitClassSystemRoots(
+ Tcl_Interp *interp,
+ Foundation *fPtr)
+{
+ Class fakeCls;
+ Object fakeObject;
+
+ /* Stand up a phony class for bootstrapping. */
+ fPtr->objectCls = &fakeCls;
+ /* referenced in AllocClass to increment the refCount. */
+ fakeCls.thisPtr = &fakeObject;
+
+ fPtr->objectCls = AllocClass(interp,
+ AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL));
+ /* Corresponding TclOODecrRefCount in KillFoudation */
+ AddRef(fPtr->objectCls->thisPtr);
+
+ /* This is why it is unnecessary in this routine to replace the
+ * incremented reference count of fPtr->objectCls that was swallowed by
+ * fakeObject. */
+ fPtr->objectCls->superclasses.num = 0;
+ ckfree(fPtr->objectCls->superclasses.list);
+ fPtr->objectCls->superclasses.list = NULL;
+
+ /* special initialization for the primordial objects */
+ fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT;
+ fPtr->objectCls->flags |= ROOT_OBJECT;
+
+ fPtr->classCls = AllocClass(interp,
+ AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL));
+ /* Corresponding TclOODecrRefCount in KillFoudation */
+ AddRef(fPtr->classCls->thisPtr);
+
+ /*
+ * Increment reference counts for each reference because these
+ * relationships can be dynamically changed.
+ *
+ * Corresponding TclOODecrRefCount for all incremented refcounts is in
+ * KillFoundation.
+ */
+
+ /* Rewire bootstrapped objects. */
+ fPtr->objectCls->thisPtr->selfCls = fPtr->classCls;
+ AddRef(fPtr->classCls->thisPtr);
+ TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls);
+
+ fPtr->classCls->thisPtr->selfCls = fPtr->classCls;
+ AddRef(fPtr->classCls->thisPtr);
+ TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls);
+
+ fPtr->classCls->thisPtr->flags |= ROOT_CLASS;
+ fPtr->classCls->flags |= ROOT_CLASS;
+
+ /* Standard initialization for new Objects */
+ TclOOAddToSubclasses(fPtr->classCls, fPtr->objectCls);
+
+ /*
+ * THIS IS THE ONLY FUNCTION THAT DOES NON-STANDARD CLASS SPLICING.
+ * Everything else is careful to prohibit looping.
+ */
+}
/*
* ----------------------------------------------------------------------
@@ -522,13 +624,14 @@ KillFoundation(
{
Foundation *fPtr = GetFoundation(interp);
- DelRef(fPtr->objectCls->thisPtr);
- DelRef(fPtr->objectCls);
TclDecrRefCount(fPtr->unknownMethodNameObj);
TclDecrRefCount(fPtr->constructorName);
TclDecrRefCount(fPtr->destructorName);
TclDecrRefCount(fPtr->clonedName);
TclDecrRefCount(fPtr->defineName);
+ TclOODecrRefCount(fPtr->objectCls->thisPtr);
+ TclOODecrRefCount(fPtr->classCls->thisPtr);
+
ckfree(fPtr);
}
@@ -538,8 +641,11 @@ KillFoundation(
* AllocObject --
*
* Allocate an object of basic type. Does not splice the object into its
- * class's instance list. The caller must set the classPtr on the object,
- * either to a class or to NULL.
+ * class's instance list. The caller must set the classPtr on the object
+ * to either a class or NULL, call TclOOAddToInstances to add the object
+ * to the class's instance list, and if the object itself is a class, use
+ * call TclOOAddToSubclasses() to add it to the right class's list of
+ * subclasses.
*
* ----------------------------------------------------------------------
*/
@@ -552,8 +658,8 @@ AllocObject(
* if the OO system should pick the object
* name itself (equal to the namespace
* name). */
- Namespace *nsPtr, /* The namespace to create the object in,
- or NULL if *nameStr is NULL */
+ Namespace *nsPtr, /* The namespace to create the object in, or
+ * NULL if *nameStr is NULL */
const char *nsNameStr) /* The name of the namespace to create, or
* NULL if the OO system should pick a unique
* name itself. If this is non-NULL but names
@@ -564,7 +670,7 @@ AllocObject(
Object *oPtr;
Command *cmdPtr;
CommandTrace *tracePtr;
- int creationEpoch, ignored;
+ int creationEpoch;
oPtr = ckalloc(sizeof(Object));
memset(oPtr, 0, sizeof(Object));
@@ -609,12 +715,16 @@ AllocObject(
Tcl_ResetResult(interp);
}
+
+ configNamespace:
+
+ ((Namespace *)oPtr->namespacePtr)->refCount++;
+
/*
* Make the namespace know about the helper commands. This grants access
* to the [self] and [next] commands.
*/
- configNamespace:
if (fPtr->helpersNs != NULL) {
TclSetNsPath((Namespace *) oPtr->namespacePtr, 1, &fPtr->helpersNs);
}
@@ -641,9 +751,15 @@ AllocObject(
*/
oPtr->fPtr = fPtr;
- oPtr->selfCls = fPtr->objectCls;
oPtr->creationEpoch = creationEpoch;
- oPtr->refCount = 1;
+
+ /*
+ * An object starts life with a refCount of 2 to mark the two stages of
+ * destruction it occur: A call to ObjectRenamedTrace(), and a call to
+ * ObjectNamespaceDeleted().
+ */
+
+ oPtr->refCount = 2;
oPtr->flags = USE_CLASS_CACHE;
/*
@@ -655,6 +771,10 @@ AllocObject(
if (!nameStr) {
nameStr = oPtr->namespacePtr->name;
nsPtr = (Namespace *)oPtr->namespacePtr;
+ if (nsPtr->parentPtr != NULL) {
+ nsPtr = nsPtr->parentPtr;
+ }
+
}
oPtr->command = TclCreateObjCommandInNs(interp, nameStr,
(Tcl_Namespace *)nsPtr, PublicObjectCmd, oPtr, NULL);
@@ -673,26 +793,8 @@ AllocObject(
tracePtr->nextPtr = NULL;
tracePtr->refCount = 1;
- /*
- * Access the namespace command table directly when creating "my" to avoid
- * a bottleneck in string manipulation. Another abstraction-buster.
- */
-
- cmdPtr = ckalloc(sizeof(Command));
- memset(cmdPtr, 0, sizeof(Command));
- cmdPtr->nsPtr = (Namespace *) oPtr->namespacePtr;
- cmdPtr->hPtr = Tcl_CreateHashEntry(&cmdPtr->nsPtr->cmdTable, "my",
- &ignored);
- cmdPtr->refCount = 1;
- cmdPtr->objProc = PrivateObjectCmd;
- cmdPtr->deleteProc = MyDeleted;
- cmdPtr->objClientData = cmdPtr->deleteData = oPtr;
- cmdPtr->proc = TclInvokeObjectCommand;
- cmdPtr->clientData = cmdPtr;
- cmdPtr->nreProc = PrivateNRObjectCmd;
- Tcl_SetHashValue(cmdPtr->hPtr, cmdPtr);
- oPtr->myCommand = (Tcl_Command) cmdPtr;
-
+ oPtr->myCommand = TclNRCreateCommandInNs(interp, "my", oPtr->namespacePtr,
+ PrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted);
return oPtr;
}
@@ -762,6 +864,7 @@ ObjectRenamedTrace(
int flags) /* Why was the object deleted? */
{
Object *oPtr = clientData;
+
/*
* If this is a rename and not a delete of the object, we just flush the
* cache of the object name.
@@ -774,83 +877,98 @@ ObjectRenamedTrace(
/*
* The namespace is only deleted if it hasn't already been deleted. [Bug
- * 2950259]. If the namespace has already been deleted, then
- * ObjectNamespaceDeleted() has already cleaned up this command.
+ * 2950259].
*/
- if (oPtr->namespacePtr == NULL) {
- /*
- * ObjectNamespaceDeleted() has already done all the cleanup, but
- * detected that the command was in the process of being deleted, and
- * left the pointer allocated for us.
- */
- DelRef(oPtr);
- } else {
- if (((Namespace *) oPtr->namespacePtr)->earlyDeleteProc == NULL) {
- /*
- * ObjectNamespaceDeleted() called us, and still has some work to
- * do, so we leave the pointer allocated for it to finish, and then
- * it will deallocate the pointer.
- */
- } else {
- Tcl_DeleteNamespace(oPtr->namespacePtr);
- /*
- * ObjectNamespaceDeleted() doesn't know it was us that just
- * called, so it left the pointer allocated.
- */
- DelRef(oPtr);
- }
+ if (!Deleted(oPtr)) {
+ Tcl_DeleteNamespace(oPtr->namespacePtr);
}
+ oPtr->command = NULL;
+ TclOODecrRefCount(oPtr);
return;
}
/*
* ----------------------------------------------------------------------
*
- * ClearMixins, ClearSuperclasses --
+ * DeleteDescendants --
*
- * Utility functions for correctly clearing the list of mixins or
- * superclasses of a class. Will ckfree() the list storage.
+ * Delete all descendants of a particular class.
*
* ----------------------------------------------------------------------
*/
static void
-ClearMixins(
- Class *clsPtr)
+DeleteDescendants(
+ Tcl_Interp *interp, /* The interpreter containing the class. */
+ Object *oPtr) /* The object representing the class. */
{
- int i;
- Class *mixinPtr;
+ Class *clsPtr = oPtr->classPtr, *subclassPtr, *mixinSubclassPtr;
+ Object *instancePtr;
- if (clsPtr->mixins.num == 0) {
- return;
- }
+ /*
+ * Squelch classes that this class has been mixed into.
+ */
- FOREACH(mixinPtr, clsPtr->mixins) {
- TclOORemoveFromMixinSubs(clsPtr, mixinPtr);
+ if (clsPtr->mixinSubs.num > 0) {
+ while (clsPtr->mixinSubs.num > 0) {
+ mixinSubclassPtr = clsPtr->mixinSubs.list[clsPtr->mixinSubs.num-1];
+ /* This condition also covers the case where mixinSubclassPtr ==
+ * clsPtr
+ */
+ if (!Deleted(mixinSubclassPtr->thisPtr)) {
+ Tcl_DeleteCommandFromToken(interp,
+ mixinSubclassPtr->thisPtr->command);
+ }
+ TclOORemoveFromMixinSubs(mixinSubclassPtr, clsPtr);
+ }
+ }
+ if (clsPtr->mixinSubs.size > 0) {
+ ckfree(clsPtr->mixinSubs.list);
+ clsPtr->mixinSubs.size = 0;
}
- ckfree(clsPtr->mixins.list);
- clsPtr->mixins.list = NULL;
- clsPtr->mixins.num = 0;
-}
-static void
-ClearSuperclasses(
- Class *clsPtr)
-{
- int i;
- Class *superPtr;
+ /*
+ * Squelch subclasses of this class.
+ */
- if (clsPtr->superclasses.num == 0) {
- return;
+ if (clsPtr->subclasses.num > 0) {
+ while (clsPtr->subclasses.num > 0) {
+ subclassPtr = clsPtr->subclasses.list[clsPtr->subclasses.num-1];
+ if (!Deleted(subclassPtr->thisPtr) && !IsRoot(subclassPtr)) {
+ Tcl_DeleteCommandFromToken(interp, subclassPtr->thisPtr->command);
+ }
+ TclOORemoveFromSubclasses(subclassPtr, clsPtr);
+ }
+ }
+ if (clsPtr->subclasses.size > 0) {
+ ckfree(clsPtr->subclasses.list);
+ clsPtr->subclasses.list = NULL;
+ clsPtr->subclasses.size = 0;
}
- FOREACH(superPtr, clsPtr->superclasses) {
- TclOORemoveFromSubclasses(clsPtr, superPtr);
+ /*
+ * Squelch instances of this class (includes objects we're mixed into).
+ */
+
+ if (clsPtr->instances.num > 0) {
+ while (clsPtr->instances.num > 0) {
+ instancePtr = clsPtr->instances.list[clsPtr->instances.num-1];
+ /*
+ * This condition also covers the case where instancePtr == oPtr
+ */
+
+ if (!Deleted(instancePtr) && !IsRoot(instancePtr)) {
+ Tcl_DeleteCommandFromToken(interp, instancePtr->command);
+ }
+ TclOORemoveFromInstances(instancePtr, clsPtr);
+ }
+ }
+ if (clsPtr->instances.size > 0) {
+ ckfree(clsPtr->instances.list);
+ clsPtr->instances.list = NULL;
+ clsPtr->instances.size = 0;
}
- ckfree(clsPtr->superclasses.list);
- clsPtr->superclasses.list = NULL;
- clsPtr->superclasses.num = 0;
}
/*
@@ -871,8 +989,7 @@ ReleaseClassContents(
{
FOREACH_HASH_DECLS;
int i;
- Class *clsPtr = oPtr->classPtr, *mixinSubclassPtr, *subclassPtr;
- Object *instancePtr;
+ Class *clsPtr = oPtr->classPtr, *tmpClsPtr;
Method *mPtr;
Foundation *fPtr = oPtr->fPtr;
Tcl_Obj *variableObj;
@@ -895,132 +1012,6 @@ ReleaseClassContents(
}
/*
- * Lock a number of dependent objects until we've stopped putting our
- * fingers in them.
- */
-
- FOREACH(mixinSubclassPtr, clsPtr->mixinSubs) {
- if (mixinSubclassPtr != NULL) {
- AddRef(mixinSubclassPtr);
- AddRef(mixinSubclassPtr->thisPtr);
- }
- }
- FOREACH(subclassPtr, clsPtr->subclasses) {
- if (subclassPtr != NULL && !IsRoot(subclassPtr)) {
- AddRef(subclassPtr);
- AddRef(subclassPtr->thisPtr);
- }
- }
- if (!IsRootClass(oPtr)) {
- FOREACH(instancePtr, clsPtr->instances) {
- if (instancePtr != oPtr) {
- int j;
- if (instancePtr->selfCls == clsPtr) {
- instancePtr->flags |= CLASS_GONE;
- }
- for(j=0 ; j<instancePtr->mixins.num ; j++) {
- Class *mixin = instancePtr->mixins.list[j];
- Class *nextMixin = NULL;
- if (mixin == clsPtr) {
- if (j < instancePtr->mixins.num - 1) {
- nextMixin = instancePtr->mixins.list[j+1];
- }
- if (j == 0) {
- instancePtr->mixins.num = 0;
- instancePtr->mixins.list = NULL;
- } else {
- instancePtr->mixins.list[j-1] = nextMixin;
- }
- instancePtr->mixins.num -= 1;
- }
- }
- if (instancePtr != NULL && !IsRoot(instancePtr)) {
- AddRef(instancePtr);
- }
- }
- }
- }
-
- /*
- * Squelch classes that this class has been mixed into.
- */
-
- FOREACH(mixinSubclassPtr, clsPtr->mixinSubs) {
- if (mixinSubclassPtr != clsPtr) {
- if (!Deleted(mixinSubclassPtr->thisPtr)) {
- Tcl_DeleteCommandFromToken(interp,
- mixinSubclassPtr->thisPtr->command);
- }
- ClearMixins(mixinSubclassPtr);
- DelRef(mixinSubclassPtr->thisPtr);
- DelRef(mixinSubclassPtr);
- }
- }
- if (clsPtr->mixinSubs.list != NULL) {
- ckfree(clsPtr->mixinSubs.list);
- clsPtr->mixinSubs.list = NULL;
- clsPtr->mixinSubs.num = 0;
- }
-
- /*
- * Squelch subclasses of this class.
- */
-
- FOREACH(subclassPtr, clsPtr->subclasses) {
- if (IsRoot(subclassPtr)) {
- continue;
- }
- if (!Deleted(subclassPtr->thisPtr)) {
- Tcl_DeleteCommandFromToken(interp, subclassPtr->thisPtr->command);
- }
- ClearSuperclasses(subclassPtr);
- DelRef(subclassPtr->thisPtr);
- DelRef(subclassPtr);
- }
- if (clsPtr->subclasses.list != NULL) {
- ckfree(clsPtr->subclasses.list);
- clsPtr->subclasses.list = NULL;
- clsPtr->subclasses.num = 0;
- }
-
- /*
- * Squelch instances of this class (includes objects we're mixed into).
- */
-
- if (!IsRootClass(oPtr)) {
- FOREACH(instancePtr, clsPtr->instances) {
- if (instancePtr != oPtr) {
- if (instancePtr == NULL || IsRoot(instancePtr)) {
- continue;
- }
- if (!Deleted(instancePtr)) {
- Tcl_DeleteCommandFromToken(interp, instancePtr->command);
- /*
- * Tcl_DeleteCommandFromToken() may have done to whole
- * job for us. Roll back and check again.
- */
- i--;
- continue;
- }
- DelRef(instancePtr);
- }
- }
- }
- if (clsPtr->instances.list != NULL) {
- ckfree(clsPtr->instances.list);
- clsPtr->instances.list = NULL;
- clsPtr->instances.num = 0;
- }
-
- /*
- * Special: We delete these after everything else.
- */
-
- if (IsRootClass(oPtr) && !Deleted(fPtr->objectCls->thisPtr)) {
- Tcl_DeleteCommandFromToken(interp, fPtr->objectCls->thisPtr->command);
- }
-
- /*
* Squelch method implementation chain caches.
*/
@@ -1054,6 +1045,7 @@ ReleaseClassContents(
TclDecrRefCount(filterObj);
}
ckfree(clsPtr->filters.list);
+ clsPtr->filters.list = NULL;
clsPtr->filters.num = 0;
}
@@ -1073,8 +1065,25 @@ ReleaseClassContents(
clsPtr->metadataPtr = NULL;
}
- ClearMixins(clsPtr);
- ClearSuperclasses(clsPtr);
+ if (clsPtr->mixins.num) {
+ FOREACH(tmpClsPtr, clsPtr->mixins) {
+ TclOORemoveFromMixinSubs(clsPtr, tmpClsPtr);
+ TclOODecrRefCount(tmpClsPtr->thisPtr);
+ }
+ ckfree(clsPtr->mixins.list);
+ clsPtr->mixins.list = NULL;
+ clsPtr->mixins.num = 0;
+ }
+
+ if (clsPtr->superclasses.num > 0) {
+ FOREACH(tmpClsPtr, clsPtr->superclasses) {
+ TclOORemoveFromSubclasses(clsPtr, tmpClsPtr);
+ TclOODecrRefCount(tmpClsPtr->thisPtr);
+ }
+ ckfree(clsPtr->superclasses.list);
+ clsPtr->superclasses.num = 0;
+ clsPtr->superclasses.list = NULL;
+ }
FOREACH_HASH_VALUE(mPtr, &clsPtr->classMethods) {
TclOODelMethodRef(mPtr);
@@ -1090,12 +1099,9 @@ ReleaseClassContents(
ckfree(clsPtr->variables.list);
}
- /* Tell oPtr that it's class is gone so that it doesn't try to remove
- * itself from it's classe's list of instances
- */
- oPtr->flags |= CLASS_GONE;
- DelRef(clsPtr);
-
+ if (IsRootClass(oPtr) && !Deleted(fPtr->objectCls->thisPtr)) {
+ Tcl_DeleteCommandFromToken(interp, fPtr->objectCls->thisPtr->command);
+ }
}
/*
@@ -1123,13 +1129,29 @@ ObjectNamespaceDeleted(
Method *mPtr;
Tcl_Obj *filterObj, *variableObj;
Tcl_Interp *interp = oPtr->fPtr->interp;
- int finished = 0, i;
+ int i;
+ if (Deleted(oPtr)) {
+ /*
+ * TODO: Can ObjectNamespaceDeleted ever be called twice? If not, this
+ * guard could be removed.
+ */
- AddRef(fPtr->classCls);
- AddRef(fPtr->objectCls);
- AddRef(fPtr->classCls->thisPtr);
- AddRef(fPtr->objectCls->thisPtr);
+ return;
+ }
+
+ /*
+ * One rule for the teardown routines is that if an object is in the
+ * process of being deleted, nothing else may modify its bookeeping
+ * records. This is the flag that
+ */
+
+ oPtr->flags |= OBJECT_DELETED;
+
+ /* Let the dominoes fall */
+ if (oPtr->classPtr) {
+ DeleteDescendants(interp, oPtr);
+ }
/*
* We do not run destructors on the core class objects when the
@@ -1138,14 +1160,14 @@ ObjectNamespaceDeleted(
* of it have gone. [Bug 2949397]
*/
- if (!(oPtr->flags & DESTRUCTOR_CALLED) && !Tcl_InterpDeleted(interp)) {
+ if (!Tcl_InterpDeleted(interp) && !(oPtr->flags & DESTRUCTOR_CALLED)) {
CallContext *contextPtr =
TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL);
int result;
Tcl_InterpState state;
-
oPtr->flags |= DESTRUCTOR_CALLED;
+
if (contextPtr != NULL) {
contextPtr->callPtr->flags |= DESTRUCTOR;
contextPtr->skip = 0;
@@ -1167,7 +1189,7 @@ ObjectNamespaceDeleted(
* points into freed memory.
*/
- if ((((Command *)oPtr->command)->flags && CMD_IS_DELETED)) {
+ if (((Command *)oPtr->command)->flags && CMD_IS_DELETED) {
/*
* Something has already started the command deletion process. We can
* go ahead and clean up the the namespace,
@@ -1177,10 +1199,9 @@ ObjectNamespaceDeleted(
* The namespace must have been deleted directly. Delete the command
* as well.
*/
+
Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command);
- finished = 1;
}
- oPtr->command = NULL;
if (oPtr->myCommand) {
Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myCommand);
@@ -1191,16 +1212,17 @@ ObjectNamespaceDeleted(
* methods on the object.
*/
- if (!IsRootObject(oPtr) && !(oPtr->flags & CLASS_GONE)) {
- TclOORemoveFromInstances(oPtr, oPtr->selfCls);
- }
+ /*
+ * TODO: Should this be protected with a * !IsRoot() condition?
+ */
+
+ TclOORemoveFromInstances(oPtr, oPtr->selfCls);
- FOREACH(mixinPtr, oPtr->mixins) {
- if (mixinPtr && mixinPtr != oPtr->classPtr) {
+ if (oPtr->mixins.num > 0) {
+ FOREACH(mixinPtr, oPtr->mixins) {
TclOORemoveFromInstances(oPtr, mixinPtr);
+ TclOODecrRefCount(mixinPtr->thisPtr);
}
- }
- if (i) {
ckfree(oPtr->mixins.list);
}
@@ -1245,21 +1267,19 @@ ObjectNamespaceDeleted(
}
/*
- * Because an object can be a class that is an instance of itself, the
- * A class object's class structure should only be cleaned after most of
- * the cleanup on the object is done.
- */
-
-
- /*
+ * Because an object can be a class that is an instance of itself, the
+ * class object's class structure should only be cleaned after most of the
+ * cleanup on the object is done.
+ *
* The class of objects needs some special care; if it is deleted (and
* we're not killing the whole interpreter) we force the delete of the
* class of classes now as well. Due to the incestuous nature of those two
* classes, if one goes the other must too and yet the tangle can
* sometimes not go away automatically; we force it here. [Bug 2962664]
*/
- if (!Tcl_InterpDeleted(interp) && IsRootObject(oPtr)
- && !Deleted(fPtr->classCls->thisPtr)) {
+
+ if (IsRootObject(oPtr) && !Deleted(fPtr->classCls->thisPtr)
+ && !Tcl_InterpDeleted(interp)) {
Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command);
}
@@ -1267,30 +1287,43 @@ ObjectNamespaceDeleted(
ReleaseClassContents(interp, oPtr);
}
-
/*
* Delete the object structure itself.
*/
- oPtr->classPtr = NULL;
+ TclNsDecrRefCount((Namespace *)oPtr->namespacePtr);
oPtr->namespacePtr = NULL;
-
- DelRef(fPtr->classCls->thisPtr);
- DelRef(fPtr->objectCls->thisPtr);
- DelRef(fPtr->classCls);
- DelRef(fPtr->objectCls);
- if (finished) {
- /*
- * ObjectRenamedTrace called us, and not the other way around.
- */
- DelRef(oPtr);
- } else {
- /*
- * ObjectRenamedTrace will call DelRef(oPtr).
- */
- }
+ TclOODecrRefCount(oPtr->selfCls->thisPtr);
+ oPtr->selfCls = NULL;
+ TclOODecrRefCount(oPtr);
return;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODecrRefCount --
+ *
+ * Decrement the refcount of an object and deallocate storage then object
+ * is no longer referenced. Returns 1 if storage was deallocated, and 0
+ * otherwise.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODecrRefCount(
+ Object *oPtr)
+{
+ if (oPtr->refCount-- <= 1) {
+ if (oPtr->classPtr != NULL) {
+ ckfree(oPtr->classPtr);
+ }
+ ckfree(oPtr);
+ return 1;
+ }
+ return 0;
}
/*
@@ -1304,36 +1337,24 @@ ObjectNamespaceDeleted(
* ----------------------------------------------------------------------
*/
-void
+int
TclOORemoveFromInstances(
Object *oPtr, /* The instance to remove. */
Class *clsPtr) /* The class (possibly) containing the
* reference to the instance. */
{
- int i;
+ int i, res = 0;
Object *instPtr;
FOREACH(instPtr, clsPtr->instances) {
if (oPtr == instPtr) {
- goto removeInstance;
- }
- }
- return;
-
- removeInstance:
- if (Deleted(clsPtr->thisPtr)) {
- if (!IsRootClass(clsPtr)) {
- DelRef(clsPtr->instances.list[i]);
- }
- clsPtr->instances.list[i] = NULL;
- } else {
- clsPtr->instances.num--;
- if (i < clsPtr->instances.num) {
- clsPtr->instances.list[i] =
- clsPtr->instances.list[clsPtr->instances.num];
+ RemoveItem(Object, clsPtr->instances, i);
+ TclOODecrRefCount(oPtr);
+ res++;
+ break;
}
- clsPtr->instances.list[clsPtr->instances.num] = NULL;
}
+ return res;
}
/*
@@ -1354,9 +1375,6 @@ TclOOAddToInstances(
* assumed that the class is not already
* present as an instance in the class. */
{
- if (Deleted(clsPtr->thisPtr)) {
- return;
- }
if (clsPtr->instances.num >= clsPtr->instances.size) {
clsPtr->instances.size += ALLOC_CHUNK;
if (clsPtr->instances.size == ALLOC_CHUNK) {
@@ -1367,6 +1385,7 @@ TclOOAddToInstances(
}
}
clsPtr->instances.list[clsPtr->instances.num++] = oPtr;
+ AddRef(oPtr);
}
/*
@@ -1375,36 +1394,28 @@ TclOOAddToInstances(
* TclOORemoveFromSubclasses --
*
* Utility function to remove a class from the list of subclasses within
- * another class.
+ * another class. Returns the number of removals performed.
*
* ----------------------------------------------------------------------
*/
-void
+int
TclOORemoveFromSubclasses(
Class *subPtr, /* The subclass to remove. */
Class *superPtr) /* The superclass to possibly remove the
* subclass reference from. */
{
- int i;
+ int i, res = 0;
Class *subclsPtr;
FOREACH(subclsPtr, superPtr->subclasses) {
if (subPtr == subclsPtr) {
- goto removeSubclass;
- }
- }
- return;
-
- removeSubclass:
- if (!Deleted(superPtr->thisPtr)) {
- superPtr->subclasses.num--;
- if (i < superPtr->subclasses.num) {
- superPtr->subclasses.list[i] =
- superPtr->subclasses.list[superPtr->subclasses.num];
+ RemoveItem(Class, superPtr->subclasses, i);
+ TclOODecrRefCount(subPtr->thisPtr);
+ res++;
}
- superPtr->subclasses.list[superPtr->subclasses.num] = NULL;
}
+ return res;
}
/*
@@ -1431,13 +1442,14 @@ TclOOAddToSubclasses(
if (superPtr->subclasses.num >= superPtr->subclasses.size) {
superPtr->subclasses.size += ALLOC_CHUNK;
if (superPtr->subclasses.size == ALLOC_CHUNK) {
- superPtr->subclasses.list = ckalloc(sizeof(Class*) * ALLOC_CHUNK);
+ superPtr->subclasses.list = ckalloc(sizeof(Class *) * ALLOC_CHUNK);
} else {
superPtr->subclasses.list = ckrealloc(superPtr->subclasses.list,
sizeof(Class *) * superPtr->subclasses.size);
}
}
superPtr->subclasses.list[superPtr->subclasses.num++] = subPtr;
+ AddRef(subPtr->thisPtr);
}
/*
@@ -1451,31 +1463,24 @@ TclOOAddToSubclasses(
* ----------------------------------------------------------------------
*/
-void
+int
TclOORemoveFromMixinSubs(
Class *subPtr, /* The subclass to remove. */
Class *superPtr) /* The superclass to possibly remove the
* subclass reference from. */
{
- int i;
+ int i, res = 0;
Class *subclsPtr;
FOREACH(subclsPtr, superPtr->mixinSubs) {
if (subPtr == subclsPtr) {
- goto removeSubclass;
- }
- }
- return;
-
- removeSubclass:
- if (!Deleted(superPtr->thisPtr)) {
- superPtr->mixinSubs.num--;
- if (i < superPtr->mixinSubs.num) {
- superPtr->mixinSubs.list[i] =
- superPtr->mixinSubs.list[superPtr->mixinSubs.num];
+ RemoveItem(Class, superPtr->mixinSubs, i);
+ TclOODecrRefCount(subPtr->thisPtr);
+ res++;
+ break;
}
- superPtr->mixinSubs.list[superPtr->mixinSubs.num] = NULL;
}
+ return res;
}
/*
@@ -1509,6 +1514,7 @@ TclOOAddToMixinSubs(
}
}
superPtr->mixinSubs.list[superPtr->mixinSubs.num++] = subPtr;
+ AddRef(subPtr->thisPtr);
}
/*
@@ -1516,37 +1522,18 @@ TclOOAddToMixinSubs(
*
* AllocClass --
*
- * Allocate a basic class. Does not splice the class object into its
+ * Allocate a basic class. Does not add class to its
* class's instance list.
*
* ----------------------------------------------------------------------
*/
-static Class *
-AllocClass(
- Tcl_Interp *interp, /* Interpreter within which to allocate the
- * class. */
- Object *useThisObj) /* Object that is to act as the class
- * representation, or NULL if a new object
- * with automatic name is to be used. */
+static inline void
+InitClassPath(
+ Tcl_Interp *interp,
+ Class *clsPtr)
{
Foundation *fPtr = GetFoundation(interp);
- Class *clsPtr = ckalloc(sizeof(Class));
-
- /*
- * Make an object if we haven't been given one.
- */
-
- memset(clsPtr, 0, sizeof(Class));
- if (useThisObj == NULL) {
- clsPtr->thisPtr = AllocObject(interp, NULL, NULL, NULL);
- } else {
- clsPtr->thisPtr = useThisObj;
- }
-
- /*
- * Configure the namespace path for the class's object.
- */
if (fPtr->helpersNs != NULL) {
Tcl_Namespace *path[2];
@@ -1558,13 +1545,26 @@ AllocClass(
TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 1,
&fPtr->ooNs);
}
+}
+
+static Class *
+AllocClass(
+ Tcl_Interp *interp, /* Interpreter within which to allocate the
+ * class. */
+ Object *useThisObj) /* Object that is to act as the class
+ * representation. */
+{
+ Foundation *fPtr = GetFoundation(interp);
+ Class *clsPtr = ckalloc(sizeof(Class));
+
+ memset(clsPtr, 0, sizeof(Class));
+ clsPtr->thisPtr = useThisObj;
/*
- * Class objects inherit from the class of classes unless they inherit
- * from some subclass of it. Enforce this right now.
+ * Configure the namespace path for the class's object.
*/
- clsPtr->thisPtr->selfCls = fPtr->classCls;
+ InitClassPath(interp, clsPtr);
/*
* Classes are subclasses of oo::object, i.e. the objects they create are
@@ -1574,6 +1574,7 @@ AllocClass(
clsPtr->superclasses.num = 1;
clsPtr->superclasses.list = ckalloc(sizeof(Class *));
clsPtr->superclasses.list[0] = fPtr->objectCls;
+ AddRef(fPtr->objectCls->thisPtr);
/*
* Finish connecting the class structure to the object structure.
@@ -1586,7 +1587,6 @@ AllocClass(
* fields.
*/
- clsPtr->refCount = 1;
Tcl_InitObjHashTable(&clsPtr->classMethods);
return clsPtr;
}
@@ -1620,7 +1620,9 @@ Tcl_NewObjectInstance(
ClientData clientData[4];
oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr);
- if (oPtr == NULL) {return NULL;}
+ if (oPtr == NULL) {
+ return NULL;
+ }
/*
* Run constructors, except when objc < 0, which is a special flag case
@@ -1640,7 +1642,7 @@ Tcl_NewObjectInstance(
contextPtr->skip = skip;
/*
- * Adjust the ensmble tracking record if necessary. [Bug 3514761]
+ * Adjust the ensemble tracking record if necessary. [Bug 3514761]
*/
isRoot = TclInitRewriteEnsemble(interp, skip, skip, objv);
@@ -1656,7 +1658,6 @@ Tcl_NewObjectInstance(
clientData[2] = state;
clientData[3] = &oPtr;
- AddRef(oPtr);
result = FinalizeAlloc(clientData, interp, result);
if (result != TCL_OK) {
return NULL;
@@ -1690,7 +1691,9 @@ TclNRNewObjectInstance(
Object *oPtr;
oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr);
- if (oPtr == NULL) {return TCL_ERROR;}
+ if (oPtr == NULL) {
+ return TCL_ERROR;
+ }
/*
* Run constructors, except when objc < 0 (a special flag case used for
@@ -1723,7 +1726,6 @@ TclNRNewObjectInstance(
* Fire off the constructors non-recursively.
*/
- AddRef(oPtr);
TclNRAddCallback(interp, FinalizeAlloc, contextPtr, oPtr, state,
objectPtr);
TclPushTailcallPoint(interp);
@@ -1742,45 +1744,42 @@ TclNewObjectInstanceCommon(
Foundation *fPtr = GetFoundation(interp);
Object *oPtr;
const char *simpleName = NULL;
- Namespace *nsPtr = NULL, *dummy,
- *inNsPtr = (Namespace *)TclGetCurrentNamespace(interp);
+ Namespace *nsPtr = NULL, *dummy;
+ Namespace *inNsPtr = (Namespace *) TclGetCurrentNamespace(interp);
int isNew;
if (nameStr) {
- TclGetNamespaceForQualName(interp, nameStr, inNsPtr, TCL_CREATE_NS_IF_UNKNOWN,
- &nsPtr, &dummy, &dummy, &simpleName);
+ TclGetNamespaceForQualName(interp, nameStr, inNsPtr,
+ TCL_CREATE_NS_IF_UNKNOWN, &nsPtr, &dummy, &dummy, &simpleName);
/*
* Disallow creation of an object over an existing command.
*/
hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, simpleName, &isNew);
- if (isNew) {
- /* Just kidding */
- Tcl_DeleteHashEntry(hPtr);
- } else {
+ if (!isNew) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"can't create object \"%s\": command already exists with"
" that name", nameStr));
Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL);
return NULL;
}
+
+ /*
+ * We could make a hash entry! Don't actually want to do that here so
+ * nuke it immediately because we'll create it properly soon.
+ */
+
+ Tcl_DeleteHashEntry(hPtr);
}
/*
* Create the object.
*/
- /*
- * The command for the object could have the same name as the command
- * associated with classPtr, so protect the structure from deallocation
- * here.
- */
- AddRef(classPtr);
-
oPtr = AllocObject(interp, simpleName, nsPtr, nsNameStr);
- DelRef(classPtr);
oPtr->selfCls = classPtr;
+ AddRef(classPtr->thisPtr);
TclOOAddToInstances(oPtr, classPtr);
/*
@@ -1797,7 +1796,6 @@ TclNewObjectInstanceCommon(
*/
AllocClass(interp, oPtr);
- oPtr->selfCls = classPtr;
TclOOAddToSubclasses(oPtr->classPtr, fPtr->objectCls);
} else {
oPtr->classPtr = NULL;
@@ -1819,8 +1817,8 @@ FinalizeAlloc(
Tcl_Object *objectPtr = data[3];
/*
- * Ensure an error if the object was deleted in the constructor.
- * Don't want to lose errors by accident. [Bug 2903011]
+ * Ensure an error if the object was deleted in the constructor. Don't
+ * want to lose errors by accident. [Bug 2903011]
*/
if (result != TCL_ERROR && Deleted(oPtr)) {
@@ -1829,7 +1827,6 @@ FinalizeAlloc(
Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL);
result = TCL_ERROR;
}
- TclOODeleteContext(contextPtr);
if (result != TCL_OK) {
Tcl_DiscardInterpState(state);
@@ -1843,12 +1840,22 @@ FinalizeAlloc(
(void) TclOOObjectName(interp, oPtr);
Tcl_DeleteCommandFromToken(interp, oPtr->command);
}
- DelRef(oPtr);
+
+ /*
+ * This decrements the refcount of oPtr.
+ */
+
+ TclOODeleteContext(contextPtr);
return TCL_ERROR;
}
Tcl_RestoreInterpState(interp, state);
*objectPtr = (Tcl_Object) oPtr;
- DelRef(oPtr);
+
+ /*
+ * This decrements the refcount of oPtr.
+ */
+
+ TclOODeleteContext(contextPtr);
return TCL_OK;
}
@@ -1918,16 +1925,22 @@ Tcl_CopyObjectInstance(
* Copy the object's mixin references to the new object.
*/
- FOREACH(mixinPtr, o2Ptr->mixins) {
- if (mixinPtr && mixinPtr != o2Ptr->selfCls) {
- TclOORemoveFromInstances(o2Ptr, mixinPtr);
+ if (o2Ptr->mixins.num != 0) {
+ FOREACH(mixinPtr, o2Ptr->mixins) {
+ if (mixinPtr && mixinPtr != o2Ptr->selfCls) {
+ TclOORemoveFromInstances(o2Ptr, mixinPtr);
+ }
+ TclOODecrRefCount(mixinPtr->thisPtr);
}
+ ckfree(o2Ptr->mixins.list);
}
DUPLICATE(o2Ptr->mixins, oPtr->mixins, Class *);
FOREACH(mixinPtr, o2Ptr->mixins) {
if (mixinPtr && mixinPtr != o2Ptr->selfCls) {
TclOOAddToInstances(o2Ptr, mixinPtr);
}
+ /* For the reference just created in DUPLICATE */
+ AddRef(mixinPtr->thisPtr);
}
/*
@@ -1957,7 +1970,6 @@ Tcl_CopyObjectInstance(
o2Ptr->flags = oPtr->flags & ~(
OBJECT_DELETED | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING);
-
/*
* Copy the object's metadata.
*/
@@ -2006,6 +2018,7 @@ Tcl_CopyObjectInstance(
FOREACH(superPtr, cls2Ptr->superclasses) {
TclOORemoveFromSubclasses(cls2Ptr, superPtr);
+ TclOODecrRefCount(superPtr->thisPtr);
}
if (cls2Ptr->superclasses.num) {
cls2Ptr->superclasses.list = ckrealloc(cls2Ptr->superclasses.list,
@@ -2019,6 +2032,11 @@ Tcl_CopyObjectInstance(
cls2Ptr->superclasses.num = clsPtr->superclasses.num;
FOREACH(superPtr, cls2Ptr->superclasses) {
TclOOAddToSubclasses(cls2Ptr, superPtr);
+
+ /* For the new item in cls2Ptr->superclasses that memcpy just
+ * created
+ */
+ AddRef(superPtr->thisPtr);
}
/*
@@ -2044,15 +2062,18 @@ Tcl_CopyObjectInstance(
* references to the duplicate).
*/
- FOREACH(mixinPtr, cls2Ptr->mixins) {
- TclOORemoveFromMixinSubs(cls2Ptr, mixinPtr);
- }
if (cls2Ptr->mixins.num != 0) {
+ FOREACH(mixinPtr, cls2Ptr->mixins) {
+ TclOORemoveFromMixinSubs(cls2Ptr, mixinPtr);
+ TclOODecrRefCount(mixinPtr->thisPtr);
+ }
ckfree(clsPtr->mixins.list);
}
DUPLICATE(cls2Ptr->mixins, clsPtr->mixins, Class *);
FOREACH(mixinPtr, cls2Ptr->mixins) {
TclOOAddToMixinSubs(cls2Ptr, mixinPtr);
+ /* For the copy just created in DUPLICATE */
+ AddRef(mixinPtr->thisPtr);
}
/*
@@ -2969,7 +2990,7 @@ int
Tcl_ObjectDeleted(
Tcl_Object object)
{
- return Deleted(object) ? 1 : 0;
+ return ((Object *)object)->command == NULL;
}
Tcl_Object
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index b2c06a7..d874cba 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -1206,22 +1206,10 @@ TclOOCopyObjectCmd(
o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, NULL, NULL);
} else {
const char *name, *namespaceName;
- Tcl_DString buffer;
name = TclGetString(objv[2]);
- Tcl_DStringInit(&buffer);
if (name[0] == '\0') {
name = NULL;
- } else if (name[0]!=':' || name[1]!=':') {
- Interp *iPtr = (Interp *) interp;
-
- if (iPtr->varFramePtr != NULL) {
- Tcl_DStringAppend(&buffer,
- iPtr->varFramePtr->nsPtr->fullName, -1);
- }
- TclDStringAppendLiteral(&buffer, "::");
- Tcl_DStringAppend(&buffer, name, -1);
- name = Tcl_DStringValue(&buffer);
}
/*
@@ -1243,7 +1231,6 @@ TclOOCopyObjectCmd(
}
o2Ptr = Tcl_CopyObjectInstance(interp, oPtr, name, namespaceName);
- Tcl_DStringFree(&buffer);
}
if (o2Ptr == NULL) {
diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c
index d4e1e34..7da9da0 100644
--- a/generic/tclOOCall.c
+++ b/generic/tclOOCall.c
@@ -110,7 +110,12 @@ TclOODeleteContext(
TclOODeleteChain(contextPtr->callPtr);
if (oPtr != NULL) {
TclStackFree(oPtr->fPtr->interp, contextPtr);
- DelRef(oPtr);
+
+ /*
+ * Corresponding AddRef() in TclOO.c/TclOOObjectCmdCore
+ */
+
+ TclOODecrRefCount(oPtr);
}
}
@@ -900,6 +905,7 @@ InitCallChain(
* ----------------------------------------------------------------------
*
* IsStillValid --
+ *
* Calculates whether the given call chain can be used for executing a
* method for the given object. The condition on a chain from a cached
* location being reusable is:
@@ -1171,6 +1177,11 @@ TclOOGetCallContext(
returnContext:
contextPtr = TclStackAlloc(oPtr->fPtr->interp, sizeof(CallContext));
contextPtr->oPtr = oPtr;
+
+ /*
+ * Corresponding TclOODecrRefCount() in TclOODeleteContext
+ */
+
AddRef(oPtr);
contextPtr->callPtr = callPtr;
contextPtr->skip = 2;
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index b0bfd9c..b443be8 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -123,6 +123,7 @@ static const struct DeclaredSlot slots[] = {
* ----------------------------------------------------------------------
*
* BumpGlobalEpoch --
+ *
* Utility that ensures that call chains that are invalid will get thrown
* away at an appropriate time. Note that exactly which epoch gets
* advanced will depend on exactly what the class is tangled up in; in
@@ -167,6 +168,7 @@ BumpGlobalEpoch(
* ----------------------------------------------------------------------
*
* RecomputeClassCacheFlag --
+ *
* Determine whether the object is prototypical of its class, and hence
* able to use the class's method chain cache.
*
@@ -189,6 +191,7 @@ RecomputeClassCacheFlag(
* ----------------------------------------------------------------------
*
* TclOOObjectSetFilters --
+ *
* Install a list of filter method names into an object.
*
* ----------------------------------------------------------------------
@@ -247,6 +250,7 @@ TclOOObjectSetFilters(
* ----------------------------------------------------------------------
*
* TclOOClassSetFilters --
+ *
* Install a list of filter method names into a class.
*
* ----------------------------------------------------------------------
@@ -309,6 +313,7 @@ TclOOClassSetFilters(
* ----------------------------------------------------------------------
*
* TclOOObjectSetMixins --
+ *
* Install a list of mixin classes into an object.
*
* ----------------------------------------------------------------------
@@ -326,9 +331,8 @@ TclOOObjectSetMixins(
if (numMixins == 0) {
if (oPtr->mixins.num != 0) {
FOREACH(mixinPtr, oPtr->mixins) {
- if (mixinPtr) {
- TclOORemoveFromInstances(oPtr, mixinPtr);
- }
+ TclOORemoveFromInstances(oPtr, mixinPtr);
+ TclOODecrRefCount(mixinPtr->thisPtr);
}
ckfree(oPtr->mixins.list);
oPtr->mixins.num = 0;
@@ -340,6 +344,7 @@ TclOOObjectSetMixins(
if (mixinPtr && mixinPtr != oPtr->selfCls) {
TclOORemoveFromInstances(oPtr, mixinPtr);
}
+ TclOODecrRefCount(mixinPtr->thisPtr);
}
oPtr->mixins.list = ckrealloc(oPtr->mixins.list,
sizeof(Class *) * numMixins);
@@ -352,6 +357,8 @@ TclOOObjectSetMixins(
FOREACH(mixinPtr, oPtr->mixins) {
if (mixinPtr != oPtr->selfCls) {
TclOOAddToInstances(oPtr, mixinPtr);
+ /* For the new copy created by memcpy */
+ AddRef(mixinPtr->thisPtr);
}
}
}
@@ -362,6 +369,7 @@ TclOOObjectSetMixins(
* ----------------------------------------------------------------------
*
* TclOOClassSetMixins --
+ *
* Install a list of mixin classes into a class.
*
* ----------------------------------------------------------------------
@@ -381,6 +389,7 @@ TclOOClassSetMixins(
if (classPtr->mixins.num != 0) {
FOREACH(mixinPtr, classPtr->mixins) {
TclOORemoveFromMixinSubs(classPtr, mixinPtr);
+ TclOODecrRefCount(mixinPtr->thisPtr);
}
ckfree(classPtr->mixins.list);
classPtr->mixins.num = 0;
@@ -389,6 +398,7 @@ TclOOClassSetMixins(
if (classPtr->mixins.num != 0) {
FOREACH(mixinPtr, classPtr->mixins) {
TclOORemoveFromMixinSubs(classPtr, mixinPtr);
+ TclOODecrRefCount(mixinPtr->thisPtr);
}
classPtr->mixins.list = ckrealloc(classPtr->mixins.list,
sizeof(Class *) * numMixins);
@@ -399,6 +409,8 @@ TclOOClassSetMixins(
memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins);
FOREACH(mixinPtr, classPtr->mixins) {
TclOOAddToMixinSubs(classPtr, mixinPtr);
+ /* For the new copy created by memcpy */
+ AddRef(mixinPtr->thisPtr);
}
}
BumpGlobalEpoch(interp, classPtr);
@@ -408,6 +420,7 @@ TclOOClassSetMixins(
* ----------------------------------------------------------------------
*
* RenameDeleteMethod --
+ *
* Core of the code to rename and delete methods.
*
* ----------------------------------------------------------------------
@@ -497,6 +510,7 @@ RenameDeleteMethod(
* ----------------------------------------------------------------------
*
* TclOOUnknownDefinition --
+ *
* Handles what happens when an unknown command is encountered during the
* processing of a definition script. Works by finding a command in the
* operating definition namespace that the requested command is a unique
@@ -575,6 +589,7 @@ TclOOUnknownDefinition(
* ----------------------------------------------------------------------
*
* FindCommand --
+ *
* Specialized version of Tcl_FindCommand that handles command prefixes
* and disallows namespace magic.
*
@@ -635,6 +650,7 @@ FindCommand(
* ----------------------------------------------------------------------
*
* InitDefineContext --
+ *
* Does the magic incantations necessary to push the special stack frame
* used when processing object definitions. It is up to the caller to
* dispose of the frame (with TclPopStackFrame) when finished.
@@ -660,7 +676,9 @@ InitDefineContext(
return TCL_ERROR;
}
- /* framePtrPtr is needed to satisfy GCC 3.3's strict aliasing rules */
+ /*
+ * framePtrPtr is needed to satisfy GCC 3.3's strict aliasing rules.
+ */
(void) TclPushStackFrame(interp, (Tcl_CallFrame **) framePtrPtr,
namespacePtr, FRAME_IS_OO_DEFINE);
@@ -675,6 +693,7 @@ InitDefineContext(
* ----------------------------------------------------------------------
*
* TclOOGetDefineCmdContext --
+ *
* Extracts the magic token from the current stack frame, or returns NULL
* (and leaves an error message) otherwise.
*
@@ -711,6 +730,7 @@ TclOOGetDefineCmdContext(
* ----------------------------------------------------------------------
*
* GetClassInOuterContext --
+ *
* Wrapper round Tcl_GetObjectFromObj to perform the lookup in the
* context that called oo::define (or equivalent). Note that this may
* have to go up multiple levels to get the level that we started doing
@@ -753,6 +773,7 @@ GetClassInOuterContext(
* ----------------------------------------------------------------------
*
* GenerateErrorInfo --
+ *
* Factored out code to generate part of the error trace messages.
*
* ----------------------------------------------------------------------
@@ -791,6 +812,7 @@ GenerateErrorInfo(
* ----------------------------------------------------------------------
*
* MagicDefinitionInvoke --
+ *
* Part of the implementation of the "oo::define" and "oo::objdefine"
* commands that is used to implement the more-than-one-argument case,
* applying ensemble-like tricks with dispatch so that error messages are
@@ -854,6 +876,7 @@ MagicDefinitionInvoke(
* ----------------------------------------------------------------------
*
* TclOODefineObjCmd --
+ *
* Implementation of the "oo::define" command. Works by effectively doing
* the same as 'namespace eval', but with extra magic applied so that the
* object to be modified is known to the commands in the target
@@ -914,7 +937,7 @@ TclOODefineObjCmd(
} else {
result = MagicDefinitionInvoke(interp, fPtr->defineNs, 2, objc, objv);
}
- DelRef(oPtr);
+ TclOODecrRefCount(oPtr);
/*
* Restore the previous "current" namespace.
@@ -928,6 +951,7 @@ TclOODefineObjCmd(
* ----------------------------------------------------------------------
*
* TclOOObjDefObjCmd --
+ *
* Implementation of the "oo::objdefine" command. Works by effectively
* doing the same as 'namespace eval', but with extra magic applied so
* that the object to be modified is known to the commands in the target
@@ -981,7 +1005,7 @@ TclOOObjDefObjCmd(
} else {
result = MagicDefinitionInvoke(interp, fPtr->objdefNs, 2, objc, objv);
}
- DelRef(oPtr);
+ TclOODecrRefCount(oPtr);
/*
* Restore the previous "current" namespace.
@@ -995,6 +1019,7 @@ TclOOObjDefObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineSelfObjCmd --
+ *
* Implementation of the "self" subcommand of the "oo::define" command.
* Works by effectively doing the same as 'namespace eval', but with
* extra magic applied so that the object to be modified is known to the
@@ -1048,7 +1073,7 @@ TclOODefineSelfObjCmd(
} else {
result = MagicDefinitionInvoke(interp, fPtr->objdefNs, 1, objc, objv);
}
- DelRef(oPtr);
+ TclOODecrRefCount(oPtr);
/*
* Restore the previous "current" namespace.
@@ -1062,6 +1087,7 @@ TclOODefineSelfObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineObjSelfObjCmd --
+ *
* Implementation of the "self" subcommand of the "oo::objdefine"
* command.
*
@@ -1095,6 +1121,7 @@ TclOODefineObjSelfObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineClassObjCmd --
+ *
* Implementation of the "class" subcommand of the "oo::objdefine"
* command.
*
@@ -1110,7 +1137,6 @@ TclOODefineClassObjCmd(
{
Object *oPtr;
Class *clsPtr;
- Foundation *fPtr = TclOOGetFoundation(interp);
/*
* Parse the context to get the object to operate on.
@@ -1147,20 +1173,6 @@ TclOODefineClassObjCmd(
return TCL_ERROR;
}
- /*
- * Apply semantic checks. In particular, classes and non-classes are not
- * interchangable (too complicated to do the conversion!) so we must
- * produce an error if any attempt is made to swap from one to the other.
- */
-
- if ((oPtr->classPtr==NULL) == TclOOIsReachable(fPtr->classCls, clsPtr)) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "may not change a %sclass object into a %sclass object",
- (oPtr->classPtr==NULL ? "non-" : ""),
- (oPtr->classPtr==NULL ? "" : "non-")));
- Tcl_SetErrorCode(interp, "TCL", "OO", "TRANSMUTATION", NULL);
- return TCL_ERROR;
- }
/*
* Set the object's class.
@@ -1168,11 +1180,11 @@ TclOODefineClassObjCmd(
if (oPtr->selfCls != clsPtr) {
TclOORemoveFromInstances(oPtr, oPtr->selfCls);
+ TclOODecrRefCount(oPtr->selfCls->thisPtr);
oPtr->selfCls = clsPtr;
+ AddRef(oPtr->selfCls->thisPtr);
TclOOAddToInstances(oPtr, oPtr->selfCls);
- if (!(clsPtr->thisPtr->flags & OBJECT_DELETED)) {
- oPtr->flags &= ~CLASS_GONE;
- }
+
if (oPtr->classPtr != NULL) {
BumpGlobalEpoch(interp, oPtr->classPtr);
} else {
@@ -1186,6 +1198,7 @@ TclOODefineClassObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineConstructorObjCmd --
+ *
* Implementation of the "constructor" subcommand of the "oo::define"
* command.
*
@@ -1254,6 +1267,7 @@ TclOODefineConstructorObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineDeleteMethodObjCmd --
+ *
* Implementation of the "deletemethod" subcommand of the "oo::define"
* and "oo::objdefine" commands.
*
@@ -1310,6 +1324,7 @@ TclOODefineDeleteMethodObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineDestructorObjCmd --
+ *
* Implementation of the "destructor" subcommand of the "oo::define"
* command.
*
@@ -1374,6 +1389,7 @@ TclOODefineDestructorObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineExportObjCmd --
+ *
* Implementation of the "export" subcommand of the "oo::define" and
* "oo::objdefine" commands.
*
@@ -1468,6 +1484,7 @@ TclOODefineExportObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineForwardObjCmd --
+ *
* Implementation of the "forward" subcommand of the "oo::define" and
* "oo::objdefine" commands.
*
@@ -1528,6 +1545,7 @@ TclOODefineForwardObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineMethodObjCmd --
+ *
* Implementation of the "method" subcommand of the "oo::define" and
* "oo::objdefine" commands.
*
@@ -1585,6 +1603,7 @@ TclOODefineMethodObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineMixinObjCmd --
+ *
* Implementation of the "mixin" subcommand of the "oo::define" and
* "oo::objdefine" commands.
*
@@ -1648,6 +1667,7 @@ TclOODefineMixinObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineRenameMethodObjCmd --
+ *
* Implementation of the "renamemethod" subcommand of the "oo::define"
* and "oo::objdefine" commands.
*
@@ -1704,6 +1724,7 @@ TclOODefineRenameMethodObjCmd(
* ----------------------------------------------------------------------
*
* TclOODefineUnexportObjCmd --
+ *
* Implementation of the "unexport" subcommand of the "oo::define" and
* "oo::objdefine" commands.
*
@@ -1798,6 +1819,7 @@ TclOODefineUnexportObjCmd(
* ----------------------------------------------------------------------
*
* Tcl_ClassSetConstructor, Tcl_ClassSetDestructor --
+ *
* How to install a constructor or destructor into a class; API to call
* from C.
*
@@ -1852,6 +1874,7 @@ Tcl_ClassSetDestructor(
* ----------------------------------------------------------------------
*
* TclOODefineSlots --
+ *
* Create the "::oo::Slot" class and its standard instances. Class
* definition is empty at the stage (added by scripting).
*
@@ -1895,6 +1918,7 @@ TclOODefineSlots(
* ----------------------------------------------------------------------
*
* ClassFilterGet, ClassFilterSet --
+ *
* Implementation of the "filter" slot accessors of the "oo::define"
* command.
*
@@ -1974,6 +1998,7 @@ ClassFilterSet(
* ----------------------------------------------------------------------
*
* ClassMixinGet, ClassMixinSet --
+ *
* Implementation of the "mixin" slot accessors of the "oo::define"
* command.
*
@@ -2055,6 +2080,7 @@ ClassMixinSet(
mixins[i] = GetClassInOuterContext(interp, mixinv[i],
"may only mix in classes");
if (mixins[i] == NULL) {
+ i--;
goto freeAndError;
}
if (TclOOIsReachable(oPtr->classPtr, mixins[i])) {
@@ -2078,6 +2104,7 @@ ClassMixinSet(
* ----------------------------------------------------------------------
*
* ClassSuperGet, ClassSuperSet --
+ *
* Implementation of the "superclass" slot accessors of the "oo::define"
* command.
*
@@ -2172,16 +2199,19 @@ ClassSuperSet(
if (superc == 0) {
superclasses = ckrealloc(superclasses, sizeof(Class *));
- superclasses[0] = oPtr->fPtr->objectCls;
- superc = 1;
if (TclOOIsReachable(oPtr->fPtr->classCls, oPtr->classPtr)) {
superclasses[0] = oPtr->fPtr->classCls;
+ } else {
+ superclasses[0] = oPtr->fPtr->objectCls;
}
+ superc = 1;
+ AddRef(superclasses[0]->thisPtr);
} else {
for (i=0 ; i<superc ; i++) {
superclasses[i] = GetClassInOuterContext(interp, superv[i],
"only a class can be a superclass");
if (superclasses[i] == NULL) {
+ i--;
goto failedAfterAlloc;
}
for (j=0 ; j<i ; j++) {
@@ -2198,9 +2228,19 @@ ClassSuperSet(
"attempt to form circular dependency graph", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", NULL);
failedAfterAlloc:
+ for (; i > 0; i--) {
+ TclOODecrRefCount(superclasses[i]->thisPtr);
+ }
ckfree(superclasses);
return TCL_ERROR;
}
+
+ /*
+ * Corresponding TclOODecrRefCount() is near the end of this
+ * function.
+ */
+
+ AddRef(superclasses[i]->thisPtr);
}
}
@@ -2214,6 +2254,7 @@ ClassSuperSet(
if (oPtr->classPtr->superclasses.num != 0) {
FOREACH(superPtr, oPtr->classPtr->superclasses) {
TclOORemoveFromSubclasses(oPtr->classPtr, superPtr);
+ TclOODecrRefCount(superPtr->thisPtr);
}
ckfree(oPtr->classPtr->superclasses.list);
}
@@ -2231,6 +2272,7 @@ ClassSuperSet(
* ----------------------------------------------------------------------
*
* ClassVarsGet, ClassVarsSet --
+ *
* Implementation of the "variable" slot accessors of the "oo::define"
* command.
*
@@ -2373,6 +2415,7 @@ ClassVarsSet(
* ----------------------------------------------------------------------
*
* ObjectFilterGet, ObjectFilterSet --
+ *
* Implementation of the "filter" slot accessors of the "oo::objdefine"
* command.
*
@@ -2440,6 +2483,7 @@ ObjFilterSet(
* ----------------------------------------------------------------------
*
* ObjectMixinGet, ObjectMixinSet --
+ *
* Implementation of the "mixin" slot accessors of the "oo::objdefine"
* command.
*
@@ -2525,6 +2569,7 @@ ObjMixinSet(
* ----------------------------------------------------------------------
*
* ObjectVarsGet, ObjectVarsSet --
+ *
* Implementation of the "variable" slot accessors of the "oo::objdefine"
* command.
*
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index 83b4d58..084c026 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -193,9 +193,10 @@ typedef struct Object {
* destroyed. */
#define DESTRUCTOR_CALLED 2 /* Flag to say that the destructor has been
* called. */
-#define CLASS_GONE 4 /* Indicates that the class of this object has
- * been deleted, and so the object should not
- * attempt to remove itself from its class. */
+#define CLASS_GONE 4 /* Obsolete. Indicates that the class of this
+ * object has been deleted, and so the object
+ * should not attempt to remove itself from its
+ * class. */
#define ROOT_OBJECT 0x1000 /* Flag to say that this object is the root of
* the class hierarchy and should be treated
* specially during teardown. */
@@ -222,10 +223,6 @@ typedef struct Object {
typedef struct Class {
Object *thisPtr; /* Reference to the object associated with
* this class. */
- int refCount; /* Number of strong references to this class.
- * Weak references are not counted; the
- * purpose of this is to avoid Tcl_Preserve as
- * that is quite slow. */
int flags; /* Assorted flags. */
LIST_STATIC(struct Class *) superclasses;
/* List of superclasses, used for generation
@@ -499,6 +496,7 @@ MODULE_SCOPE Object * TclNewObjectInstanceCommon(Tcl_Interp *interp,
Class *classPtr,
const char *nameStr,
const char *nsNameStr);
+MODULE_SCOPE int TclOODecrRefCount(Object *oPtr);
MODULE_SCOPE int TclOODefineSlots(Foundation *fPtr);
MODULE_SCOPE void TclOODeleteChain(CallChain *callPtr);
MODULE_SCOPE void TclOODeleteChainCache(Tcl_HashTable *tablePtr);
@@ -528,10 +526,10 @@ MODULE_SCOPE int TclNRObjectContextInvokeNext(Tcl_Interp *interp,
MODULE_SCOPE void TclOONewBasicMethod(Tcl_Interp *interp, Class *clsPtr,
const DeclaredClassMethod *dcm);
MODULE_SCOPE Tcl_Obj * TclOOObjectName(Tcl_Interp *interp, Object *oPtr);
-MODULE_SCOPE void TclOORemoveFromInstances(Object *oPtr, Class *clsPtr);
-MODULE_SCOPE void TclOORemoveFromMixinSubs(Class *subPtr,
+MODULE_SCOPE int TclOORemoveFromInstances(Object *oPtr, Class *clsPtr);
+MODULE_SCOPE int TclOORemoveFromMixinSubs(Class *subPtr,
Class *mixinPtr);
-MODULE_SCOPE void TclOORemoveFromSubclasses(Class *subPtr,
+MODULE_SCOPE int TclOORemoveFromSubclasses(Class *subPtr,
Class *superPtr);
MODULE_SCOPE Tcl_Obj * TclOORenderCallChain(Tcl_Interp *interp,
CallChain *callPtr);
@@ -546,18 +544,21 @@ MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr);
#include "tclOOIntDecls.h"
/*
+ * Alternatives to Tcl_Preserve/Tcl_EventuallyFree/Tcl_Release.
+ */
+
+#define AddRef(ptr) ((ptr)->refCount++)
+
+/*
* A convenience macro for iterating through the lists used in the internal
- * memory management of objects. This is a bit gnarly because we want to do
- * the assignment of the picked-out value only when the body test succeeds,
- * but we cannot rely on the assigned value being useful, forcing us to do
- * some nasty stuff with the comma operator. The compiler's optimizer should
- * be able to sort it all out!
- *
+ * memory management of objects.
* REQUIRES DECLARATION: int i;
*/
#define FOREACH(var,ary) \
- for(i=0 ; (i<(ary).num?((var=(ary).list[i]),1):0) ; i++)
+ for(i=0 ; i<(ary).num; i++) if ((ary).list[i] == NULL) { \
+ continue; \
+ } else if (var = (ary).list[i], 1)
/*
* Convenience macros for iterating through hash tables. FOREACH_HASH_DECLS
@@ -592,17 +593,6 @@ MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr);
} \
} while(0)
-/*
- * Alternatives to Tcl_Preserve/Tcl_EventuallyFree/Tcl_Release.
- */
-
-#define AddRef(ptr) ((ptr)->refCount++)
-#define DelRef(ptr) do { \
- if ((ptr)->refCount-- <= 1) { \
- ckfree(ptr); \
- } \
- } while(0)
-
#endif /* TCL_OO_INTERNAL_H */
/*
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 4ec0a57..7b9488e 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -210,9 +210,8 @@ static int SetDoubleFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static int SetIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
static void UpdateStringOfDouble(Tcl_Obj *objPtr);
static void UpdateStringOfInt(Tcl_Obj *objPtr);
-#ifndef TCL_WIDE_INT_IS_LONG
-static void UpdateStringOfWideInt(Tcl_Obj *objPtr);
-static int SetWideIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 && !defined(TCL_WIDE_INT_IS_LONG)
+static void UpdateStringOfOldInt(Tcl_Obj *objPtr);
#endif
static void FreeBignum(Tcl_Obj *objPtr);
static void DupBignum(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);
@@ -242,6 +241,7 @@ static int SetCmdNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
* implementations.
*/
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
static const Tcl_ObjType oldBooleanType = {
"boolean", /* name */
NULL, /* freeIntRepProc */
@@ -249,6 +249,7 @@ static const Tcl_ObjType oldBooleanType = {
NULL, /* updateStringProc */
TclSetBooleanFromAny /* setFromAnyProc */
};
+#endif
const Tcl_ObjType tclBooleanType = {
"booleanString", /* name */
NULL, /* freeIntRepProc */
@@ -264,19 +265,23 @@ const Tcl_ObjType tclDoubleType = {
SetDoubleFromAny /* setFromAnyProc */
};
const Tcl_ObjType tclIntType = {
+#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 || defined(TCL_WIDE_INT_IS_LONG)
"int", /* name */
+#else
+ "wideInt", /* name, keeping maximum compatibility with Tcl 8.6 on 32-bit platforms*/
+#endif
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
UpdateStringOfInt, /* updateStringProc */
SetIntFromAny /* setFromAnyProc */
};
-#ifndef TCL_WIDE_INT_IS_LONG
-const Tcl_ObjType tclWideIntType = {
- "wideInt", /* name */
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 && !defined(TCL_WIDE_INT_IS_LONG)
+static const Tcl_ObjType oldIntType = {
+ "int", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
- UpdateStringOfWideInt, /* updateStringProc */
- SetWideIntFromAny /* setFromAnyProc */
+ UpdateStringOfOldInt, /* updateStringProc */
+ SetIntFromAny /* setFromAnyProc */
};
#endif
const Tcl_ObjType tclBignumType = {
@@ -395,8 +400,6 @@ TclInitObjSubsystem(void)
Tcl_RegisterObjType(&tclByteArrayType);
Tcl_RegisterObjType(&tclDoubleType);
- Tcl_RegisterObjType(&tclEndOffsetType);
- Tcl_RegisterObjType(&tclIntType);
Tcl_RegisterObjType(&tclStringType);
Tcl_RegisterObjType(&tclListType);
Tcl_RegisterObjType(&tclDictType);
@@ -406,9 +409,12 @@ TclInitObjSubsystem(void)
Tcl_RegisterObjType(&tclProcBodyType);
/* For backward compatibility only ... */
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
+ Tcl_RegisterObjType(&tclIntType);
+#if !defined(TCL_WIDE_INT_IS_LONG)
+ Tcl_RegisterObjType(&oldIntType);
+#endif
Tcl_RegisterObjType(&oldBooleanType);
-#ifndef TCL_WIDE_INT_IS_LONG
- Tcl_RegisterObjType(&tclWideIntType);
#endif
#ifdef TCL_COMPILE_STATS
@@ -1762,7 +1768,7 @@ Tcl_NewBooleanObj(
{
register Tcl_Obj *objPtr;
- TclNewLongObj(objPtr, boolValue!=0);
+ TclNewIntObj(objPtr, boolValue!=0);
return objPtr;
}
#endif /* TCL_MEM_DEBUG */
@@ -1810,7 +1816,7 @@ Tcl_DbNewBooleanObj(
TclDbNewObj(objPtr, file, line);
objPtr->bytes = NULL;
- objPtr->internalRep.longValue = (boolValue != 0);
+ objPtr->internalRep.wideValue = (boolValue != 0);
objPtr->typePtr = &tclIntType;
return objPtr;
}
@@ -1857,7 +1863,7 @@ Tcl_SetBooleanObj(
Tcl_Panic("%s called with shared object", "Tcl_SetBooleanObj");
}
- TclSetLongObj(objPtr, boolValue!=0);
+ TclSetIntObj(objPtr, boolValue!=0);
}
#endif /* TCL_NO_DEPRECATED */
@@ -1888,11 +1894,11 @@ Tcl_GetBooleanFromObj(
{
do {
if (objPtr->typePtr == &tclIntType) {
- *boolPtr = (objPtr->internalRep.longValue != 0);
+ *boolPtr = (objPtr->internalRep.wideValue != 0);
return TCL_OK;
}
if (objPtr->typePtr == &tclBooleanType) {
- *boolPtr = (int) objPtr->internalRep.longValue;
+ *boolPtr = objPtr->internalRep.longValue != 0;
return TCL_OK;
}
if (objPtr->typePtr == &tclDoubleType) {
@@ -1916,12 +1922,6 @@ Tcl_GetBooleanFromObj(
*boolPtr = 1;
return TCL_OK;
}
-#ifndef TCL_WIDE_INT_IS_LONG
- if (objPtr->typePtr == &tclWideIntType) {
- *boolPtr = (objPtr->internalRep.wideValue != 0);
- return TCL_OK;
- }
-#endif
} while ((ParseBoolean(objPtr) == TCL_OK) || (TCL_OK ==
TclParseNumber(interp, objPtr, "boolean value", NULL,-1,NULL,0)));
return TCL_ERROR;
@@ -1942,7 +1942,12 @@ Tcl_GetBooleanFromObj(
*
* Side effects:
* If no error occurs, an integer 1 or 0 is stored as "objPtr"s internal
- * representation and the type of "objPtr" is set to boolean.
+ * representation and the type of "objPtr" is set to boolean or int/wideInt.
+ *
+ * Warning: If the returned type is "wideInt" (32-bit platforms) and your
+ * platform is bigendian, you cannot use internalRep.longValue to distinguish
+ * between false and true. On Windows and most other platforms this still will
+ * work fine, but basically it is non-portable.
*
*----------------------------------------------------------------------
*/
@@ -1960,8 +1965,7 @@ TclSetBooleanFromAny(
if (objPtr->bytes == NULL) {
if (objPtr->typePtr == &tclIntType) {
- switch (objPtr->internalRep.longValue) {
- case 0L: case 1L:
+ if ((Tcl_WideUInt)objPtr->internalRep.wideValue < 2) {
return TCL_OK;
}
goto badBoolean;
@@ -1971,12 +1975,6 @@ TclSetBooleanFromAny(
goto badBoolean;
}
-#ifndef TCL_WIDE_INT_IS_LONG
- if (objPtr->typePtr == &tclWideIntType) {
- goto badBoolean;
- }
-#endif
-
if (objPtr->typePtr == &tclDoubleType) {
goto badBoolean;
}
@@ -2113,7 +2111,7 @@ ParseBoolean(
numericBoolean:
TclFreeIntRep(objPtr);
- objPtr->internalRep.longValue = newBool;
+ objPtr->internalRep.wideValue = newBool;
objPtr->typePtr = &tclIntType;
return TCL_OK;
}
@@ -2294,7 +2292,7 @@ Tcl_GetDoubleFromObj(
return TCL_OK;
}
if (objPtr->typePtr == &tclIntType) {
- *dblPtr = objPtr->internalRep.longValue;
+ *dblPtr = (double) objPtr->internalRep.wideValue;
return TCL_OK;
}
if (objPtr->typePtr == &tclBignumType) {
@@ -2304,12 +2302,6 @@ Tcl_GetDoubleFromObj(
*dblPtr = TclBignumToDouble(&big);
return TCL_OK;
}
-#ifndef TCL_WIDE_INT_IS_LONG
- if (objPtr->typePtr == &tclWideIntType) {
- *dblPtr = (double) objPtr->internalRep.wideValue;
- return TCL_OK;
- }
-#endif
} while (SetDoubleFromAny(interp, objPtr) == TCL_OK);
return TCL_ERROR;
}
@@ -2427,7 +2419,7 @@ Tcl_NewIntObj(
{
register Tcl_Obj *objPtr;
- TclNewLongObj(objPtr, intValue);
+ TclNewIntObj(objPtr, intValue);
return objPtr;
}
#endif /* if TCL_MEM_DEBUG */
@@ -2460,7 +2452,7 @@ Tcl_SetIntObj(
Tcl_Panic("%s called with shared object", "Tcl_SetIntObj");
}
- TclSetLongObj(objPtr, intValue);
+ TclSetIntObj(objPtr, intValue);
}
/*
@@ -2538,9 +2530,8 @@ SetIntFromAny(
Tcl_Interp *interp, /* Tcl interpreter */
Tcl_Obj *objPtr) /* Pointer to the object to convert */
{
- long l;
-
- return TclGetLongFromObj(interp, objPtr, &l);
+ Tcl_WideInt w;
+ return Tcl_GetWideIntFromObj(interp, objPtr, &w);
}
/*
@@ -2569,12 +2560,28 @@ UpdateStringOfInt(
char buffer[TCL_INTEGER_SPACE];
register int len;
+ len = TclFormatInt(buffer, objPtr->internalRep.wideValue);
+
+ objPtr->bytes = ckalloc(len + 1);
+ memcpy(objPtr->bytes, buffer, (unsigned) len + 1);
+ objPtr->length = len;
+}
+
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 && !defined(TCL_WIDE_INT_IS_LONG)
+static void
+UpdateStringOfOldInt(
+ register Tcl_Obj *objPtr) /* Int object whose string rep to update. */
+{
+ char buffer[TCL_INTEGER_SPACE];
+ register int len;
+
len = TclFormatInt(buffer, objPtr->internalRep.longValue);
objPtr->bytes = ckalloc(len + 1);
memcpy(objPtr->bytes, buffer, (unsigned) len + 1);
objPtr->length = len;
}
+#endif
/*
*----------------------------------------------------------------------
@@ -2606,8 +2613,8 @@ UpdateStringOfInt(
*----------------------------------------------------------------------
*/
-#ifdef TCL_MEM_DEBUG
#undef Tcl_NewLongObj
+#ifdef TCL_MEM_DEBUG
Tcl_Obj *
Tcl_NewLongObj(
@@ -2626,7 +2633,7 @@ Tcl_NewLongObj(
{
register Tcl_Obj *objPtr;
- TclNewLongObj(objPtr, longValue);
+ TclNewIntObj(objPtr, longValue);
return objPtr;
}
#endif /* if TCL_MEM_DEBUG */
@@ -2663,6 +2670,7 @@ Tcl_NewLongObj(
*----------------------------------------------------------------------
*/
+#undef Tcl_DbNewLongObj
#ifdef TCL_MEM_DEBUG
Tcl_Obj *
@@ -2679,7 +2687,7 @@ Tcl_DbNewLongObj(
TclDbNewObj(objPtr, file, line);
objPtr->bytes = NULL;
- objPtr->internalRep.longValue = longValue;
+ objPtr->internalRep.wideValue = longValue;
objPtr->typePtr = &tclIntType;
return objPtr;
}
@@ -2717,6 +2725,7 @@ Tcl_DbNewLongObj(
*----------------------------------------------------------------------
*/
+#undef Tcl_SetLongObj
void
Tcl_SetLongObj(
register Tcl_Obj *objPtr, /* Object whose internal rep to init. */
@@ -2727,7 +2736,7 @@ Tcl_SetLongObj(
Tcl_Panic("%s called with shared object", "Tcl_SetLongObj");
}
- TclSetLongObj(objPtr, longValue);
+ TclSetIntObj(objPtr, longValue);
}
/*
@@ -2758,12 +2767,13 @@ Tcl_GetLongFromObj(
register long *longPtr) /* Place to store resulting long. */
{
do {
+#ifdef TCL_WIDE_INT_IS_LONG
if (objPtr->typePtr == &tclIntType) {
- *longPtr = objPtr->internalRep.longValue;
+ *longPtr = objPtr->internalRep.wideValue;
return TCL_OK;
}
-#ifndef TCL_WIDE_INT_IS_LONG
- if (objPtr->typePtr == &tclWideIntType) {
+#else
+ if (objPtr->typePtr == &tclIntType) {
/*
* We return any integer in the range -ULONG_MAX to ULONG_MAX
* converted to a long, ignoring overflow. The rule preserves
@@ -2836,49 +2846,6 @@ Tcl_GetLongFromObj(
TCL_PARSE_INTEGER_ONLY)==TCL_OK);
return TCL_ERROR;
}
-#ifndef TCL_WIDE_INT_IS_LONG
-
-/*
- *----------------------------------------------------------------------
- *
- * UpdateStringOfWideInt --
- *
- * Update the string representation for a wide integer object. Note: this
- * function does not free an existing old string rep so storage will be
- * lost if this has not already been done.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The object's string is set to a valid string that results from the
- * wideInt-to-string conversion.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-UpdateStringOfWideInt(
- register Tcl_Obj *objPtr) /* Int object whose string rep to update. */
-{
- char buffer[TCL_INTEGER_SPACE+2];
- register unsigned len;
- register Tcl_WideInt wideVal = objPtr->internalRep.wideValue;
-
- /*
- * Note that sprintf will generate a compiler warning under Mingw claiming
- * %I64 is an unknown format specifier. Just ignore this warning. We can't
- * use %L as the format specifier since that gets printed as a 32 bit
- * value.
- */
-
- sprintf(buffer, "%" TCL_LL_MODIFIER "d", wideVal);
- len = strlen(buffer);
- objPtr->bytes = ckalloc(len + 1);
- memcpy(objPtr->bytes, buffer, len + 1);
- objPtr->length = len;
-}
-#endif /* !TCL_WIDE_INT_IS_LONG */
/*
*----------------------------------------------------------------------
@@ -2928,7 +2895,7 @@ Tcl_NewWideIntObj(
register Tcl_Obj *objPtr;
TclNewObj(objPtr);
- Tcl_SetWideIntObj(objPtr, wideValue);
+ TclSetIntObj(objPtr, wideValue);
return objPtr;
}
#endif /* if TCL_MEM_DEBUG */
@@ -2980,7 +2947,7 @@ Tcl_DbNewWideIntObj(
register Tcl_Obj *objPtr;
TclDbNewObj(objPtr, file, line);
- Tcl_SetWideIntObj(objPtr, wideValue);
+ TclSetIntObj(objPtr, wideValue);
return objPtr;
}
@@ -3029,19 +2996,7 @@ Tcl_SetWideIntObj(
Tcl_Panic("%s called with shared object", "Tcl_SetWideIntObj");
}
- if ((wideValue >= (Tcl_WideInt) LONG_MIN)
- && (wideValue <= (Tcl_WideInt) LONG_MAX)) {
- TclSetLongObj(objPtr, (long) wideValue);
- } else {
-#ifndef TCL_WIDE_INT_IS_LONG
- TclSetWideIntObj(objPtr, wideValue);
-#else
- mp_int big;
-
- TclInitBignumFromWideInt(&big, wideValue);
- Tcl_SetBignumObj(objPtr, &big);
-#endif
- }
+ TclSetIntObj(objPtr, wideValue);
}
/*
@@ -3073,14 +3028,8 @@ Tcl_GetWideIntFromObj(
/* Place to store resulting long. */
{
do {
-#ifndef TCL_WIDE_INT_IS_LONG
- if (objPtr->typePtr == &tclWideIntType) {
- *wideIntPtr = objPtr->internalRep.wideValue;
- return TCL_OK;
- }
-#endif
if (objPtr->typePtr == &tclIntType) {
- *wideIntPtr = (Tcl_WideInt) objPtr->internalRep.longValue;
+ *wideIntPtr = objPtr->internalRep.wideValue;
return TCL_OK;
}
if (objPtr->typePtr == &tclDoubleType) {
@@ -3133,33 +3082,6 @@ Tcl_GetWideIntFromObj(
TCL_PARSE_INTEGER_ONLY)==TCL_OK);
return TCL_ERROR;
}
-#ifndef TCL_WIDE_INT_IS_LONG
-
-/*
- *----------------------------------------------------------------------
- *
- * SetWideIntFromAny --
- *
- * Attempts to force the internal representation for a Tcl object to
- * tclWideIntType, specifically.
- *
- * Results:
- * The return value is a standard object Tcl result. If an error occurs
- * during conversion, an error message is left in the interpreter's
- * result unless "interp" is NULL.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-SetWideIntFromAny(
- Tcl_Interp *interp, /* Tcl interpreter */
- Tcl_Obj *objPtr) /* Pointer to the object to convert */
-{
- Tcl_WideInt w;
- return Tcl_GetWideIntFromObj(interp, objPtr, &w);
-}
-#endif /* !TCL_WIDE_INT_IS_LONG */
/*
*----------------------------------------------------------------------
@@ -3402,16 +3324,10 @@ GetBignumFromObj(
return TCL_OK;
}
if (objPtr->typePtr == &tclIntType) {
- TclInitBignumFromLong(bignumValue, objPtr->internalRep.longValue);
- return TCL_OK;
- }
-#ifndef TCL_WIDE_INT_IS_LONG
- if (objPtr->typePtr == &tclWideIntType) {
TclInitBignumFromWideInt(bignumValue,
objPtr->internalRep.wideValue);
return TCL_OK;
}
-#endif
if (objPtr->typePtr == &tclDoubleType) {
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
@@ -3521,36 +3437,11 @@ Tcl_SetBignumObj(
Tcl_Panic("%s called with shared object", "Tcl_SetBignumObj");
}
if ((size_t) bignumValue->used
- <= (CHAR_BIT * sizeof(long) + DIGIT_BIT - 1) / DIGIT_BIT) {
- unsigned long value = 0, numBytes = sizeof(long);
- long scratch;
- unsigned char *bytes = (unsigned char *) &scratch;
-
- if (mp_to_unsigned_bin_n(bignumValue, bytes, &numBytes) != MP_OKAY) {
- goto tooLargeForLong;
- }
- while (numBytes-- > 0) {
- value = (value << CHAR_BIT) | *bytes++;
- }
- if (value > (((~(unsigned long)0) >> 1) + bignumValue->sign)) {
- goto tooLargeForLong;
- }
- if (bignumValue->sign) {
- TclSetLongObj(objPtr, -(long)value);
- } else {
- TclSetLongObj(objPtr, (long)value);
- }
- mp_clear(bignumValue);
- return;
- }
- tooLargeForLong:
-#ifndef TCL_WIDE_INT_IS_LONG
- if ((size_t) bignumValue->used
- <= (CHAR_BIT * sizeof(Tcl_WideInt) + DIGIT_BIT - 1) / DIGIT_BIT) {
+ <= (CHAR_BIT * sizeof(Tcl_WideUInt) + DIGIT_BIT - 1) / DIGIT_BIT) {
Tcl_WideUInt value = 0;
- unsigned long numBytes = sizeof(Tcl_WideInt);
- Tcl_WideInt scratch;
- unsigned char *bytes = (unsigned char *)&scratch;
+ unsigned long numBytes = sizeof(Tcl_WideUInt);
+ Tcl_WideUInt scratch;
+ unsigned char *bytes = (unsigned char *) &scratch;
if (mp_to_unsigned_bin_n(bignumValue, bytes, &numBytes) != MP_OKAY) {
goto tooLargeForWide;
@@ -3562,15 +3453,14 @@ Tcl_SetBignumObj(
goto tooLargeForWide;
}
if (bignumValue->sign) {
- TclSetWideIntObj(objPtr, -(Tcl_WideInt)value);
+ TclSetIntObj(objPtr, -(Tcl_WideInt)value);
} else {
- TclSetWideIntObj(objPtr, (Tcl_WideInt)value);
+ TclSetIntObj(objPtr, (Tcl_WideInt)value);
}
mp_clear(bignumValue);
return;
}
tooLargeForWide:
-#endif
TclInvalidateStringRep(objPtr);
TclFreeIntRep(objPtr);
TclSetBignumIntRep(objPtr, bignumValue);
@@ -3652,17 +3542,10 @@ TclGetNumberFromObj(
return TCL_OK;
}
if (objPtr->typePtr == &tclIntType) {
- *typePtr = TCL_NUMBER_LONG;
- *clientDataPtr = &objPtr->internalRep.longValue;
- return TCL_OK;
- }
-#ifndef TCL_WIDE_INT_IS_LONG
- if (objPtr->typePtr == &tclWideIntType) {
*typePtr = TCL_NUMBER_WIDE;
*clientDataPtr = &objPtr->internalRep.wideValue;
return TCL_OK;
}
-#endif
if (objPtr->typePtr == &tclBignumType) {
static Tcl_ThreadDataKey bignumKey;
mp_int *bigPtr = Tcl_GetThreadData(&bignumKey,
diff --git a/generic/tclPipe.c b/generic/tclPipe.c
index b679ec4..f94fe5c 100644
--- a/generic/tclPipe.c
+++ b/generic/tclPipe.c
@@ -221,13 +221,13 @@ Tcl_ReapDetachedProcs(void)
{
register Detached *detPtr;
Detached *nextPtr, *prevPtr;
- int status;
- Tcl_Pid pid;
+ int status, code;
Tcl_MutexLock(&pipeMutex);
for (detPtr = detList, prevPtr = NULL; detPtr != NULL; ) {
- pid = Tcl_WaitPid(detPtr->pid, &status, WNOHANG);
- if ((pid == 0) || ((pid == (Tcl_Pid) -1) && (errno != ECHILD))) {
+ status = TclProcessWait(detPtr->pid, WNOHANG, &code, NULL, NULL);
+ if (status == TCL_PROCESS_UNCHANGED || (status == TCL_PROCESS_ERROR
+ && code != ECHILD)) {
prevPtr = detPtr;
detPtr = detPtr->nextPtr;
continue;
@@ -277,38 +277,21 @@ TclCleanupChildren(
{
int result = TCL_OK;
int i, abnormalExit, anyErrorInfo;
- Tcl_Pid pid;
- int waitStatus;
- const char *msg;
- unsigned long resolvedPid;
+ TclProcessWaitStatus waitStatus;
+ int code;
+ Tcl_Obj *msg, *error;
abnormalExit = 0;
for (i = 0; i < numPids; i++) {
- /*
- * We need to get the resolved pid before we wait on it as the windows
- * implementation of Tcl_WaitPid deletes the information such that any
- * following calls to TclpGetPid fail.
- */
-
- resolvedPid = TclpGetPid(pidPtr[i]);
- pid = Tcl_WaitPid(pidPtr[i], &waitStatus, 0);
- if (pid == (Tcl_Pid) -1) {
+ waitStatus = TclProcessWait(pidPtr[i], 0, &code, &msg, &error);
+ if (waitStatus == TCL_PROCESS_ERROR) {
result = TCL_ERROR;
if (interp != NULL) {
- msg = Tcl_PosixError(interp);
- if (errno == ECHILD) {
- /*
- * This changeup in message suggested by Mark Diekhans to
- * remind people that ECHILD errors can occur on some
- * systems if SIGCHLD isn't in its default state.
- */
-
- msg =
- "child process lost (is SIGCHLD ignored or trapped?)";
- }
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "error waiting for process to exit: %s", msg));
+ Tcl_SetObjErrorCode(interp, error);
+ Tcl_SetObjResult(interp, msg);
}
+ Tcl_DecrRefCount(error);
+ Tcl_DecrRefCount(msg);
continue;
}
@@ -319,39 +302,19 @@ TclCleanupChildren(
* removed).
*/
- if (!WIFEXITED(waitStatus) || (WEXITSTATUS(waitStatus) != 0)) {
- char msg1[TCL_INTEGER_SPACE], msg2[TCL_INTEGER_SPACE];
-
+ if (waitStatus != TCL_PROCESS_EXITED || code != 0) {
result = TCL_ERROR;
- sprintf(msg1, "%lu", resolvedPid);
- if (WIFEXITED(waitStatus)) {
+ if (waitStatus == TCL_PROCESS_EXITED) {
if (interp != NULL) {
- sprintf(msg2, "%u", WEXITSTATUS(waitStatus));
- Tcl_SetErrorCode(interp, "CHILDSTATUS", msg1, msg2, NULL);
+ Tcl_SetObjErrorCode(interp, error);
}
abnormalExit = 1;
} else if (interp != NULL) {
- const char *p;
-
- if (WIFSIGNALED(waitStatus)) {
- p = Tcl_SignalMsg(WTERMSIG(waitStatus));
- Tcl_SetErrorCode(interp, "CHILDKILLED", msg1,
- Tcl_SignalId(WTERMSIG(waitStatus)), p, NULL);
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "child killed: %s\n", p));
- } else if (WIFSTOPPED(waitStatus)) {
- p = Tcl_SignalMsg(WSTOPSIG(waitStatus));
- Tcl_SetErrorCode(interp, "CHILDSUSP", msg1,
- Tcl_SignalId(WSTOPSIG(waitStatus)), p, NULL);
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "child suspended: %s\n", p));
- } else {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "child wait status didn't make sense\n", -1));
- Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
- "ODDWAITRESULT", msg1, NULL);
- }
+ Tcl_SetObjErrorCode(interp, error);
+ Tcl_SetObjResult(interp, msg);
}
+ Tcl_DecrRefCount(error);
+ Tcl_DecrRefCount(msg);
}
}
@@ -936,6 +899,7 @@ TclCreatePipeline(
pidPtr[numPids] = pid;
numPids++;
+ TclProcessCreated(pid);
/*
* Close off our copies of file descriptors that were set up for this
diff --git a/generic/tclPkg.c b/generic/tclPkg.c
index cdf9a8b..223ef93 100644
--- a/generic/tclPkg.c
+++ b/generic/tclPkg.c
@@ -65,6 +65,18 @@ typedef struct Package {
const void *clientData; /* Client data. */
} Package;
+typedef struct Require {
+ void * clientDataPtr;
+ const char *name;
+ Package *pkgPtr;
+ char *versionToProvide;
+} Require;
+
+typedef struct RequireProcArgs {
+ const char *name;
+ void *clientDataPtr;
+} RequireProcArgs;
+
/*
* Prototypes for functions defined in this file:
*/
@@ -85,9 +97,15 @@ static void AddRequirementsToResult(Tcl_Interp *interp, int reqc,
static void AddRequirementsToDString(Tcl_DString *dstring,
int reqc, Tcl_Obj *const reqv[]);
static Package * FindPackage(Tcl_Interp *interp, const char *name);
-static const char * PkgRequireCore(Tcl_Interp *interp, const char *name,
- int reqc, Tcl_Obj *const reqv[],
- void *clientDataPtr);
+static int PkgRequireCore(ClientData data[], Tcl_Interp *interp, int result);
+static int PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result);
+static int PkgRequireCoreCleanup(ClientData data[], Tcl_Interp *interp, int result);
+static int PkgRequireCoreStep1(ClientData data[], Tcl_Interp *interp, int result);
+static int PkgRequireCoreStep2(ClientData data[], Tcl_Interp *interp, int result);
+static int TclNRPkgRequireProc(ClientData clientData, Tcl_Interp *interp, int reqc, Tcl_Obj *const reqv[]);
+static int SelectPackage(ClientData data[], Tcl_Interp *interp, int result);
+static int SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result);
+static int TclNRPackageObjCmdCleanup(ClientData data[], Tcl_Interp *interp, int result);
/*
* Helper macros.
@@ -365,7 +383,10 @@ Tcl_PkgRequireEx(
*/
if (version == NULL) {
- result = PkgRequireCore(interp, name, 0, NULL, clientDataPtr);
+ if (Tcl_PkgRequireProc(interp, name, 0, NULL, clientDataPtr) == TCL_OK) {
+ result = Tcl_GetStringResult(interp);
+ Tcl_ResetResult(interp);
+ }
} else {
if (exact && TCL_OK
!= CheckVersionAndConvert(interp, version, NULL, NULL)) {
@@ -376,10 +397,12 @@ Tcl_PkgRequireEx(
Tcl_AppendStringsToObj(ov, "-", version, NULL);
}
Tcl_IncrRefCount(ov);
- result = PkgRequireCore(interp, name, 1, &ov, clientDataPtr);
+ if (Tcl_PkgRequireProc(interp, name, 1, &ov, clientDataPtr) == TCL_OK) {
+ result = Tcl_GetStringResult(interp);
+ Tcl_ResetResult(interp);
+ }
TclDecrRefCount(ov);
}
-
return result;
}
@@ -394,368 +417,432 @@ Tcl_PkgRequireProc(
* available. */
void *clientDataPtr)
{
- const char *result =
- PkgRequireCore(interp, name, reqc, reqv, clientDataPtr);
+ RequireProcArgs args;
+ args.name = name;
+ args.clientDataPtr = clientDataPtr;
+ return Tcl_NRCallObjProc(interp, TclNRPkgRequireProc, (void *)&args, reqc, reqv);
+}
- if (result == NULL) {
- return TCL_ERROR;
- }
- Tcl_SetObjResult(interp, Tcl_NewStringObj(result, -1));
+static int
+TclNRPkgRequireProc(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int reqc,
+ Tcl_Obj *const reqv[]) {
+ RequireProcArgs *args = clientData;
+ Tcl_NRAddCallback(interp, PkgRequireCore, (void *)args->name, INT2PTR(reqc), (void *)reqv, args->clientDataPtr);
return TCL_OK;
}
-static const char *
-PkgRequireCore(
- Tcl_Interp *interp, /* Interpreter in which package is now
- * available. */
- const char *name, /* Name of desired package. */
- int reqc, /* Requirements constraining the desired
- * version. */
- Tcl_Obj *const reqv[], /* 0 means to use the latest version
- * available. */
- void *clientDataPtr)
+static int
+PkgRequireCore(ClientData data[], Tcl_Interp *interp, int result)
{
- Interp *iPtr = (Interp *) interp;
- Package *pkgPtr;
- PkgAvail *availPtr, *bestPtr, *bestStablePtr;
- char *availVersion, *bestVersion, *bestStableVersion;
- /* Internal rep. of versions */
- int availStable, code, satisfies, pass;
- char *script, *pkgVersionI;
+ const char *name = data[0];
+ int reqc = PTR2INT(data[1]);
+ Tcl_Obj *const *reqv = data[2];
+ int code = CheckAllRequirements(interp, reqc, reqv);
+ Require *reqPtr;
+ if (code != TCL_OK) {
+ return code;
+ }
+ reqPtr = ckalloc(sizeof(Require));
+ Tcl_NRAddCallback(interp, PkgRequireCoreCleanup, reqPtr, NULL, NULL, NULL);
+ reqPtr->clientDataPtr = data[3];
+ reqPtr->name = name;
+ reqPtr->pkgPtr = FindPackage(interp, name);
+ if (reqPtr->pkgPtr->version == NULL) {
+ Tcl_NRAddCallback(interp, SelectPackage, reqPtr, INT2PTR(reqc), (void *)reqv, PkgRequireCoreStep1);
+ } else {
+ Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
+ }
+ return TCL_OK;
+}
+
+static int
+PkgRequireCoreStep1(ClientData data[], Tcl_Interp *interp, int result) {
Tcl_DString command;
+ char *script;
+ Require *reqPtr = data[0];
+ int reqc = PTR2INT(data[1]);
+ Tcl_Obj **const reqv = data[2];
+ const char *name = reqPtr->name /* Name of desired package. */;
+ if (reqPtr->pkgPtr->version == NULL) {
+ /*
+ * The package is not in the database. If there is a "package unknown"
+ * command, invoke it.
+ */
- if (TCL_OK != CheckAllRequirements(interp, reqc, reqv)) {
- return NULL;
+ script = ((Interp *) interp)->packageUnknown;
+ if (script == NULL) {
+ Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
+ } else {
+ Tcl_DStringInit(&command);
+ Tcl_DStringAppend(&command, script, -1);
+ Tcl_DStringAppendElement(&command, name);
+ AddRequirementsToDString(&command, reqc, reqv);
+
+ Tcl_NRAddCallback(interp, PkgRequireCoreStep2, reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
+ Tcl_NREvalObj(interp,
+ Tcl_NewStringObj(Tcl_DStringValue(&command), Tcl_DStringLength(&command)),
+ TCL_EVAL_GLOBAL
+ );
+ Tcl_DStringFree(&command);
+ }
+ return TCL_OK;
+ } else {
+ Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
+ }
+ return TCL_OK;
+}
+
+static int
+PkgRequireCoreStep2(ClientData data[], Tcl_Interp *interp, int result) {
+ Require *reqPtr = data[0];
+ int reqc = PTR2INT(data[1]);
+ Tcl_Obj **const reqv = data[2];
+ const char *name = reqPtr->name /* Name of desired package. */;
+ if ((result != TCL_OK) && (result != TCL_ERROR)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad return code: %d", result));
+ Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL);
+ result = TCL_ERROR;
+ }
+ if (result == TCL_ERROR) {
+ Tcl_AddErrorInfo(interp,
+ "\n (\"package unknown\" script)");
+ return result;
+ }
+ Tcl_ResetResult(interp);
+ /* pkgPtr may now be invalid, so refresh it. */
+ reqPtr->pkgPtr = FindPackage(interp, name);
+ Tcl_NRAddCallback(interp, SelectPackage, reqPtr, INT2PTR(reqc), (void *)reqv, PkgRequireCoreFinal);
+ return TCL_OK;
+}
+
+static int
+PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result) {
+ Require *reqPtr = data[0];
+ int reqc = PTR2INT(data[1]), satisfies;
+ Tcl_Obj **const reqv = data[2];
+ char *pkgVersionI;
+ void *clientDataPtr = reqPtr->clientDataPtr;
+ const char *name = reqPtr->name /* Name of desired package. */;
+ if (reqPtr->pkgPtr->version == NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "can't find package %s", name));
+ Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", NULL);
+ AddRequirementsToResult(interp, reqc, reqv);
+ return TCL_ERROR;
}
/*
- * It can take up to three passes to find the package: one pass to run the
- * "package unknown" script, one to run the "package ifneeded" script for
- * a specific version, and a final pass to lookup the package loaded by
- * the "package ifneeded" script.
+ * Ensure that the provided version meets the current requirements.
*/
- for (pass=1 ;; pass++) {
- pkgPtr = FindPackage(interp, name);
- if (pkgPtr->version != NULL) {
- break;
- }
+ if (reqc != 0) {
+ CheckVersionAndConvert(interp, reqPtr->pkgPtr->version, &pkgVersionI, NULL);
+ satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv);
- /*
- * Check whether we're already attempting to load some version of this
- * package (circular dependency detection).
- */
+ ckfree(pkgVersionI);
- if (pkgPtr->clientData != NULL) {
+ if (!satisfies) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "circular package dependency:"
- " attempt to provide %s %s requires %s",
- name, (char *) pkgPtr->clientData, name));
+ "version conflict for package \"%s\": have %s, need",
+ name, reqPtr->pkgPtr->version));
+ Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT",
+ NULL);
AddRequirementsToResult(interp, reqc, reqv);
- Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", NULL);
- return NULL;
+ return TCL_ERROR;
}
+ }
- /*
- * The package isn't yet present. Search the list of available
- * versions and invoke the script for the best available version. We
- * are actually locating the best, and the best stable version. One of
- * them is then chosen based on the selection mode.
- */
+ if (clientDataPtr) {
+ const void **ptr = (const void **) clientDataPtr;
- bestPtr = NULL;
- bestStablePtr = NULL;
- bestVersion = NULL;
- bestStableVersion = NULL;
+ *ptr = reqPtr->pkgPtr->clientData;
+ }
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(reqPtr->pkgPtr->version, -1));
+ return TCL_OK;
+}
- for (availPtr = pkgPtr->availPtr; availPtr != NULL;
- availPtr = availPtr->nextPtr) {
- if (CheckVersionAndConvert(interp, availPtr->version,
- &availVersion, &availStable) != TCL_OK) {
- /*
- * The provided version number has invalid syntax. This
- * should not happen. This should have been caught by the
- * 'package ifneeded' registering the package.
- */
+static int
+PkgRequireCoreCleanup(ClientData data[], Tcl_Interp *interp, int result) {
+ ckfree(data[0]);
+ return result;
+}
- continue;
- }
+
+static int
+SelectPackage(ClientData data[], Tcl_Interp *interp, int result) {
+ PkgAvail *availPtr, *bestPtr, *bestStablePtr;
+ char *availVersion, *bestVersion, *bestStableVersion;
+ /* Internal rep. of versions */
+ int availStable, satisfies;
+ Require *reqPtr = data[0];
+ int reqc = PTR2INT(data[1]);
+ Tcl_Obj **const reqv = data[2];
+ const char *name = reqPtr->name;
+ Package *pkgPtr = reqPtr->pkgPtr;
+ Interp *iPtr = (Interp *) interp;
- /* Check satisfaction of requirements before considering the current version further. */
- if (reqc > 0) {
- satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv);
- if (!satisfies) {
- ckfree(availVersion);
- availVersion = NULL;
- continue;
- }
- }
+ /*
+ * Check whether we're already attempting to load some version of this
+ * package (circular dependency detection).
+ */
- if (bestPtr != NULL) {
- int res = CompareVersions(availVersion, bestVersion, NULL);
+ if (pkgPtr->clientData != NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "circular package dependency:"
+ " attempt to provide %s %s requires %s",
+ name, (char *) pkgPtr->clientData, name));
+ AddRequirementsToResult(interp, reqc, reqv);
+ Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", NULL);
+ return TCL_ERROR;
+ }
- /*
- * Note: Used internal reps in the comparison!
- */
+ /*
+ * The package isn't yet present. Search the list of available
+ * versions and invoke the script for the best available version. We
+ * are actually locating the best, and the best stable version. One of
+ * them is then chosen based on the selection mode.
+ */
- if (res > 0) {
- /*
- * The version of the package sought is better than the
- * currently selected version.
- */
- ckfree(bestVersion);
- bestVersion = NULL;
- goto newbest;
- }
- } else {
- newbest:
- /* We have found a version which is better than our max. */
+ bestPtr = NULL;
+ bestStablePtr = NULL;
+ bestVersion = NULL;
+ bestStableVersion = NULL;
- bestPtr = availPtr;
- CheckVersionAndConvert(interp, bestPtr->version, &bestVersion, NULL);
- }
+ for (availPtr = pkgPtr->availPtr; availPtr != NULL;
+ availPtr = availPtr->nextPtr) {
+ if (CheckVersionAndConvert(interp, availPtr->version,
+ &availVersion, &availStable) != TCL_OK) {
+ /*
+ * The provided version number has invalid syntax. This
+ * should not happen. This should have been caught by the
+ * 'package ifneeded' registering the package.
+ */
- if (!availStable) {
+ continue;
+ }
+
+ /* Check satisfaction of requirements before considering the current version further. */
+ if (reqc > 0) {
+ satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv);
+ if (!satisfies) {
ckfree(availVersion);
availVersion = NULL;
continue;
}
+ }
+
+ if (bestPtr != NULL) {
+ int res = CompareVersions(availVersion, bestVersion, NULL);
- if (bestStablePtr != NULL) {
- int res = CompareVersions(availVersion, bestStableVersion, NULL);
+ /*
+ * Note: Used internal reps in the comparison!
+ */
+ if (res > 0) {
/*
- * Note: Used internal reps in the comparison!
+ * The version of the package sought is better than the
+ * currently selected version.
*/
-
- if (res > 0) {
- /*
- * This stable version of the package sought is better
- * than the currently selected stable version.
- */
- ckfree(bestStableVersion);
- bestStableVersion = NULL;
- goto newstable;
- }
- } else {
- newstable:
- /* We have found a stable version which is better than our max stable. */
- bestStablePtr = availPtr;
- CheckVersionAndConvert(interp, bestStablePtr->version, &bestStableVersion, NULL);
+ ckfree(bestVersion);
+ bestVersion = NULL;
+ goto newbest;
}
+ } else {
+ newbest:
+ /* We have found a version which is better than our max. */
+ bestPtr = availPtr;
+ CheckVersionAndConvert(interp, bestPtr->version, &bestVersion, NULL);
+ }
+
+ if (!availStable) {
ckfree(availVersion);
availVersion = NULL;
- } /* end for */
-
- /*
- * Clean up memorized internal reps, if any.
- */
-
- if (bestVersion != NULL) {
- ckfree(bestVersion);
- bestVersion = NULL;
+ continue;
}
- if (bestStableVersion != NULL) {
- ckfree(bestStableVersion);
- bestStableVersion = NULL;
- }
+ if (bestStablePtr != NULL) {
+ int res = CompareVersions(availVersion, bestStableVersion, NULL);
- /*
- * Now choose a version among the two best. For 'latest' we simply
- * take (actually keep) the best. For 'stable' we take the best
- * stable, if there is any, or the best if there is nothing stable.
- */
-
- if ((iPtr->packagePrefer == PKG_PREFER_STABLE)
- && (bestStablePtr != NULL)) {
- bestPtr = bestStablePtr;
- }
-
- if (bestPtr != NULL) {
/*
- * We found an ifneeded script for the package. Be careful while
- * executing it: this could cause reentrancy, so (a) protect the
- * script itself from deletion and (b) don't assume that bestPtr
- * will still exist when the script completes.
+ * Note: Used internal reps in the comparison!
*/
- char *versionToProvide = bestPtr->version;
- PkgFiles *pkgFiles;
- PkgName *pkgName;
- script = bestPtr->script;
-
- pkgPtr->clientData = versionToProvide;
- Tcl_Preserve(versionToProvide);
- Tcl_Preserve(script);
- pkgFiles = TclInitPkgFiles(interp);
- /* Push "ifneeded" package name in "tclPkgFiles" assocdata. */
- pkgName = ckalloc(sizeof(PkgName) + strlen(name));
- pkgName->nextPtr = pkgFiles->names;
- strcpy(pkgName->name, name);
- pkgFiles->names = pkgName;
- if (bestPtr->pkgIndex) {
- TclPkgFileSeen(interp, bestPtr->pkgIndex);
- }
- code = Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL);
- /* Pop the "ifneeded" package name from "tclPkgFiles" assocdata*/
- pkgFiles->names = pkgName->nextPtr;
- ckfree(pkgName);
- Tcl_Release(script);
-
- pkgPtr = FindPackage(interp, name);
- if (code == TCL_OK) {
- Tcl_ResetResult(interp);
- if (pkgPtr->version == NULL) {
- code = TCL_ERROR;
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "attempt to provide package %s %s failed:"
- " no version of package %s provided",
- name, versionToProvide, name));
- Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED",
- NULL);
- } else {
- char *pvi, *vi;
-
- if (CheckVersionAndConvert(interp, pkgPtr->version, &pvi,
- NULL) != TCL_OK) {
- code = TCL_ERROR;
- } else if (CheckVersionAndConvert(interp,
- versionToProvide, &vi, NULL) != TCL_OK) {
- ckfree(pvi);
- code = TCL_ERROR;
- } else {
- int res = CompareVersions(pvi, vi, NULL);
-
- ckfree(pvi);
- ckfree(vi);
- if (res != 0) {
- code = TCL_ERROR;
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "attempt to provide package %s %s failed:"
- " package %s %s provided instead",
- name, versionToProvide,
- name, pkgPtr->version));
- Tcl_SetErrorCode(interp, "TCL", "PACKAGE",
- "WRONGPROVIDE", NULL);
- }
- }
- }
- } else if (code != TCL_ERROR) {
- Tcl_Obj *codePtr = Tcl_NewIntObj(code);
-
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "attempt to provide package %s %s failed:"
- " bad return code: %s",
- name, versionToProvide, TclGetString(codePtr)));
- Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL);
- TclDecrRefCount(codePtr);
- code = TCL_ERROR;
- }
-
- if (code == TCL_ERROR) {
- Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
- "\n (\"package ifneeded %s %s\" script)",
- name, versionToProvide));
- }
- Tcl_Release(versionToProvide);
-
- if (code != TCL_OK) {
+ if (res > 0) {
/*
- * Take a non-TCL_OK code from the script as an indication the
- * package wasn't loaded properly, so the package system
- * should not remember an improper load.
- *
- * This is consistent with our returning NULL. If we're not
- * willing to tell our caller we got a particular version, we
- * shouldn't store that version for telling future callers
- * either.
+ * This stable version of the package sought is better
+ * than the currently selected stable version.
*/
-
- if (pkgPtr->version != NULL) {
- ckfree(pkgPtr->version);
- pkgPtr->version = NULL;
- }
- pkgPtr->clientData = NULL;
- return NULL;
+ ckfree(bestStableVersion);
+ bestStableVersion = NULL;
+ goto newstable;
}
-
- break;
- }
-
- /*
- * The package is not in the database. If there is a "package unknown"
- * command, invoke it (but only on the first pass; after that, we
- * should not get here in the first place).
- */
-
- if (pass > 1) {
- break;
+ } else {
+ newstable:
+ /* We have found a stable version which is better than our max stable. */
+ bestStablePtr = availPtr;
+ CheckVersionAndConvert(interp, bestStablePtr->version, &bestStableVersion, NULL);
}
- script = ((Interp *) interp)->packageUnknown;
- if (script != NULL) {
- Tcl_DStringInit(&command);
- Tcl_DStringAppend(&command, script, -1);
- Tcl_DStringAppendElement(&command, name);
- AddRequirementsToDString(&command, reqc, reqv);
+ ckfree(availVersion);
+ availVersion = NULL;
+ } /* end for */
- code = Tcl_EvalEx(interp, Tcl_DStringValue(&command),
- Tcl_DStringLength(&command), TCL_EVAL_GLOBAL);
- Tcl_DStringFree(&command);
+ /*
+ * Clean up memorized internal reps, if any.
+ */
- if ((code != TCL_OK) && (code != TCL_ERROR)) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "bad return code: %d", code));
- Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL);
- code = TCL_ERROR;
- }
- if (code == TCL_ERROR) {
- Tcl_AddErrorInfo(interp,
- "\n (\"package unknown\" script)");
- return NULL;
- }
- Tcl_ResetResult(interp);
- }
+ if (bestVersion != NULL) {
+ ckfree(bestVersion);
+ bestVersion = NULL;
}
- if (pkgPtr->version == NULL) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "can't find package %s", name));
- Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", NULL);
- AddRequirementsToResult(interp, reqc, reqv);
- return NULL;
+ if (bestStableVersion != NULL) {
+ ckfree(bestStableVersion);
+ bestStableVersion = NULL;
}
/*
- * At this point we know that the package is present. Make sure that the
- * provided version meets the current requirements.
+ * Now choose a version among the two best. For 'latest' we simply
+ * take (actually keep) the best. For 'stable' we take the best
+ * stable, if there is any, or the best if there is nothing stable.
*/
- if (reqc != 0) {
- CheckVersionAndConvert(interp, pkgPtr->version, &pkgVersionI, NULL);
- satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv);
+ if ((iPtr->packagePrefer == PKG_PREFER_STABLE)
+ && (bestStablePtr != NULL)) {
+ bestPtr = bestStablePtr;
+ }
- ckfree(pkgVersionI);
+ if (bestPtr == NULL) {
+ Tcl_NRAddCallback(interp, data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
+ } else {
+ /*
+ * We found an ifneeded script for the package. Be careful while
+ * executing it: this could cause reentrancy, so (a) protect the
+ * script itself from deletion and (b) don't assume that bestPtr
+ * will still exist when the script completes.
+ */
- if (!satisfies) {
+ char *versionToProvide = bestPtr->version;
+ PkgFiles *pkgFiles;
+ PkgName *pkgName;
+
+ Tcl_Preserve(versionToProvide);
+ pkgPtr->clientData = versionToProvide;
+
+ pkgFiles = TclInitPkgFiles(interp);
+ /* Push "ifneeded" package name in "tclPkgFiles" assocdata. */
+ pkgName = ckalloc(sizeof(PkgName) + strlen(name));
+ pkgName->nextPtr = pkgFiles->names;
+ strcpy(pkgName->name, name);
+ pkgFiles->names = pkgName;
+ if (bestPtr->pkgIndex) {
+ TclPkgFileSeen(interp, bestPtr->pkgIndex);
+ }
+ reqPtr->versionToProvide = versionToProvide;
+ Tcl_NRAddCallback(interp, SelectPackageFinal, reqPtr, INT2PTR(reqc), (void *)reqv, data[3]);
+ Tcl_NREvalObj(interp, Tcl_NewStringObj(bestPtr->script, -1), TCL_EVAL_GLOBAL);
+ }
+ return TCL_OK;
+}
+
+static int
+SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) {
+ Require *reqPtr = data[0];
+ int reqc = PTR2INT(data[1]);
+ Tcl_Obj **const reqv = data[2];
+ const char *name = reqPtr->name;
+ char *versionToProvide = reqPtr->versionToProvide;
+
+ /* Pop the "ifneeded" package name from "tclPkgFiles" assocdata*/
+ PkgFiles *pkgFiles = Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
+ PkgName *pkgName = pkgFiles->names;
+ pkgFiles->names = pkgName->nextPtr;
+ ckfree(pkgName);
+
+ reqPtr->pkgPtr = FindPackage(interp, name);
+ if (result == TCL_OK) {
+ Tcl_ResetResult(interp);
+ if (reqPtr->pkgPtr->version == NULL) {
+ result = TCL_ERROR;
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "version conflict for package \"%s\": have %s, need",
- name, pkgPtr->version));
- Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT",
+ "attempt to provide package %s %s failed:"
+ " no version of package %s provided",
+ name, versionToProvide, name));
+ Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED",
NULL);
- AddRequirementsToResult(interp, reqc, reqv);
- return NULL;
+ } else {
+ char *pvi, *vi;
+
+ if (CheckVersionAndConvert(interp, reqPtr->pkgPtr->version, &pvi,
+ NULL) != TCL_OK) {
+ result = TCL_ERROR;
+ } else if (CheckVersionAndConvert(interp,
+ versionToProvide, &vi, NULL) != TCL_OK) {
+ ckfree(pvi);
+ result = TCL_ERROR;
+ } else {
+ int res = CompareVersions(pvi, vi, NULL);
+
+ ckfree(pvi);
+ ckfree(vi);
+ if (res != 0) {
+ result = TCL_ERROR;
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "attempt to provide package %s %s failed:"
+ " package %s %s provided instead",
+ name, versionToProvide,
+ name, reqPtr->pkgPtr->version));
+ Tcl_SetErrorCode(interp, "TCL", "PACKAGE",
+ "WRONGPROVIDE", NULL);
+ }
+ }
}
+ } else if (result != TCL_ERROR) {
+ Tcl_Obj *codePtr = Tcl_NewIntObj(result);
+
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "attempt to provide package %s %s failed:"
+ " bad return code: %s",
+ name, versionToProvide, TclGetString(codePtr)));
+ Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL);
+ TclDecrRefCount(codePtr);
+ result = TCL_ERROR;
}
- if (clientDataPtr) {
- const void **ptr = (const void **) clientDataPtr;
+ if (result == TCL_ERROR) {
+ Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf(
+ "\n (\"package ifneeded %s %s\" script)",
+ name, versionToProvide));
+ }
+ Tcl_Release(versionToProvide);
+
+ if (result != TCL_OK) {
+ /*
+ * Take a non-TCL_OK code from the script as an indication the
+ * package wasn't loaded properly, so the package system
+ * should not remember an improper load.
+ *
+ * This is consistent with our returning NULL. If we're not
+ * willing to tell our caller we got a particular version, we
+ * shouldn't store that version for telling future callers
+ * either.
+ */
- *ptr = pkgPtr->clientData;
+ if (reqPtr->pkgPtr->version != NULL) {
+ ckfree(reqPtr->pkgPtr->version);
+ reqPtr->pkgPtr->version = NULL;
+ }
+ reqPtr->pkgPtr->clientData = NULL;
+ return result;
}
- return pkgPtr->version;
+
+ Tcl_NRAddCallback(interp, data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL);
+ return TCL_OK;
}
/*
@@ -861,10 +948,19 @@ Tcl_PkgPresentEx(
*
*----------------------------------------------------------------------
*/
+int
+Tcl_PackageObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ return Tcl_NRCallObjProc(interp, TclNRPackageObjCmd, NULL, objc, objv);
+}
/* ARGSUSED */
int
-Tcl_PackageObjCmd(
+TclNRPackageObjCmd(
ClientData dummy, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
@@ -881,7 +977,7 @@ Tcl_PackageObjCmd(
PKG_VERSIONS, PKG_VSATISFIES
};
Interp *iPtr = (Interp *) interp;
- int optionIndex, exact, i, satisfies;
+ int optionIndex, exact, i, newobjc, satisfies;
PkgAvail *availPtr, *prevPtr;
Package *pkgPtr;
Tcl_HashEntry *hPtr;
@@ -890,6 +986,7 @@ Tcl_PackageObjCmd(
const char *version;
const char *argv2, *argv3, *argv4;
char *iva = NULL, *ivb = NULL;
+ Tcl_Obj *objvListPtr, **newObjvPtr;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
@@ -948,6 +1045,7 @@ Tcl_PackageObjCmd(
Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
if (availPtr->pkgIndex) {
Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC);
+ availPtr->pkgIndex = NULL;
}
ckfree(availPtr);
}
@@ -1001,6 +1099,7 @@ Tcl_PackageObjCmd(
Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
if (availPtr->pkgIndex) {
Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC);
+ availPtr->pkgIndex = NULL;
}
break;
}
@@ -1012,7 +1111,7 @@ Tcl_PackageObjCmd(
}
if (availPtr == NULL) {
availPtr = ckalloc(sizeof(PkgAvail));
- availPtr->pkgIndex = 0;
+ availPtr->pkgIndex = NULL;
DupBlock(availPtr->version, argv3, (unsigned) length + 1);
if (prevPtr == NULL) {
@@ -1133,7 +1232,6 @@ Tcl_PackageObjCmd(
argv2 = TclGetString(objv[2]);
if ((argv2[0] == '-') && (strcmp(argv2, "-exact") == 0)) {
Tcl_Obj *ov;
- int res;
if (objc != 5) {
goto requireSyntax;
@@ -1153,17 +1251,38 @@ Tcl_PackageObjCmd(
Tcl_AppendStringsToObj(ov, "-", version, NULL);
version = NULL;
argv3 = TclGetString(objv[3]);
+ Tcl_IncrRefCount(objv[3]);
+
+ objvListPtr = Tcl_NewListObj(0, NULL);
+ Tcl_IncrRefCount(objvListPtr);
+ Tcl_ListObjAppendElement(interp, objvListPtr, ov);
+ Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr);
- Tcl_IncrRefCount(ov);
- res = Tcl_PkgRequireProc(interp, argv3, 1, &ov, NULL);
- TclDecrRefCount(ov);
- return res;
+ Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[3], objvListPtr, NULL, NULL);
+ Tcl_NRAddCallback(interp, PkgRequireCore, (void *)argv3, INT2PTR(newobjc), newObjvPtr, NULL);
+ return TCL_OK;
} else {
+ int i, newobjc = objc-3;
+ Tcl_Obj *const *newobjv = objv + 3;
if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) {
return TCL_ERROR;
}
+ objvListPtr = Tcl_NewListObj(0, NULL);
+ Tcl_IncrRefCount(objvListPtr);
+ Tcl_IncrRefCount(objv[2]);
+ for (i = 0; i < newobjc; i++) {
+
+ /*
+ * Tcl_Obj structures may have come from another interpreter,
+ * so duplicate them.
+ */
- return Tcl_PkgRequireProc(interp, argv2, objc-3, objv+3, NULL);
+ Tcl_ListObjAppendElement(interp, objvListPtr, Tcl_DuplicateObj(newobjv[i]));
+ }
+ Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr);
+ Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[2], objvListPtr, NULL, NULL);
+ Tcl_NRAddCallback(interp, PkgRequireCore, (void *)argv2, INT2PTR(newobjc), newObjvPtr, NULL);
+ return TCL_OK;
}
break;
case PKG_UNKNOWN: {
@@ -1303,6 +1422,13 @@ Tcl_PackageObjCmd(
}
return TCL_OK;
}
+
+static int
+TclNRPackageObjCmdCleanup(ClientData data[], Tcl_Interp *interp, int result) {
+ TclDecrRefCount((Tcl_Obj *)data[0]);
+ TclDecrRefCount((Tcl_Obj *)data[1]);
+ return result;
+}
/*
*----------------------------------------------------------------------
@@ -1384,6 +1510,7 @@ TclFreePackageInfo(
Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
if (availPtr->pkgIndex) {
Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC);
+ availPtr->pkgIndex = NULL;
}
ckfree(availPtr);
}
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 70dc4dc..212b680 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -790,7 +790,7 @@ TclObjGetFrame(
level = curLevel - level;
result = 1;
} else if (objPtr->typePtr == &levelReferenceType) {
- level = (int) objPtr->internalRep.longValue;
+ level = (int) objPtr->internalRep.wideValue;
result = 1;
} else {
name = TclGetString(objPtr);
@@ -798,7 +798,7 @@ TclObjGetFrame(
if (TCL_OK == Tcl_GetInt(NULL, name+1, &level) && level >= 0) {
TclFreeIntRep(objPtr);
objPtr->typePtr = &levelReferenceType;
- objPtr->internalRep.longValue = level;
+ objPtr->internalRep.wideValue = level;
result = 1;
} else {
result = -1;
diff --git a/generic/tclProcess.c b/generic/tclProcess.c
new file mode 100644
index 0000000..7187ee4
--- /dev/null
+++ b/generic/tclProcess.c
@@ -0,0 +1,952 @@
+/*
+ * tclProcess.c --
+ *
+ * This file implements the "tcl::process" ensemble for subprocess
+ * management as defined by TIP #462.
+ *
+ * Copyright (c) 2017 Frederic Bonnet.
+ *
+ * See the file "license.terms" for information on usage and redistribution of
+ * this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ */
+
+#include "tclInt.h"
+
+/*
+ * Autopurge flag. Process-global because of the way Tcl manages child
+ * processes (see tclPipe.c).
+ */
+
+static int autopurge = 1; /* Autopurge flag. */
+
+/*
+ * Hash tables that keeps track of all child process statuses. Keys are the
+ * child process ids and resolved pids, values are (ProcessInfo *).
+ */
+
+typedef struct ProcessInfo {
+ Tcl_Pid pid; /* Process id. */
+ int resolvedPid; /* Resolved process id. */
+ int purge; /* Purge eventualy. */
+ TclProcessWaitStatus status;/* Process status. */
+ int code; /* Error code, exit status or signal
+ number. */
+ Tcl_Obj *msg; /* Error message. */
+ Tcl_Obj *error; /* Error code. */
+} ProcessInfo;
+static Tcl_HashTable infoTablePerPid;
+static Tcl_HashTable infoTablePerResolvedPid;
+static int infoTablesInitialized = 0; /* 0 means not yet initialized. */
+TCL_DECLARE_MUTEX(infoTablesMutex)
+
+ /*
+ * Prototypes for functions defined later in this file:
+ */
+
+static void InitProcessInfo(ProcessInfo *info, Tcl_Pid pid,
+ int resolvedPid);
+static void FreeProcessInfo(ProcessInfo *info);
+static int RefreshProcessInfo(ProcessInfo *info, int options);
+static TclProcessWaitStatus WaitProcessStatus(Tcl_Pid pid, int resolvedPid,
+ int options, int *codePtr, Tcl_Obj **msgPtr,
+ Tcl_Obj **errorObjPtr);
+static Tcl_Obj * BuildProcessStatusObj(ProcessInfo *info);
+static int ProcessListObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+static int ProcessStatusObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+static int ProcessPurgeObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+static int ProcessAutopurgeObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InitProcessInfo --
+ *
+ * Initializes the ProcessInfo structure.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Memory written.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+InitProcessInfo(
+ ProcessInfo *info, /* Structure to initialize. */
+ Tcl_Pid pid, /* Process id. */
+ int resolvedPid) /* Resolved process id. */
+{
+ info->pid = pid;
+ info->resolvedPid = resolvedPid;
+ info->purge = 0;
+ info->status = TCL_PROCESS_UNCHANGED;
+ info->code = 0;
+ info->msg = NULL;
+ info->error = NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeProcessInfo --
+ *
+ * Free the ProcessInfo structure.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Memory deallocated, Tcl_Obj refcount decreased.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+FreeProcessInfo(
+ ProcessInfo *info) /* Structure to free. */
+{
+ /*
+ * Free stored Tcl_Objs.
+ */
+
+ if (info->msg) {
+ Tcl_DecrRefCount(info->msg);
+ }
+ if (info->error) {
+ Tcl_DecrRefCount(info->error);
+ }
+
+ /*
+ * Free allocated structure.
+ */
+
+ ckfree(info);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * RefreshProcessInfo --
+ *
+ * Refresh process info.
+ *
+ * Results:
+ * Nonzero if state changed, else zero.
+ *
+ * Side effects:
+ * May call WaitProcessStatus, which can block if WNOHANG option is set.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+RefreshProcessInfo(
+ ProcessInfo *info, /* Structure to refresh. */
+ int options /* Options passed to WaitProcessStatus. */
+)
+{
+ if (info->status == TCL_PROCESS_UNCHANGED) {
+ /*
+ * Refresh & store status.
+ */
+
+ info->status = WaitProcessStatus(info->pid, info->resolvedPid,
+ options, &info->code, &info->msg, &info->error);
+ if (info->msg) Tcl_IncrRefCount(info->msg);
+ if (info->error) Tcl_IncrRefCount(info->error);
+ return (info->status != TCL_PROCESS_UNCHANGED);
+ } else {
+ /*
+ * No change.
+ */
+
+ return 0;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * WaitProcessStatus --
+ *
+ * Wait for process status to change.
+ *
+ * Results:
+ * TclProcessWaitStatus enum value.
+ *
+ * Side effects:
+ * May call WaitProcessStatus, which can block if WNOHANG option is set.
+ *
+ *----------------------------------------------------------------------
+ */
+
+TclProcessWaitStatus
+WaitProcessStatus(
+ Tcl_Pid pid, /* Process id. */
+ int resolvedPid, /* Resolved process id. */
+ int options, /* Options passed to Tcl_WaitPid. */
+ int *codePtr, /* If non-NULL, will receive either:
+ * - 0 for normal exit.
+ * - errno in case of error.
+ * - non-zero exit code for abormal exit.
+ * - signal number if killed or suspended.
+ * - Tcl_WaitPid status in all other cases.
+ */
+ Tcl_Obj **msgObjPtr, /* If non-NULL, will receive error message. */
+ Tcl_Obj **errorObjPtr) /* If non-NULL, will receive error code. */
+{
+ int waitStatus;
+ Tcl_Obj *errorStrings[5];
+ const char *msg;
+
+ pid = Tcl_WaitPid(pid, &waitStatus, options);
+ if (pid == 0) {
+ /*
+ * No change.
+ */
+
+ return TCL_PROCESS_UNCHANGED;
+ }
+
+ /*
+ * Get process status.
+ */
+
+ if (pid == (Tcl_Pid) -1) {
+ /*
+ * POSIX errName msg
+ */
+
+ msg = Tcl_ErrnoMsg(errno);
+ if (errno == ECHILD) {
+ /*
+ * This changeup in message suggested by Mark Diekhans to
+ * remind people that ECHILD errors can occur on some
+ * systems if SIGCHLD isn't in its default state.
+ */
+
+ msg = "child process lost (is SIGCHLD ignored or trapped?)";
+ }
+ if (codePtr) *codePtr = errno;
+ if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf(
+ "error waiting for process to exit: %s", msg);
+ if (errorObjPtr) {
+ errorStrings[0] = Tcl_NewStringObj("POSIX", -1);
+ errorStrings[1] = Tcl_NewStringObj(Tcl_ErrnoId(), -1);
+ errorStrings[2] = Tcl_NewStringObj(msg, -1);
+ *errorObjPtr = Tcl_NewListObj(3, errorStrings);
+ }
+ return TCL_PROCESS_ERROR;
+ } else if (WIFEXITED(waitStatus)) {
+ if (codePtr) *codePtr = WEXITSTATUS(waitStatus);
+ if (!WEXITSTATUS(waitStatus)) {
+ /*
+ * Normal exit.
+ */
+
+ if (msgObjPtr) *msgObjPtr = NULL;
+ if (errorObjPtr) *errorObjPtr = NULL;
+ } else {
+ /*
+ * CHILDSTATUS pid code
+ *
+ * Child exited with a non-zero exit status.
+ */
+
+ if (msgObjPtr) *msgObjPtr = Tcl_NewStringObj(
+ "child process exited abnormally", -1);
+ if (errorObjPtr) {
+ errorStrings[0] = Tcl_NewStringObj("CHILDSTATUS", -1);
+ errorStrings[1] = Tcl_NewIntObj(resolvedPid);
+ errorStrings[2] = Tcl_NewIntObj(WEXITSTATUS(waitStatus));
+ *errorObjPtr = Tcl_NewListObj(3, errorStrings);
+ }
+ }
+ return TCL_PROCESS_EXITED;
+ } else if (WIFSIGNALED(waitStatus)) {
+ /*
+ * CHILDKILLED pid sigName msg
+ *
+ * Child killed because of a signal.
+ */
+
+ msg = Tcl_SignalMsg(WTERMSIG(waitStatus));
+ if (codePtr) *codePtr = WTERMSIG(waitStatus);
+ if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf(
+ "child killed: %s", msg);
+ if (errorObjPtr) {
+ errorStrings[0] = Tcl_NewStringObj("CHILDKILLED", -1);
+ errorStrings[1] = Tcl_NewIntObj(resolvedPid);
+ errorStrings[2] = Tcl_NewStringObj(Tcl_SignalId(WTERMSIG(waitStatus)), -1);
+ errorStrings[3] = Tcl_NewStringObj(msg, -1);
+ *errorObjPtr = Tcl_NewListObj(4, errorStrings);
+ }
+ return TCL_PROCESS_SIGNALED;
+ } else if (WIFSTOPPED(waitStatus)) {
+ /*
+ * CHILDSUSP pid sigName msg
+ *
+ * Child suspended because of a signal.
+ */
+
+ msg = Tcl_SignalMsg(WSTOPSIG(waitStatus));
+ if (codePtr) *codePtr = WSTOPSIG(waitStatus);
+ if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf(
+ "child suspended: %s", msg);
+ if (errorObjPtr) {
+ errorStrings[0] = Tcl_NewStringObj("CHILDSUSP", -1);
+ errorStrings[1] = Tcl_NewIntObj(resolvedPid);
+ errorStrings[2] = Tcl_NewStringObj(Tcl_SignalId(WSTOPSIG(waitStatus)), -1);
+ errorStrings[3] = Tcl_NewStringObj(msg, -1);
+ *errorObjPtr = Tcl_NewListObj(4, errorStrings);
+ }
+ return TCL_PROCESS_STOPPED;
+ } else {
+ /*
+ * TCL OPERATION EXEC ODDWAITRESULT
+ *
+ * Child wait status didn't make sense.
+ */
+
+ if (codePtr) *codePtr = waitStatus;
+ if (msgObjPtr) *msgObjPtr = Tcl_NewStringObj(
+ "child wait status didn't make sense\n", -1);
+ if (errorObjPtr) {
+ errorStrings[0] = Tcl_NewStringObj("TCL", -1);
+ errorStrings[1] = Tcl_NewStringObj("OPERATION", -1);
+ errorStrings[2] = Tcl_NewStringObj("EXEC", -1);
+ errorStrings[3] = Tcl_NewStringObj("ODDWAITRESULT", -1);
+ errorStrings[4] = Tcl_NewIntObj(resolvedPid);
+ *errorObjPtr = Tcl_NewListObj(5, errorStrings);
+ }
+ return TCL_PROCESS_UNKNOWN_STATUS;
+ }
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * BuildProcessStatusObj --
+ *
+ * Build a list object with process status. The first element is always
+ * a standard Tcl return value, which can be either TCL_OK or TCL_ERROR.
+ * In the latter case, the second element is the error message and the
+ * third element is a Tcl error code (see tclvars).
+ *
+ * Results:
+ * A list object.
+ *
+ * Side effects:
+ * Tcl_Objs are created.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+BuildProcessStatusObj(
+ ProcessInfo *info)
+{
+ Tcl_Obj *resultObjs[3];
+
+ if (info->status == TCL_PROCESS_UNCHANGED) {
+ /*
+ * Process still running, return empty obj.
+ */
+
+ return Tcl_NewObj();
+ }
+ if (info->status == TCL_PROCESS_EXITED && info->code == 0) {
+ /*
+ * Normal exit, return TCL_OK.
+ */
+
+ return Tcl_NewIntObj(TCL_OK);
+ }
+
+ /*
+ * Abnormal exit, return {TCL_ERROR msg error}
+ */
+
+ resultObjs[0] = Tcl_NewIntObj(TCL_ERROR);
+ resultObjs[1] = info->msg;
+ resultObjs[2] = info->error;
+ return Tcl_NewListObj(3, resultObjs);
+}
+
+/*----------------------------------------------------------------------
+ *
+ * ProcessListObjCmd --
+ *
+ * This function implements the 'tcl::process list' Tcl command.
+ * Refer to the user documentation for details on what it does.
+ *
+ * Results:
+ * Returns a standard Tcl result.
+ *
+ * Side effects:
+ * Access to the internal structures is protected by infoTablesMutex.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ProcessListObjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ Tcl_Obj *list;
+ Tcl_HashEntry *entry;
+ Tcl_HashSearch search;
+ ProcessInfo *info;
+
+ if (objc != 1) {
+ Tcl_WrongNumArgs(interp, 1, objv, NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Return the list of all chid process ids.
+ */
+
+ list = Tcl_NewListObj(0, NULL);
+ Tcl_MutexLock(&infoTablesMutex);
+ for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search);
+ entry != NULL; entry = Tcl_NextHashEntry(&search)) {
+ info = (ProcessInfo *) Tcl_GetHashValue(entry);
+ Tcl_ListObjAppendElement(interp, list,
+ Tcl_NewIntObj(info->resolvedPid));
+ }
+ Tcl_MutexUnlock(&infoTablesMutex);
+ Tcl_SetObjResult(interp, list);
+ return TCL_OK;
+}
+
+/*----------------------------------------------------------------------
+ *
+ * ProcessStatusObjCmd --
+ *
+ * This function implements the 'tcl::process status' Tcl command.
+ * Refer to the user documentation for details on what it does.
+ *
+ * Results:
+ * Returns a standard Tcl result.
+ *
+ * Side effects:
+ * Access to the internal structures is protected by infoTablesMutex.
+ * Calls RefreshProcessInfo, which can block if -wait switch is given.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ProcessStatusObjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ Tcl_Obj *dict;
+ int index, options = WNOHANG;
+ Tcl_HashEntry *entry;
+ Tcl_HashSearch search;
+ ProcessInfo *info;
+ int numPids;
+ Tcl_Obj **pidObjs;
+ int result;
+ int i;
+ int pid;
+ Tcl_Obj *const *savedobjv = objv;
+ static const char *const switches[] = {
+ "-wait", "--", NULL
+ };
+ enum switches {
+ STATUS_WAIT, STATUS_LAST
+ };
+
+ while (objc > 1) {
+ if (TclGetString(objv[1])[0] != '-') {
+ break;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[1], switches, "switches", 0,
+ &index) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ ++objv; --objc;
+ if (STATUS_WAIT == (enum switches) index) {
+ options = 0;
+ } else {
+ break;
+ }
+ }
+
+ if (objc != 1 && objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, savedobjv, "?switches? ?pids?");
+ return TCL_ERROR;
+ }
+
+ if (objc == 1) {
+ /*
+ * Return a dict with all child process statuses.
+ */
+
+ dict = Tcl_NewDictObj();
+ Tcl_MutexLock(&infoTablesMutex);
+ for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search);
+ entry != NULL; entry = Tcl_NextHashEntry(&search)) {
+ info = (ProcessInfo *) Tcl_GetHashValue(entry);
+ RefreshProcessInfo(info, options);
+
+ if (info->purge && autopurge) {
+ /*
+ * Purge entry.
+ */
+
+ Tcl_DeleteHashEntry(entry);
+ entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid);
+ Tcl_DeleteHashEntry(entry);
+ FreeProcessInfo(info);
+ } else {
+ /*
+ * Add to result.
+ */
+
+ Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid),
+ BuildProcessStatusObj(info));
+ }
+ }
+ Tcl_MutexUnlock(&infoTablesMutex);
+ } else {
+ /*
+ * Only return statuses of provided processes.
+ */
+
+ result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs);
+ if (result != TCL_OK) {
+ return result;
+ }
+ dict = Tcl_NewDictObj();
+ Tcl_MutexLock(&infoTablesMutex);
+ for (i = 0; i < numPids; i++) {
+ result = Tcl_GetIntFromObj(interp, pidObjs[i], (int *) &pid);
+ if (result != TCL_OK) {
+ Tcl_MutexUnlock(&infoTablesMutex);
+ Tcl_DecrRefCount(dict);
+ return result;
+ }
+
+ entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(pid));
+ if (!entry) {
+ /*
+ * Skip unknown process.
+ */
+
+ continue;
+ }
+
+ info = (ProcessInfo *) Tcl_GetHashValue(entry);
+ RefreshProcessInfo(info, options);
+
+ if (info->purge && autopurge) {
+ /*
+ * Purge entry.
+ */
+
+ Tcl_DeleteHashEntry(entry);
+ entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid);
+ Tcl_DeleteHashEntry(entry);
+ FreeProcessInfo(info);
+ } else {
+ /*
+ * Add to result.
+ */
+
+ Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid),
+ BuildProcessStatusObj(info));
+ }
+ }
+ Tcl_MutexUnlock(&infoTablesMutex);
+ }
+ Tcl_SetObjResult(interp, dict);
+ return TCL_OK;
+}
+
+/*----------------------------------------------------------------------
+ *
+ * ProcessPurgeObjCmd --
+ *
+ * This function implements the 'tcl::process purge' Tcl command.
+ * Refer to the user documentation for details on what it does.
+ *
+ * Results:
+ * Returns a standard Tcl result.
+ *
+ * Side effects:
+ * Frees all ProcessInfo structures with their purge flag set.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ProcessPurgeObjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ Tcl_HashEntry *entry;
+ Tcl_HashSearch search;
+ ProcessInfo *info;
+ int numPids;
+ Tcl_Obj **pidObjs;
+ int result;
+ int i;
+ int pid;
+
+ if (objc != 1 && objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?pids?");
+ return TCL_ERROR;
+ }
+
+ /*
+ * First reap detached procs so that their purge flag is up-to-date.
+ */
+
+ Tcl_ReapDetachedProcs();
+
+ if (objc == 1) {
+ /*
+ * Purge all terminated processes.
+ */
+
+ Tcl_MutexLock(&infoTablesMutex);
+ for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search);
+ entry != NULL; entry = Tcl_NextHashEntry(&search)) {
+ info = (ProcessInfo *) Tcl_GetHashValue(entry);
+ if (info->purge) {
+ Tcl_DeleteHashEntry(entry);
+ entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid);
+ Tcl_DeleteHashEntry(entry);
+ FreeProcessInfo(info);
+ }
+ }
+ Tcl_MutexUnlock(&infoTablesMutex);
+ } else {
+ /*
+ * Purge only provided processes.
+ */
+
+ result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs);
+ if (result != TCL_OK) {
+ return result;
+ }
+ Tcl_MutexLock(&infoTablesMutex);
+ for (i = 0; i < numPids; i++) {
+ result = Tcl_GetIntFromObj(interp, pidObjs[i], (int *) &pid);
+ if (result != TCL_OK) {
+ Tcl_MutexUnlock(&infoTablesMutex);
+ return result;
+ }
+
+ entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(pid));
+ if (!entry) {
+ /*
+ * Skip unknown process.
+ */
+
+ continue;
+ }
+
+ info = (ProcessInfo *) Tcl_GetHashValue(entry);
+ if (info->purge) {
+ Tcl_DeleteHashEntry(entry);
+ entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid);
+ Tcl_DeleteHashEntry(entry);
+ FreeProcessInfo(info);
+ }
+ }
+ Tcl_MutexUnlock(&infoTablesMutex);
+ }
+
+ return TCL_OK;
+}
+
+/*----------------------------------------------------------------------
+ *
+ * ProcessAutopurgeObjCmd --
+ *
+ * This function implements the 'tcl::process autopurge' Tcl command.
+ * Refer to the user documentation for details on what it does.
+ *
+ * Results:
+ * Returns a standard Tcl result.
+ *
+ * Side effects:
+ * Alters detached process handling by Tcl_ReapDetachedProcs().
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ProcessAutopurgeObjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ if (objc != 1 && objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?flag?");
+ return TCL_ERROR;
+ }
+
+ if (objc == 2) {
+ /*
+ * Set given value.
+ */
+
+ int flag;
+ int result = Tcl_GetBooleanFromObj(interp, objv[1], &flag);
+ if (result != TCL_OK) {
+ return result;
+ }
+
+ autopurge = !!flag;
+ }
+
+ /*
+ * Return current value.
+ */
+
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(autopurge));
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclInitProcessCmd --
+ *
+ * This procedure creates the "tcl::process" Tcl command. See the user
+ * documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Command
+TclInitProcessCmd(
+ Tcl_Interp *interp) /* Current interpreter. */
+{
+ static const EnsembleImplMap processImplMap[] = {
+ {"list", ProcessListObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1},
+ {"status", ProcessStatusObjCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 1},
+ {"purge", ProcessPurgeObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1},
+ {"autopurge", ProcessAutopurgeObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1},
+ {NULL, NULL, NULL, NULL, NULL, 0}
+ };
+ Tcl_Command processCmd;
+
+ if (infoTablesInitialized == 0) {
+ Tcl_MutexLock(&infoTablesMutex);
+ if (infoTablesInitialized == 0) {
+ Tcl_InitHashTable(&infoTablePerPid, TCL_ONE_WORD_KEYS);
+ Tcl_InitHashTable(&infoTablePerResolvedPid, TCL_ONE_WORD_KEYS);
+ infoTablesInitialized = 1;
+ }
+ Tcl_MutexUnlock(&infoTablesMutex);
+ }
+
+ processCmd = TclMakeEnsemble(interp, "::tcl::process", processImplMap);
+ Tcl_Export(interp, Tcl_FindNamespace(interp, "::tcl", NULL, 0),
+ "process", 0);
+ return processCmd;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclProcessCreated --
+ *
+ * Called when a child process has been created by Tcl.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Internal structures are updated with a new ProcessInfo.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclProcessCreated(
+ Tcl_Pid pid) /* Process id. */
+{
+ int resolvedPid;
+ Tcl_HashEntry *entry, *entry2;
+ int isNew;
+ ProcessInfo *info;
+
+ /*
+ * Get resolved pid first.
+ */
+
+ resolvedPid = TclpGetPid(pid);
+
+ Tcl_MutexLock(&infoTablesMutex);
+
+ /*
+ * Create entry in pid table.
+ */
+
+ entry = Tcl_CreateHashEntry(&infoTablePerPid, pid, &isNew);
+ if (!isNew) {
+ /*
+ * Pid was reused, free old info and reuse structure.
+ */
+
+ info = (ProcessInfo *) Tcl_GetHashValue(entry);
+ entry2 = Tcl_FindHashEntry(&infoTablePerResolvedPid,
+ INT2PTR(resolvedPid));
+ if (entry2) Tcl_DeleteHashEntry(entry2);
+ FreeProcessInfo(info);
+ }
+
+ /*
+ * Allocate and initialize info structure.
+ */
+
+ info = (ProcessInfo *) ckalloc(sizeof(ProcessInfo));
+ InitProcessInfo(info, pid, resolvedPid);
+
+ /*
+ * Add entry to tables.
+ */
+
+ Tcl_SetHashValue(entry, info);
+ entry = Tcl_CreateHashEntry(&infoTablePerResolvedPid, INT2PTR(resolvedPid),
+ &isNew);
+ Tcl_SetHashValue(entry, info);
+
+ Tcl_MutexUnlock(&infoTablesMutex);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclProcessWait --
+ *
+ * Wait for process status to change.
+ *
+ * Results:
+ * TclProcessWaitStatus enum value.
+ *
+ * Side effects:
+ * Completed process info structures are purged immediately (autopurge on)
+ * or eventually (autopurge off).
+ *
+ *----------------------------------------------------------------------
+ */
+
+TclProcessWaitStatus
+TclProcessWait(
+ Tcl_Pid pid, /* Process id. */
+ int options, /* Options passed to WaitProcessStatus. */
+ int *codePtr, /* If non-NULL, will receive either:
+ * - 0 for normal exit.
+ * - errno in case of error.
+ * - non-zero exit code for abormal exit.
+ * - signal number if killed or suspended.
+ * - Tcl_WaitPid status in all other cases.
+ */
+ Tcl_Obj **msgObjPtr, /* If non-NULL, will receive error message. */
+ Tcl_Obj **errorObjPtr) /* If non-NULL, will receive error code. */
+{
+ Tcl_HashEntry *entry;
+ ProcessInfo *info;
+ TclProcessWaitStatus result;
+
+ /*
+ * First search for pid in table.
+ */
+
+ entry = Tcl_FindHashEntry(&infoTablePerPid, pid);
+ if (!entry) {
+ /*
+ * Unknown process, just call WaitProcessStatus and return.
+ */
+
+ result = WaitProcessStatus(pid, TclpGetPid(pid), options, codePtr,
+ msgObjPtr, errorObjPtr);
+ if (msgObjPtr && *msgObjPtr) Tcl_IncrRefCount(*msgObjPtr);
+ if (errorObjPtr && *errorObjPtr) Tcl_IncrRefCount(*errorObjPtr);
+ return result;
+ }
+
+ info = (ProcessInfo *) Tcl_GetHashValue(entry);
+ if (info->purge) {
+ /*
+ * Process has completed but TclProcessWait has already been called,
+ * so report no change.
+ */
+
+ return TCL_PROCESS_UNCHANGED;
+ }
+
+ RefreshProcessInfo(info, options);
+ if (info->status == TCL_PROCESS_UNCHANGED) {
+ /*
+ * No change, stop there.
+ */
+
+ return TCL_PROCESS_UNCHANGED;
+ }
+
+ /*
+ * Set return values.
+ */
+
+ result = info->status;
+ if (codePtr) *codePtr = info->code;
+ if (msgObjPtr) *msgObjPtr = info->msg;
+ if (errorObjPtr) *errorObjPtr = info->error;
+ if (msgObjPtr && *msgObjPtr) Tcl_IncrRefCount(*msgObjPtr);
+ if (errorObjPtr && *errorObjPtr) Tcl_IncrRefCount(*errorObjPtr);
+
+ if (autopurge) {
+ /*
+ * Purge now.
+ */
+
+ Tcl_DeleteHashEntry(entry);
+ entry = Tcl_FindHashEntry(&infoTablePerResolvedPid,
+ INT2PTR(info->resolvedPid));
+ Tcl_DeleteHashEntry(entry);
+ FreeProcessInfo(info);
+ } else {
+ /*
+ * Eventually purge. Subsequent calls will return
+ * TCL_PROCESS_UNCHANGED.
+ */
+
+ info->purge = 1;
+ }
+ return result;
+}
diff --git a/generic/tclResult.c b/generic/tclResult.c
index 57a6de5..a5ec4be 100644
--- a/generic/tclResult.c
+++ b/generic/tclResult.c
@@ -651,23 +651,6 @@ Tcl_AppendResultVA(
}
Tcl_AppendStringsToObjVA(objPtr, argList);
Tcl_SetObjResult(interp, objPtr);
-
- /*
- * Strictly we should call Tcl_GetStringResult(interp) here to make sure
- * that interp->result is correct according to the old contract, but that
- * makes the performance of much code (e.g. in Tk) absolutely awful. So we
- * leave it out; code that really wants interp->result can just insert the
- * calls to Tcl_GetStringResult() itself. [Patch 1041072 discussion]
- */
-
-#ifdef USE_INTERP_RESULT
- /*
- * Ensure that the interp->result is legal so old Tcl 7.* code still
- * works. There's still embarrasingly much of it about...
- */
-
- (void) Tcl_GetStringResult(interp);
-#endif /* USE_INTERP_RESULT */
}
/*
diff --git a/generic/tclScan.c b/generic/tclScan.c
index e0798df..113b4c6 100644
--- a/generic/tclScan.c
+++ b/generic/tclScan.c
@@ -10,6 +10,7 @@
*/
#include "tclInt.h"
+#include "tommath.h"
/*
* Flag values used by Tcl_ScanObjCmd.
@@ -415,14 +416,7 @@ ValidateFormat(
case 'x':
case 'X':
case 'b':
- break;
case 'u':
- if (flags & SCAN_BIG) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "unsigned bignum scans are invalid", -1));
- Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADUNSIGNED",NULL);
- goto error;
- }
break;
/*
* Bracket terms need special checking
@@ -932,9 +926,9 @@ Tcl_ScanObjCmd(
}
if (flags & SCAN_LONGER) {
if (Tcl_GetWideIntFromObj(NULL, objPtr, &wideValue) != TCL_OK) {
- wideValue = ~(Tcl_WideUInt)0 >> 1; /* WIDE_MAX */
+ wideValue = LLONG_MAX;
if (TclGetString(objPtr)[0] == '-') {
- wideValue++; /* WIDE_MAX + 1 = WIDE_MIN */
+ wideValue = LLONG_MIN;
}
}
if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) {
@@ -942,9 +936,20 @@ Tcl_ScanObjCmd(
(Tcl_WideUInt)wideValue);
Tcl_SetStringObj(objPtr, buf, -1);
} else {
- Tcl_SetWideIntObj(objPtr, wideValue);
+ TclSetIntObj(objPtr, wideValue);
}
- } else if (!(flags & SCAN_BIG)) {
+ } else if (flags & SCAN_BIG) {
+ if (flags & SCAN_UNSIGNED) {
+ mp_int big;
+ if ((Tcl_GetBignumFromObj(interp, objPtr, &big) != TCL_OK)
+ || mp_isneg(&big)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "unsigned bignum scans are invalid", -1));
+ Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADUNSIGNED",NULL);
+ return TCL_ERROR;
+ }
+ }
+ } else {
if (TclGetLongFromObj(NULL, objPtr, &value) != TCL_OK) {
if (TclGetString(objPtr)[0] == '-') {
value = LONG_MIN;
@@ -956,7 +961,7 @@ Tcl_ScanObjCmd(
sprintf(buf, "%lu", value); /* INTL: ISO digit */
Tcl_SetStringObj(objPtr, buf, -1);
} else {
- Tcl_SetLongObj(objPtr, value);
+ TclSetIntObj(objPtr, value);
}
}
objs[objIndex++] = objPtr;
diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c
index 630e498..0434919 100644
--- a/generic/tclStrToD.c
+++ b/generic/tclStrToD.c
@@ -1268,32 +1268,18 @@ TclParseNumber(
}
}
if (!octalSignificandOverflow) {
- if (octalSignificandWide >
- (Tcl_WideUInt)(((~(unsigned long)0) >> 1) + signum)) {
-#ifndef TCL_WIDE_INT_IS_LONG
- if (octalSignificandWide <= (MOST_BITS + signum)) {
- objPtr->typePtr = &tclWideIntType;
- if (signum) {
- objPtr->internalRep.wideValue =
- - (Tcl_WideInt) octalSignificandWide;
- } else {
- objPtr->internalRep.wideValue =
- (Tcl_WideInt) octalSignificandWide;
- }
- break;
- }
-#endif
+ if (octalSignificandWide > (MOST_BITS + signum)) {
TclInitBignumFromWideUInt(&octalSignificandBig,
octalSignificandWide);
octalSignificandOverflow = 1;
} else {
objPtr->typePtr = &tclIntType;
if (signum) {
- objPtr->internalRep.longValue =
- - (long) octalSignificandWide;
+ objPtr->internalRep.wideValue =
+ - (Tcl_WideInt) octalSignificandWide;
} else {
- objPtr->internalRep.longValue =
- (long) octalSignificandWide;
+ objPtr->internalRep.wideValue =
+ (Tcl_WideInt) octalSignificandWide;
}
}
}
@@ -1315,32 +1301,18 @@ TclParseNumber(
}
returnInteger:
if (!significandOverflow) {
- if (significandWide >
- (Tcl_WideUInt)(((~(unsigned long)0) >> 1) + signum)) {
-#ifndef TCL_WIDE_INT_IS_LONG
- if (significandWide <= MOST_BITS+signum) {
- objPtr->typePtr = &tclWideIntType;
- if (signum) {
- objPtr->internalRep.wideValue =
- - (Tcl_WideInt) significandWide;
- } else {
- objPtr->internalRep.wideValue =
- (Tcl_WideInt) significandWide;
- }
- break;
- }
-#endif
+ if (significandWide > MOST_BITS+signum) {
TclInitBignumFromWideUInt(&significandBig,
significandWide);
significandOverflow = 1;
} else {
objPtr->typePtr = &tclIntType;
if (signum) {
- objPtr->internalRep.longValue =
- - (long) significandWide;
+ objPtr->internalRep.wideValue =
+ - (Tcl_WideInt) significandWide;
} else {
- objPtr->internalRep.longValue =
- (long) significandWide;
+ objPtr->internalRep.wideValue =
+ (Tcl_WideInt) significandWide;
}
}
}
@@ -4725,7 +4697,7 @@ TclCeil(
mp_int b;
mp_init(&b);
- if (mp_cmp_d(a, 0) == MP_LT) {
+ if (mp_isneg(a)) {
mp_neg(a, &b);
r = -TclFloor(&b);
} else {
@@ -4782,7 +4754,7 @@ TclFloor(
mp_int b;
mp_init(&b);
- if (mp_cmp_d(a, 0) == MP_LT) {
+ if (mp_isneg(a)) {
mp_neg(a, &b);
r = -TclCeil(&b);
} else {
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 385ce4f..9913160 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -38,6 +38,7 @@
#include "tommath.h"
#include "tclStringRep.h"
+#include "assert.h"
/*
* Prototypes for functions defined later in this file:
*/
@@ -140,8 +141,8 @@ GrowStringBuffer(
objPtr->bytes = NULL;
}
if (flag == 0 || stringPtr->allocated > 0) {
- attempt = 2 * needed;
- if (attempt >= 0) {
+ if (needed <= INT_MAX / 2) {
+ attempt = 2 * needed;
ptr = attemptckrealloc(objPtr->bytes, attempt + 1);
}
if (ptr == NULL) {
@@ -190,8 +191,8 @@ GrowUnicodeBuffer(
* Subsequent appends - apply the growth algorithm.
*/
- attempt = 2 * needed;
- if (attempt >= 0 && attempt <= STRING_MAXCHARS) {
+ if (needed <= STRING_MAXCHARS / 2) {
+ attempt = 2 * needed;
ptr = stringAttemptRealloc(stringPtr, attempt);
}
if (ptr == NULL) {
@@ -481,8 +482,7 @@ Tcl_GetUniChar(
/*
* Optimize the case where we're really dealing with a bytearray object
- * without string representation; we don't need to convert to a string to
- * perform the indexing operation.
+ * we don't need to convert to a string to perform the indexing operation.
*/
if (TclIsPureByteArray(objPtr)) {
@@ -522,7 +522,7 @@ Tcl_GetUniChar(
*
* Get the Unicode form of the String object. If the object is not
* already a String object, it will be converted to one. If the String
- * object does not have a Unicode rep, then one is create from the UTF
+ * object does not have a Unicode rep, then one is created from the UTF
* string format.
*
* Results:
@@ -615,8 +615,7 @@ Tcl_GetRange(
/*
* Optimize the case where we're really dealing with a bytearray object
- * without string representation; we don't need to convert to a string to
- * perform the substring operation.
+ * we don't need to convert to a string to perform the substring operation.
*/
if (TclIsPureByteArray(objPtr)) {
@@ -656,6 +655,17 @@ Tcl_GetRange(
stringPtr = GET_STRING(objPtr);
}
+#if TCL_UTF_MAX == 4
+ /* See: bug [11ae2be95dac9417] */
+ if ((first>0) && ((stringPtr->unicode[first]&0xFC00) == 0xDC00)
+ && ((stringPtr->unicode[first-1]&0xFC00) == 0xD800)) {
+ ++first;
+ }
+ if ((last+1<stringPtr->numChars) && ((stringPtr->unicode[last+1]&0xFC00) == 0xDC00)
+ && ((stringPtr->unicode[last]&0xFC00) == 0xD800)) {
+ ++last;
+ }
+#endif
return Tcl_NewUnicodeObj(stringPtr->unicode + first, last-first+1);
}
@@ -1213,9 +1223,9 @@ Tcl_AppendObjToObj(
/*
* Handle append of one bytearray object to another as a special case.
- * Note that we only do this when the objects don't have string reps; if
- * it did, then appending the byte arrays together could well lose
- * information; this is a special-case optimization only.
+ * Note that we only do this when the objects are pure so that the
+ * bytearray faithfully represent the true value; Otherwise
+ * appending the byte arrays together could lose information;
*/
if ((TclIsPureByteArray(objPtr) || objPtr->bytes == &tclEmptyString)
@@ -1885,20 +1895,10 @@ Tcl_AppendFormatToObj(
format += step;
step = TclUtfToUniChar(format, &ch);
}
- } else if ((ch == 't') || (ch == 'z')) {
- format += step;
- step = TclUtfToUniChar(format, &ch);
-#ifndef TCL_WIDE_INT_IS_LONG
- if (sizeof(size_t) > sizeof(int)) {
- useWide = 1;
- }
-#endif
- } else if ((ch == 'q') ||(ch == 'j')) {
+ } else if ((ch == 't') || (ch == 'z') || (ch == 'q') || (ch == 'j') || (ch == 'L')) {
format += step;
step = TclUtfToUniChar(format, &ch);
-#ifndef TCL_WIDE_INT_IS_LONG
- useWide = 1;
-#endif
+ useBig = 1;
}
format += step;
@@ -1944,11 +1944,6 @@ Tcl_AppendFormatToObj(
}
case 'u':
- if (useBig) {
- msg = "unsigned bignum format is invalid";
- errCode = "BADUNSIGNED";
- goto errorMsg;
- }
case 'd':
case 'o':
case 'p':
@@ -1968,13 +1963,25 @@ Tcl_AppendFormatToObj(
}
#endif
if (useBig) {
+ int cmpResult;
if (Tcl_GetBignumFromObj(interp, segment, &big) != TCL_OK) {
goto error;
}
- isNegative = (mp_cmp_d(&big, 0) == MP_LT);
+ cmpResult = mp_cmp_d(&big, 0);
+ isNegative = (cmpResult == MP_LT);
+ if (cmpResult == MP_EQ) gotHash = 0;
+ if (ch == 'u') {
+ if (isNegative) {
+ msg = "unsigned bignum format is invalid";
+ errCode = "BADUNSIGNED";
+ goto errorMsg;
+ } else {
+ ch = 'd';
+ }
+ }
#ifndef TCL_WIDE_INT_IS_LONG
} else if (useWide) {
- if (Tcl_GetWideIntFromObj(NULL, segment, &w) != TCL_OK) {
+ if (TclGetWideIntFromObj(NULL, segment, &w) != TCL_OK) {
Tcl_Obj *objPtr;
if (Tcl_GetBignumFromObj(interp,segment,&big) != TCL_OK) {
@@ -1983,13 +1990,14 @@ Tcl_AppendFormatToObj(
mp_mod_2d(&big, (int) CHAR_BIT*sizeof(Tcl_WideInt), &big);
objPtr = Tcl_NewBignumObj(&big);
Tcl_IncrRefCount(objPtr);
- Tcl_GetWideIntFromObj(NULL, objPtr, &w);
+ TclGetWideIntFromObj(NULL, objPtr, &w);
Tcl_DecrRefCount(objPtr);
}
isNegative = (w < (Tcl_WideInt) 0);
+ if (w == (Tcl_WideInt) 0) gotHash = 0;
#endif
} else if (TclGetLongFromObj(NULL, segment, &l) != TCL_OK) {
- if (Tcl_GetWideIntFromObj(NULL, segment, &w) != TCL_OK) {
+ if (TclGetWideIntFromObj(NULL, segment, &w) != TCL_OK) {
Tcl_Obj *objPtr;
if (Tcl_GetBignumFromObj(interp,segment,&big) != TCL_OK) {
@@ -2006,14 +2014,18 @@ Tcl_AppendFormatToObj(
if (useShort) {
s = (short) l;
isNegative = (s < (short) 0);
+ if (s == (short) 0) gotHash = 0;
} else {
isNegative = (l < (long) 0);
+ if (l == (long) 0) gotHash = 0;
}
} else if (useShort) {
s = (short) l;
isNegative = (s < (short) 0);
+ if (s == (short) 0) gotHash = 0;
} else {
isNegative = (l < (long) 0);
+ if (l == (long) 0) gotHash = 0;
}
segment = Tcl_NewObj();
@@ -2030,16 +2042,12 @@ Tcl_AppendFormatToObj(
if (gotHash || (ch == 'p')) {
switch (ch) {
case 'o':
- Tcl_AppendToObj(segment, "0", 1);
- segmentLimit -= 1;
- precision--;
- break;
- case 'X':
- Tcl_AppendToObj(segment, "0X", 2);
+ Tcl_AppendToObj(segment, "0o", 2);
segmentLimit -= 2;
break;
case 'p':
case 'x':
+ case 'X':
Tcl_AppendToObj(segment, "0x", 2);
segmentLimit -= 2;
break;
@@ -2047,10 +2055,14 @@ Tcl_AppendFormatToObj(
Tcl_AppendToObj(segment, "0b", 2);
segmentLimit -= 2;
break;
+#if TCL_MAJOR_VERSION < 9
case 'd':
- Tcl_AppendToObj(segment, "0d", 2);
- segmentLimit -= 2;
+ if (gotZero) {
+ Tcl_AppendToObj(segment, "0d", 2);
+ segmentLimit -= 2;
+ }
break;
+#endif
}
}
@@ -2188,7 +2200,7 @@ Tcl_AppendFormatToObj(
* Need to be sure zero becomes "0", not "".
*/
- if ((numDigits == 0) && !((ch == 'o') && gotHash)) {
+ if (numDigits == 0) {
numDigits = 1;
}
pure = Tcl_NewObj();
@@ -2255,6 +2267,8 @@ Tcl_AppendFormatToObj(
break;
}
+ case 'a':
+ case 'A':
case 'e':
case 'E':
case 'f':
@@ -2323,6 +2337,12 @@ Tcl_AppendFormatToObj(
errCode = "OVERFLOW";
goto errorMsg;
}
+ if (ch == 'A') {
+ char *p = TclGetString(segment) + 1;
+ *p = 'x';
+ p = strchr(p, 'P');
+ if (p) *p = 'p';
+ }
break;
}
default:
@@ -2528,15 +2548,26 @@ AppendPrintfToObjVA(
Tcl_ListObjAppendElement(NULL, list, Tcl_NewWideIntObj(
va_arg(argList, Tcl_WideInt)));
break;
+ case 3:
+ Tcl_ListObjAppendElement(NULL, list, Tcl_NewBignumObj(
+ va_arg(argList, mp_int *)));
+ break;
}
break;
+ case 'a':
+ case 'A':
case 'e':
case 'E':
case 'f':
case 'g':
case 'G':
+ if (size > 0) {
Tcl_ListObjAppendElement(NULL, list, Tcl_NewDoubleObj(
- va_arg(argList, double)));
+ (double)va_arg(argList, long double)));
+ } else {
+ Tcl_ListObjAppendElement(NULL, list, Tcl_NewDoubleObj(
+ va_arg(argList, double)));
+ }
seekingConversion = 0;
break;
case '*':
@@ -2556,7 +2587,6 @@ AppendPrintfToObjVA(
gotPrecision = 1;
p++;
break;
- /* TODO: support for bignum arguments */
case 'l':
++size;
p++;
@@ -2584,6 +2614,10 @@ AppendPrintfToObjVA(
}
p++;
break;
+ case 'L':
+ size = 3;
+ p++;
+ break;
case 'h':
size = -1;
default:
@@ -2697,23 +2731,24 @@ TclGetStringStorage(
* Performs the [string repeat] function.
*
* Results:
- * A standard Tcl result.
+ * A (Tcl_Obj *) pointing to the result value, or NULL in case of an
+ * error.
*
* Side effects:
- * Writes to *objPtrPtr the address of Tcl_Obj that is concatenation
- * of count copies of the value in objPtr.
+ * On error, when interp is not NULL, error information is left in it.
*
*---------------------------------------------------------------------------
*/
-int
+Tcl_Obj *
TclStringRepeat(
Tcl_Interp *interp,
Tcl_Obj *objPtr,
int count,
- Tcl_Obj **objPtrPtr)
+ int flags)
{
Tcl_Obj *objResultPtr;
+ int inPlace = flags & TCL_STRING_IN_PLACE;
int length = 0, unichar = 0, done = 1;
int binary = TclIsPureByteArray(objPtr);
@@ -2748,8 +2783,7 @@ TclStringRepeat(
if (length == 0) {
/* Any repeats of empty is empty. */
- *objPtrPtr = objPtr;
- return TCL_OK;
+ return objPtr;
}
if (count > INT_MAX/length) {
@@ -2758,13 +2792,13 @@ TclStringRepeat(
"max size for a Tcl value (%d bytes) exceeded", INT_MAX));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
}
- return TCL_ERROR;
+ return NULL;
}
if (binary) {
/* Efficiently produce a pure byte array result */
- objResultPtr = Tcl_IsShared(objPtr) ? Tcl_DuplicateObj(objPtr)
- : objPtr;
+ objResultPtr = (!inPlace || Tcl_IsShared(objPtr)) ?
+ Tcl_DuplicateObj(objPtr) : objPtr;
Tcl_SetByteArrayLength(objResultPtr, count*length); /* PANIC? */
Tcl_SetByteArrayLength(objResultPtr, length);
@@ -2777,7 +2811,7 @@ TclStringRepeat(
(count - done) * length);
} else if (unichar) {
/* Efficiently produce a pure Tcl_UniChar array result */
- if (Tcl_IsShared(objPtr)) {
+ if (!inPlace || Tcl_IsShared(objPtr)) {
objResultPtr = Tcl_NewUnicodeObj(Tcl_GetUnicode(objPtr), length);
} else {
TclInvalidateStringRep(objPtr);
@@ -2788,11 +2822,11 @@ TclStringRepeat(
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"string size overflow: unable to alloc %"
- TCL_LL_MODIFIER "d bytes",
- (Tcl_WideUInt)STRING_SIZE(count*length)));
+ TCL_Z_MODIFIER "u bytes",
+ STRING_SIZE(count*length)));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
}
- return TCL_ERROR;
+ return NULL;
}
Tcl_SetObjLength(objResultPtr, length);
while (count - done > done) {
@@ -2803,7 +2837,7 @@ TclStringRepeat(
(count - done) * length);
} else {
/* Efficiently concatenate string reps */
- if (Tcl_IsShared(objPtr)) {
+ if (!inPlace || Tcl_IsShared(objPtr)) {
objResultPtr = Tcl_NewStringObj(Tcl_GetString(objPtr), length);
} else {
TclFreeIntRep(objPtr);
@@ -2816,7 +2850,7 @@ TclStringRepeat(
count*length));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
}
- return TCL_ERROR;
+ return NULL;
}
Tcl_SetObjLength(objResultPtr, length);
while (count - done > done) {
@@ -2826,47 +2860,45 @@ TclStringRepeat(
Tcl_AppendToObj(objResultPtr, Tcl_GetString(objResultPtr),
(count - done) * length);
}
- *objPtrPtr = objResultPtr;
- return TCL_OK;
+ return objResultPtr;
}
/*
*---------------------------------------------------------------------------
*
- * TclStringCatObjv --
+ * TclStringCat --
*
* Performs the [string cat] function.
*
* Results:
- * A standard Tcl result.
+ * A (Tcl_Obj *) pointing to the result value, or NULL in case of an
+ * error.
*
* Side effects:
- * Writes to *objPtrPtr the address of Tcl_Obj that is concatenation
- * of all objc values in objv.
+ * On error, when interp is not NULL, error information is left in it.
*
*---------------------------------------------------------------------------
*/
-int
-TclStringCatObjv(
+Tcl_Obj *
+TclStringCat(
Tcl_Interp *interp,
- int inPlace,
int objc,
Tcl_Obj * const objv[],
- Tcl_Obj **objPtrPtr)
+ int flags)
{
Tcl_Obj *objResultPtr, * const *ov;
int oc, length = 0, binary = 1;
int allowUniChar = 1, requestUniChar = 0;
int first = objc - 1; /* Index of first value possibly not empty */
int last = 0; /* Index of last value possibly not empty */
+ int inPlace = flags & TCL_STRING_IN_PLACE;
/* assert ( objc >= 0 ) */
if (objc <= 1) {
/* Only one or no objects; return first or empty */
- *objPtrPtr = objc ? objv[0] : Tcl_NewObj();
- return TCL_OK;
+ return objc ? objv[0] : Tcl_NewObj();
}
/* assert ( objc >= 2 ) */
@@ -2882,7 +2914,9 @@ TclStringCatObjv(
do {
Tcl_Obj *objPtr = *ov++;
- if (objPtr->bytes) {
+ if (TclIsPureByteArray(objPtr)) {
+ allowUniChar = 0;
+ } else if (objPtr->bytes) {
/* Value has a string rep. */
if (objPtr->length) {
/*
@@ -2897,17 +2931,13 @@ TclStringCatObjv(
}
} else {
/* assert (objPtr->typePtr != NULL) -- stork! */
- if (TclIsPureByteArray(objPtr)) {
- allowUniChar = 0;
+ binary = 0;
+ if (objPtr->typePtr == &tclStringType) {
+ /* Have a pure Unicode value; ask to preserve it */
+ requestUniChar = 1;
} else {
- binary = 0;
- if (objPtr->typePtr == &tclStringType) {
- /* Have a pure Unicode value; ask to preserve it */
- requestUniChar = 1;
- } else {
- /* Have another type; prevent shimmer */
- allowUniChar = 0;
- }
+ /* Have another type; prevent shimmer */
+ allowUniChar = 0;
}
}
} while (--oc && (binary || allowUniChar));
@@ -3043,8 +3073,7 @@ TclStringCatObjv(
if (last <= first /*|| length == 0 */) {
/* Only one non-empty value or zero length; return first */
/* NOTE: (length == 0) implies (last <= first) */
- *objPtrPtr = objv[first];
- return TCL_OK;
+ return objv[first];
}
objv += first; objc = (last - first + 1);
@@ -3094,11 +3123,11 @@ TclStringCatObjv(
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"concatenation failed: unable to alloc %"
- TCL_LL_MODIFIER "d bytes",
- (Tcl_WideUInt)STRING_SIZE(length)));
+ TCL_Z_MODIFIER "u bytes",
+ STRING_SIZE(length)));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
}
- return TCL_ERROR;
+ return NULL;
}
dst = Tcl_GetUnicode(objResultPtr) + start;
} else {
@@ -3111,11 +3140,11 @@ TclStringCatObjv(
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"concatenation failed: unable to alloc %"
- TCL_LL_MODIFIER "d bytes",
- (Tcl_WideUInt)STRING_SIZE(length)));
+ TCL_Z_MODIFIER "u bytes",
+ STRING_SIZE(length)));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
}
- return TCL_ERROR;
+ return NULL;
}
dst = Tcl_GetUnicode(objResultPtr);
}
@@ -3146,7 +3175,7 @@ TclStringCatObjv(
length));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
}
- return TCL_ERROR;
+ return NULL;
}
dst = Tcl_GetString(objResultPtr) + start;
@@ -3162,7 +3191,7 @@ TclStringCatObjv(
length));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
}
- return TCL_ERROR;
+ return NULL;
}
dst = Tcl_GetString(objResultPtr);
}
@@ -3177,8 +3206,7 @@ TclStringCatObjv(
}
}
}
- *objPtrPtr = objResultPtr;
- return TCL_OK;
+ return objResultPtr;
overflow:
if (interp) {
@@ -3186,13 +3214,13 @@ TclStringCatObjv(
"max size for a Tcl value (%d bytes) exceeded", INT_MAX));
Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
}
- return TCL_ERROR;
+ return NULL;
}
/*
*---------------------------------------------------------------------------
*
- * TclStringFind --
+ * TclStringFirst --
*
* Implements the [string first] operation.
*
@@ -3208,20 +3236,20 @@ TclStringCatObjv(
*/
int
-TclStringFind(
+TclStringFirst(
Tcl_Obj *needle,
Tcl_Obj *haystack,
int start)
{
int lh, ln = Tcl_GetCharLength(needle);
+ if (start < 0) {
+ start = 0;
+ }
if (ln == 0) {
- /*
- * We don't find empty substrings. Bizarre!
- *
- * TODO: When we one day make this a true substring
- * finder, change this to "return 0"
- */
+ /* We don't find empty substrings. Bizarre!
+ * Whenever this routine is turned into a proper substring
+ * finder, change to `return start` after limits imposed. */
return -1;
}
@@ -3229,51 +3257,46 @@ TclStringFind(
unsigned char *end, *try, *bh;
unsigned char *bn = Tcl_GetByteArrayFromObj(needle, &ln);
+ /* Find bytes in bytes */
bh = Tcl_GetByteArrayFromObj(haystack, &lh);
end = bh + lh;
try = bh + start;
while (try + ln <= end) {
- try = memchr(try, bn[0], end - try);
-
+ /*
+ * Look for the leading byte of the needle in the haystack
+ * starting at try and stopping when there's not enough room
+ * for the needle left.
+ */
+ try = memchr(try, bn[0], (end + 1 - ln) - try);
if (try == NULL) {
+ /* Leading byte not found -> needle cannot be found. */
return -1;
}
+ /* Leading byte found, check rest of needle. */
if (0 == memcmp(try+1, bn+1, ln-1)) {
+ /* Checks! Return the successful index. */
return (try - bh);
}
+ /* Rest of needle match failed; Iterate to continue search. */
try++;
}
return -1;
}
/*
- * Check if we have two strings of single-byte characters. If we have, we
- * can use strstr() to do the search. Note that we can sometimes have
- * multibyte characters when the string could be minimally represented
- * using single byte characters; we can't assume that a mismatch here
- * means no match.
+ * TODO: It might be nice to support some cases where it is not
+ * necessary to shimmer to &tclStringType to compute the result,
+ * and instead operate just on the objPtr->bytes values directly.
+ * However, we also do not want the answer to change based on the
+ * code pathway, or if it does we want that to be for some values
+ * we explicitly decline to support. Getting there will involve
+ * locking down in practice more firmly just what encodings produce
+ * what supported results for the objPtr->bytes values. For now,
+ * do only the well-defined Tcl_UniChar array search.
*/
- lh = Tcl_GetCharLength(haystack);
- if (haystack->bytes && (lh == haystack->length) && needle->bytes
- && (ln == needle->length)) {
- /*
- * Both haystack and needle are all single-byte chars.
- */
-
- char *found = strstr(haystack->bytes + start, needle->bytes);
-
- if (found) {
- return (found - haystack->bytes);
- } else {
- return -1;
- }
- } else {
- /*
- * Do the search on the unicode representation for simplicity.
- */
-
+ {
Tcl_UniChar *try, *end, *uh;
Tcl_UniChar *un = Tcl_GetUnicodeFromObj(needle, &ln);
@@ -3321,24 +3344,24 @@ TclStringLast(
* We don't find empty substrings. Bizarre!
*
* TODO: When we one day make this a true substring
- * finder, change this to "return 0"
+ * finder, change this to "return last", after limitation.
*/
return -1;
}
- if (ln > last + 1) {
+ lh = Tcl_GetCharLength(haystack);
+ if (last >= lh) {
+ last = lh - 1;
+ }
+
+ if (last < ln - 1) {
return -1;
}
if (TclIsPureByteArray(needle) && TclIsPureByteArray(haystack)) {
- unsigned char *try, *bh;
+ unsigned char *try, *bh = Tcl_GetByteArrayFromObj(haystack, &lh);
unsigned char *bn = Tcl_GetByteArrayFromObj(needle, &ln);
- bh = Tcl_GetByteArrayFromObj(haystack, &lh);
-
- if (last + 1 > lh) {
- last = lh - 1;
- }
try = bh + last + 1 - ln;
while (try >= bh) {
if ((*try == bn[0])
@@ -3350,38 +3373,10 @@ TclStringLast(
return -1;
}
- lh = Tcl_GetCharLength(haystack);
- if (last + 1 > lh) {
- last = lh - 1;
- }
- if (haystack->bytes && (lh == haystack->length)) {
- /* haystack is all single-byte chars */
-
- if (needle->bytes && (ln == needle->length)) {
- /* needle is also all single-byte chars */
-
- char *try = haystack->bytes + last + 1 - ln;
- while (try >= haystack->bytes) {
- if ((*try == needle->bytes[0])
- && (0 == memcmp(try+1, needle->bytes + 1, ln - 1))) {
- return (try - haystack->bytes);
- }
- try--;
- }
- return -1;
- } else {
- /*
- * Cannot find substring with a multi-byte char inside
- * a string with no multi-byte chars.
- */
- return -1;
- }
- } else {
- Tcl_UniChar *try, *uh;
+ {
+ Tcl_UniChar *try, *uh = Tcl_GetUnicodeFromObj(haystack, &lh);
Tcl_UniChar *un = Tcl_GetUnicodeFromObj(needle, &ln);
- uh = Tcl_GetUnicodeFromObj(haystack, &lh);
-
try = uh + last + 1 - ln;
while (try >= uh) {
if ((*try == un[0])
@@ -3397,14 +3392,14 @@ TclStringLast(
/*
*---------------------------------------------------------------------------
*
- * TclStringObjReverse --
+ * TclStringReverse --
*
* Implements the [string reverse] operation.
*
* Results:
- * An unshared Tcl value which is the [string reverse] of the argument
- * supplied. When sharing rules permit, the returned value might be the
- * argument with modifications done in place.
+ * A Tcl value which is the [string reverse] of the argument supplied.
+ * When sharing rules permit and the caller requests, the returned value
+ * might be the argument with modifications done in place.
*
* Side effects:
* May allocate a new Tcl_Obj.
@@ -3435,17 +3430,19 @@ ReverseBytes(
}
Tcl_Obj *
-TclStringObjReverse(
- Tcl_Obj *objPtr)
+TclStringReverse(
+ Tcl_Obj *objPtr,
+ int flags)
{
String *stringPtr;
Tcl_UniChar ch = 0;
+ int inPlace = flags & TCL_STRING_IN_PLACE;
if (TclIsPureByteArray(objPtr)) {
int numBytes;
unsigned char *from = Tcl_GetByteArrayFromObj(objPtr, &numBytes);
- if (Tcl_IsShared(objPtr)) {
+ if (!inPlace || Tcl_IsShared(objPtr)) {
objPtr = Tcl_NewByteArrayObj(NULL, numBytes);
}
ReverseBytes(Tcl_GetByteArrayFromObj(objPtr, NULL), from, numBytes);
@@ -3459,7 +3456,7 @@ TclStringObjReverse(
Tcl_UniChar *from = Tcl_GetUnicode(objPtr);
Tcl_UniChar *src = from + stringPtr->numChars;
- if (Tcl_IsShared(objPtr)) {
+ if (!inPlace || Tcl_IsShared(objPtr)) {
Tcl_UniChar *to;
/*
@@ -3488,7 +3485,7 @@ TclStringObjReverse(
int numBytes = objPtr->length;
char *to, *from = objPtr->bytes;
- if (Tcl_IsShared(objPtr)) {
+ if (!inPlace || Tcl_IsShared(objPtr)) {
objPtr = Tcl_NewObj();
Tcl_SetObjLength(objPtr, numBytes);
}
@@ -3535,6 +3532,150 @@ TclStringObjReverse(
/*
*---------------------------------------------------------------------------
*
+ * TclStringReplace --
+ *
+ * Implements the inner engine of the [string replace] command.
+ *
+ * The result is a concatenation of a prefix from objPtr, characters
+ * 0 through first-1, the insertPtr string value, and a suffix from
+ * objPtr, characters from first + count to the end. The effect is
+ * as if the inner substring of characters first through first+count-1
+ * are removed and replaced with insertPtr.
+ * If insertPtr is NULL, it is treated as an empty string.
+ * When passed the flag TCL_STRING_IN_PLACE, this routine will try
+ * to do the work within objPtr, so long as no sharing forbids it.
+ * Without that request, or as needed, a new Tcl value will be allocated
+ * to be the result.
+ *
+ * Results:
+ * A Tcl value that is the result of the substring replacement.
+ * May return NULL in case of an error. When NULL is returned and
+ * interp is non-NULL, error information is left in interp
+ *
+ *---------------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclStringReplace(
+ Tcl_Interp *interp, /* For error reporting, may be NULL */
+ Tcl_Obj *objPtr, /* String to act upon */
+ int first, /* First index to replace */
+ int count, /* How many chars to replace */
+ Tcl_Obj *insertPtr, /* Replacement string, may be NULL */
+ int flags) /* TCL_STRING_IN_PLACE => attempt in-place */
+{
+ int inPlace = flags & TCL_STRING_IN_PLACE;
+ Tcl_Obj *result;
+
+ /* Caller is expected to pass sensible arguments */
+ assert ( count >= 0 ) ;
+ assert ( first >= 0 ) ;
+
+ /* Replace nothing with nothing */
+ if ((insertPtr == NULL) && (count == 0)) {
+ if (inPlace) {
+ return objPtr;
+ } else {
+ return Tcl_DuplicateObj(objPtr);
+ }
+ }
+
+ /*
+ * The caller very likely had to call Tcl_GetCharLength() or similar
+ * to be able to process index values. This means it is like that
+ * objPtr is either a proper "bytearray" or a "string" or else it has
+ * a known and short string rep.
+ */
+
+ if (TclIsPureByteArray(objPtr)) {
+ int numBytes;
+ unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &numBytes);
+
+ if (insertPtr == NULL) {
+ /* Replace something with nothing. */
+
+ assert ( first <= numBytes ) ;
+ assert ( count <= numBytes ) ;
+ assert ( first + count <= numBytes ) ;
+
+ result = Tcl_NewByteArrayObj(NULL, numBytes - count);/* PANIC? */
+ TclAppendBytesToByteArray(result, bytes, first);
+ TclAppendBytesToByteArray(result, bytes + first + count,
+ numBytes - count - first);
+ return result;
+ }
+
+ /* Replace everything */
+ if ((first == 0) && (count == numBytes)) {
+ return insertPtr;
+ }
+
+ if (TclIsPureByteArray(insertPtr)) {
+ int newBytes;
+ unsigned char *iBytes
+ = Tcl_GetByteArrayFromObj(insertPtr, &newBytes);
+
+ if (count == newBytes && inPlace && !Tcl_IsShared(objPtr)) {
+ /*
+ * Removal count and replacement count are equal.
+ * Other conditions permit. Do in-place splice.
+ */
+
+ memcpy(bytes + first, iBytes, count);
+ Tcl_InvalidateStringRep(objPtr);
+ return objPtr;
+ }
+
+ if (newBytes > INT_MAX - (numBytes - count)) {
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "max size for a Tcl value (%d bytes) exceeded",
+ INT_MAX));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ }
+ return NULL;
+ }
+ result = Tcl_NewByteArrayObj(NULL, numBytes - count + newBytes);
+ /* PANIC? */
+ TclAppendBytesToByteArray(result, bytes, first);
+ TclAppendBytesToByteArray(result, iBytes, newBytes);
+ TclAppendBytesToByteArray(result, bytes + first + count,
+ numBytes - count - first);
+ return result;
+ }
+
+ /* Flow through to try other approaches below */
+ }
+
+ /*
+ * TODO: Figure out how not to generate a Tcl_UniChar array rep
+ * when it can be determined objPtr->bytes points to a string of
+ * all single-byte characters so we can index it directly.
+ */
+
+ /* The traditional implementation... */
+ {
+ int numChars;
+ Tcl_UniChar *ustring = Tcl_GetUnicodeFromObj(objPtr, &numChars);
+
+ /* TODO: Is there an in-place option worth pursuing here? */
+
+ result = Tcl_NewUnicodeObj(ustring, first);
+ if (insertPtr) {
+ Tcl_AppendObjToObj(result, insertPtr);
+ }
+ if (first + count < numChars) {
+ Tcl_AppendUnicodeToObj(result, ustring + first + count,
+ numChars - first - count);
+ }
+
+ return result;
+ }
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
* FillUnicodeRep --
*
* Populate the Unicode internal rep with the Unicode form of its string
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index bd0971b..86406c1 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -31,6 +31,7 @@
#undef Tcl_NewIntObj
#undef Tcl_NewListObj
#undef Tcl_NewLongObj
+#undef Tcl_DbNewLongObj
#undef Tcl_NewObj
#undef Tcl_NewStringObj
#undef Tcl_DumpActiveMemory
@@ -42,6 +43,7 @@
#undef TclpGetPid
#undef TclSockMinimumBuffers
#undef Tcl_SetIntObj
+#undef Tcl_SetLongObj
#undef TclpInetNtoa
#undef TclWinGetServByName
#undef TclWinGetSockOpt
@@ -71,9 +73,19 @@ static int TclSockMinimumBuffersOld(int sock, int size)
# define TclWinSetSockOpt 0
# define TclWinNToHS 0
# define TclWinGetPlatformId 0
+# define TclWinResetInterfaces 0
+# define TclWinSetInterfaces 0
+# define TclWinGetPlatformId 0
# define TclBNInitBignumFromWideUInt 0
# define TclBNInitBignumFromWideInt 0
# define TclBNInitBignumFromLong 0
+# define Tcl_Backslash 0
+# define Tcl_GetDefaultEncodingDir 0
+# define Tcl_SetDefaultEncodingDir 0
+# define Tcl_EvalTokens 0
+# define Tcl_CreateMathFunc 0
+# define Tcl_GetMathFuncInfo 0
+# define Tcl_ListMathFuncs 0
#else
#define TclSetStartupScriptPath setStartupScriptPath
static void TclSetStartupScriptPath(Tcl_Obj *path)
@@ -100,11 +112,16 @@ static const char *TclGetStartupScriptFileName(void)
}
return Tcl_GetString(path);
}
-
#if defined(_WIN32) || defined(__CYGWIN__)
#undef TclWinNToHS
#undef TclWinGetPlatformId
-#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
+#undef TclWinResetInterfaces
+#undef TclWinSetInterfaces
+static void
+doNothing(void)
+{
+ /* dummy implementation, no need to do anything */
+}
#define TclWinNToHS winNToHS
static unsigned short TclWinNToHS(unsigned short ns) {
return ntohs(ns);
@@ -115,10 +132,8 @@ TclWinGetPlatformId(void)
{
return 2; /* VER_PLATFORM_WIN32_NT */;
}
-#else
-#define TclWinNToHS 0
-#define TclWinGetPlatformId 0
-#endif
+#define TclWinResetInterfaces doNothing
+#define TclWinSetInterfaces (void (*) (int)) doNothing
#endif
# define TclBNInitBignumFromWideUInt TclInitBignumFromWideUInt
# define TclBNInitBignumFromWideInt TclInitBignumFromWideInt
@@ -133,12 +148,15 @@ TclWinGetPlatformId(void)
# define TclpIsAtty 0
#elif defined(__CYGWIN__)
# define TclpIsAtty TclPlatIsAtty
-# define TclWinSetInterfaces (void (*) (int)) doNothing
+#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8
+static void
+doNothing(void)
+{
+ /* dummy implementation, no need to do anything */
+}
+#endif
# define TclWinAddProcess (void (*) (void *, unsigned int)) doNothing
# define TclWinFlushDirtyChannels doNothing
-# define TclWinResetInterfaces doNothing
-
-static Tcl_Encoding winTCharEncoding;
static int
TclpIsAtty(int fd)
@@ -150,7 +168,7 @@ void *TclWinGetTclInstance()
{
void *hInstance = NULL;
GetModuleHandleExW(GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS,
- (const char *)&winTCharEncoding, &hInstance);
+ (const char *)&TclpIsAtty, &hInstance);
return hInstance;
}
@@ -199,23 +217,23 @@ TclpGetPid(Tcl_Pid pid)
return (int) (size_t) pid;
}
-static void
-doNothing(void)
-{
- /* dummy implementation, no need to do anything */
-}
-
char *
Tcl_WinUtfToTChar(
const char *string,
int len,
Tcl_DString *dsPtr)
{
- if (!winTCharEncoding) {
- winTCharEncoding = Tcl_GetEncoding(0, "unicode");
- }
- return Tcl_UtfToExternalDString(winTCharEncoding,
- string, len, dsPtr);
+ WCHAR *wp;
+ int size = MultiByteToWideChar(CP_UTF8, 0, string, len, 0, 0);
+
+ Tcl_DStringInit(dsPtr);
+ Tcl_DStringSetLength(dsPtr, 2*size+2);
+ wp = (WCHAR *)Tcl_DStringValue(dsPtr);
+ MultiByteToWideChar(CP_UTF8, 0, string, len, wp, size+1);
+ if (len == -1) --size; /* account for 0-byte at string end */
+ Tcl_DStringSetLength(dsPtr, 2*size);
+ wp[size] = 0;
+ return (char *)wp;
}
char *
@@ -224,11 +242,21 @@ Tcl_WinTCharToUtf(
int len,
Tcl_DString *dsPtr)
{
- if (!winTCharEncoding) {
- winTCharEncoding = Tcl_GetEncoding(0, "unicode");
+ char *p;
+ int size;
+
+ if (len > 0) {
+ len /= 2;
}
- return Tcl_ExternalToUtfDString(winTCharEncoding,
- string, len, dsPtr);
+ size = WideCharToMultiByte(CP_UTF8, 0, string, len, 0, 0, NULL, NULL);
+ Tcl_DStringInit(dsPtr);
+ Tcl_DStringSetLength(dsPtr, size+1);
+ p = (char *)Tcl_DStringValue(dsPtr);
+ WideCharToMultiByte(CP_UTF8, 0, string, len, p, size, NULL, NULL);
+ if (len == -1) --size; /* account for 0-byte at string end */
+ Tcl_DStringSetLength(dsPtr, size);
+ p[size] = 0;
+ return p;
}
#if defined(TCL_WIDE_INT_IS_LONG)
@@ -249,7 +277,7 @@ static Tcl_Obj *dbNewLongObj(
TclDbNewObj(objPtr, file, line);
objPtr->bytes = NULL;
- objPtr->internalRep.longValue = (long) intValue;
+ objPtr->internalRep.wideValue = (long) intValue;
objPtr->typePtr = &tclIntType;
return objPtr;
#else
diff --git a/generic/tclTest.c b/generic/tclTest.c
index 7fb1f29..2ddb595 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -305,14 +305,6 @@ static int TestlinkCmd(ClientData dummy,
static int TestlocaleCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
-#ifndef TCL_NO_DEPRECATED
-static int TestMathFunc(ClientData clientData,
- Tcl_Interp *interp, Tcl_Value *args,
- Tcl_Value *resultPtr);
-static int TestMathFunc2(ClientData clientData,
- Tcl_Interp *interp, Tcl_Value *args,
- Tcl_Value *resultPtr);
-#endif /* TCL_NO_DEPRECATED */
static int TestmainthreadCmd(ClientData dummy,
Tcl_Interp *interp, int argc, const char **argv);
static int TestsetmainloopCmd(ClientData dummy,
@@ -555,10 +547,6 @@ int
Tcltest_Init(
Tcl_Interp *interp) /* Interpreter for application. */
{
-#ifndef TCL_NO_DEPRECATED
- Tcl_ValueType t3ArgTypes[2];
-#endif /* TCL_NO_DEPRECATED */
-
Tcl_Obj *listPtr;
Tcl_Obj **objv;
int objc, index;
@@ -711,10 +699,6 @@ Tcltest_Init(
Tcl_CreateCommand(interp, "testtranslatefilename",
TesttranslatefilenameCmd, NULL, NULL);
Tcl_CreateCommand(interp, "testupvar", TestupvarCmd, NULL, NULL);
-#ifndef TCL_NO_DEPRECATED
- Tcl_CreateMathFunc(interp, "T1", 0, NULL, TestMathFunc, (ClientData) 123);
- Tcl_CreateMathFunc(interp, "T2", 0, NULL, TestMathFunc, (ClientData) 345);
-#endif /* TCL_NO_DEPRECATED */
Tcl_CreateCommand(interp, "testmainthread", TestmainthreadCmd, NULL,
NULL);
Tcl_CreateCommand(interp, "testsetmainloop", TestsetmainloopCmd,
@@ -725,13 +709,6 @@ Tcltest_Init(
Tcl_CreateObjCommand(interp, "testcpuid", TestcpuidCmd,
(ClientData) 0, NULL);
#endif
-#ifndef TCL_NO_DEPRECATED
- t3ArgTypes[0] = TCL_EITHER;
- t3ArgTypes[1] = TCL_EITHER;
- Tcl_CreateMathFunc(interp, "T3", 2, t3ArgTypes, TestMathFunc2,
- NULL);
-#endif /* TCL_NO_DEPRECATED */
-
Tcl_CreateObjCommand(interp, "testnreunwind", TestNREUnwind,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testnrelevels", TestNRELevels,
@@ -3357,146 +3334,6 @@ TestlocaleCmd(
/*
*----------------------------------------------------------------------
*
- * TestMathFunc --
- *
- * This is a user-defined math procedure to test out math procedures
- * with no arguments.
- *
- * Results:
- * A normal Tcl completion code.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
- /* ARGSUSED */
-#ifndef TCL_NO_DEPRECATED
-static int
-TestMathFunc(
- ClientData clientData, /* Integer value to return. */
- Tcl_Interp *interp, /* Not used. */
- Tcl_Value *args, /* Not used. */
- Tcl_Value *resultPtr) /* Where to store result. */
-{
- resultPtr->type = TCL_INT;
- resultPtr->intValue = PTR2INT(clientData);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TestMathFunc2 --
- *
- * This is a user-defined math procedure to test out math procedures
- * that do have arguments, in this case 2.
- *
- * Results:
- * A normal Tcl completion code.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
- /* ARGSUSED */
-static int
-TestMathFunc2(
- ClientData clientData, /* Integer value to return. */
- Tcl_Interp *interp, /* Used to report errors. */
- Tcl_Value *args, /* Points to an array of two Tcl_Value structs
- * for the two arguments. */
- Tcl_Value *resultPtr) /* Where to store the result. */
-{
- int result = TCL_OK;
-
- /*
- * Return the maximum of the two arguments with the correct type.
- */
-
- if (args[0].type == TCL_INT) {
- int i0 = args[0].intValue;
-
- if (args[1].type == TCL_INT) {
- int i1 = args[1].intValue;
-
- resultPtr->type = TCL_INT;
- resultPtr->intValue = ((i0 > i1)? i0 : i1);
- } else if (args[1].type == TCL_DOUBLE) {
- double d0 = i0;
- double d1 = args[1].doubleValue;
-
- resultPtr->type = TCL_DOUBLE;
- resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
- } else if (args[1].type == TCL_WIDE_INT) {
- Tcl_WideInt w0 = Tcl_LongAsWide(i0);
- Tcl_WideInt w1 = args[1].wideValue;
-
- resultPtr->type = TCL_WIDE_INT;
- resultPtr->wideValue = ((w0 > w1)? w0 : w1);
- } else {
- Tcl_AppendResult(interp, "T3: wrong type for arg 2", NULL);
- result = TCL_ERROR;
- }
- } else if (args[0].type == TCL_DOUBLE) {
- double d0 = args[0].doubleValue;
-
- if (args[1].type == TCL_INT) {
- double d1 = args[1].intValue;
-
- resultPtr->type = TCL_DOUBLE;
- resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
- } else if (args[1].type == TCL_DOUBLE) {
- double d1 = args[1].doubleValue;
-
- resultPtr->type = TCL_DOUBLE;
- resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
- } else if (args[1].type == TCL_WIDE_INT) {
- double d1 = Tcl_WideAsDouble(args[1].wideValue);
-
- resultPtr->type = TCL_DOUBLE;
- resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
- } else {
- Tcl_AppendResult(interp, "T3: wrong type for arg 2", NULL);
- result = TCL_ERROR;
- }
- } else if (args[0].type == TCL_WIDE_INT) {
- Tcl_WideInt w0 = args[0].wideValue;
-
- if (args[1].type == TCL_INT) {
- Tcl_WideInt w1 = Tcl_LongAsWide(args[1].intValue);
-
- resultPtr->type = TCL_WIDE_INT;
- resultPtr->wideValue = ((w0 > w1)? w0 : w1);
- } else if (args[1].type == TCL_DOUBLE) {
- double d0 = Tcl_WideAsDouble(w0);
- double d1 = args[1].doubleValue;
-
- resultPtr->type = TCL_DOUBLE;
- resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
- } else if (args[1].type == TCL_WIDE_INT) {
- Tcl_WideInt w1 = args[1].wideValue;
-
- resultPtr->type = TCL_WIDE_INT;
- resultPtr->wideValue = ((w0 > w1)? w0 : w1);
- } else {
- Tcl_AppendResult(interp, "T3: wrong type for arg 2", NULL);
- result = TCL_ERROR;
- }
- } else {
- Tcl_AppendResult(interp, "T3: wrong type for arg 1", NULL);
- result = TCL_ERROR;
- }
- return result;
-}
-#endif /* TCL_NO_DEPRECATED */
-
-/*
- *----------------------------------------------------------------------
- *
* CleanupTestSetassocdataTests --
*
* This function is called when an interpreter is deleted to clean
@@ -5370,7 +5207,7 @@ TestmainthreadCmd(
const char **argv) /* Argument strings. */
{
if (argc == 1) {
- Tcl_Obj *idObj = Tcl_NewLongObj((long)(size_t)Tcl_GetCurrentThread());
+ Tcl_Obj *idObj = Tcl_NewWideIntObj((Tcl_WideInt)(size_t)Tcl_GetCurrentThread());
Tcl_SetObjResult(interp, idObj);
return TCL_OK;
@@ -5767,8 +5604,8 @@ TestChannelCmd(
return TCL_ERROR;
}
- TclFormatInt(buf, (size_t) Tcl_GetChannelThread(chan));
- Tcl_AppendResult(interp, buf, NULL);
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(
+ (Tcl_WideInt) (size_t) Tcl_GetChannelThread(chan)));
return TCL_OK;
}
diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c
index 5627608..547792a 100644
--- a/generic/tclTestObj.c
+++ b/generic/tclTestObj.c
@@ -1088,6 +1088,9 @@ TestobjCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1));
} else {
typeName = objv[2]->typePtr->name;
+#ifndef TCL_WIDE_INT_IS_LONG
+ if (!strcmp(typeName, "wideInt")) typeName = "int";
+#endif
Tcl_SetObjResult(interp, Tcl_NewStringObj(typeName, -1));
}
} else if (strcmp(subCmd, "refcount") == 0) {
@@ -1115,6 +1118,11 @@ TestobjCmd(
}
if (varPtr[varIndex]->typePtr == NULL) { /* a string! */
Tcl_AppendToObj(Tcl_GetObjResult(interp), "string", -1);
+#ifndef TCL_WIDE_INT_IS_LONG
+ } else if (!strcmp(varPtr[varIndex]->typePtr->name, "wideInt")) {
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "int", -1);
+#endif
} else {
Tcl_AppendToObj(Tcl_GetObjResult(interp),
varPtr[varIndex]->typePtr->name, -1);
diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c
index 9c5fecb..a008799 100644
--- a/generic/tclThreadTest.c
+++ b/generic/tclThreadTest.c
@@ -248,7 +248,7 @@ ThreadObjCmd(
switch ((enum options)option) {
case THREAD_CANCEL: {
- long id;
+ Tcl_WideInt id;
const char *result;
int flags, arg;
@@ -264,7 +264,7 @@ ThreadObjCmd(
arg++;
}
}
- if (Tcl_GetLongFromObj(interp, objv[arg], &id) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(interp, objv[arg], &id) != TCL_OK) {
return TCL_ERROR;
}
arg++;
diff --git a/generic/tclTimer.c b/generic/tclTimer.c
index 3467305..54854d0 100644
--- a/generic/tclTimer.c
+++ b/generic/tclTimer.c
@@ -819,9 +819,6 @@ Tcl_AfterObjCmd(
*/
if (objv[1]->typePtr == &tclIntType
-#ifndef TCL_WIDE_INT_IS_LONG
- || objv[1]->typePtr == &tclWideIntType
-#endif
|| objv[1]->typePtr == &tclBignumType
|| (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0,
&index) != TCL_OK)) {
@@ -1045,37 +1042,27 @@ AfterDelay(
if (iPtr->limit.timeEvent == NULL
|| TCL_TIME_BEFORE(endTime, iPtr->limit.time)) {
diff = TCL_TIME_DIFF_MS_CEILING(endTime, now);
-#ifndef TCL_WIDE_INT_IS_LONG
- if (diff > LONG_MAX) {
- diff = LONG_MAX;
- }
-#endif
if (diff > TCL_TIME_MAXIMUM_SLICE) {
diff = TCL_TIME_MAXIMUM_SLICE;
}
- if (diff == 0 && TCL_TIME_BEFORE(now, endTime)) {
- diff = 1;
- }
+ if (diff == 0 && TCL_TIME_BEFORE(now, endTime)) {
+ diff = 1;
+ }
if (diff > 0) {
- Tcl_Sleep((long) diff);
- if (diff < SLEEP_OFFLOAD_GETTIMEOFDAY) {
- break;
- }
+ Tcl_Sleep((int) diff);
+ if (diff < SLEEP_OFFLOAD_GETTIMEOFDAY) {
+ break;
+ }
} else {
- break;
- }
+ break;
+ }
} else {
diff = TCL_TIME_DIFF_MS(iPtr->limit.time, now);
-#ifndef TCL_WIDE_INT_IS_LONG
- if (diff > LONG_MAX) {
- diff = LONG_MAX;
- }
-#endif
if (diff > TCL_TIME_MAXIMUM_SLICE) {
diff = TCL_TIME_MAXIMUM_SLICE;
}
if (diff > 0) {
- Tcl_Sleep((long) diff);
+ Tcl_Sleep((int) diff);
}
if (Tcl_AsyncReady()) {
if (Tcl_AsyncInvoke(interp, TCL_OK) != TCL_OK) {
@@ -1089,7 +1076,7 @@ AfterDelay(
return TCL_ERROR;
}
}
- Tcl_GetTime(&now);
+ Tcl_GetTime(&now);
} while (TCL_TIME_BEFORE(now, endTime));
return TCL_OK;
}
diff --git a/generic/tclTomMath.h b/generic/tclTomMath.h
index df54ff5..e0f8497 100644
--- a/generic/tclTomMath.h
+++ b/generic/tclTomMath.h
@@ -26,9 +26,14 @@
extern "C" {
#endif
+/* MS Visual C++ doesn't have a 128bit type for words, so fall back to 32bit MPI's (where words are 64bit) */
+#if defined(_MSC_VER) || defined(__LLP64__)
+# define MP_32BIT
+#endif
+
/* detect 64-bit mode if possible */
-#if defined(NEVER) /* 128-bit ints fail in too many places */
-# if !(defined(MP_32BIT) || defined(MP_16BIT) || defined(MP_8BIT))
+#if defined(NEVER)
+# if !(defined(MP_32BIT) || defined(MP_16BIT) || defined(MP_8BIT) || defined(_MSC_VER))
# define MP_64BIT
# endif
#endif
@@ -73,12 +78,7 @@ typedef uint32_t mp_word;
typedef uint64_t mp_digit;
#define MP_DIGIT_DECLARED
#endif
-# if defined(_WIN32)
-#ifndef MP_WORD_DECLARED
-typedef unsigned __int128 mp_word;
-#define MP_WORD_DECLARED
-#endif
-# elif defined(__GNUC__)
+# if defined(__GNUC__)
typedef unsigned long mp_word __attribute__((mode(TI)));
# else
/* it seems you have a problem
@@ -124,7 +124,7 @@ typedef mp_digit mp_min_u32;
/* use arc4random on platforms that support it */
#if defined(__FreeBSD__) || defined(__OpenBSD__) || defined(__NetBSD__) || defined(__DragonFly__)
# define MP_GEN_RANDOM() arc4random()
-# define MP_GEN_RANDOM_MAX 0xffffffff
+# define MP_GEN_RANDOM_MAX 0xffffffffu
#endif
/* use rand() as fall-back if there's no better rand function */
@@ -181,7 +181,7 @@ MODULE_SCOPE int KARATSUBA_MUL_CUTOFF,
#endif
/* size of comba arrays, should be at least 2 * 2**(BITS_PER_WORD - BITS_PER_DIGIT*2) */
-#define MP_WARRAY (1 << (((sizeof(mp_word) * CHAR_BIT) - (2 * DIGIT_BIT)) + 1))
+#define MP_WARRAY (1u << (((sizeof(mp_word) * CHAR_BIT) - (2 * DIGIT_BIT)) + 1))
/* the infamous mp_int structure */
#ifndef MP_INT_DECLARED
@@ -271,9 +271,9 @@ int mp_set_int(mp_int *a, unsigned long b);
int mp_set_long(mp_int *a, unsigned long b);
*/
-/* set a platform dependent unsigned long long value */
+/* set a platform dependent Tcl_WideUInt value */
/*
-int mp_set_long_long(mp_int *a, unsigned long long b);
+int mp_set_long_long(mp_int *a, Tcl_WideUInt b);
*/
/* get a 32-bit value */
@@ -286,9 +286,9 @@ unsigned long mp_get_int(const mp_int *a);
unsigned long mp_get_long(const mp_int *a);
*/
-/* get a platform dependent unsigned long long value */
+/* get a platform dependent Tcl_WideUInt value */
/*
-unsigned long long mp_get_long_long(const mp_int *a);
+Tcl_WideUInt mp_get_long_long(const mp_int *a);
*/
/* initialize and set a digit */
@@ -553,7 +553,7 @@ int mp_sqrt(const mp_int *arg, mp_int *ret);
/* special sqrt (mod prime) */
/*
-int mp_sqrtmod_prime(const mp_int *arg, const mp_int *prime, mp_int *ret);
+int mp_sqrtmod_prime(const mp_int *n, const mp_int *prime, mp_int *ret);
*/
/* is number a square? */
@@ -573,16 +573,16 @@ int mp_reduce_setup(mp_int *a, const mp_int *b);
/* Barrett Reduction, computes a (mod b) with a precomputed value c
*
- * Assumes that 0 < a <= b*b, note if 0 > a > -(b*b) then you can merely
- * compute the reduction as -1 * mp_reduce(mp_abs(a)) [pseudo code].
+ * Assumes that 0 < x <= m*m, note if 0 > x > -(m*m) then you can merely
+ * compute the reduction as -1 * mp_reduce(mp_abs(x)) [pseudo code].
*/
/*
-int mp_reduce(mp_int *a, const mp_int *b, const mp_int *c);
+int mp_reduce(mp_int *x, const mp_int *m, const mp_int *mu);
*/
/* setups the montgomery reduction */
/*
-int mp_montgomery_setup(const mp_int *a, mp_digit *mp);
+int mp_montgomery_setup(const mp_int *n, mp_digit *rho);
*/
/* computes a = B**n mod b without division or multiplication useful for
@@ -594,7 +594,7 @@ int mp_montgomery_calc_normalization(mp_int *a, const mp_int *b);
/* computes x/R == x (mod N) via Montgomery Reduction */
/*
-int mp_montgomery_reduce(mp_int *a, const mp_int *m, mp_digit mp);
+int mp_montgomery_reduce(mp_int *x, const mp_int *n, mp_digit rho);
*/
/* returns 1 if a is a valid DR modulus */
@@ -607,9 +607,9 @@ int mp_dr_is_modulus(const mp_int *a);
void mp_dr_setup(const mp_int *a, mp_digit *d);
*/
-/* reduces a modulo b using the Diminished Radix method */
+/* reduces a modulo n using the Diminished Radix method */
/*
-int mp_dr_reduce(mp_int *a, const mp_int *b, mp_digit mp);
+int mp_dr_reduce(mp_int *x, const mp_int *n, mp_digit k);
*/
/* returns true if a can be reduced with mp_reduce_2k */
@@ -642,9 +642,9 @@ int mp_reduce_2k_setup_l(const mp_int *a, mp_int *d);
int mp_reduce_2k_l(mp_int *a, const mp_int *n, const mp_int *d);
*/
-/* d = a**b (mod c) */
+/* Y = G**X (mod P) */
/*
-int mp_exptmod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d);
+int mp_exptmod(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y);
*/
/* ---> Primes <--- */
diff --git a/generic/tclUtf.c b/generic/tclUtf.c
index 43636b4..2d8750d 100644
--- a/generic/tclUtf.c
+++ b/generic/tclUtf.c
@@ -68,11 +68,7 @@ static const unsigned char totalBytes[256] = {
1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,
2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,
3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,
-#if TCL_UTF_MAX > 3
4,4,4,4,4,4,4,4,
-#else
- 1,1,1,1,1,1,1,1,
-#endif
1,1,1,1,1,1,1,1
};
@@ -328,13 +324,22 @@ Tcl_UtfToUniChar(
* represents itself.
*/
}
-#if TCL_UTF_MAX > 3
else if (byte < 0xF8) {
if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80) && ((src[3] & 0xC0) == 0x80)) {
/*
* Four-byte-character lead byte followed by three trail bytes.
*/
-#if TCL_UTF_MAX == 4
+#if TCL_UTF_MAX == 3
+ byte = (((byte & 0x07) << 18) | ((src[1] & 0x3F) << 12)
+ | ((src[2] & 0x3F) << 6) | (src[3] & 0x3F)) - 0x10000;
+ if (byte & 0x100000) {
+ /* out of range, < 0x10000 or > 0x10ffff */
+ } else {
+ /* produce replacement character, and advance source pointer */
+ *chPtr = (Tcl_UniChar) 0xFFFD;
+ return 4;
+ }
+#elif TCL_UTF_MAX == 4
Tcl_UniChar surrogate;
byte = (((byte & 0x07) << 18) | ((src[1] & 0x3F) << 12)
@@ -365,7 +370,6 @@ Tcl_UtfToUniChar(
* represents itself.
*/
}
-#endif
*chPtr = (Tcl_UniChar) byte;
return 1;
@@ -499,13 +503,13 @@ Tcl_NumUtfChars(
}
if (i < 0) i = INT_MAX; /* Bug [2738427] */
} else {
- register const char *endPtr = src + length - TCL_UTF_MAX;
+ register const char *endPtr = src + length - 4;
while (src < endPtr) {
src += TclUtfToUniChar(src, &ch);
i++;
}
- endPtr += TCL_UTF_MAX;
+ endPtr += 4;
while ((src < endPtr) && Tcl_UtfCharComplete(src, endPtr - src)) {
src += TclUtfToUniChar(src, &ch);
i++;
@@ -677,7 +681,7 @@ Tcl_UtfPrev(
int i, byte;
look = --src;
- for (i = 0; i < TCL_UTF_MAX; i++) {
+ for (i = 0; i < 4; i++) {
if (look < start) {
if (src < start) {
src = start;
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index 15018de..0ba6c8e 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -107,10 +107,11 @@ static Tcl_ThreadDataKey precisionKey;
static void ClearHash(Tcl_HashTable *tablePtr);
static void FreeProcessGlobalValue(ClientData clientData);
static void FreeThreadHash(ClientData clientData);
+static int GetEndOffsetFromObj(Tcl_Obj *objPtr, int endValue,
+ int *indexPtr);
static Tcl_HashTable * GetThreadHash(Tcl_ThreadDataKey *keyPtr);
static int SetEndOffsetFromAny(Tcl_Interp *interp,
Tcl_Obj *objPtr);
-static void UpdateStringOfEndOffset(Tcl_Obj *objPtr);
static int FindElement(Tcl_Interp *interp, const char *string,
int stringLength, const char *typeStr,
const char *typeCode, const char **elementPtr,
@@ -119,15 +120,18 @@ static int FindElement(Tcl_Interp *interp, const char *string,
/*
* The following is the Tcl object type definition for an object that
* represents a list index in the form, "end-offset". It is used as a
- * performance optimization in TclGetIntForIndex. The internal rep is an
- * integer, so no memory management is required for it.
+ * performance optimization in TclGetIntForIndex. The internal rep is
+ * stored directly in the wideValue, so no memory management is required
+ * for it. This is a caching intrep, keeping the result of a parse
+ * around. This type is only created from a pre-existing string, so an
+ * updateStringProc will never be called and need not exist.
*/
-const Tcl_ObjType tclEndOffsetType = {
+static const Tcl_ObjType endOffsetType = {
"end-offset", /* name */
NULL, /* freeIntRepProc */
NULL, /* dupIntRepProc */
- UpdateStringOfEndOffset, /* updateStringProc */
+ NULL, /* updateStringProc */
SetEndOffsetFromAny
};
@@ -1604,6 +1608,7 @@ Tcl_Merge(
return result;
}
+#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9
/*
*----------------------------------------------------------------------
*
@@ -1637,15 +1642,51 @@ Tcl_Backslash(
TclUtfToUniChar(buf, &ch);
return (char) ch;
}
+#endif /* !TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
*
- * TclTrimRight --
+ * UtfWellFormedEnd --
+ * Checks the end of utf string is malformed, if yes - wraps bytes
+ * to the given buffer (as well-formed NTS string). The buffer
+ * argument should be initialized by the caller and ready to use.
+ *
+ * Results:
+ * The bytes with well-formed end of the string.
+ *
+ * Side effects:
+ * Buffer (DString) may be allocated, so must be released.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static inline const char*
+UtfWellFormedEnd(
+ Tcl_DString *buffer, /* Buffer used to hold well-formed string. */
+ const char *bytes, /* Pointer to the beginning of the string. */
+ int length) /* Length of the string. */
+{
+ const char *l = bytes + length;
+ const char *p = Tcl_UtfPrev(l, bytes);
+
+ if (Tcl_UtfCharComplete(p, l - p)) {
+ return bytes;
+ }
+ /*
+ * Malformed utf-8 end, be sure we've NTS to safe compare of end-character,
+ * avoid segfault by access violation out of range.
+ */
+ Tcl_DStringAppend(buffer, bytes, length);
+ return Tcl_DStringValue(buffer);
+}
+/*
+ *----------------------------------------------------------------------
*
- * Takes two counted strings in the Tcl encoding which must both be null
- * terminated. Conceptually trims from the right side of the first string
- * all characters found in the second string.
+ * TclTrimRight --
+ * Takes two counted strings in the Tcl encoding. Conceptually
+ * finds the sub string (offset) to trim from the right side of the
+ * first string all characters found in the second string.
*
* Results:
* The number of bytes to be removed from the end of the string.
@@ -1656,8 +1697,8 @@ Tcl_Backslash(
*----------------------------------------------------------------------
*/
-int
-TclTrimRight(
+static inline int
+TrimRight(
const char *bytes, /* String to be trimmed... */
int numBytes, /* ...and its length in bytes */
const char *trim, /* String of trim characters... */
@@ -1667,18 +1708,6 @@ TclTrimRight(
int pInc;
Tcl_UniChar ch1 = 0, ch2 = 0;
- if ((bytes[numBytes] != '\0') || (trim[numTrim] != '\0')) {
- Tcl_Panic("TclTrimRight works only on null-terminated strings");
- }
-
- /*
- * Empty strings -> nothing to do.
- */
-
- if ((numBytes == 0) || (numTrim == 0)) {
- return 0;
- }
-
/*
* Outer loop: iterate over string to be trimmed.
*/
@@ -1717,15 +1746,46 @@ TclTrimRight(
return numBytes - (p - bytes);
}
+
+int
+TclTrimRight(
+ const char *bytes, /* String to be trimmed... */
+ int numBytes, /* ...and its length in bytes */
+ const char *trim, /* String of trim characters... */
+ int numTrim) /* ...and its length in bytes */
+{
+ int res;
+ Tcl_DString bytesBuf, trimBuf;
+
+ /* Empty strings -> nothing to do */
+ if ((numBytes == 0) || (numTrim == 0)) {
+ return 0;
+ }
+
+ Tcl_DStringInit(&bytesBuf);
+ Tcl_DStringInit(&trimBuf);
+ bytes = UtfWellFormedEnd(&bytesBuf, bytes, numBytes);
+ trim = UtfWellFormedEnd(&trimBuf, trim, numTrim);
+
+ res = TrimRight(bytes, numBytes, trim, numTrim);
+ if (res > numBytes) {
+ res = numBytes;
+ }
+
+ Tcl_DStringFree(&bytesBuf);
+ Tcl_DStringFree(&trimBuf);
+
+ return res;
+}
/*
*----------------------------------------------------------------------
*
* TclTrimLeft --
*
- * Takes two counted strings in the Tcl encoding which must both be null
- * terminated. Conceptually trims from the left side of the first string
- * all characters found in the second string.
+ * Takes two counted strings in the Tcl encoding. Conceptually
+ * finds the sub string (offset) to trim from the left side of the
+ * first string all characters found in the second string.
*
* Results:
* The number of bytes to be removed from the start of the string.
@@ -1736,8 +1796,8 @@ TclTrimRight(
*----------------------------------------------------------------------
*/
-int
-TclTrimLeft(
+static inline int
+TrimLeft(
const char *bytes, /* String to be trimmed... */
int numBytes, /* ...and its length in bytes */
const char *trim, /* String of trim characters... */
@@ -1746,18 +1806,6 @@ TclTrimLeft(
const char *p = bytes;
Tcl_UniChar ch1 = 0, ch2 = 0;
- if ((bytes[numBytes] != '\0') || (trim[numTrim] != '\0')) {
- Tcl_Panic("TclTrimLeft works only on null-terminated strings");
- }
-
- /*
- * Empty strings -> nothing to do.
- */
-
- if ((numBytes == 0) || (numTrim == 0)) {
- return 0;
- }
-
/*
* Outer loop: iterate over string to be trimmed.
*/
@@ -1792,10 +1840,99 @@ TclTrimLeft(
p += pInc;
numBytes -= pInc;
- } while (numBytes);
+ } while (numBytes > 0);
return p - bytes;
}
+
+int
+TclTrimLeft(
+ const char *bytes, /* String to be trimmed... */
+ int numBytes, /* ...and its length in bytes */
+ const char *trim, /* String of trim characters... */
+ int numTrim) /* ...and its length in bytes */
+{
+ int res;
+ Tcl_DString bytesBuf, trimBuf;
+
+ /* Empty strings -> nothing to do */
+ if ((numBytes == 0) || (numTrim == 0)) {
+ return 0;
+ }
+
+ Tcl_DStringInit(&bytesBuf);
+ Tcl_DStringInit(&trimBuf);
+ bytes = UtfWellFormedEnd(&bytesBuf, bytes, numBytes);
+ trim = UtfWellFormedEnd(&trimBuf, trim, numTrim);
+
+ res = TrimLeft(bytes, numBytes, trim, numTrim);
+ if (res > numBytes) {
+ res = numBytes;
+ }
+
+ Tcl_DStringFree(&bytesBuf);
+ Tcl_DStringFree(&trimBuf);
+
+ return res;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclTrim --
+ * Finds the sub string (offset) to trim from both sides of the
+ * first string all characters found in the second string.
+ *
+ * Results:
+ * The number of bytes to be removed from the start of the string
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclTrim(
+ const char *bytes, /* String to be trimmed... */
+ int numBytes, /* ...and its length in bytes */
+ const char *trim, /* String of trim characters... */
+ int numTrim, /* ...and its length in bytes */
+ int *trimRight) /* Offset from the end of the string. */
+{
+ int trimLeft;
+ Tcl_DString bytesBuf, trimBuf;
+
+ *trimRight = 0;
+ /* Empty strings -> nothing to do */
+ if ((numBytes == 0) || (numTrim == 0)) {
+ return 0;
+ }
+
+ Tcl_DStringInit(&bytesBuf);
+ Tcl_DStringInit(&trimBuf);
+ bytes = UtfWellFormedEnd(&bytesBuf, bytes, numBytes);
+ trim = UtfWellFormedEnd(&trimBuf, trim, numTrim);
+
+ trimLeft = TrimLeft(bytes, numBytes, trim, numTrim);
+ if (trimLeft > numBytes) {
+ trimLeft = numBytes;
+ }
+ numBytes -= trimLeft;
+ /* have to trim yet (first char was already verified within TrimLeft) */
+ if (numBytes > 1) {
+ bytes += trimLeft;
+ *trimRight = TrimRight(bytes, numBytes, trim, numTrim);
+ if (*trimRight > numBytes) {
+ *trimRight = numBytes;
+ }
+ }
+
+ Tcl_DStringFree(&bytesBuf);
+ Tcl_DStringFree(&trimBuf);
+
+ return trimLeft;
+}
/*
*----------------------------------------------------------------------
@@ -1863,30 +2000,20 @@ Tcl_Concat(
result = ckalloc((unsigned) (bytesNeeded + argc));
for (p = result, i = 0; i < argc; i++) {
- int trim, elemLength;
+ int triml, trimr, elemLength;
const char *element;
element = argv[i];
elemLength = strlen(argv[i]);
- /*
- * Trim away the leading whitespace.
- */
+ /* Trim away the leading/trailing whitespace. */
+ triml = TclTrim(element, elemLength, CONCAT_TRIM_SET,
+ CONCAT_WS_SIZE, &trimr);
+ element += triml;
+ elemLength -= triml + trimr;
- trim = TclTrimLeft(element, elemLength, CONCAT_TRIM_SET,
- CONCAT_WS_SIZE);
- element += trim;
- elemLength -= trim;
-
- /*
- * Trim away the trailing whitespace. Do not permit trimming to expose
- * a final backslash character.
- */
-
- trim = TclTrimRight(element, elemLength, CONCAT_TRIM_SET,
- CONCAT_WS_SIZE);
- trim -= trim && (element[elemLength - trim - 1] == '\\');
- elemLength -= trim;
+ /* Do not permit trimming to expose a final backslash character. */
+ elemLength += trimr && (element[elemLength - 1] == '\\');
/*
* If we're left with empty element after trimming, do nothing.
@@ -2006,28 +2133,18 @@ Tcl_ConcatObj(
Tcl_SetObjLength(resPtr, 0);
for (i = 0; i < objc; i++) {
- int trim;
+ int triml, trimr;
element = TclGetStringFromObj(objv[i], &elemLength);
- /*
- * Trim away the leading whitespace.
- */
-
- trim = TclTrimLeft(element, elemLength, CONCAT_TRIM_SET,
- CONCAT_WS_SIZE);
- element += trim;
- elemLength -= trim;
-
- /*
- * Trim away the trailing whitespace. Do not permit trimming to expose
- * a final backslash character.
- */
+ /* Trim away the leading/trailing whitespace. */
+ triml = TclTrim(element, elemLength, CONCAT_TRIM_SET,
+ CONCAT_WS_SIZE, &trimr);
+ element += triml;
+ elemLength -= triml + trimr;
- trim = TclTrimRight(element, elemLength, CONCAT_TRIM_SET,
- CONCAT_WS_SIZE);
- trim -= trim && (element[elemLength - trim - 1] == '\\');
- elemLength -= trim;
+ /* Do not permit trimming to expose a final backslash character. */
+ elemLength += trimr && (element[elemLength - 1] == '\\');
/*
* If we're left with empty element after trimming, do nothing.
@@ -2528,7 +2645,8 @@ TclStringMatchObj(
udata = Tcl_GetUnicodeFromObj(strObj, &length);
uptn = Tcl_GetUnicodeFromObj(ptnObj, &plen);
match = TclUniCharMatch(udata, length, uptn, plen, flags);
- } else if (TclIsPureByteArray(strObj) && !flags) {
+ } else if (TclIsPureByteArray(strObj) && TclIsPureByteArray(ptnObj)
+ && !flags) {
unsigned char *data, *ptn;
data = Tcl_GetByteArrayFromObj(strObj, &length);
@@ -3474,9 +3592,9 @@ int
TclFormatInt(
char *buffer, /* Points to the storage into which the
* formatted characters are written. */
- long n) /* The integer to format. */
+ Tcl_WideInt n) /* The integer to format. */
{
- long intVal;
+ Tcl_WideInt intVal;
int i;
int numFormatted, j;
const char *digits = "0123456789";
@@ -3499,7 +3617,7 @@ TclFormatInt(
intVal = -n; /* [Bug 3390638] Workaround for*/
if (n == -n || intVal == n) { /* broken compiler optimizers. */
- return sprintf(buffer, "%ld", n);
+ return sprintf(buffer, "%" TCL_LL_MODIFIER "d", n);
}
/*
@@ -3577,13 +3695,7 @@ TclGetIntForIndex(
return TCL_OK;
}
- if (SetEndOffsetFromAny(NULL, objPtr) == TCL_OK) {
- /*
- * If the object is already an offset from the end of the list, or can
- * be converted to one, use it.
- */
-
- *indexPtr = endValue + objPtr->internalRep.longValue;
+ if (GetEndOffsetFromObj(objPtr, endValue, indexPtr) == TCL_OK) {
return TCL_OK;
}
@@ -3650,40 +3762,38 @@ TclGetIntForIndex(
/*
*----------------------------------------------------------------------
*
- * UpdateStringOfEndOffset --
+ * GetEndOffsetFromObj --
*
- * Update the string rep of a Tcl object holding an "end-offset"
- * expression.
+ * Look for a string of the form "end[+-]offset" and convert it to an
+ * internal representation holding the offset.
*
* Results:
- * None.
+ * Tcl return code.
*
* Side effects:
- * Stores a valid string in the object's string rep.
- *
- * This function does NOT free any earlier string rep. If it is called on an
- * object that already has a valid string rep, it will leak memory.
+ * May store a Tcl_ObjType.
*
*----------------------------------------------------------------------
*/
-static void
-UpdateStringOfEndOffset(
- register Tcl_Obj *objPtr)
+static int
+GetEndOffsetFromObj(
+ Tcl_Obj *objPtr, /* Pointer to the object to parse */
+ int endValue, /* The value to be stored at "indexPtr" if
+ * "objPtr" holds "end". */
+ int *indexPtr) /* Location filled in with an integer
+ * representing an index. */
{
- char buffer[TCL_INTEGER_SPACE + 5];
- register int len = 3;
-
- memcpy(buffer, "end", 4);
- if (objPtr->internalRep.longValue != 0) {
- buffer[len++] = '-';
- len += TclFormatInt(buffer+len, -(objPtr->internalRep.longValue));
+ if (SetEndOffsetFromAny(NULL, objPtr) != TCL_OK) {
+ return TCL_ERROR;
}
- objPtr->bytes = ckalloc((unsigned) len+1);
- memcpy(objPtr->bytes, buffer, (unsigned) len+1);
- objPtr->length = len;
+
+ /* TODO: Handle overflow cases sensibly */
+ *indexPtr = endValue + (int)objPtr->internalRep.wideValue;
+ return TCL_OK;
}
-
+
+
/*
*----------------------------------------------------------------------
*
@@ -3707,7 +3817,7 @@ SetEndOffsetFromAny(
Tcl_Interp *interp, /* Tcl interpreter or NULL */
Tcl_Obj *objPtr) /* Pointer to the object to parse */
{
- int offset; /* Offset in the "end-offset" expression */
+ Tcl_WideInt offset; /* Offset in the "end-offset" expression */
register const char *bytes; /* String rep of the object */
int length; /* Length of the object's string rep */
@@ -3715,7 +3825,7 @@ SetEndOffsetFromAny(
* If it's already the right type, we're fine.
*/
- if (objPtr->typePtr == &tclEndOffsetType) {
+ if (objPtr->typePtr == &endOffsetType) {
return TCL_OK;
}
@@ -3743,16 +3853,23 @@ SetEndOffsetFromAny(
} else if ((length > 4) && ((bytes[3] == '-') || (bytes[3] == '+'))) {
/*
* This is our limited string expression evaluator. Pass everything
- * after "end-" to Tcl_GetInt, then reverse for offset.
+ * after "end-" to TclParseNumber.
*/
if (TclIsSpaceProc(bytes[4])) {
goto badIndexFormat;
}
- if (Tcl_GetInt(interp, bytes+4, &offset) != TCL_OK) {
+ if (TclParseNumber(NULL, objPtr, NULL, bytes+4, length-4, NULL,
+ TCL_PARSE_INTEGER_ONLY) != TCL_OK) {
return TCL_ERROR;
}
+ if (objPtr->typePtr != &tclIntType) {
+ goto badIndexFormat;
+ }
+ offset = objPtr->internalRep.wideValue;
if (bytes[3] == '-') {
+
+ /* TODO: Review overflow concerns here! */
offset = -offset;
}
} else {
@@ -3775,8 +3892,8 @@ SetEndOffsetFromAny(
*/
TclFreeIntRep(objPtr);
- objPtr->internalRep.longValue = offset;
- objPtr->typePtr = &tclEndOffsetType;
+ objPtr->internalRep.wideValue = offset;
+ objPtr->typePtr = &endOffsetType;
return TCL_OK;
}
@@ -3784,6 +3901,143 @@ SetEndOffsetFromAny(
/*
*----------------------------------------------------------------------
*
+ * TclIndexEncode --
+ *
+ * Parse objPtr to determine if it is an index value. Two cases
+ * are possible. The value objPtr might be parsed as an absolute
+ * index value in the C signed int range. Note that this includes
+ * index values that are integers as presented and it includes index
+ * arithmetic expressions. The absolute index values that can be
+ * directly meaningful as an index into either a list or a string are
+ * those integer values >= TCL_INDEX_START (0)
+ * and < TCL_INDEX_AFTER (INT_MAX).
+ * The largest string supported in Tcl 8 has bytelength INT_MAX.
+ * This means the largest supported character length is also INT_MAX,
+ * and the index of the last character in a string of length INT_MAX
+ * is INT_MAX-1.
+ *
+ * Any absolute index value parsed outside that range is encoded
+ * using the before and after values passed in by the
+ * caller as the encoding to use for indices that are either
+ * less than or greater than the usable index range. TCL_INDEX_AFTER
+ * is available as a good choice for most callers to use for
+ * after. Likewise, the value TCL_INDEX_BEFORE is good for
+ * most callers to use for before. Other values are possible
+ * when the caller knows it is helpful in producing its own behavior
+ * for indices before and after the indexed item.
+ *
+ * A token can also be parsed as an end-relative index expression.
+ * All end-relative expressions that indicate an index larger
+ * than end (end+2, end--5) point beyond the end of the indexed
+ * collection, and can be encoded as after. The end-relative
+ * expressions that indicate an index less than or equal to end
+ * are encoded relative to the value TCL_INDEX_END (-2). The
+ * index "end" is encoded as -2, down to the index "end-0x7ffffffe"
+ * which is encoded as INT_MIN. Since the largest index into a
+ * string possible in Tcl 8 is 0x7ffffffe, the interpretation of
+ * "end-0x7ffffffe" for that largest string would be 0. Thus,
+ * if the tokens "end-0x7fffffff" or "end+-0x80000000" are parsed,
+ * they can be encoded with the before value.
+ *
+ * These details will require re-examination whenever string and
+ * list length limits are increased, but that will likely also
+ * mean a revised routine capable of returning Tcl_WideInt values.
+ *
+ * Returns:
+ * TCL_OK if parsing succeeded, and TCL_ERROR if it failed.
+ *
+ * Side effects:
+ * When TCL_OK is returned, the encoded index value is written
+ * to *indexPtr.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclIndexEncode(
+ Tcl_Interp *interp, /* For error reporting, may be NULL */
+ Tcl_Obj *objPtr, /* Index value to parse */
+ int before, /* Value to return for index before beginning */
+ int after, /* Value to return for index after end */
+ int *indexPtr) /* Where to write the encoded answer, not NULL */
+{
+ int idx;
+
+ if (TCL_OK == TclGetIntFromObj(NULL, objPtr, &idx)) {
+ /* We parsed a value in the range INT_MIN...INT_MAX */
+ integerEncode:
+ if (idx < TCL_INDEX_START) {
+ /* All negative absolute indices are "before the beginning" */
+ idx = before;
+ } else if (idx == INT_MAX) {
+ /* This index value is always "after the end" */
+ idx = after;
+ }
+ /* usual case, the absolute index value encodes itself */
+ } else if (TCL_OK == GetEndOffsetFromObj(objPtr, 0, &idx)) {
+ /*
+ * We parsed an end+offset index value.
+ * idx holds the offset value in the range INT_MIN...INT_MAX.
+ */
+ if (idx > 0) {
+ /*
+ * All end+postive or end-negative expressions
+ * always indicate "after the end".
+ */
+ idx = after;
+ } else if (idx < INT_MIN - TCL_INDEX_END) {
+ /* These indices always indicate "before the beginning */
+ idx = before;
+ } else {
+ /* Encoded end-positive (or end+negative) are offset */
+ idx += TCL_INDEX_END;
+ }
+
+ /* TODO: Consider flag to suppress repeated end-offset parse. */
+ } else if (TCL_OK == TclGetIntForIndexM(interp, objPtr, 0, &idx)) {
+ /*
+ * Only reach this case when the index value is a
+ * constant index arithmetic expression, and idx
+ * holds the result. Treat it the same as if it were
+ * parsed as an absolute integer value.
+ */
+ goto integerEncode;
+ } else {
+ return TCL_ERROR;
+ }
+ *indexPtr = idx;
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclIndexDecode --
+ *
+ * Decodes a value previously encoded by TclIndexEncode. The argument
+ * endValue indicates what value of "end" should be used in the
+ * decoding.
+ *
+ * Results:
+ * The decoded index value.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclIndexDecode(
+ int encoded, /* Value to decode */
+ int endValue) /* Meaning of "end" to use, > TCL_INDEX_END */
+{
+ if (encoded <= TCL_INDEX_END) {
+ return (encoded - TCL_INDEX_END) + endValue;
+ }
+ return encoded;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclCheckBadOctal --
*
* This function checks for a bad octal value and appends a meaningful
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 7c8bb73..9405fd5 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -280,7 +280,7 @@ CleanupVar(
{
if (TclIsVarUndefined(varPtr) && TclIsVarInHash(varPtr)
&& !TclIsVarTraced(varPtr)
- && (VarHashRefCount(varPtr) == !TclIsVarDeadHash(varPtr))) {
+ && (VarHashRefCount(varPtr) == (unsigned)!TclIsVarDeadHash(varPtr))) {
if (VarHashRefCount(varPtr) == 0) {
ckfree(varPtr);
} else {
@@ -289,7 +289,7 @@ CleanupVar(
}
if (arrayPtr != NULL && TclIsVarUndefined(arrayPtr) &&
TclIsVarInHash(arrayPtr) && !TclIsVarTraced(arrayPtr) &&
- (VarHashRefCount(arrayPtr) == !TclIsVarDeadHash(arrayPtr))) {
+ (VarHashRefCount(arrayPtr) == (unsigned)!TclIsVarDeadHash(arrayPtr))) {
if (VarHashRefCount(arrayPtr) == 0) {
ckfree(arrayPtr);
} else {
diff --git a/generic/tclZlib.c b/generic/tclZlib.c
index 33eebd1..994bcef 100644
--- a/generic/tclZlib.c
+++ b/generic/tclZlib.c
@@ -373,7 +373,7 @@ ConvertErrorToList(
default:
TclNewLiteralStringObj(objv[2], "UNKNOWN");
- TclNewLongObj(objv[3], code);
+ TclNewIntObj(objv[3], code);
return Tcl_NewListObj(4, objv);
}
}
diff --git a/library/http1.0/http.tcl b/library/http1.0/http.tcl
deleted file mode 100644
index 8329de4..0000000
--- a/library/http1.0/http.tcl
+++ /dev/null
@@ -1,377 +0,0 @@
-# http.tcl
-# Client-side HTTP for GET, POST, and HEAD commands.
-# These routines can be used in untrusted code that uses the Safesock
-# security policy.
-# These procedures use a callback interface to avoid using vwait,
-# which is not defined in the safe base.
-#
-# See the http.n man page for documentation
-
-package provide http 1.0
-
-array set http {
- -accept */*
- -proxyhost {}
- -proxyport {}
- -useragent {Tcl http client package 1.0}
- -proxyfilter httpProxyRequired
-}
-proc http_config {args} {
- global http
- set options [lsort [array names http -*]]
- set usage [join $options ", "]
- if {[llength $args] == 0} {
- set result {}
- foreach name $options {
- lappend result $name $http($name)
- }
- return $result
- }
- regsub -all -- - $options {} options
- set pat ^-([join $options |])$
- if {[llength $args] == 1} {
- set flag [lindex $args 0]
- if {[regexp -- $pat $flag]} {
- return $http($flag)
- } else {
- return -code error "Unknown option $flag, must be: $usage"
- }
- } else {
- foreach {flag value} $args {
- if {[regexp -- $pat $flag]} {
- set http($flag) $value
- } else {
- return -code error "Unknown option $flag, must be: $usage"
- }
- }
- }
-}
-
- proc httpFinish { token {errormsg ""} } {
- upvar #0 $token state
- global errorInfo errorCode
- if {[string length $errormsg] != 0} {
- set state(error) [list $errormsg $errorInfo $errorCode]
- set state(status) error
- }
- catch {close $state(sock)}
- catch {after cancel $state(after)}
- if {[info exists state(-command)]} {
- if {[catch {eval $state(-command) {$token}} err]} {
- if {[string length $errormsg] == 0} {
- set state(error) [list $err $errorInfo $errorCode]
- set state(status) error
- }
- }
- unset state(-command)
- }
-}
-proc http_reset { token {why reset} } {
- upvar #0 $token state
- set state(status) $why
- catch {fileevent $state(sock) readable {}}
- httpFinish $token
- if {[info exists state(error)]} {
- set errorlist $state(error)
- unset state(error)
- eval error $errorlist
- }
-}
-proc http_get { url args } {
- global http
- if {![info exists http(uid)]} {
- set http(uid) 0
- }
- set token http#[incr http(uid)]
- upvar #0 $token state
- http_reset $token
- array set state {
- -blocksize 8192
- -validate 0
- -headers {}
- -timeout 0
- state header
- meta {}
- currentsize 0
- totalsize 0
- type text/html
- body {}
- status ""
- }
- set options {-blocksize -channel -command -handler -headers \
- -progress -query -validate -timeout}
- set usage [join $options ", "]
- regsub -all -- - $options {} options
- set pat ^-([join $options |])$
- foreach {flag value} $args {
- if {[regexp $pat $flag]} {
- # Validate numbers
- if {[info exists state($flag)] && \
- [regexp {^[0-9]+$} $state($flag)] && \
- ![regexp {^[0-9]+$} $value]} {
- return -code error "Bad value for $flag ($value), must be integer"
- }
- set state($flag) $value
- } else {
- return -code error "Unknown option $flag, can be: $usage"
- }
- }
- if {! [regexp -nocase {^(http://)?([^/:]+)(:([0-9]+))?(/.*)?$} $url \
- x proto host y port srvurl]} {
- error "Unsupported URL: $url"
- }
- if {[string length $port] == 0} {
- set port 80
- }
- if {[string length $srvurl] == 0} {
- set srvurl /
- }
- if {[string length $proto] == 0} {
- set url http://$url
- }
- set state(url) $url
- if {![catch {$http(-proxyfilter) $host} proxy]} {
- set phost [lindex $proxy 0]
- set pport [lindex $proxy 1]
- }
- if {$state(-timeout) > 0} {
- set state(after) [after $state(-timeout) [list http_reset $token timeout]]
- }
- if {[info exists phost] && [string length $phost]} {
- set srvurl $url
- set s [socket $phost $pport]
- } else {
- set s [socket $host $port]
- }
- set state(sock) $s
-
- # Send data in cr-lf format, but accept any line terminators
-
- fconfigure $s -translation {auto crlf} -buffersize $state(-blocksize)
-
- # The following is disallowed in safe interpreters, but the socket
- # is already in non-blocking mode in that case.
-
- catch {fconfigure $s -blocking off}
- set len 0
- set how GET
- if {[info exists state(-query)]} {
- set len [string length $state(-query)]
- if {$len > 0} {
- set how POST
- }
- } elseif {$state(-validate)} {
- set how HEAD
- }
- puts $s "$how $srvurl HTTP/1.0"
- puts $s "Accept: $http(-accept)"
- puts $s "Host: $host"
- puts $s "User-Agent: $http(-useragent)"
- foreach {key value} $state(-headers) {
- regsub -all \[\n\r\] $value {} value
- set key [string trim $key]
- if {[string length $key]} {
- puts $s "$key: $value"
- }
- }
- if {$len > 0} {
- puts $s "Content-Length: $len"
- puts $s "Content-Type: application/x-www-form-urlencoded"
- puts $s ""
- fconfigure $s -translation {auto binary}
- puts -nonewline $s $state(-query)
- } else {
- puts $s ""
- }
- flush $s
- fileevent $s readable [list httpEvent $token]
- if {! [info exists state(-command)]} {
- http_wait $token
- }
- return $token
-}
-proc http_data {token} {
- upvar #0 $token state
- return $state(body)
-}
-proc http_status {token} {
- upvar #0 $token state
- return $state(status)
-}
-proc http_code {token} {
- upvar #0 $token state
- return $state(http)
-}
-proc http_size {token} {
- upvar #0 $token state
- return $state(currentsize)
-}
-
- proc httpEvent {token} {
- upvar #0 $token state
- set s $state(sock)
-
- if {[eof $s]} {
- httpEof $token
- return
- }
- if {$state(state) == "header"} {
- set n [gets $s line]
- if {$n == 0} {
- set state(state) body
- if {![regexp -nocase ^text $state(type)]} {
- # Turn off conversions for non-text data
- fconfigure $s -translation binary
- if {[info exists state(-channel)]} {
- fconfigure $state(-channel) -translation binary
- }
- }
- if {[info exists state(-channel)] &&
- ![info exists state(-handler)]} {
- # Initiate a sequence of background fcopies
- fileevent $s readable {}
- httpCopyStart $s $token
- }
- } elseif {$n > 0} {
- if {[regexp -nocase {^content-type:(.+)$} $line x type]} {
- set state(type) [string trim $type]
- }
- if {[regexp -nocase {^content-length:(.+)$} $line x length]} {
- set state(totalsize) [string trim $length]
- }
- if {[regexp -nocase {^([^:]+):(.+)$} $line x key value]} {
- lappend state(meta) $key $value
- } elseif {[regexp ^HTTP $line]} {
- set state(http) $line
- }
- }
- } else {
- if {[catch {
- if {[info exists state(-handler)]} {
- set n [eval $state(-handler) {$s $token}]
- } else {
- set block [read $s $state(-blocksize)]
- set n [string length $block]
- if {$n >= 0} {
- append state(body) $block
- }
- }
- if {$n >= 0} {
- incr state(currentsize) $n
- }
- } err]} {
- httpFinish $token $err
- } else {
- if {[info exists state(-progress)]} {
- eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
- }
- }
- }
-}
- proc httpCopyStart {s token} {
- upvar #0 $token state
- if {[catch {
- fcopy $s $state(-channel) -size $state(-blocksize) -command \
- [list httpCopyDone $token]
- } err]} {
- httpFinish $token $err
- }
-}
- proc httpCopyDone {token count {error {}}} {
- upvar #0 $token state
- set s $state(sock)
- incr state(currentsize) $count
- if {[info exists state(-progress)]} {
- eval $state(-progress) {$token $state(totalsize) $state(currentsize)}
- }
- if {([string length $error] != 0)} {
- httpFinish $token $error
- } elseif {[eof $s]} {
- httpEof $token
- } else {
- httpCopyStart $s $token
- }
-}
- proc httpEof {token} {
- upvar #0 $token state
- if {$state(state) == "header"} {
- # Premature eof
- set state(status) eof
- } else {
- set state(status) ok
- }
- set state(state) eof
- httpFinish $token
-}
-proc http_wait {token} {
- upvar #0 $token state
- if {![info exists state(status)] || [string length $state(status)] == 0} {
- vwait $token\(status)
- }
- if {[info exists state(error)]} {
- set errorlist $state(error)
- unset state(error)
- eval error $errorlist
- }
- return $state(status)
-}
-
-# Call http_formatQuery with an even number of arguments, where the first is
-# a name, the second is a value, the third is another name, and so on.
-
-proc http_formatQuery {args} {
- set result ""
- set sep ""
- foreach i $args {
- append result $sep [httpMapReply $i]
- if {$sep != "="} {
- set sep =
- } else {
- set sep &
- }
- }
- return $result
-}
-
-# do x-www-urlencoded character mapping
-# The spec says: "non-alphanumeric characters are replaced by '%HH'"
-# 1 leave alphanumerics characters alone
-# 2 Convert every other character to an array lookup
-# 3 Escape constructs that are "special" to the tcl parser
-# 4 "subst" the result, doing all the array substitutions
-
- proc httpMapReply {string} {
- global httpFormMap
- set alphanumeric a-zA-Z0-9
- if {![info exists httpFormMap]} {
-
- for {set i 1} {$i <= 256} {incr i} {
- set c [format %c $i]
- if {![string match \[$alphanumeric\] $c]} {
- set httpFormMap($c) %[format %.2x $i]
- }
- }
- # These are handled specially
- array set httpFormMap {
- " " + \n %0d%0a
- }
- }
- regsub -all \[^$alphanumeric\] $string {$httpFormMap(&)} string
- regsub -all \n $string {\\n} string
- regsub -all \t $string {\\t} string
- regsub -all {[][{})\\]\)} $string {\\&} string
- return [subst $string]
-}
-
-# Default proxy filter.
- proc httpProxyRequired {host} {
- global http
- if {[info exists http(-proxyhost)] && [string length $http(-proxyhost)]} {
- if {![info exists http(-proxyport)] || ![string length $http(-proxyport)]} {
- set http(-proxyport) 8080
- }
- return [list $http(-proxyhost) $http(-proxyport)]
- } else {
- return {}
- }
-}
diff --git a/library/http1.0/pkgIndex.tcl b/library/http1.0/pkgIndex.tcl
deleted file mode 100644
index ab6170f..0000000
--- a/library/http1.0/pkgIndex.tcl
+++ /dev/null
@@ -1,11 +0,0 @@
-# Tcl package index file, version 1.0
-# This file is generated by the "pkg_mkIndex" command
-# and sourced either when an application starts up or
-# by a "package unknown" script. It invokes the
-# "package ifneeded" command to set up package-related
-# information so that packages will be loaded automatically
-# in response to "package require" commands. When this
-# script is sourced, the variable $dir must contain the
-# full path name of this file's directory.
-
-package ifneeded http 1.0 [list tclPkgSetup $dir http 1.0 {{http.tcl source {httpCopyDone httpCopyStart httpEof httpEvent httpFinish httpMapReply httpProxyRequired http_code http_config http_data http_formatQuery http_get http_reset http_size http_status http_wait}}}]
diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl
index 646bc17..598330d 100644
--- a/library/msgcat/msgcat.tcl
+++ b/library/msgcat/msgcat.tcl
@@ -4,22 +4,24 @@
# message catalog facility for Tcl programs. It should be
# loaded with the command "package require msgcat".
#
-# Copyright (c) 2010-2015 by Harald Oehlmann.
+# Copyright (c) 2010-2018 by Harald Oehlmann.
# Copyright (c) 1998-2000 by Ajuba Solutions.
# Copyright (c) 1998 by Mark Harrison.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-package require Tcl 8.5-
+# We use oo::define::self, which is new in Tcl 8.7
+package require Tcl 8.7-
# When the version number changes, be sure to update the pkgIndex.tcl file,
# and the installation directory in the Makefiles.
-package provide msgcat 1.6.1
+package provide msgcat 1.7.0
namespace eval msgcat {
- namespace export mc mcexists mcload mclocale mcmax mcmset mcpreferences mcset\
+ namespace export mc mcn mcexists mcload mclocale mcmax\
+ mcmset mcpreferences mcset\
mcunknown mcflset mcflmset mcloadedlocales mcforgetpackage\
- mcpackageconfig mcpackagelocale
+ mcpackagenamespaceget mcpackageconfig mcpackagelocale mcutil
# Records the list of locales to search
variable Loclist {}
@@ -41,7 +43,13 @@ namespace eval msgcat {
# namespace should be themselves dict values and the value is
# the translated string.
variable Msgs [dict create]
+}
+# create ensemble namespace for mcutil command
+namespace eval msgcat::mcutil {
+ namespace export getsystemlocale getpreferences
+ namespace ensemble create -prefix 0
+
# Map of language codes used in Windows registry to those of ISO-639
if {[info sharedlibextension] eq ".dll"} {
variable WinRegToISO639 [dict create {*}{
@@ -192,10 +200,30 @@ namespace eval msgcat {
# Returns the translated string. Propagates errors thrown by the
# format command.
-proc msgcat::mc {src args} {
- # this may be replaced by:
- # return [mcget -namespace [uplevel 1 [list ::namespace current]] --\
- # $src {*}$args]
+proc msgcat::mc {args} {
+ tailcall mcn [PackageNamespaceGet] {*}$args
+}
+
+# msgcat::mcn --
+#
+# Find the translation for the given string based on the current
+# locale setting. Check the passed namespace first, then look in each
+# parent namespace until the source is found. If additional args are
+# specified, use the format command to work them into the traslated
+# string.
+# If no catalog item is found, mcunknown is called in the caller frame
+# and its result is returned.
+#
+# Arguments:
+# ns Package namespace of the translation
+# src The string to translate.
+# args Args to pass to the format command
+#
+# Results:
+# Returns the translated string. Propagates errors thrown by the
+# format command.
+
+proc msgcat::mcn {ns src args} {
# Check for the src in each namespace starting from the local and
# ending in the global.
@@ -203,7 +231,6 @@ proc msgcat::mc {src args} {
variable Msgs
variable Loclist
- set ns [uplevel 1 [list ::namespace current]]
set loclist [PackagePreferences $ns]
set nscur $ns
@@ -219,7 +246,7 @@ proc msgcat::mc {src args} {
# call package local or default unknown command
set args [linsert $args 0 [lindex $loclist 0] $src]
switch -exact -- [Invoke unknowncmd $args $ns result 1] {
- 0 { return [uplevel 1 [linsert $args 0 [namespace origin mcunknown]]] }
+ 0 { tailcall mcunknown {*}$args }
1 { return [DefaultUnknown {*}$args] }
default { return $result }
}
@@ -245,23 +272,31 @@ proc msgcat::mcexists {args} {
variable Loclist
variable PackageConfig
- set ns [uplevel 1 [list ::namespace current]]
- set loclist [PackagePreferences $ns]
-
while {[llength $args] != 1} {
set args [lassign $args option]
switch -glob -- $option {
- -exactnamespace { set exactnamespace 1 }
- -exactlocale { set loclist [lrange $loclist 0 0] }
+ -exactnamespace - -exactlocale { set $option 1 }
+ -namespace {
+ if {[llength $args] < 2} {
+ return -code error\
+ "Argument missing for switch \"-namespace\""
+ }
+ set args [lassign $args ns]
+ }
-* { return -code error "unknown option \"$option\"" }
default {
return -code error "wrong # args: should be\
\"[lindex [info level 0] 0] ?-exactnamespace?\
- ?-exactlocale? src\""
+ ?-exactlocale? ?-namespace ns? src\""
}
}
}
set src [lindex $args 0]
+
+ if {![info exists ns]} { set ns [PackageNamespaceGet] }
+
+ set loclist [PackagePreferences $ns]
+ if {[info exists -exactlocale]} { set loclist [lrange $loclist 0 0] }
while {$ns ne ""} {
foreach loc $loclist {
@@ -269,7 +304,7 @@ proc msgcat::mcexists {args} {
return 1
}
}
- if {[info exists exactnamespace]} {return 0}
+ if {[info exists -exactnamespace]} {return 0}
set ns [namespace parent $ns]
}
return 0
@@ -303,32 +338,27 @@ proc msgcat::mclocale {args} {
return -code error "invalid newLocale value \"$newLocale\":\
could be path to unsafe code."
}
- if {[lindex $Loclist 0] ne $newLocale} {
- set Loclist [GetPreferences $newLocale]
-
- # locale not loaded jet
- LoadAll $Loclist
- # Invoke callback
- Invoke changecmd $Loclist
- }
+ mcpreferences {*}[mcutil getpreferences $newLocale]
}
return [lindex $Loclist 0]
}
-# msgcat::GetPreferences --
+# msgcat::mcutil::getpreferences --
#
# Get list of locales from a locale.
# The first element is always the lowercase locale.
# Other elements have one component separated by "_" less.
# Multiple "_" are seen as one separator: de__ch_spec de__ch de {}
#
+# This method is part of the ensemble mcutil
+#
# Arguments:
# Locale.
#
# Results:
# Locale list
-proc msgcat::GetPreferences {locale} {
+proc msgcat::mcutil::getpreferences {locale} {
set locale [string tolower $locale]
set loclist [list $locale]
while {-1 !=[set pos [string last "_" $locale]]} {
@@ -349,16 +379,51 @@ proc msgcat::GetPreferences {locale} {
# most preferred to least preferred.
#
# Arguments:
-# None.
+# New location list
#
# Results:
# Returns an ordered list of the locales preferred by the user.
-proc msgcat::mcpreferences {} {
+proc msgcat::mcpreferences {args} {
variable Loclist
+
+ if {[llength $args] > 0} {
+ # args is the new loclist
+ if {![ListEqualString $args $Loclist]} {
+ set Loclist $args
+
+ # locale not loaded jet
+ LoadAll $Loclist
+ # Invoke callback
+ Invoke changecmd $Loclist
+ }
+ }
return $Loclist
}
+# msgcat::ListStringEqual --
+#
+# Compare two strings for equal string contents
+#
+# Arguments:
+# list1 first list
+# list2 second list
+#
+# Results:
+# 1 if lists of strings are identical, 0 otherwise
+
+proc msgcat::ListEqualString {list1 list2} {
+ if {[llength $list1] != [llength $list2]} {
+ return 0
+ }
+ foreach item1 $list1 item2 $list2 {
+ if {$item1 ne $item2} {
+ return 0
+ }
+ }
+ return 1
+}
+
# msgcat::mcloadedlocales --
#
# Get or change the list of currently loaded default locales
@@ -442,7 +507,7 @@ proc msgcat::mcloadedlocales {subcommand} {
# Results:
# Empty string, if not stated differently for the subcommand
-proc msgcat::mcpackagelocale {subcommand {locale ""}} {
+proc msgcat::mcpackagelocale {subcommand args} {
# todo: implement using an ensemble
variable Loclist
variable LoadedLocales
@@ -450,27 +515,39 @@ proc msgcat::mcpackagelocale {subcommand {locale ""}} {
variable PackageConfig
# Check option
# check if required item is exactly provided
- if {[llength [info level 0]] == 2} {
- # locale not given
- unset locale
- } else {
- # locale given
- if {$subcommand in
- {"get" "isset" "unset" "preferences" "loaded" "clear"} } {
- return -code error "wrong # args: should be\
- \"[lrange [info level 0] 0 1]\""
- }
- set locale [string tolower $locale]
+ if { [llength $args] > 0
+ && $subcommand in {"get" "isset" "unset" "loaded" "clear"} } {
+ return -code error "wrong # args: should be\
+ \"[lrange [info level 0] 0 1]\""
}
- set ns [uplevel 1 {::namespace current}]
+ set ns [PackageNamespaceGet]
switch -exact -- $subcommand {
get { return [lindex [PackagePreferences $ns] 0] }
- preferences { return [PackagePreferences $ns] }
loaded { return [PackageLocales $ns] }
- present { return [expr {$locale in [PackageLocales $ns]} ]}
+ present {
+ if {[llength $args] != 1} {
+ return -code error "wrong # args: should be\
+ \"[lrange [info level 0] 0 1] locale\""
+ }
+ return [expr {[string tolower [lindex $args 0]]
+ in [PackageLocales $ns]} ]
+ }
isset { return [dict exists $PackageConfig loclist $ns] }
- set { # set a package locale or add a package locale
+ set - preferences {
+ # set a package locale or add a package locale
+ set fSet [expr {$subcommand eq "set"}]
+
+ # Check parameter
+ if {$fSet && 1 < [llength $args] } {
+ return -code error "wrong # args: should be\
+ \"[lrange [info level 0] 0 1] ?locale?\""
+ }
+
+ # > Return preferences if no parameter
+ if {!$fSet && 0 == [llength $args] } {
+ return [PackagePreferences $ns]
+ }
# Copy the default locale if no package locale set so far
if {![dict exists $PackageConfig loclist $ns]} {
@@ -478,25 +555,43 @@ proc msgcat::mcpackagelocale {subcommand {locale ""}} {
dict set PackageConfig loadedlocales $ns $LoadedLocales
}
- # Check if changed
- set loclist [dict get $PackageConfig loclist $ns]
- if {! [info exists locale] || $locale eq [lindex $loclist 0] } {
- return [lindex $loclist 0]
+ # No argument for set: return current package locale
+ # The difference to no argument and subcommand "preferences" is,
+ # that "preferences" does not set the package locale property.
+ # This case is processed above, so no check for fSet here
+ if { 0 == [llength $args] } {
+ return [lindex [dict get $PackageConfig loclist $ns] 0]
+ }
+
+ # Get new loclist
+ if {$fSet} {
+ set loclist [mcutil getpreferences [lindex $args 0]]
+ } else {
+ set loclist $args
+ }
+
+ # Check if not changed to return imediately
+ if { [ListEqualString $loclist\
+ [dict get $PackageConfig loclist $ns]] } {
+ if {$fSet} {
+ return [lindex $loclist 0]
+ }
+ return $loclist
}
# Change loclist
- set loclist [GetPreferences $locale]
- set locale [lindex $loclist 0]
dict set PackageConfig loclist $ns $loclist
# load eventual missing locales
set loadedLocales [dict get $PackageConfig loadedlocales $ns]
- if {$locale in $loadedLocales} { return $locale }
set loadLocales [ListComplement $loadedLocales $loclist]
dict set PackageConfig loadedlocales $ns\
[concat $loadedLocales $loadLocales]
Load $ns $loadLocales
- return $locale
+ if {$fSet} {
+ return [lindex $loclist 0]
+ }
+ return $loclist
}
clear { # Remove all locales not contained in Loclist
if {![dict exists $PackageConfig loclist $ns]} {
@@ -551,7 +646,7 @@ proc msgcat::mcforgetpackage {} {
# todo: this may be implemented using an ensemble
variable PackageConfig
variable Msgs
- set ns [uplevel 1 {::namespace current}]
+ set ns [PackageNamespaceGet]
# Remove MC items
dict unset Msgs $ns
# Remove config items
@@ -561,6 +656,15 @@ proc msgcat::mcforgetpackage {} {
return
}
+# msgcat::mcgetmynamespace --
+#
+# Return the package namespace of the caller
+# This consideres to be called from a class or object.
+
+proc msgcat::mcpackagenamespaceget {} {
+ return [PackageNamespaceGet]
+}
+
# msgcat::mcpackageconfig --
#
# Get or modify the per caller namespace (e.g. packages) config options.
@@ -616,7 +720,7 @@ proc msgcat::mcforgetpackage {} {
proc msgcat::mcpackageconfig {subcommand option {value ""}} {
variable PackageConfig
# get namespace
- set ns [uplevel 1 {::namespace current}]
+ set ns [PackageNamespaceGet]
if {$option ni {"mcfolder" "loadcmd" "changecmd" "unknowncmd"}} {
return -code error "bad option \"$option\": must be mcfolder, loadcmd,\
@@ -756,8 +860,7 @@ proc msgcat::ListComplement {list1 list2 {inlistname ""}} {
# Returns the number of message catalogs that were loaded.
proc msgcat::mcload {langdir} {
- return [uplevel 1 [list\
- [namespace origin mcpackageconfig] set mcfolder $langdir]]
+ tailcall mcpackageconfig set mcfolder $langdir
}
# msgcat::LoadAll --
@@ -923,7 +1026,7 @@ proc msgcat::mcset {locale src {dest ""}} {
set dest $src
}
- set ns [uplevel 1 [list ::namespace current]]
+ set ns [PackageNamespaceGet]
set locale [string tolower $locale]
@@ -951,7 +1054,7 @@ proc msgcat::mcflset {src {dest ""}} {
return -code error "must only be used inside a message catalog loaded\
with ::msgcat::mcload"
}
- return [uplevel 1 [list [namespace origin mcset] $FileLocale $src $dest]]
+ tailcall mcset $FileLocale $src $dest
}
# msgcat::mcmset --
@@ -975,7 +1078,7 @@ proc msgcat::mcmset {locale pairs} {
}
set locale [string tolower $locale]
- set ns [uplevel 1 [list ::namespace current]]
+ set ns [PackageNamespaceGet]
foreach {src dest} $pairs {
dict set Msgs $ns $locale $src $dest
@@ -1002,7 +1105,7 @@ proc msgcat::mcflmset {pairs} {
return -code error "must only be used inside a message catalog loaded\
with ::msgcat::mcload"
}
- return [uplevel 1 [list [namespace origin mcmset] $FileLocale $pairs]]
+ tailcal mcmset $FileLocale $pairs
}
# msgcat::mcunknown --
@@ -1024,7 +1127,7 @@ proc msgcat::mcflmset {pairs} {
# Returns the translated value.
proc msgcat::mcunknown {args} {
- return [uplevel 1 [list [namespace origin DefaultUnknown] {*}$args]]
+ tailcall DefaultUnknown {*}$args
}
# msgcat::DefaultUnknown --
@@ -1067,8 +1170,9 @@ proc msgcat::DefaultUnknown {locale src args} {
proc msgcat::mcmax {args} {
set max 0
+ set ns [PackageNamespaceGet]
foreach string $args {
- set translated [uplevel 1 [list [namespace origin mc] $string]]
+ set translated [uplevel 1 [list [namespace origin mcn] $ns $string]]
set len [string length $translated]
if {$len>$max} {
set max $len
@@ -1079,7 +1183,7 @@ proc msgcat::mcmax {args} {
# Convert the locale values stored in environment variables to a form
# suitable for passing to [mclocale]
-proc msgcat::ConvertLocale {value} {
+proc msgcat::mcutil::ConvertLocale {value} {
# Assume $value is of form: $language[_$territory][.$codeset][@modifier]
# Convert to form: $language[_$territory][_$modifier]
#
@@ -1106,8 +1210,40 @@ proc msgcat::ConvertLocale {value} {
return $ret
}
+# helper function to find package namespace of stack-frame -2
+# There are 4 possibilities:
+# - called from a proc
+# - called within a class definition script
+# - called from an class defined oo object
+# - called from a classless oo object
+proc ::msgcat::PackageNamespaceGet {} {
+ uplevel 2 {
+ # Check self namespace to determine environment
+ switch -exact -- [namespace which self] {
+ {::oo::define::self} {
+ # We are within a class definition
+ return [namespace qualifiers [self]]
+ }
+ {::oo::Helpers::self} {
+ # We are within an object
+ set Class [info object class [self]]
+ # Check for classless defined object
+ if {$Class eq {::oo::object}} {
+ return [namespace qualifiers [self]]
+ }
+ # Class defined object
+ return [namespace qualifiers $Class]
+ }
+ default {
+ # Not in object environment
+ return [namespace current]
+ }
+ }
+ }
+}
+
# Initialize the default locale
-proc msgcat::Init {} {
+proc msgcat::mcutil::getsystemlocale {} {
global env
#
@@ -1115,10 +1251,8 @@ proc msgcat::Init {} {
#
foreach varName {LC_ALL LC_MESSAGES LANG} {
if {[info exists env($varName)] && ("" ne $env($varName))} {
- if {![catch {
- mclocale [ConvertLocale $env($varName)]
- }]} {
- return
+ if {![catch { ConvertLocale $env($varName) } locale]} {
+ return $locale
}
}
}
@@ -1126,10 +1260,8 @@ proc msgcat::Init {} {
# On Darwin, fallback to current CFLocale identifier if available.
#
if {[info exists ::tcl::mac::locale] && $::tcl::mac::locale ne ""} {
- if {![catch {
- mclocale [ConvertLocale $::tcl::mac::locale]
- }]} {
- return
+ if {![catch { ConvertLocale $::tcl::mac::locale } locale]} {
+ return $locale
}
}
#
@@ -1138,8 +1270,7 @@ proc msgcat::Init {} {
#
if {([info sharedlibextension] ne ".dll")
|| [catch {package require registry}]} {
- mclocale C
- return
+ return C
}
#
# On Windows or Cygwin, try to set locale depending on registry
@@ -1170,8 +1301,8 @@ proc msgcat::Init {} {
if {[dict exists $modifierDict $script]} {
append locale @ [dict get $modifierDict $script]
}
- if {![catch {mclocale [ConvertLocale $locale]}]} {
- return
+ if {![catch {ConvertLocale $locale} locale]} {
+ return $locale
}
}
}
@@ -1180,8 +1311,7 @@ proc msgcat::Init {} {
if {[catch {
set locale [registry get $key "locale"]
}]} {
- mclocale C
- return
+ return C
}
#
# Keep trying to match against smaller and smaller suffixes
@@ -1196,15 +1326,15 @@ proc msgcat::Init {} {
set locale [string tolower $locale]
while {[string length $locale]} {
if {![catch {
- mclocale [ConvertLocale [dict get $WinRegToISO639 $locale]]
- }]} {
- return
+ ConvertLocale [dict get $WinRegToISO639 $locale]
+ } localeOut]} {
+ return $localeOut
}
set locale [string range $locale 1 end]
}
#
# No translation known. Fall back on "C" locale
#
- mclocale C
+ return C
}
-msgcat::Init
+msgcat::mclocale [msgcat::mcutil getsystemlocale]
diff --git a/library/msgcat/pkgIndex.tcl b/library/msgcat/pkgIndex.tcl
index 72c5dc0..3309a30 100644
--- a/library/msgcat/pkgIndex.tcl
+++ b/library/msgcat/pkgIndex.tcl
@@ -1,2 +1,2 @@
-if {![package vsatisfies [package provide Tcl] 8.5-]} {return}
-package ifneeded msgcat 1.6.1 [list source [file join $dir msgcat.tcl]]
+if {![package vsatisfies [package provide Tcl] 8.7-]} {return}
+package ifneeded msgcat 1.7.0 [list source [file join $dir msgcat.tcl]]
diff --git a/library/tzdata/Africa/Sao_Tome b/library/tzdata/Africa/Sao_Tome
index 078591d..fe08d89 100644
--- a/library/tzdata/Africa/Sao_Tome
+++ b/library/tzdata/Africa/Sao_Tome
@@ -1,5 +1,8 @@
# created by tools/tclZIC.tcl - do not edit
-if {![info exists TZData(Africa/Abidjan)]} {
- LoadTimeZoneFile Africa/Abidjan
+
+set TZData(:Africa/Sao_Tome) {
+ {-9223372036854775808 1616 0 LMT}
+ {-2713912016 -2205 0 LMT}
+ {-1830381795 0 0 GMT}
+ {1514768400 3600 0 WAT}
}
-set TZData(:Africa/Sao_Tome) $TZData(:Africa/Abidjan)
diff --git a/library/tzdata/America/Campo_Grande b/library/tzdata/America/Campo_Grande
index 77cb4d1..f8bfb67 100644
--- a/library/tzdata/America/Campo_Grande
+++ b/library/tzdata/America/Campo_Grande
@@ -91,167 +91,167 @@ set TZData(:America/Campo_Grande) {
{1487473200 -14400 0 -04}
{1508040000 -10800 1 -03}
{1518922800 -14400 0 -04}
- {1540094400 -10800 1 -03}
+ {1541304000 -10800 1 -03}
{1550372400 -14400 0 -04}
- {1571544000 -10800 1 -03}
+ {1572753600 -10800 1 -03}
{1581822000 -14400 0 -04}
- {1602993600 -10800 1 -03}
+ {1604203200 -10800 1 -03}
{1613876400 -14400 0 -04}
- {1634443200 -10800 1 -03}
+ {1636257600 -10800 1 -03}
{1645326000 -14400 0 -04}
- {1665892800 -10800 1 -03}
+ {1667707200 -10800 1 -03}
{1677380400 -14400 0 -04}
- {1697342400 -10800 1 -03}
+ {1699156800 -10800 1 -03}
{1708225200 -14400 0 -04}
- {1729396800 -10800 1 -03}
+ {1730606400 -10800 1 -03}
{1739674800 -14400 0 -04}
- {1760846400 -10800 1 -03}
+ {1762056000 -10800 1 -03}
{1771729200 -14400 0 -04}
- {1792296000 -10800 1 -03}
+ {1793505600 -10800 1 -03}
{1803178800 -14400 0 -04}
- {1823745600 -10800 1 -03}
+ {1825560000 -10800 1 -03}
{1834628400 -14400 0 -04}
- {1855195200 -10800 1 -03}
+ {1857009600 -10800 1 -03}
{1866078000 -14400 0 -04}
- {1887249600 -10800 1 -03}
+ {1888459200 -10800 1 -03}
{1897527600 -14400 0 -04}
- {1918699200 -10800 1 -03}
+ {1919908800 -10800 1 -03}
{1928977200 -14400 0 -04}
- {1950148800 -10800 1 -03}
+ {1951358400 -10800 1 -03}
{1960426800 -14400 0 -04}
- {1981598400 -10800 1 -03}
+ {1983412800 -10800 1 -03}
{1992481200 -14400 0 -04}
- {2013048000 -10800 1 -03}
+ {2014862400 -10800 1 -03}
{2024535600 -14400 0 -04}
- {2044497600 -10800 1 -03}
+ {2046312000 -10800 1 -03}
{2055380400 -14400 0 -04}
- {2076552000 -10800 1 -03}
+ {2077761600 -10800 1 -03}
{2086830000 -14400 0 -04}
- {2108001600 -10800 1 -03}
+ {2109211200 -10800 1 -03}
{2118884400 -14400 0 -04}
- {2139451200 -10800 1 -03}
+ {2140660800 -10800 1 -03}
{2150334000 -14400 0 -04}
- {2170900800 -10800 1 -03}
+ {2172715200 -10800 1 -03}
{2181783600 -14400 0 -04}
- {2202350400 -10800 1 -03}
+ {2204164800 -10800 1 -03}
{2213233200 -14400 0 -04}
- {2234404800 -10800 1 -03}
+ {2235614400 -10800 1 -03}
{2244682800 -14400 0 -04}
- {2265854400 -10800 1 -03}
+ {2267064000 -10800 1 -03}
{2276132400 -14400 0 -04}
- {2297304000 -10800 1 -03}
+ {2298513600 -10800 1 -03}
{2307582000 -14400 0 -04}
- {2328753600 -10800 1 -03}
+ {2329963200 -10800 1 -03}
{2339636400 -14400 0 -04}
- {2360203200 -10800 1 -03}
+ {2362017600 -10800 1 -03}
{2371086000 -14400 0 -04}
- {2391652800 -10800 1 -03}
+ {2393467200 -10800 1 -03}
{2402535600 -14400 0 -04}
- {2423707200 -10800 1 -03}
+ {2424916800 -10800 1 -03}
{2433985200 -14400 0 -04}
- {2455156800 -10800 1 -03}
+ {2456366400 -10800 1 -03}
{2465434800 -14400 0 -04}
- {2486606400 -10800 1 -03}
+ {2487816000 -10800 1 -03}
{2497489200 -14400 0 -04}
- {2518056000 -10800 1 -03}
+ {2519870400 -10800 1 -03}
{2528938800 -14400 0 -04}
- {2549505600 -10800 1 -03}
+ {2551320000 -10800 1 -03}
{2560388400 -14400 0 -04}
- {2580955200 -10800 1 -03}
+ {2582769600 -10800 1 -03}
{2591838000 -14400 0 -04}
- {2613009600 -10800 1 -03}
+ {2614219200 -10800 1 -03}
{2623287600 -14400 0 -04}
- {2644459200 -10800 1 -03}
+ {2645668800 -10800 1 -03}
{2654737200 -14400 0 -04}
- {2675908800 -10800 1 -03}
+ {2677118400 -10800 1 -03}
{2686791600 -14400 0 -04}
- {2707358400 -10800 1 -03}
+ {2709172800 -10800 1 -03}
{2718241200 -14400 0 -04}
- {2738808000 -10800 1 -03}
+ {2740622400 -10800 1 -03}
{2749690800 -14400 0 -04}
- {2770862400 -10800 1 -03}
+ {2772072000 -10800 1 -03}
{2781140400 -14400 0 -04}
- {2802312000 -10800 1 -03}
+ {2803521600 -10800 1 -03}
{2812590000 -14400 0 -04}
- {2833761600 -10800 1 -03}
+ {2834971200 -10800 1 -03}
{2844039600 -14400 0 -04}
- {2865211200 -10800 1 -03}
+ {2867025600 -10800 1 -03}
{2876094000 -14400 0 -04}
- {2896660800 -10800 1 -03}
+ {2898475200 -10800 1 -03}
{2907543600 -14400 0 -04}
- {2928110400 -10800 1 -03}
+ {2929924800 -10800 1 -03}
{2938993200 -14400 0 -04}
- {2960164800 -10800 1 -03}
+ {2961374400 -10800 1 -03}
{2970442800 -14400 0 -04}
- {2991614400 -10800 1 -03}
+ {2992824000 -10800 1 -03}
{3001892400 -14400 0 -04}
- {3023064000 -10800 1 -03}
+ {3024273600 -10800 1 -03}
{3033946800 -14400 0 -04}
- {3054513600 -10800 1 -03}
+ {3056328000 -10800 1 -03}
{3065396400 -14400 0 -04}
- {3085963200 -10800 1 -03}
+ {3087777600 -10800 1 -03}
{3096846000 -14400 0 -04}
- {3118017600 -10800 1 -03}
+ {3119227200 -10800 1 -03}
{3128295600 -14400 0 -04}
- {3149467200 -10800 1 -03}
+ {3150676800 -10800 1 -03}
{3159745200 -14400 0 -04}
- {3180916800 -10800 1 -03}
+ {3182126400 -10800 1 -03}
{3191194800 -14400 0 -04}
- {3212366400 -10800 1 -03}
+ {3213576000 -10800 1 -03}
{3223249200 -14400 0 -04}
- {3243816000 -10800 1 -03}
+ {3245630400 -10800 1 -03}
{3254698800 -14400 0 -04}
- {3275265600 -10800 1 -03}
+ {3277080000 -10800 1 -03}
{3286148400 -14400 0 -04}
- {3307320000 -10800 1 -03}
+ {3308529600 -10800 1 -03}
{3317598000 -14400 0 -04}
- {3338769600 -10800 1 -03}
+ {3339979200 -10800 1 -03}
{3349047600 -14400 0 -04}
- {3370219200 -10800 1 -03}
+ {3371428800 -10800 1 -03}
{3381102000 -14400 0 -04}
- {3401668800 -10800 1 -03}
+ {3403483200 -10800 1 -03}
{3412551600 -14400 0 -04}
- {3433118400 -10800 1 -03}
+ {3434932800 -10800 1 -03}
{3444001200 -14400 0 -04}
- {3464568000 -10800 1 -03}
+ {3466382400 -10800 1 -03}
{3475450800 -14400 0 -04}
- {3496622400 -10800 1 -03}
+ {3497832000 -10800 1 -03}
{3506900400 -14400 0 -04}
- {3528072000 -10800 1 -03}
+ {3529281600 -10800 1 -03}
{3538350000 -14400 0 -04}
- {3559521600 -10800 1 -03}
+ {3560731200 -10800 1 -03}
{3570404400 -14400 0 -04}
- {3590971200 -10800 1 -03}
+ {3592785600 -10800 1 -03}
{3601854000 -14400 0 -04}
- {3622420800 -10800 1 -03}
+ {3624235200 -10800 1 -03}
{3633303600 -14400 0 -04}
- {3654475200 -10800 1 -03}
+ {3655684800 -10800 1 -03}
{3664753200 -14400 0 -04}
- {3685924800 -10800 1 -03}
+ {3687134400 -10800 1 -03}
{3696202800 -14400 0 -04}
- {3717374400 -10800 1 -03}
+ {3718584000 -10800 1 -03}
{3727652400 -14400 0 -04}
- {3748824000 -10800 1 -03}
+ {3750638400 -10800 1 -03}
{3759706800 -14400 0 -04}
- {3780273600 -10800 1 -03}
+ {3782088000 -10800 1 -03}
{3791156400 -14400 0 -04}
- {3811723200 -10800 1 -03}
+ {3813537600 -10800 1 -03}
{3822606000 -14400 0 -04}
- {3843777600 -10800 1 -03}
+ {3844987200 -10800 1 -03}
{3854055600 -14400 0 -04}
- {3875227200 -10800 1 -03}
+ {3876436800 -10800 1 -03}
{3885505200 -14400 0 -04}
- {3906676800 -10800 1 -03}
+ {3907886400 -10800 1 -03}
{3917559600 -14400 0 -04}
- {3938126400 -10800 1 -03}
+ {3939940800 -10800 1 -03}
{3949009200 -14400 0 -04}
- {3969576000 -10800 1 -03}
+ {3971390400 -10800 1 -03}
{3980458800 -14400 0 -04}
- {4001630400 -10800 1 -03}
+ {4002840000 -10800 1 -03}
{4011908400 -14400 0 -04}
- {4033080000 -10800 1 -03}
+ {4034289600 -10800 1 -03}
{4043358000 -14400 0 -04}
- {4064529600 -10800 1 -03}
+ {4065739200 -10800 1 -03}
{4074807600 -14400 0 -04}
- {4095979200 -10800 1 -03}
+ {4097188800 -10800 1 -03}
}
diff --git a/library/tzdata/America/Cuiaba b/library/tzdata/America/Cuiaba
index 57cd38c..69acddb 100644
--- a/library/tzdata/America/Cuiaba
+++ b/library/tzdata/America/Cuiaba
@@ -91,167 +91,167 @@ set TZData(:America/Cuiaba) {
{1487473200 -14400 0 -04}
{1508040000 -10800 1 -03}
{1518922800 -14400 0 -04}
- {1540094400 -10800 1 -03}
+ {1541304000 -10800 1 -03}
{1550372400 -14400 0 -04}
- {1571544000 -10800 1 -03}
+ {1572753600 -10800 1 -03}
{1581822000 -14400 0 -04}
- {1602993600 -10800 1 -03}
+ {1604203200 -10800 1 -03}
{1613876400 -14400 0 -04}
- {1634443200 -10800 1 -03}
+ {1636257600 -10800 1 -03}
{1645326000 -14400 0 -04}
- {1665892800 -10800 1 -03}
+ {1667707200 -10800 1 -03}
{1677380400 -14400 0 -04}
- {1697342400 -10800 1 -03}
+ {1699156800 -10800 1 -03}
{1708225200 -14400 0 -04}
- {1729396800 -10800 1 -03}
+ {1730606400 -10800 1 -03}
{1739674800 -14400 0 -04}
- {1760846400 -10800 1 -03}
+ {1762056000 -10800 1 -03}
{1771729200 -14400 0 -04}
- {1792296000 -10800 1 -03}
+ {1793505600 -10800 1 -03}
{1803178800 -14400 0 -04}
- {1823745600 -10800 1 -03}
+ {1825560000 -10800 1 -03}
{1834628400 -14400 0 -04}
- {1855195200 -10800 1 -03}
+ {1857009600 -10800 1 -03}
{1866078000 -14400 0 -04}
- {1887249600 -10800 1 -03}
+ {1888459200 -10800 1 -03}
{1897527600 -14400 0 -04}
- {1918699200 -10800 1 -03}
+ {1919908800 -10800 1 -03}
{1928977200 -14400 0 -04}
- {1950148800 -10800 1 -03}
+ {1951358400 -10800 1 -03}
{1960426800 -14400 0 -04}
- {1981598400 -10800 1 -03}
+ {1983412800 -10800 1 -03}
{1992481200 -14400 0 -04}
- {2013048000 -10800 1 -03}
+ {2014862400 -10800 1 -03}
{2024535600 -14400 0 -04}
- {2044497600 -10800 1 -03}
+ {2046312000 -10800 1 -03}
{2055380400 -14400 0 -04}
- {2076552000 -10800 1 -03}
+ {2077761600 -10800 1 -03}
{2086830000 -14400 0 -04}
- {2108001600 -10800 1 -03}
+ {2109211200 -10800 1 -03}
{2118884400 -14400 0 -04}
- {2139451200 -10800 1 -03}
+ {2140660800 -10800 1 -03}
{2150334000 -14400 0 -04}
- {2170900800 -10800 1 -03}
+ {2172715200 -10800 1 -03}
{2181783600 -14400 0 -04}
- {2202350400 -10800 1 -03}
+ {2204164800 -10800 1 -03}
{2213233200 -14400 0 -04}
- {2234404800 -10800 1 -03}
+ {2235614400 -10800 1 -03}
{2244682800 -14400 0 -04}
- {2265854400 -10800 1 -03}
+ {2267064000 -10800 1 -03}
{2276132400 -14400 0 -04}
- {2297304000 -10800 1 -03}
+ {2298513600 -10800 1 -03}
{2307582000 -14400 0 -04}
- {2328753600 -10800 1 -03}
+ {2329963200 -10800 1 -03}
{2339636400 -14400 0 -04}
- {2360203200 -10800 1 -03}
+ {2362017600 -10800 1 -03}
{2371086000 -14400 0 -04}
- {2391652800 -10800 1 -03}
+ {2393467200 -10800 1 -03}
{2402535600 -14400 0 -04}
- {2423707200 -10800 1 -03}
+ {2424916800 -10800 1 -03}
{2433985200 -14400 0 -04}
- {2455156800 -10800 1 -03}
+ {2456366400 -10800 1 -03}
{2465434800 -14400 0 -04}
- {2486606400 -10800 1 -03}
+ {2487816000 -10800 1 -03}
{2497489200 -14400 0 -04}
- {2518056000 -10800 1 -03}
+ {2519870400 -10800 1 -03}
{2528938800 -14400 0 -04}
- {2549505600 -10800 1 -03}
+ {2551320000 -10800 1 -03}
{2560388400 -14400 0 -04}
- {2580955200 -10800 1 -03}
+ {2582769600 -10800 1 -03}
{2591838000 -14400 0 -04}
- {2613009600 -10800 1 -03}
+ {2614219200 -10800 1 -03}
{2623287600 -14400 0 -04}
- {2644459200 -10800 1 -03}
+ {2645668800 -10800 1 -03}
{2654737200 -14400 0 -04}
- {2675908800 -10800 1 -03}
+ {2677118400 -10800 1 -03}
{2686791600 -14400 0 -04}
- {2707358400 -10800 1 -03}
+ {2709172800 -10800 1 -03}
{2718241200 -14400 0 -04}
- {2738808000 -10800 1 -03}
+ {2740622400 -10800 1 -03}
{2749690800 -14400 0 -04}
- {2770862400 -10800 1 -03}
+ {2772072000 -10800 1 -03}
{2781140400 -14400 0 -04}
- {2802312000 -10800 1 -03}
+ {2803521600 -10800 1 -03}
{2812590000 -14400 0 -04}
- {2833761600 -10800 1 -03}
+ {2834971200 -10800 1 -03}
{2844039600 -14400 0 -04}
- {2865211200 -10800 1 -03}
+ {2867025600 -10800 1 -03}
{2876094000 -14400 0 -04}
- {2896660800 -10800 1 -03}
+ {2898475200 -10800 1 -03}
{2907543600 -14400 0 -04}
- {2928110400 -10800 1 -03}
+ {2929924800 -10800 1 -03}
{2938993200 -14400 0 -04}
- {2960164800 -10800 1 -03}
+ {2961374400 -10800 1 -03}
{2970442800 -14400 0 -04}
- {2991614400 -10800 1 -03}
+ {2992824000 -10800 1 -03}
{3001892400 -14400 0 -04}
- {3023064000 -10800 1 -03}
+ {3024273600 -10800 1 -03}
{3033946800 -14400 0 -04}
- {3054513600 -10800 1 -03}
+ {3056328000 -10800 1 -03}
{3065396400 -14400 0 -04}
- {3085963200 -10800 1 -03}
+ {3087777600 -10800 1 -03}
{3096846000 -14400 0 -04}
- {3118017600 -10800 1 -03}
+ {3119227200 -10800 1 -03}
{3128295600 -14400 0 -04}
- {3149467200 -10800 1 -03}
+ {3150676800 -10800 1 -03}
{3159745200 -14400 0 -04}
- {3180916800 -10800 1 -03}
+ {3182126400 -10800 1 -03}
{3191194800 -14400 0 -04}
- {3212366400 -10800 1 -03}
+ {3213576000 -10800 1 -03}
{3223249200 -14400 0 -04}
- {3243816000 -10800 1 -03}
+ {3245630400 -10800 1 -03}
{3254698800 -14400 0 -04}
- {3275265600 -10800 1 -03}
+ {3277080000 -10800 1 -03}
{3286148400 -14400 0 -04}
- {3307320000 -10800 1 -03}
+ {3308529600 -10800 1 -03}
{3317598000 -14400 0 -04}
- {3338769600 -10800 1 -03}
+ {3339979200 -10800 1 -03}
{3349047600 -14400 0 -04}
- {3370219200 -10800 1 -03}
+ {3371428800 -10800 1 -03}
{3381102000 -14400 0 -04}
- {3401668800 -10800 1 -03}
+ {3403483200 -10800 1 -03}
{3412551600 -14400 0 -04}
- {3433118400 -10800 1 -03}
+ {3434932800 -10800 1 -03}
{3444001200 -14400 0 -04}
- {3464568000 -10800 1 -03}
+ {3466382400 -10800 1 -03}
{3475450800 -14400 0 -04}
- {3496622400 -10800 1 -03}
+ {3497832000 -10800 1 -03}
{3506900400 -14400 0 -04}
- {3528072000 -10800 1 -03}
+ {3529281600 -10800 1 -03}
{3538350000 -14400 0 -04}
- {3559521600 -10800 1 -03}
+ {3560731200 -10800 1 -03}
{3570404400 -14400 0 -04}
- {3590971200 -10800 1 -03}
+ {3592785600 -10800 1 -03}
{3601854000 -14400 0 -04}
- {3622420800 -10800 1 -03}
+ {3624235200 -10800 1 -03}
{3633303600 -14400 0 -04}
- {3654475200 -10800 1 -03}
+ {3655684800 -10800 1 -03}
{3664753200 -14400 0 -04}
- {3685924800 -10800 1 -03}
+ {3687134400 -10800 1 -03}
{3696202800 -14400 0 -04}
- {3717374400 -10800 1 -03}
+ {3718584000 -10800 1 -03}
{3727652400 -14400 0 -04}
- {3748824000 -10800 1 -03}
+ {3750638400 -10800 1 -03}
{3759706800 -14400 0 -04}
- {3780273600 -10800 1 -03}
+ {3782088000 -10800 1 -03}
{3791156400 -14400 0 -04}
- {3811723200 -10800 1 -03}
+ {3813537600 -10800 1 -03}
{3822606000 -14400 0 -04}
- {3843777600 -10800 1 -03}
+ {3844987200 -10800 1 -03}
{3854055600 -14400 0 -04}
- {3875227200 -10800 1 -03}
+ {3876436800 -10800 1 -03}
{3885505200 -14400 0 -04}
- {3906676800 -10800 1 -03}
+ {3907886400 -10800 1 -03}
{3917559600 -14400 0 -04}
- {3938126400 -10800 1 -03}
+ {3939940800 -10800 1 -03}
{3949009200 -14400 0 -04}
- {3969576000 -10800 1 -03}
+ {3971390400 -10800 1 -03}
{3980458800 -14400 0 -04}
- {4001630400 -10800 1 -03}
+ {4002840000 -10800 1 -03}
{4011908400 -14400 0 -04}
- {4033080000 -10800 1 -03}
+ {4034289600 -10800 1 -03}
{4043358000 -14400 0 -04}
- {4064529600 -10800 1 -03}
+ {4065739200 -10800 1 -03}
{4074807600 -14400 0 -04}
- {4095979200 -10800 1 -03}
+ {4097188800 -10800 1 -03}
}
diff --git a/library/tzdata/America/La_Paz b/library/tzdata/America/La_Paz
index a245afd..ea2f711 100644
--- a/library/tzdata/America/La_Paz
+++ b/library/tzdata/America/La_Paz
@@ -3,6 +3,6 @@
set TZData(:America/La_Paz) {
{-9223372036854775808 -16356 0 LMT}
{-2524505244 -16356 0 CMT}
- {-1205954844 -12756 1 BOST}
+ {-1205954844 -12756 1 BST}
{-1192307244 -14400 0 -04}
}
diff --git a/library/tzdata/America/Sao_Paulo b/library/tzdata/America/Sao_Paulo
index a61c638..93c524d 100644
--- a/library/tzdata/America/Sao_Paulo
+++ b/library/tzdata/America/Sao_Paulo
@@ -92,167 +92,167 @@ set TZData(:America/Sao_Paulo) {
{1487469600 -10800 0 -03}
{1508036400 -7200 1 -02}
{1518919200 -10800 0 -03}
- {1540090800 -7200 1 -02}
+ {1541300400 -7200 1 -02}
{1550368800 -10800 0 -03}
- {1571540400 -7200 1 -02}
+ {1572750000 -7200 1 -02}
{1581818400 -10800 0 -03}
- {1602990000 -7200 1 -02}
+ {1604199600 -7200 1 -02}
{1613872800 -10800 0 -03}
- {1634439600 -7200 1 -02}
+ {1636254000 -7200 1 -02}
{1645322400 -10800 0 -03}
- {1665889200 -7200 1 -02}
+ {1667703600 -7200 1 -02}
{1677376800 -10800 0 -03}
- {1697338800 -7200 1 -02}
+ {1699153200 -7200 1 -02}
{1708221600 -10800 0 -03}
- {1729393200 -7200 1 -02}
+ {1730602800 -7200 1 -02}
{1739671200 -10800 0 -03}
- {1760842800 -7200 1 -02}
+ {1762052400 -7200 1 -02}
{1771725600 -10800 0 -03}
- {1792292400 -7200 1 -02}
+ {1793502000 -7200 1 -02}
{1803175200 -10800 0 -03}
- {1823742000 -7200 1 -02}
+ {1825556400 -7200 1 -02}
{1834624800 -10800 0 -03}
- {1855191600 -7200 1 -02}
+ {1857006000 -7200 1 -02}
{1866074400 -10800 0 -03}
- {1887246000 -7200 1 -02}
+ {1888455600 -7200 1 -02}
{1897524000 -10800 0 -03}
- {1918695600 -7200 1 -02}
+ {1919905200 -7200 1 -02}
{1928973600 -10800 0 -03}
- {1950145200 -7200 1 -02}
+ {1951354800 -7200 1 -02}
{1960423200 -10800 0 -03}
- {1981594800 -7200 1 -02}
+ {1983409200 -7200 1 -02}
{1992477600 -10800 0 -03}
- {2013044400 -7200 1 -02}
+ {2014858800 -7200 1 -02}
{2024532000 -10800 0 -03}
- {2044494000 -7200 1 -02}
+ {2046308400 -7200 1 -02}
{2055376800 -10800 0 -03}
- {2076548400 -7200 1 -02}
+ {2077758000 -7200 1 -02}
{2086826400 -10800 0 -03}
- {2107998000 -7200 1 -02}
+ {2109207600 -7200 1 -02}
{2118880800 -10800 0 -03}
- {2139447600 -7200 1 -02}
+ {2140657200 -7200 1 -02}
{2150330400 -10800 0 -03}
- {2170897200 -7200 1 -02}
+ {2172711600 -7200 1 -02}
{2181780000 -10800 0 -03}
- {2202346800 -7200 1 -02}
+ {2204161200 -7200 1 -02}
{2213229600 -10800 0 -03}
- {2234401200 -7200 1 -02}
+ {2235610800 -7200 1 -02}
{2244679200 -10800 0 -03}
- {2265850800 -7200 1 -02}
+ {2267060400 -7200 1 -02}
{2276128800 -10800 0 -03}
- {2297300400 -7200 1 -02}
+ {2298510000 -7200 1 -02}
{2307578400 -10800 0 -03}
- {2328750000 -7200 1 -02}
+ {2329959600 -7200 1 -02}
{2339632800 -10800 0 -03}
- {2360199600 -7200 1 -02}
+ {2362014000 -7200 1 -02}
{2371082400 -10800 0 -03}
- {2391649200 -7200 1 -02}
+ {2393463600 -7200 1 -02}
{2402532000 -10800 0 -03}
- {2423703600 -7200 1 -02}
+ {2424913200 -7200 1 -02}
{2433981600 -10800 0 -03}
- {2455153200 -7200 1 -02}
+ {2456362800 -7200 1 -02}
{2465431200 -10800 0 -03}
- {2486602800 -7200 1 -02}
+ {2487812400 -7200 1 -02}
{2497485600 -10800 0 -03}
- {2518052400 -7200 1 -02}
+ {2519866800 -7200 1 -02}
{2528935200 -10800 0 -03}
- {2549502000 -7200 1 -02}
+ {2551316400 -7200 1 -02}
{2560384800 -10800 0 -03}
- {2580951600 -7200 1 -02}
+ {2582766000 -7200 1 -02}
{2591834400 -10800 0 -03}
- {2613006000 -7200 1 -02}
+ {2614215600 -7200 1 -02}
{2623284000 -10800 0 -03}
- {2644455600 -7200 1 -02}
+ {2645665200 -7200 1 -02}
{2654733600 -10800 0 -03}
- {2675905200 -7200 1 -02}
+ {2677114800 -7200 1 -02}
{2686788000 -10800 0 -03}
- {2707354800 -7200 1 -02}
+ {2709169200 -7200 1 -02}
{2718237600 -10800 0 -03}
- {2738804400 -7200 1 -02}
+ {2740618800 -7200 1 -02}
{2749687200 -10800 0 -03}
- {2770858800 -7200 1 -02}
+ {2772068400 -7200 1 -02}
{2781136800 -10800 0 -03}
- {2802308400 -7200 1 -02}
+ {2803518000 -7200 1 -02}
{2812586400 -10800 0 -03}
- {2833758000 -7200 1 -02}
+ {2834967600 -7200 1 -02}
{2844036000 -10800 0 -03}
- {2865207600 -7200 1 -02}
+ {2867022000 -7200 1 -02}
{2876090400 -10800 0 -03}
- {2896657200 -7200 1 -02}
+ {2898471600 -7200 1 -02}
{2907540000 -10800 0 -03}
- {2928106800 -7200 1 -02}
+ {2929921200 -7200 1 -02}
{2938989600 -10800 0 -03}
- {2960161200 -7200 1 -02}
+ {2961370800 -7200 1 -02}
{2970439200 -10800 0 -03}
- {2991610800 -7200 1 -02}
+ {2992820400 -7200 1 -02}
{3001888800 -10800 0 -03}
- {3023060400 -7200 1 -02}
+ {3024270000 -7200 1 -02}
{3033943200 -10800 0 -03}
- {3054510000 -7200 1 -02}
+ {3056324400 -7200 1 -02}
{3065392800 -10800 0 -03}
- {3085959600 -7200 1 -02}
+ {3087774000 -7200 1 -02}
{3096842400 -10800 0 -03}
- {3118014000 -7200 1 -02}
+ {3119223600 -7200 1 -02}
{3128292000 -10800 0 -03}
- {3149463600 -7200 1 -02}
+ {3150673200 -7200 1 -02}
{3159741600 -10800 0 -03}
- {3180913200 -7200 1 -02}
+ {3182122800 -7200 1 -02}
{3191191200 -10800 0 -03}
- {3212362800 -7200 1 -02}
+ {3213572400 -7200 1 -02}
{3223245600 -10800 0 -03}
- {3243812400 -7200 1 -02}
+ {3245626800 -7200 1 -02}
{3254695200 -10800 0 -03}
- {3275262000 -7200 1 -02}
+ {3277076400 -7200 1 -02}
{3286144800 -10800 0 -03}
- {3307316400 -7200 1 -02}
+ {3308526000 -7200 1 -02}
{3317594400 -10800 0 -03}
- {3338766000 -7200 1 -02}
+ {3339975600 -7200 1 -02}
{3349044000 -10800 0 -03}
- {3370215600 -7200 1 -02}
+ {3371425200 -7200 1 -02}
{3381098400 -10800 0 -03}
- {3401665200 -7200 1 -02}
+ {3403479600 -7200 1 -02}
{3412548000 -10800 0 -03}
- {3433114800 -7200 1 -02}
+ {3434929200 -7200 1 -02}
{3443997600 -10800 0 -03}
- {3464564400 -7200 1 -02}
+ {3466378800 -7200 1 -02}
{3475447200 -10800 0 -03}
- {3496618800 -7200 1 -02}
+ {3497828400 -7200 1 -02}
{3506896800 -10800 0 -03}
- {3528068400 -7200 1 -02}
+ {3529278000 -7200 1 -02}
{3538346400 -10800 0 -03}
- {3559518000 -7200 1 -02}
+ {3560727600 -7200 1 -02}
{3570400800 -10800 0 -03}
- {3590967600 -7200 1 -02}
+ {3592782000 -7200 1 -02}
{3601850400 -10800 0 -03}
- {3622417200 -7200 1 -02}
+ {3624231600 -7200 1 -02}
{3633300000 -10800 0 -03}
- {3654471600 -7200 1 -02}
+ {3655681200 -7200 1 -02}
{3664749600 -10800 0 -03}
- {3685921200 -7200 1 -02}
+ {3687130800 -7200 1 -02}
{3696199200 -10800 0 -03}
- {3717370800 -7200 1 -02}
+ {3718580400 -7200 1 -02}
{3727648800 -10800 0 -03}
- {3748820400 -7200 1 -02}
+ {3750634800 -7200 1 -02}
{3759703200 -10800 0 -03}
- {3780270000 -7200 1 -02}
+ {3782084400 -7200 1 -02}
{3791152800 -10800 0 -03}
- {3811719600 -7200 1 -02}
+ {3813534000 -7200 1 -02}
{3822602400 -10800 0 -03}
- {3843774000 -7200 1 -02}
+ {3844983600 -7200 1 -02}
{3854052000 -10800 0 -03}
- {3875223600 -7200 1 -02}
+ {3876433200 -7200 1 -02}
{3885501600 -10800 0 -03}
- {3906673200 -7200 1 -02}
+ {3907882800 -7200 1 -02}
{3917556000 -10800 0 -03}
- {3938122800 -7200 1 -02}
+ {3939937200 -7200 1 -02}
{3949005600 -10800 0 -03}
- {3969572400 -7200 1 -02}
+ {3971386800 -7200 1 -02}
{3980455200 -10800 0 -03}
- {4001626800 -7200 1 -02}
+ {4002836400 -7200 1 -02}
{4011904800 -10800 0 -03}
- {4033076400 -7200 1 -02}
+ {4034286000 -7200 1 -02}
{4043354400 -10800 0 -03}
- {4064526000 -7200 1 -02}
+ {4065735600 -7200 1 -02}
{4074804000 -10800 0 -03}
- {4095975600 -7200 1 -02}
+ {4097185200 -7200 1 -02}
}
diff --git a/library/tzdata/Asia/Tokyo b/library/tzdata/Asia/Tokyo
index 10add1c..790df0a 100644
--- a/library/tzdata/Asia/Tokyo
+++ b/library/tzdata/Asia/Tokyo
@@ -3,12 +3,12 @@
set TZData(:Asia/Tokyo) {
{-9223372036854775808 33539 0 LMT}
{-2587712400 32400 0 JST}
- {-683794800 36000 1 JDT}
- {-672393600 32400 0 JST}
- {-654764400 36000 1 JDT}
- {-640944000 32400 0 JST}
- {-620290800 36000 1 JDT}
- {-609494400 32400 0 JST}
- {-588841200 36000 1 JDT}
- {-578044800 32400 0 JST}
+ {-683802000 36000 1 JDT}
+ {-672314400 32400 0 JST}
+ {-654771600 36000 1 JDT}
+ {-640864800 32400 0 JST}
+ {-620298000 36000 1 JDT}
+ {-609415200 32400 0 JST}
+ {-588848400 36000 1 JDT}
+ {-577965600 32400 0 JST}
}
diff --git a/libtommath/README.md b/libtommath/README.md
index 4c5da71..3bc491d 100644
--- a/libtommath/README.md
+++ b/libtommath/README.md
@@ -1,8 +1,14 @@
-[![Build Status - master](https://travis-ci.org/libtom/libtommath.png?branch=master)](https://travis-ci.org/libtom/libtommath)
+# libtommath
-[![Build Status - develop](https://travis-ci.org/libtom/libtommath.png?branch=develop)](https://travis-ci.org/libtom/libtommath)
+This is the git repository for [LibTomMath](http://www.libtom.net/LibTomMath/), a free open source portable number theoretic multiple-precision integer (MPI) library written entirely in C.
-This is the git repository for [LibTomMath](http://www.libtom.org/), a free open source portable number theoretic multiple-precision integer (MPI) library written entirely in C.
+## Build Status
+
+master - [![Build Status - master](https://travis-ci.org/libtom/libtommath.png?branch=master)](https://travis-ci.org/libtom/libtommath)
+
+develop - [![Build Status - develop](https://travis-ci.org/libtom/libtommath.png?branch=develop)](https://travis-ci.org/libtom/libtommath)
+
+## Summary
The `develop` branch contains the in-development version. Stable releases are tagged.
@@ -10,6 +16,8 @@ Documentation is built from the LaTeX file `bn.tex`. There is also limited docum
The project can be build by using `make`. Along with the usual `make`, `make clean` and `make install`, there are several other build targets, see the makefile for details. There are also makefiles for certain specific platforms.
+## Testing
+
Tests are located in `demo/` and can be built in two flavors.
* `make test` creates a test binary that is intended to be run against `mtest`. `mtest` can be built with `make mtest` and test execution is done like `./mtest/mtest | ./test`. `mtest` is creating test vectors using an alternative MPI library and `test` is consuming these vectors to verify correct behavior of ltm
* `make test_standalone` creates a stand-alone test binary that executes several test routines.
diff --git a/libtommath/bn_error.c b/libtommath/bn_error.c
index a51d712..7e816bf 100644
--- a/libtommath/bn_error.c
+++ b/libtommath/bn_error.c
@@ -27,10 +27,10 @@ static const struct {
/* return a char * string for a given code */
const char *mp_error_to_string(int code)
{
- int x;
+ size_t x;
/* scan the lookup table for the given message */
- for (x = 0; x < (int)(sizeof(msgs) / sizeof(msgs[0])); x++) {
+ for (x = 0; x < (sizeof(msgs) / sizeof(msgs[0])); x++) {
if (msgs[x].code == code) {
return msgs[x].msg;
}
diff --git a/libtommath/bn_fast_mp_invmod.c b/libtommath/bn_fast_mp_invmod.c
index 08389dd..6be44f8 100644
--- a/libtommath/bn_fast_mp_invmod.c
+++ b/libtommath/bn_fast_mp_invmod.c
@@ -46,6 +46,12 @@ int fast_mp_invmod(const mp_int *a, const mp_int *b, mp_int *c)
goto LBL_ERR;
}
+ /* if one of x,y is zero return an error! */
+ if ((mp_iszero(&x) == MP_YES) || (mp_iszero(&y) == MP_YES)) {
+ res = MP_VAL;
+ goto LBL_ERR;
+ }
+
/* 3. u=x, v=y, A=1, B=0, C=0,D=1 */
if ((res = mp_copy(&x, &u)) != MP_OKAY) {
goto LBL_ERR;
@@ -53,7 +59,7 @@ int fast_mp_invmod(const mp_int *a, const mp_int *b, mp_int *c)
if ((res = mp_copy(&y, &v)) != MP_OKAY) {
goto LBL_ERR;
}
- mp_set(&D, 1);
+ mp_set(&D, 1uL);
top:
/* 4. while u is even do */
@@ -122,7 +128,7 @@ top:
/* now a = C, b = D, gcd == g*v */
/* if v != 1 then there is no inverse */
- if (mp_cmp_d(&v, 1) != MP_EQ) {
+ if (mp_cmp_d(&v, 1uL) != MP_EQ) {
res = MP_VAL;
goto LBL_ERR;
}
diff --git a/libtommath/bn_fast_mp_montgomery_reduce.c b/libtommath/bn_fast_mp_montgomery_reduce.c
index 54d9b0a..8f91196 100644
--- a/libtommath/bn_fast_mp_montgomery_reduce.c
+++ b/libtommath/bn_fast_mp_montgomery_reduce.c
@@ -28,6 +28,10 @@ int fast_mp_montgomery_reduce(mp_int *x, const mp_int *n, mp_digit rho)
int ix, res, olduse;
mp_word W[MP_WARRAY];
+ if (x->used > (int)MP_WARRAY) {
+ return MP_VAL;
+ }
+
/* get old used count */
olduse = x->used;
@@ -73,7 +77,7 @@ int fast_mp_montgomery_reduce(mp_int *x, const mp_int *n, mp_digit rho)
* that W[ix-1] have the carry cleared (see after the inner loop)
*/
mp_digit mu;
- mu = (mp_digit)(((W[ix] & MP_MASK) * rho) & MP_MASK);
+ mu = ((W[ix] & MP_MASK) * rho) & MP_MASK;
/* a = a + mu * m * b**i
*
@@ -102,12 +106,12 @@ int fast_mp_montgomery_reduce(mp_int *x, const mp_int *n, mp_digit rho)
/* inner loop */
for (iy = 0; iy < n->used; iy++) {
- *_W++ += ((mp_word)mu) * ((mp_word)*tmpn++);
+ *_W++ += (mp_word)mu * (mp_word)*tmpn++;
}
}
/* now fix carry for next digit, W[ix+1] */
- W[ix + 1] += W[ix] >> ((mp_word) DIGIT_BIT);
+ W[ix + 1] += W[ix] >> (mp_word)DIGIT_BIT;
}
/* now we have to propagate the carries and
@@ -127,7 +131,7 @@ int fast_mp_montgomery_reduce(mp_int *x, const mp_int *n, mp_digit rho)
_W = W + ++ix;
for (; ix <= ((n->used * 2) + 1); ix++) {
- *_W++ += *_W1++ >> ((mp_word) DIGIT_BIT);
+ *_W++ += *_W1++ >> (mp_word)DIGIT_BIT;
}
/* copy out, A = A/b**n
@@ -144,7 +148,7 @@ int fast_mp_montgomery_reduce(mp_int *x, const mp_int *n, mp_digit rho)
_W = W + n->used;
for (ix = 0; ix < (n->used + 1); ix++) {
- *tmpx++ = (mp_digit)(*_W++ & ((mp_word) MP_MASK));
+ *tmpx++ = *_W++ & (mp_word)MP_MASK;
}
/* zero oldused digits, if the input a was larger than
diff --git a/libtommath/bn_fast_s_mp_mul_digs.c b/libtommath/bn_fast_s_mp_mul_digs.c
index 558d151..e542c2e 100644
--- a/libtommath/bn_fast_s_mp_mul_digs.c
+++ b/libtommath/bn_fast_s_mp_mul_digs.c
@@ -69,15 +69,15 @@ int fast_s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs)
/* execute loop */
for (iz = 0; iz < iy; ++iz) {
- _W += ((mp_word)*tmpx++)*((mp_word)*tmpy--);
+ _W += (mp_word)*tmpx++ * (mp_word)*tmpy--;
}
/* store term */
- W[ix] = ((mp_digit)_W) & MP_MASK;
+ W[ix] = (mp_digit)_W & MP_MASK;
/* make next carry */
- _W = _W >> ((mp_word)DIGIT_BIT);
+ _W = _W >> (mp_word)DIGIT_BIT;
}
/* setup dest */
@@ -87,7 +87,7 @@ int fast_s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs)
{
mp_digit *tmpc;
tmpc = c->dp;
- for (ix = 0; ix < (pa + 1); ix++) {
+ for (ix = 0; ix < pa; ix++) {
/* now extract the previous digit [below the carry] */
*tmpc++ = W[ix];
}
diff --git a/libtommath/bn_fast_s_mp_mul_high_digs.c b/libtommath/bn_fast_s_mp_mul_high_digs.c
index 8b662ed..6ea8a6c 100644
--- a/libtommath/bn_fast_s_mp_mul_high_digs.c
+++ b/libtommath/bn_fast_s_mp_mul_high_digs.c
@@ -60,14 +60,14 @@ int fast_s_mp_mul_high_digs(const mp_int *a, const mp_int *b, mp_int *c, int dig
/* execute loop */
for (iz = 0; iz < iy; iz++) {
- _W += ((mp_word)*tmpx++)*((mp_word)*tmpy--);
+ _W += (mp_word)*tmpx++ * (mp_word)*tmpy--;
}
/* store term */
- W[ix] = ((mp_digit)_W) & MP_MASK;
+ W[ix] = (mp_digit)_W & MP_MASK;
/* make next carry */
- _W = _W >> ((mp_word)DIGIT_BIT);
+ _W = _W >> (mp_word)DIGIT_BIT;
}
/* setup dest */
diff --git a/libtommath/bn_fast_s_mp_sqr.c b/libtommath/bn_fast_s_mp_sqr.c
index 161f785..1050121 100644
--- a/libtommath/bn_fast_s_mp_sqr.c
+++ b/libtommath/bn_fast_s_mp_sqr.c
@@ -70,22 +70,22 @@ int fast_s_mp_sqr(const mp_int *a, mp_int *b)
/* execute loop */
for (iz = 0; iz < iy; iz++) {
- _W += ((mp_word)*tmpx++)*((mp_word)*tmpy--);
+ _W += (mp_word)*tmpx++ * (mp_word)*tmpy--;
}
/* double the inner product and add carry */
_W = _W + _W + W1;
/* even columns have the square term in them */
- if ((ix&1) == 0) {
- _W += ((mp_word)a->dp[ix>>1])*((mp_word)a->dp[ix>>1]);
+ if (((unsigned)ix & 1u) == 0u) {
+ _W += (mp_word)a->dp[ix>>1] * (mp_word)a->dp[ix>>1];
}
/* store it */
- W[ix] = (mp_digit)(_W & MP_MASK);
+ W[ix] = _W & MP_MASK;
/* make next carry */
- W1 = _W >> ((mp_word)DIGIT_BIT);
+ W1 = _W >> (mp_word)DIGIT_BIT;
}
/* setup dest */
diff --git a/libtommath/bn_mp_2expt.c b/libtommath/bn_mp_2expt.c
index 701144c..5333d48 100644
--- a/libtommath/bn_mp_2expt.c
+++ b/libtommath/bn_mp_2expt.c
@@ -36,7 +36,7 @@ int mp_2expt(mp_int *a, int b)
a->used = (b / DIGIT_BIT) + 1;
/* put the single bit in its place */
- a->dp[b / DIGIT_BIT] = ((mp_digit)1) << (b % DIGIT_BIT);
+ a->dp[b / DIGIT_BIT] = (mp_digit)1 << (mp_digit)(b % DIGIT_BIT);
return MP_OKAY;
}
diff --git a/libtommath/bn_mp_clamp.c b/libtommath/bn_mp_clamp.c
index 3853914..79a5b20 100644
--- a/libtommath/bn_mp_clamp.c
+++ b/libtommath/bn_mp_clamp.c
@@ -27,7 +27,7 @@ void mp_clamp(mp_int *a)
/* decrease used while the most significant digit is
* zero.
*/
- while ((a->used > 0) && (a->dp[a->used - 1] == 0)) {
+ while ((a->used > 0) && (a->dp[a->used - 1] == 0u)) {
--(a->used);
}
diff --git a/libtommath/bn_mp_clear_multi.c b/libtommath/bn_mp_clear_multi.c
index 284fab8..ac3949a 100644
--- a/libtommath/bn_mp_clear_multi.c
+++ b/libtommath/bn_mp_clear_multi.c
@@ -14,6 +14,7 @@
*
* Tom St Denis, tstdenis82@gmail.com, http://libtom.org
*/
+
#include <stdarg.h>
void mp_clear_multi(mp_int *mp, ...)
diff --git a/libtommath/bn_mp_cnt_lsb.c b/libtommath/bn_mp_cnt_lsb.c
index 9a94d3d..219c369 100644
--- a/libtommath/bn_mp_cnt_lsb.c
+++ b/libtommath/bn_mp_cnt_lsb.c
@@ -31,17 +31,17 @@ int mp_cnt_lsb(const mp_int *a)
}
/* scan lower digits until non-zero */
- for (x = 0; (x < a->used) && (a->dp[x] == 0); x++) {}
+ for (x = 0; (x < a->used) && (a->dp[x] == 0u); x++) {}
q = a->dp[x];
x *= DIGIT_BIT;
/* now scan this digit until a 1 is found */
- if ((q & 1) == 0) {
+ if ((q & 1u) == 0u) {
do {
- qq = q & 15;
+ qq = q & 15u;
x += lnz[qq];
q >>= 4;
- } while (qq == 0);
+ } while (qq == 0u);
}
return x;
}
diff --git a/libtommath/bn_mp_count_bits.c b/libtommath/bn_mp_count_bits.c
index 7424581..4530c92 100644
--- a/libtommath/bn_mp_count_bits.c
+++ b/libtommath/bn_mp_count_bits.c
@@ -31,9 +31,9 @@ int mp_count_bits(const mp_int *a)
/* take the last digit and count the bits in it */
q = a->dp[a->used - 1];
- while (q > ((mp_digit) 0)) {
+ while (q > (mp_digit)0) {
++r;
- q >>= ((mp_digit) 1);
+ q >>= (mp_digit)1;
}
return r;
}
diff --git a/libtommath/bn_mp_div.c b/libtommath/bn_mp_div.c
index dbfdc03..f64f485 100644
--- a/libtommath/bn_mp_div.c
+++ b/libtommath/bn_mp_div.c
@@ -47,7 +47,7 @@ int mp_div(const mp_int *a, const mp_int *b, mp_int *c, mp_int *d)
}
- mp_set(&tq, 1);
+ mp_set(&tq, 1uL);
n = mp_count_bits(a) - mp_count_bits(b);
if (((res = mp_abs(a, &ta)) != MP_OKAY) ||
((res = mp_abs(b, &tb)) != MP_OKAY) ||
@@ -150,8 +150,8 @@ int mp_div(const mp_int *a, const mp_int *b, mp_int *c, mp_int *d)
/* normalize both x and y, ensure that y >= b/2, [b == 2**DIGIT_BIT] */
norm = mp_count_bits(&y) % DIGIT_BIT;
- if (norm < (int)(DIGIT_BIT-1)) {
- norm = (DIGIT_BIT-1) - norm;
+ if (norm < (DIGIT_BIT - 1)) {
+ norm = (DIGIT_BIT - 1) - norm;
if ((res = mp_mul_2d(&x, norm, &x)) != MP_OKAY) {
goto LBL_Y;
}
@@ -190,16 +190,16 @@ int mp_div(const mp_int *a, const mp_int *b, mp_int *c, mp_int *d)
/* step 3.1 if xi == yt then set q{i-t-1} to b-1,
* otherwise set q{i-t-1} to (xi*b + x{i-1})/yt */
if (x.dp[i] == y.dp[t]) {
- q.dp[(i - t) - 1] = ((((mp_digit)1) << DIGIT_BIT) - 1);
+ q.dp[(i - t) - 1] = ((mp_digit)1 << (mp_digit)DIGIT_BIT) - (mp_digit)1;
} else {
mp_word tmp;
- tmp = ((mp_word) x.dp[i]) << ((mp_word) DIGIT_BIT);
- tmp |= ((mp_word) x.dp[i - 1]);
- tmp /= ((mp_word) y.dp[t]);
- if (tmp > (mp_word) MP_MASK) {
+ tmp = (mp_word)x.dp[i] << (mp_word)DIGIT_BIT;
+ tmp |= (mp_word)x.dp[i - 1];
+ tmp /= (mp_word)y.dp[t];
+ if (tmp > (mp_word)MP_MASK) {
tmp = MP_MASK;
}
- q.dp[(i - t) - 1] = (mp_digit)(tmp & (mp_word)(MP_MASK));
+ q.dp[(i - t) - 1] = (mp_digit)(tmp & (mp_word)MP_MASK);
}
/* while (q{i-t-1} * (yt * b + y{t-1})) >
@@ -207,13 +207,13 @@ int mp_div(const mp_int *a, const mp_int *b, mp_int *c, mp_int *d)
do q{i-t-1} -= 1;
*/
- q.dp[(i - t) - 1] = (q.dp[(i - t) - 1] + 1) & MP_MASK;
+ q.dp[(i - t) - 1] = (q.dp[(i - t) - 1] + 1uL) & (mp_digit)MP_MASK;
do {
- q.dp[(i - t) - 1] = (q.dp[(i - t) - 1] - 1) & MP_MASK;
+ q.dp[(i - t) - 1] = (q.dp[(i - t) - 1] - 1uL) & (mp_digit)MP_MASK;
/* find left hand */
mp_zero(&t1);
- t1.dp[0] = ((t - 1) < 0) ? 0 : y.dp[t - 1];
+ t1.dp[0] = ((t - 1) < 0) ? 0u : y.dp[t - 1];
t1.dp[1] = y.dp[t];
t1.used = 2;
if ((res = mp_mul_d(&t1, q.dp[(i - t) - 1], &t1)) != MP_OKAY) {
@@ -221,8 +221,8 @@ int mp_div(const mp_int *a, const mp_int *b, mp_int *c, mp_int *d)
}
/* find right hand */
- t2.dp[0] = ((i - 2) < 0) ? 0 : x.dp[i - 2];
- t2.dp[1] = ((i - 1) < 0) ? 0 : x.dp[i - 1];
+ t2.dp[0] = ((i - 2) < 0) ? 0u : x.dp[i - 2];
+ t2.dp[1] = ((i - 1) < 0) ? 0u : x.dp[i - 1];
t2.dp[2] = x.dp[i];
t2.used = 3;
} while (mp_cmp_mag(&t1, &t2) == MP_GT);
@@ -252,7 +252,7 @@ int mp_div(const mp_int *a, const mp_int *b, mp_int *c, mp_int *d)
goto LBL_Y;
}
- q.dp[(i - t) - 1] = (q.dp[(i - t) - 1] - 1UL) & MP_MASK;
+ q.dp[(i - t) - 1] = (q.dp[(i - t) - 1] - 1uL) & MP_MASK;
}
}
diff --git a/libtommath/bn_mp_div_2.c b/libtommath/bn_mp_div_2.c
index edc8982..2907a1b 100644
--- a/libtommath/bn_mp_div_2.c
+++ b/libtommath/bn_mp_div_2.c
@@ -42,7 +42,7 @@ int mp_div_2(const mp_int *a, mp_int *b)
r = 0;
for (x = b->used - 1; x >= 0; x--) {
/* get the carry for the next iteration */
- rr = *tmpa & 1;
+ rr = *tmpa & 1u;
/* shift the current digit, add in carry and store */
*tmpb-- = (*tmpa-- >> 1) | (r << (DIGIT_BIT - 1));
diff --git a/libtommath/bn_mp_div_2d.c b/libtommath/bn_mp_div_2d.c
index eae3498..aeaa8f2 100644
--- a/libtommath/bn_mp_div_2d.c
+++ b/libtommath/bn_mp_div_2d.c
@@ -44,20 +44,20 @@ int mp_div_2d(const mp_int *a, int b, mp_int *c, mp_int *d)
}
/* shift by as many digits in the bit count */
- if (b >= (int)DIGIT_BIT) {
+ if (b >= DIGIT_BIT) {
mp_rshd(c, b / DIGIT_BIT);
}
/* shift any bit count < DIGIT_BIT */
D = (mp_digit)(b % DIGIT_BIT);
- if (D != 0) {
+ if (D != 0u) {
mp_digit *tmpc, mask, shift;
/* mask */
- mask = (((mp_digit)1) << D) - 1;
+ mask = ((mp_digit)1 << D) - 1uL;
/* shift for lsb */
- shift = DIGIT_BIT - D;
+ shift = (mp_digit)DIGIT_BIT - D;
/* alias */
tmpc = c->dp + (c->used - 1);
diff --git a/libtommath/bn_mp_div_3.c b/libtommath/bn_mp_div_3.c
index 9cc8caa..9d41793 100644
--- a/libtommath/bn_mp_div_3.c
+++ b/libtommath/bn_mp_div_3.c
@@ -24,7 +24,7 @@ int mp_div_3(const mp_int *a, mp_int *c, mp_digit *d)
int res, ix;
/* b = 2**DIGIT_BIT / 3 */
- b = (((mp_word)1) << ((mp_word)DIGIT_BIT)) / ((mp_word)3);
+ b = ((mp_word)1 << (mp_word)DIGIT_BIT) / (mp_word)3;
if ((res = mp_init_size(&q, a->used)) != MP_OKAY) {
return res;
@@ -34,11 +34,11 @@ int mp_div_3(const mp_int *a, mp_int *c, mp_digit *d)
q.sign = a->sign;
w = 0;
for (ix = a->used - 1; ix >= 0; ix--) {
- w = (w << ((mp_word)DIGIT_BIT)) | ((mp_word)a->dp[ix]);
+ w = (w << (mp_word)DIGIT_BIT) | (mp_word)a->dp[ix];
- if (w >= 3) {
+ if (w >= 3u) {
/* multiply w by [1/3] */
- t = (w * ((mp_word)b)) >> ((mp_word)DIGIT_BIT);
+ t = (w * (mp_word)b) >> (mp_word)DIGIT_BIT;
/* now subtract 3 * [w/3] from w, to get the remainder */
w -= t+t+t;
@@ -46,9 +46,9 @@ int mp_div_3(const mp_int *a, mp_int *c, mp_digit *d)
/* fixup the remainder as required since
* the optimization is not exact.
*/
- while (w >= 3) {
- t += 1;
- w -= 3;
+ while (w >= 3u) {
+ t += 1u;
+ w -= 3u;
}
} else {
t = 0;
diff --git a/libtommath/bn_mp_div_d.c b/libtommath/bn_mp_div_d.c
index c408602..7c0ab0b 100644
--- a/libtommath/bn_mp_div_d.c
+++ b/libtommath/bn_mp_div_d.c
@@ -24,12 +24,12 @@ int mp_div_d(const mp_int *a, mp_digit b, mp_int *c, mp_digit *d)
int res, ix;
/* cannot divide by zero */
- if (b == 0) {
+ if (b == 0u) {
return MP_VAL;
}
/* quick outs */
- if ((b == 1) || (mp_iszero(a) == MP_YES)) {
+ if ((b == 1u) || (mp_iszero(a) == MP_YES)) {
if (d != NULL) {
*d = 0;
}
@@ -47,7 +47,7 @@ int mp_div_d(const mp_int *a, mp_digit b, mp_int *c, mp_digit *d)
}
}
if (d != NULL) {
- *d = a->dp[0] & ((((mp_digit)1)<<ix) - 1);
+ *d = a->dp[0] & (((mp_digit)1<<(mp_digit)ix) - 1uL);
}
if (c != NULL) {
return mp_div_2d(a, ix, c, NULL);
@@ -57,7 +57,7 @@ int mp_div_d(const mp_int *a, mp_digit b, mp_int *c, mp_digit *d)
#ifdef BN_MP_DIV_3_C
/* three? */
- if (b == 3) {
+ if (b == 3u) {
return mp_div_3(a, c, d);
}
#endif
@@ -71,15 +71,15 @@ int mp_div_d(const mp_int *a, mp_digit b, mp_int *c, mp_digit *d)
q.sign = a->sign;
w = 0;
for (ix = a->used - 1; ix >= 0; ix--) {
- w = (w << ((mp_word)DIGIT_BIT)) | ((mp_word)a->dp[ix]);
+ w = (w << (mp_word)DIGIT_BIT) | (mp_word)a->dp[ix];
if (w >= b) {
t = (mp_digit)(w / b);
- w -= ((mp_word)t) * ((mp_word)b);
+ w -= (mp_word)t * (mp_word)b;
} else {
t = 0;
}
- q.dp[ix] = (mp_digit)t;
+ q.dp[ix] = t;
}
if (d != NULL) {
diff --git a/libtommath/bn_mp_dr_reduce.c b/libtommath/bn_mp_dr_reduce.c
index 1ccb669..d677b03 100644
--- a/libtommath/bn_mp_dr_reduce.c
+++ b/libtommath/bn_mp_dr_reduce.c
@@ -61,7 +61,7 @@ top:
/* compute (x mod B**m) + k * [x/B**m] inline and inplace */
for (i = 0; i < m; i++) {
- r = (((mp_word)*tmpx2++) * (mp_word)k) + *tmpx1 + mu;
+ r = ((mp_word)*tmpx2++ * (mp_word)k) + *tmpx1 + mu;
*tmpx1++ = (mp_digit)(r & MP_MASK);
mu = (mp_digit)(r >> ((mp_word)DIGIT_BIT));
}
diff --git a/libtommath/bn_mp_dr_setup.c b/libtommath/bn_mp_dr_setup.c
index af0e213..32aa582 100644
--- a/libtommath/bn_mp_dr_setup.c
+++ b/libtommath/bn_mp_dr_setup.c
@@ -21,7 +21,7 @@ void mp_dr_setup(const mp_int *a, mp_digit *d)
/* the casts are required if DIGIT_BIT is one less than
* the number of bits in a mp_digit [e.g. DIGIT_BIT==31]
*/
- *d = (mp_digit)((((mp_word)1) << ((mp_word)DIGIT_BIT)) - ((mp_word)a->dp[0]));
+ *d = (mp_digit)(((mp_word)1 << (mp_word)DIGIT_BIT) - (mp_word)a->dp[0]);
}
#endif
diff --git a/libtommath/bn_mp_export.c b/libtommath/bn_mp_export.c
index 4276f4f..92a85d5 100644
--- a/libtommath/bn_mp_export.c
+++ b/libtommath/bn_mp_export.c
@@ -38,33 +38,33 @@ int mp_export(void *rop, size_t *countp, int order, size_t size,
} lint;
lint.i = 0x01020304;
- endian = (lint.c[0] == 4) ? -1 : 1;
+ endian = (lint.c[0] == '\x04') ? -1 : 1;
}
- odd_nails = (nails % 8);
+ odd_nails = (nails % 8u);
odd_nail_mask = 0xff;
for (i = 0; i < odd_nails; ++i) {
- odd_nail_mask ^= (1 << (7 - i));
+ odd_nail_mask ^= (unsigned char)(1u << (7u - i));
}
- nail_bytes = nails / 8;
+ nail_bytes = nails / 8u;
- bits = mp_count_bits(&t);
- count = (bits / ((size * 8) - nails)) + (((bits % ((size * 8) - nails)) != 0) ? 1 : 0);
+ bits = (size_t)mp_count_bits(&t);
+ count = (bits / ((size * 8u) - nails)) + (((bits % ((size * 8u) - nails)) != 0u) ? 1u : 0u);
for (i = 0; i < count; ++i) {
for (j = 0; j < size; ++j) {
unsigned char *byte = (unsigned char *)rop +
- (((order == -1) ? i : ((count - 1) - i)) * size) +
- ((endian == -1) ? j : ((size - 1) - j));
+ (((order == -1) ? i : ((count - 1u) - i)) * size) +
+ ((endian == -1) ? j : ((size - 1u) - j));
if (j >= (size - nail_bytes)) {
*byte = 0;
continue;
}
- *byte = (unsigned char)((j == ((size - nail_bytes) - 1)) ? (t.dp[0] & odd_nail_mask) : (t.dp[0] & 0xFF));
+ *byte = (unsigned char)((j == ((size - nail_bytes) - 1u)) ? (t.dp[0] & odd_nail_mask) : (t.dp[0] & 0xFFuL));
- if ((result = mp_div_2d(&t, ((j == ((size - nail_bytes) - 1)) ? (8 - odd_nails) : 8), &t, NULL)) != MP_OKAY) {
+ if ((result = mp_div_2d(&t, (j == ((size - nail_bytes) - 1u)) ? (int)(8u - odd_nails) : 8, &t, NULL)) != MP_OKAY) {
mp_clear(&t);
return result;
}
diff --git a/libtommath/bn_mp_expt_d_ex.c b/libtommath/bn_mp_expt_d_ex.c
index 99319a5..d363d59 100644
--- a/libtommath/bn_mp_expt_d_ex.c
+++ b/libtommath/bn_mp_expt_d_ex.c
@@ -28,12 +28,12 @@ int mp_expt_d_ex(const mp_int *a, mp_digit b, mp_int *c, int fast)
}
/* set initial result */
- mp_set(c, 1);
+ mp_set(c, 1uL);
if (fast != 0) {
- while (b > 0) {
+ while (b > 0u) {
/* if the bit is set multiply */
- if ((b & 1) != 0) {
+ if ((b & 1u) != 0u) {
if ((res = mp_mul(c, &g, c)) != MP_OKAY) {
mp_clear(&g);
return res;
@@ -41,7 +41,7 @@ int mp_expt_d_ex(const mp_int *a, mp_digit b, mp_int *c, int fast)
}
/* square */
- if (b > 1) {
+ if (b > 1u) {
if ((res = mp_sqr(&g, &g)) != MP_OKAY) {
mp_clear(&g);
return res;
@@ -52,7 +52,7 @@ int mp_expt_d_ex(const mp_int *a, mp_digit b, mp_int *c, int fast)
b >>= 1;
}
} else {
- for (x = 0; x < DIGIT_BIT; x++) {
+ for (x = 0; x < (unsigned)DIGIT_BIT; x++) {
/* square */
if ((res = mp_sqr(c, c)) != MP_OKAY) {
mp_clear(&g);
@@ -60,7 +60,7 @@ int mp_expt_d_ex(const mp_int *a, mp_digit b, mp_int *c, int fast)
}
/* if the bit is set multiply */
- if ((b & (mp_digit)(((mp_digit)1) << (DIGIT_BIT - 1))) != 0) {
+ if ((b & ((mp_digit)1 << (DIGIT_BIT - 1))) != 0u) {
if ((res = mp_mul(c, &g, c)) != MP_OKAY) {
mp_clear(&g);
return res;
diff --git a/libtommath/bn_mp_exptmod_fast.c b/libtommath/bn_mp_exptmod_fast.c
index 4a188d0..52d4a55 100644
--- a/libtommath/bn_mp_exptmod_fast.c
+++ b/libtommath/bn_mp_exptmod_fast.c
@@ -39,7 +39,7 @@ int mp_exptmod_fast(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y
* one of many reduction algorithms without modding the guts of
* the code with if statements everywhere.
*/
- int (*redux)(mp_int *,const mp_int *,mp_digit);
+ int (*redux)(mp_int *x, const mp_int *n, mp_digit rho);
/* find window size */
x = mp_count_bits(X);
@@ -96,7 +96,7 @@ int mp_exptmod_fast(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y
/* automatically pick the comba one if available (saves quite a few calls/ifs) */
#ifdef BN_FAST_MP_MONTGOMERY_REDUCE_C
- if ((((P->used * 2) + 1) < MP_WARRAY) &&
+ if ((((P->used * 2) + 1) < (int)MP_WARRAY) &&
(P->used < (1 << ((CHAR_BIT * sizeof(mp_word)) - (2 * DIGIT_BIT))))) {
redux = fast_mp_montgomery_reduce;
} else
@@ -160,7 +160,7 @@ int mp_exptmod_fast(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y
goto LBL_RES;
#endif
} else {
- mp_set(&res, 1);
+ mp_set(&res, 1uL);
if ((err = mp_mod(G, P, &M[1])) != MP_OKAY) {
goto LBL_RES;
}
diff --git a/libtommath/bn_mp_exteuclid.c b/libtommath/bn_mp_exteuclid.c
index 08e5ff2..29bad83 100644
--- a/libtommath/bn_mp_exteuclid.c
+++ b/libtommath/bn_mp_exteuclid.c
@@ -28,76 +28,76 @@ int mp_exteuclid(const mp_int *a, const mp_int *b, mp_int *U1, mp_int *U2, mp_in
}
/* initialize, (u1,u2,u3) = (1,0,a) */
- mp_set(&u1, 1);
- if ((err = mp_copy(a, &u3)) != MP_OKAY) {
+ mp_set(&u1, 1uL);
+ if ((err = mp_copy(a, &u3)) != MP_OKAY) {
goto LBL_ERR;
}
/* initialize, (v1,v2,v3) = (0,1,b) */
- mp_set(&v2, 1);
- if ((err = mp_copy(b, &v3)) != MP_OKAY) {
+ mp_set(&v2, 1uL);
+ if ((err = mp_copy(b, &v3)) != MP_OKAY) {
goto LBL_ERR;
}
/* loop while v3 != 0 */
while (mp_iszero(&v3) == MP_NO) {
/* q = u3/v3 */
- if ((err = mp_div(&u3, &v3, &q, NULL)) != MP_OKAY) {
+ if ((err = mp_div(&u3, &v3, &q, NULL)) != MP_OKAY) {
goto LBL_ERR;
}
/* (t1,t2,t3) = (u1,u2,u3) - (v1,v2,v3)q */
- if ((err = mp_mul(&v1, &q, &tmp)) != MP_OKAY) {
+ if ((err = mp_mul(&v1, &q, &tmp)) != MP_OKAY) {
goto LBL_ERR;
}
- if ((err = mp_sub(&u1, &tmp, &t1)) != MP_OKAY) {
+ if ((err = mp_sub(&u1, &tmp, &t1)) != MP_OKAY) {
goto LBL_ERR;
}
- if ((err = mp_mul(&v2, &q, &tmp)) != MP_OKAY) {
+ if ((err = mp_mul(&v2, &q, &tmp)) != MP_OKAY) {
goto LBL_ERR;
}
- if ((err = mp_sub(&u2, &tmp, &t2)) != MP_OKAY) {
+ if ((err = mp_sub(&u2, &tmp, &t2)) != MP_OKAY) {
goto LBL_ERR;
}
- if ((err = mp_mul(&v3, &q, &tmp)) != MP_OKAY) {
+ if ((err = mp_mul(&v3, &q, &tmp)) != MP_OKAY) {
goto LBL_ERR;
}
- if ((err = mp_sub(&u3, &tmp, &t3)) != MP_OKAY) {
+ if ((err = mp_sub(&u3, &tmp, &t3)) != MP_OKAY) {
goto LBL_ERR;
}
/* (u1,u2,u3) = (v1,v2,v3) */
- if ((err = mp_copy(&v1, &u1)) != MP_OKAY) {
+ if ((err = mp_copy(&v1, &u1)) != MP_OKAY) {
goto LBL_ERR;
}
- if ((err = mp_copy(&v2, &u2)) != MP_OKAY) {
+ if ((err = mp_copy(&v2, &u2)) != MP_OKAY) {
goto LBL_ERR;
}
- if ((err = mp_copy(&v3, &u3)) != MP_OKAY) {
+ if ((err = mp_copy(&v3, &u3)) != MP_OKAY) {
goto LBL_ERR;
}
/* (v1,v2,v3) = (t1,t2,t3) */
- if ((err = mp_copy(&t1, &v1)) != MP_OKAY) {
+ if ((err = mp_copy(&t1, &v1)) != MP_OKAY) {
goto LBL_ERR;
}
- if ((err = mp_copy(&t2, &v2)) != MP_OKAY) {
+ if ((err = mp_copy(&t2, &v2)) != MP_OKAY) {
goto LBL_ERR;
}
- if ((err = mp_copy(&t3, &v3)) != MP_OKAY) {
+ if ((err = mp_copy(&t3, &v3)) != MP_OKAY) {
goto LBL_ERR;
}
}
/* make sure U3 >= 0 */
if (u3.sign == MP_NEG) {
- if ((err = mp_neg(&u1, &u1)) != MP_OKAY) {
+ if ((err = mp_neg(&u1, &u1)) != MP_OKAY) {
goto LBL_ERR;
}
- if ((err = mp_neg(&u2, &u2)) != MP_OKAY) {
+ if ((err = mp_neg(&u2, &u2)) != MP_OKAY) {
goto LBL_ERR;
}
- if ((err = mp_neg(&u3, &u3)) != MP_OKAY) {
+ if ((err = mp_neg(&u3, &u3)) != MP_OKAY) {
goto LBL_ERR;
}
}
diff --git a/libtommath/bn_mp_fread.c b/libtommath/bn_mp_fread.c
index d0de595..6922183 100644
--- a/libtommath/bn_mp_fread.c
+++ b/libtommath/bn_mp_fread.c
@@ -20,13 +20,14 @@
int mp_fread(mp_int *a, int radix, FILE *stream)
{
int err, ch, neg, y;
+ unsigned pos;
/* clear a */
mp_zero(a);
/* if first digit is - then set negative */
ch = fgetc(stream);
- if (ch == '-') {
+ if (ch == (int)'-') {
neg = MP_NEG;
ch = fgetc(stream);
} else {
@@ -34,27 +35,28 @@ int mp_fread(mp_int *a, int radix, FILE *stream)
}
for (;;) {
- /* find y in the radix map */
- for (y = 0; y < radix; y++) {
- if (mp_s_rmap[y] == ch) {
- break;
- }
+ pos = (unsigned)(ch - (int)'(');
+ if (mp_s_rmap_reverse_sz < pos) {
+ break;
}
- if (y == radix) {
+
+ y = (int)mp_s_rmap_reverse[pos];
+
+ if ((y == 0xff) || (y >= radix)) {
break;
}
/* shift up and add */
- if ((err = mp_mul_d(a, radix, a)) != MP_OKAY) {
+ if ((err = mp_mul_d(a, (mp_digit)radix, a)) != MP_OKAY) {
return err;
}
- if ((err = mp_add_d(a, y, a)) != MP_OKAY) {
+ if ((err = mp_add_d(a, (mp_digit)y, a)) != MP_OKAY) {
return err;
}
ch = fgetc(stream);
}
- if (mp_cmp_d(a, 0) != MP_EQ) {
+ if (mp_cmp_d(a, 0uL) != MP_EQ) {
a->sign = neg;
}
diff --git a/libtommath/bn_mp_fwrite.c b/libtommath/bn_mp_fwrite.c
index 829dd4a..8541bc7 100644
--- a/libtommath/bn_mp_fwrite.c
+++ b/libtommath/bn_mp_fwrite.c
@@ -25,7 +25,7 @@ int mp_fwrite(const mp_int *a, int radix, FILE *stream)
return err;
}
- buf = OPT_CAST(char) XMALLOC(len);
+ buf = OPT_CAST(char) XMALLOC((size_t)len);
if (buf == NULL) {
return MP_MEM;
}
@@ -36,7 +36,7 @@ int mp_fwrite(const mp_int *a, int radix, FILE *stream)
}
for (x = 0; x < len; x++) {
- if (fputc(buf[x], stream) == EOF) {
+ if (fputc((int)buf[x], stream) == EOF) {
XFREE(buf);
return MP_VAL;
}
diff --git a/libtommath/bn_mp_get_int.c b/libtommath/bn_mp_get_int.c
index f4a347f..d99a0a0 100644
--- a/libtommath/bn_mp_get_int.c
+++ b/libtommath/bn_mp_get_int.c
@@ -26,7 +26,7 @@ unsigned long mp_get_int(const mp_int *a)
}
/* get number of digits of the lsb we have to read */
- i = MIN(a->used, (int)(((sizeof(unsigned long) * CHAR_BIT) + DIGIT_BIT - 1) / DIGIT_BIT)) - 1;
+ i = MIN(a->used, ((((int)sizeof(unsigned long) * CHAR_BIT) + DIGIT_BIT - 1) / DIGIT_BIT)) - 1;
/* get most significant digit of result */
res = DIGIT(a, i);
diff --git a/libtommath/bn_mp_get_long.c b/libtommath/bn_mp_get_long.c
index 3fc7c35..9ec2664 100644
--- a/libtommath/bn_mp_get_long.c
+++ b/libtommath/bn_mp_get_long.c
@@ -26,7 +26,7 @@ unsigned long mp_get_long(const mp_int *a)
}
/* get number of digits of the lsb we have to read */
- i = MIN(a->used, (int)(((sizeof(unsigned long) * CHAR_BIT) + DIGIT_BIT - 1) / DIGIT_BIT)) - 1;
+ i = MIN(a->used, ((((int)sizeof(unsigned long) * CHAR_BIT) + DIGIT_BIT - 1) / DIGIT_BIT)) - 1;
/* get most significant digit of result */
res = DIGIT(a, i);
diff --git a/libtommath/bn_mp_get_long_long.c b/libtommath/bn_mp_get_long_long.c
index a363f60..df2aa77 100644
--- a/libtommath/bn_mp_get_long_long.c
+++ b/libtommath/bn_mp_get_long_long.c
@@ -26,7 +26,7 @@ Tcl_WideUInt mp_get_long_long(const mp_int *a)
}
/* get number of digits of the lsb we have to read */
- i = MIN(a->used, (int)(((sizeof(Tcl_WideUInt) * CHAR_BIT) + DIGIT_BIT - 1) / DIGIT_BIT)) - 1;
+ i = MIN(a->used, ((((int)sizeof(Tcl_WideUInt) * CHAR_BIT) + DIGIT_BIT - 1) / DIGIT_BIT)) - 1;
/* get most significant digit of result */
res = DIGIT(a, i);
diff --git a/libtommath/bn_mp_grow.c b/libtommath/bn_mp_grow.c
index 0030931..60f8f32 100644
--- a/libtommath/bn_mp_grow.c
+++ b/libtommath/bn_mp_grow.c
@@ -32,7 +32,7 @@ int mp_grow(mp_int *a, int size)
* in case the operation failed we don't want
* to overwrite the dp member of a.
*/
- tmp = OPT_CAST(mp_digit) XREALLOC(a->dp, sizeof(mp_digit) * size);
+ tmp = OPT_CAST(mp_digit) XREALLOC(a->dp, sizeof(mp_digit) * (size_t)size);
if (tmp == NULL) {
/* reallocation failed but "a" is still valid [can be freed] */
return MP_MEM;
diff --git a/libtommath/bn_mp_import.c b/libtommath/bn_mp_import.c
index afd735e..9bbd215 100644
--- a/libtommath/bn_mp_import.c
+++ b/libtommath/bn_mp_import.c
@@ -34,27 +34,27 @@ int mp_import(mp_int *rop, size_t count, int order, size_t size,
} lint;
lint.i = 0x01020304;
- endian = (lint.c[0] == 4) ? -1 : 1;
+ endian = (lint.c[0] == '\x04') ? -1 : 1;
}
- odd_nails = (nails % 8);
+ odd_nails = (nails % 8u);
odd_nail_mask = 0xff;
for (i = 0; i < odd_nails; ++i) {
- odd_nail_mask ^= (1 << (7 - i));
+ odd_nail_mask ^= (unsigned char)(1u << (7u - i));
}
- nail_bytes = nails / 8;
+ nail_bytes = nails / 8u;
for (i = 0; i < count; ++i) {
for (j = 0; j < (size - nail_bytes); ++j) {
unsigned char byte = *((unsigned char *)op +
- (((order == 1) ? i : ((count - 1) - i)) * size) +
- ((endian == 1) ? (j + nail_bytes) : (((size - 1) - j) - nail_bytes)));
+ (((order == 1) ? i : ((count - 1u) - i)) * size) +
+ ((endian == 1) ? (j + nail_bytes) : (((size - 1u) - j) - nail_bytes)));
- if ((result = mp_mul_2d(rop, ((j == 0) ? (8 - odd_nails) : 8), rop)) != MP_OKAY) {
+ if ((result = mp_mul_2d(rop, (j == 0u) ? (int)(8u - odd_nails) : 8, rop)) != MP_OKAY) {
return result;
}
- rop->dp[0] |= (j == 0) ? (byte & odd_nail_mask) : byte;
+ rop->dp[0] |= (j == 0u) ? (mp_digit)(byte & odd_nail_mask) : (mp_digit)byte;
rop->used += 1;
}
}
diff --git a/libtommath/bn_mp_init.c b/libtommath/bn_mp_init.c
index 0556aeb..ad630e3 100644
--- a/libtommath/bn_mp_init.c
+++ b/libtommath/bn_mp_init.c
@@ -21,7 +21,7 @@ int mp_init(mp_int *a)
int i;
/* allocate memory required and clear it */
- a->dp = OPT_CAST(mp_digit) XMALLOC(sizeof(mp_digit) * MP_PREC);
+ a->dp = OPT_CAST(mp_digit) XMALLOC(sizeof(mp_digit) * (size_t)MP_PREC);
if (a->dp == NULL) {
return MP_MEM;
}
diff --git a/libtommath/bn_mp_init_multi.c b/libtommath/bn_mp_init_multi.c
index 0da7803..9ed777c 100644
--- a/libtommath/bn_mp_init_multi.c
+++ b/libtommath/bn_mp_init_multi.c
@@ -14,6 +14,7 @@
*
* Tom St Denis, tstdenis82@gmail.com, http://libtom.org
*/
+
#include <stdarg.h>
int mp_init_multi(mp_int *mp, ...)
diff --git a/libtommath/bn_mp_init_size.c b/libtommath/bn_mp_init_size.c
index 623a03f..35713ac 100644
--- a/libtommath/bn_mp_init_size.c
+++ b/libtommath/bn_mp_init_size.c
@@ -24,7 +24,7 @@ int mp_init_size(mp_int *a, int size)
size += (MP_PREC * 2) - (size % MP_PREC);
/* alloc mem */
- a->dp = OPT_CAST(mp_digit) XMALLOC(sizeof(mp_digit) * size);
+ a->dp = OPT_CAST(mp_digit) XMALLOC(sizeof(mp_digit) * (size_t)size);
if (a->dp == NULL) {
return MP_MEM;
}
diff --git a/libtommath/bn_mp_invmod.c b/libtommath/bn_mp_invmod.c
index 525493a..96717ea 100644
--- a/libtommath/bn_mp_invmod.c
+++ b/libtommath/bn_mp_invmod.c
@@ -18,14 +18,14 @@
/* hac 14.61, pp608 */
int mp_invmod(const mp_int *a, const mp_int *b, mp_int *c)
{
- /* b cannot be negative */
- if ((b->sign == MP_NEG) || (mp_iszero(b) == MP_YES)) {
+ /* b cannot be negative and has to be >1 */
+ if ((b->sign == MP_NEG) || (mp_cmp_d(b, 1uL) != MP_GT)) {
return MP_VAL;
}
#ifdef BN_FAST_MP_INVMOD_C
/* if the modulus is odd we can use a faster routine instead */
- if ((mp_isodd(b) == MP_YES) && (mp_cmp_d(b, 1) != MP_EQ)) {
+ if ((mp_isodd(b) == MP_YES)) {
return fast_mp_invmod(a, b, c);
}
#endif
diff --git a/libtommath/bn_mp_invmod_slow.c b/libtommath/bn_mp_invmod_slow.c
index 2bb5196..360f161 100644
--- a/libtommath/bn_mp_invmod_slow.c
+++ b/libtommath/bn_mp_invmod_slow.c
@@ -53,8 +53,8 @@ int mp_invmod_slow(const mp_int *a, const mp_int *b, mp_int *c)
if ((res = mp_copy(&y, &v)) != MP_OKAY) {
goto LBL_ERR;
}
- mp_set(&A, 1);
- mp_set(&D, 1);
+ mp_set(&A, 1uL);
+ mp_set(&D, 1uL);
top:
/* 4. while u is even do */
@@ -143,13 +143,13 @@ top:
/* now a = C, b = D, gcd == g*v */
/* if v != 1 then there is no inverse */
- if (mp_cmp_d(&v, 1) != MP_EQ) {
+ if (mp_cmp_d(&v, 1uL) != MP_EQ) {
res = MP_VAL;
goto LBL_ERR;
}
/* if its too low */
- while (mp_cmp_d(&C, 0) == MP_LT) {
+ while (mp_cmp_d(&C, 0uL) == MP_LT) {
if ((res = mp_add(&C, b, &C)) != MP_OKAY) {
goto LBL_ERR;
}
diff --git a/libtommath/bn_mp_is_square.c b/libtommath/bn_mp_is_square.c
index dd5150e..329d727 100644
--- a/libtommath/bn_mp_is_square.c
+++ b/libtommath/bn_mp_is_square.c
@@ -58,15 +58,15 @@ int mp_is_square(const mp_int *arg, int *ret)
}
/* First check mod 128 (suppose that DIGIT_BIT is at least 7) */
- if (rem_128[127 & DIGIT(arg, 0)] == 1) {
+ if (rem_128[127u & DIGIT(arg, 0)] == (char)1) {
return MP_OKAY;
}
/* Next check mod 105 (3*5*7) */
- if ((res = mp_mod_d(arg, 105, &c)) != MP_OKAY) {
+ if ((res = mp_mod_d(arg, 105uL, &c)) != MP_OKAY) {
return res;
}
- if (rem_105[c] == 1) {
+ if (rem_105[c] == (char)1) {
return MP_OKAY;
}
@@ -82,13 +82,13 @@ int mp_is_square(const mp_int *arg, int *ret)
* free "t" so the easiest way is to goto ERR. We know that res
* is already equal to MP_OKAY from the mp_mod call
*/
- if (((1L<<(r%11)) & 0x5C4L) != 0L) goto ERR;
- if (((1L<<(r%13)) & 0x9E4L) != 0L) goto ERR;
- if (((1L<<(r%17)) & 0x5CE8L) != 0L) goto ERR;
- if (((1L<<(r%19)) & 0x4F50CL) != 0L) goto ERR;
- if (((1L<<(r%23)) & 0x7ACCA0L) != 0L) goto ERR;
- if (((1L<<(r%29)) & 0xC2EDD0CL) != 0L) goto ERR;
- if (((1L<<(r%31)) & 0x6DE2B848L) != 0L) goto ERR;
+ if (((1uL<<(r%11uL)) & 0x5C4uL) != 0uL) goto ERR;
+ if (((1uL<<(r%13uL)) & 0x9E4uL) != 0uL) goto ERR;
+ if (((1uL<<(r%17uL)) & 0x5CE8uL) != 0uL) goto ERR;
+ if (((1uL<<(r%19uL)) & 0x4F50CuL) != 0uL) goto ERR;
+ if (((1uL<<(r%23uL)) & 0x7ACCA0uL) != 0uL) goto ERR;
+ if (((1uL<<(r%29uL)) & 0xC2EDD0CuL) != 0uL) goto ERR;
+ if (((1uL<<(r%31uL)) & 0x6DE2B848uL) != 0uL) goto ERR;
/* Final check - is sqr(sqrt(arg)) == arg ? */
if ((res = mp_sqrt(arg, &t)) != MP_OKAY) {
diff --git a/libtommath/bn_mp_jacobi.c b/libtommath/bn_mp_jacobi.c
index c314c82..ef2e72f 100644
--- a/libtommath/bn_mp_jacobi.c
+++ b/libtommath/bn_mp_jacobi.c
@@ -32,14 +32,14 @@ int mp_jacobi(const mp_int *a, const mp_int *n, int *c)
}
/* if n <= 0 return MP_VAL */
- if (mp_cmp_d(n, 0) != MP_GT) {
+ if (mp_cmp_d(n, 0uL) != MP_GT) {
return MP_VAL;
}
/* step 1. handle case of a == 0 */
if (mp_iszero(a) == MP_YES) {
/* special case of a == 0 and n == 1 */
- if (mp_cmp_d(n, 1) == MP_EQ) {
+ if (mp_cmp_d(n, 1uL) == MP_EQ) {
*c = 1;
} else {
*c = 0;
@@ -48,7 +48,7 @@ int mp_jacobi(const mp_int *a, const mp_int *n, int *c)
}
/* step 2. if a == 1, return 1 */
- if (mp_cmp_d(a, 1) == MP_EQ) {
+ if (mp_cmp_d(a, 1uL) == MP_EQ) {
*c = 1;
return MP_OKAY;
}
@@ -72,26 +72,26 @@ int mp_jacobi(const mp_int *a, const mp_int *n, int *c)
}
/* step 4. if e is even set s=1 */
- if ((k & 1) == 0) {
+ if (((unsigned)k & 1u) == 0u) {
s = 1;
} else {
/* else set s=1 if p = 1/7 (mod 8) or s=-1 if p = 3/5 (mod 8) */
- residue = n->dp[0] & 7;
+ residue = n->dp[0] & 7u;
- if ((residue == 1) || (residue == 7)) {
+ if ((residue == 1u) || (residue == 7u)) {
s = 1;
- } else if ((residue == 3) || (residue == 5)) {
+ } else if ((residue == 3u) || (residue == 5u)) {
s = -1;
}
}
/* step 5. if p == 3 (mod 4) *and* a1 == 3 (mod 4) then s = -s */
- if (((n->dp[0] & 3) == 3) && ((a1.dp[0] & 3) == 3)) {
+ if (((n->dp[0] & 3u) == 3u) && ((a1.dp[0] & 3u) == 3u)) {
s = -s;
}
/* if a1 == 1 we're done */
- if (mp_cmp_d(&a1, 1) == MP_EQ) {
+ if (mp_cmp_d(&a1, 1uL) == MP_EQ) {
*c = s;
} else {
/* n1 = n mod a1 */
diff --git a/libtommath/bn_mp_lshd.c b/libtommath/bn_mp_lshd.c
index 888989a..b49b545 100644
--- a/libtommath/bn_mp_lshd.c
+++ b/libtommath/bn_mp_lshd.c
@@ -24,6 +24,10 @@ int mp_lshd(mp_int *a, int b)
if (b <= 0) {
return MP_OKAY;
}
+ /* no need to shift 0 around */
+ if (mp_iszero(a) == MP_YES) {
+ return MP_OKAY;
+ }
/* grow to fit the new digits */
if (a->alloc < (a->used + b)) {
diff --git a/libtommath/bn_mp_mod_2d.c b/libtommath/bn_mp_mod_2d.c
index 8e69757..7a74746 100644
--- a/libtommath/bn_mp_mod_2d.c
+++ b/libtommath/bn_mp_mod_2d.c
@@ -27,7 +27,7 @@ int mp_mod_2d(const mp_int *a, int b, mp_int *c)
}
/* if the modulus is larger than the value than return */
- if (b >= (int)(a->used * DIGIT_BIT)) {
+ if (b >= (a->used * DIGIT_BIT)) {
res = mp_copy(a, c);
return res;
}
@@ -43,7 +43,7 @@ int mp_mod_2d(const mp_int *a, int b, mp_int *c)
}
/* clear the digit that is not completely outside/inside the modulus */
c->dp[b / DIGIT_BIT] &=
- (mp_digit)((((mp_digit) 1) << (((mp_digit) b) % DIGIT_BIT)) - ((mp_digit) 1));
+ ((mp_digit)1 << (mp_digit)(b % DIGIT_BIT)) - (mp_digit)1;
mp_clamp(c);
return MP_OKAY;
}
diff --git a/libtommath/bn_mp_montgomery_calc_normalization.c b/libtommath/bn_mp_montgomery_calc_normalization.c
index f2b0856..360e3e5 100644
--- a/libtommath/bn_mp_montgomery_calc_normalization.c
+++ b/libtommath/bn_mp_montgomery_calc_normalization.c
@@ -33,7 +33,7 @@ int mp_montgomery_calc_normalization(mp_int *a, const mp_int *b)
return res;
}
} else {
- mp_set(a, 1);
+ mp_set(a, 1uL);
bits = 1;
}
diff --git a/libtommath/bn_mp_montgomery_reduce.c b/libtommath/bn_mp_montgomery_reduce.c
index a38173e..e3a0eaa 100644
--- a/libtommath/bn_mp_montgomery_reduce.c
+++ b/libtommath/bn_mp_montgomery_reduce.c
@@ -28,9 +28,10 @@ int mp_montgomery_reduce(mp_int *x, const mp_int *n, mp_digit rho)
* are fixed up in the inner loop.
*/
digs = (n->used * 2) + 1;
- if ((digs < MP_WARRAY) &&
+ if ((digs < (int)MP_WARRAY) &&
+ (x->used <= (int)MP_WARRAY) &&
(n->used <
- (1 << ((CHAR_BIT * sizeof(mp_word)) - (2 * DIGIT_BIT))))) {
+ (int)(1u << (((size_t)CHAR_BIT * sizeof(mp_word)) - (2u * (size_t)DIGIT_BIT))))) {
return fast_mp_montgomery_reduce(x, n, rho);
}
@@ -72,19 +73,19 @@ int mp_montgomery_reduce(mp_int *x, const mp_int *n, mp_digit rho)
for (iy = 0; iy < n->used; iy++) {
/* compute product and sum */
r = ((mp_word)mu * (mp_word)*tmpn++) +
- (mp_word) u + (mp_word) *tmpx;
+ (mp_word)u + (mp_word)*tmpx;
/* get carry */
- u = (mp_digit)(r >> ((mp_word) DIGIT_BIT));
+ u = (mp_digit)(r >> (mp_word)DIGIT_BIT);
/* fix digit */
- *tmpx++ = (mp_digit)(r & ((mp_word) MP_MASK));
+ *tmpx++ = (mp_digit)(r & (mp_word)MP_MASK);
}
/* At this point the ix'th digit of x should be zero */
/* propagate carries upwards as required*/
- while (u != 0) {
+ while (u != 0u) {
*tmpx += u;
u = *tmpx >> DIGIT_BIT;
*tmpx++ &= MP_MASK;
diff --git a/libtommath/bn_mp_montgomery_setup.c b/libtommath/bn_mp_montgomery_setup.c
index 685ba51..75da42b 100644
--- a/libtommath/bn_mp_montgomery_setup.c
+++ b/libtommath/bn_mp_montgomery_setup.c
@@ -30,24 +30,24 @@ int mp_montgomery_setup(const mp_int *n, mp_digit *rho)
*/
b = n->dp[0];
- if ((b & 1) == 0) {
+ if ((b & 1u) == 0u) {
return MP_VAL;
}
- x = (((b + 2) & 4) << 1) + b; /* here x*a==1 mod 2**4 */
- x *= 2 - (b * x); /* here x*a==1 mod 2**8 */
+ x = (((b + 2u) & 4u) << 1) + b; /* here x*a==1 mod 2**4 */
+ x *= 2u - (b * x); /* here x*a==1 mod 2**8 */
#if !defined(MP_8BIT)
- x *= 2 - (b * x); /* here x*a==1 mod 2**16 */
+ x *= 2u - (b * x); /* here x*a==1 mod 2**16 */
#endif
#if defined(MP_64BIT) || !(defined(MP_8BIT) || defined(MP_16BIT))
- x *= 2 - (b * x); /* here x*a==1 mod 2**32 */
+ x *= 2u - (b * x); /* here x*a==1 mod 2**32 */
#endif
#ifdef MP_64BIT
- x *= 2 - (b * x); /* here x*a==1 mod 2**64 */
+ x *= 2u - (b * x); /* here x*a==1 mod 2**64 */
#endif
/* rho = -1/m mod b */
- *rho = (mp_digit)(((mp_word)1 << ((mp_word) DIGIT_BIT)) - x) & MP_MASK;
+ *rho = (mp_digit)(((mp_word)1 << (mp_word)DIGIT_BIT) - x) & MP_MASK;
return MP_OKAY;
}
diff --git a/libtommath/bn_mp_mul.c b/libtommath/bn_mp_mul.c
index 71d523d..babb12b 100644
--- a/libtommath/bn_mp_mul.c
+++ b/libtommath/bn_mp_mul.c
@@ -43,9 +43,9 @@ int mp_mul(const mp_int *a, const mp_int *b, mp_int *c)
int digs = a->used + b->used + 1;
#ifdef BN_FAST_S_MP_MUL_DIGS_C
- if ((digs < MP_WARRAY) &&
+ if ((digs < (int)MP_WARRAY) &&
(MIN(a->used, b->used) <=
- (1 << ((CHAR_BIT * sizeof(mp_word)) - (2 * DIGIT_BIT))))) {
+ (int)(1u << (((size_t)CHAR_BIT * sizeof(mp_word)) - (2u * (size_t)DIGIT_BIT))))) {
res = fast_s_mp_mul_digs(a, b, c, digs);
} else
#endif
diff --git a/libtommath/bn_mp_mul_2.c b/libtommath/bn_mp_mul_2.c
index 1744681..7611536 100644
--- a/libtommath/bn_mp_mul_2.c
+++ b/libtommath/bn_mp_mul_2.c
@@ -46,10 +46,10 @@ int mp_mul_2(const mp_int *a, mp_int *b)
/* get what will be the *next* carry bit from the
* MSB of the current digit
*/
- rr = *tmpa >> ((mp_digit)(DIGIT_BIT - 1));
+ rr = *tmpa >> (mp_digit)(DIGIT_BIT - 1);
/* now shift up this digit, add in the carry [from the previous] */
- *tmpb++ = ((*tmpa++ << ((mp_digit)1)) | r) & MP_MASK;
+ *tmpb++ = ((*tmpa++ << 1uL) | r) & MP_MASK;
/* copy the carry that would be from the source
* digit into the next iteration
@@ -58,7 +58,7 @@ int mp_mul_2(const mp_int *a, mp_int *b)
}
/* new leading digit? */
- if (r != 0) {
+ if (r != 0u) {
/* add a MSB which is always 1 at this point */
*tmpb = 1;
++(b->used);
diff --git a/libtommath/bn_mp_mul_2d.c b/libtommath/bn_mp_mul_2d.c
index 4938e57..96aef85 100644
--- a/libtommath/bn_mp_mul_2d.c
+++ b/libtommath/bn_mp_mul_2d.c
@@ -28,14 +28,14 @@ int mp_mul_2d(const mp_int *a, int b, mp_int *c)
}
}
- if (c->alloc < (int)(c->used + (b / DIGIT_BIT) + 1)) {
+ if (c->alloc < (c->used + (b / DIGIT_BIT) + 1)) {
if ((res = mp_grow(c, c->used + (b / DIGIT_BIT) + 1)) != MP_OKAY) {
return res;
}
}
/* shift by as many digits in the bit count */
- if (b >= (int)DIGIT_BIT) {
+ if (b >= DIGIT_BIT) {
if ((res = mp_lshd(c, b / DIGIT_BIT)) != MP_OKAY) {
return res;
}
@@ -43,15 +43,15 @@ int mp_mul_2d(const mp_int *a, int b, mp_int *c)
/* shift any bit count < DIGIT_BIT */
d = (mp_digit)(b % DIGIT_BIT);
- if (d != 0) {
+ if (d != 0u) {
mp_digit *tmpc, shift, mask, r, rr;
int x;
/* bitmask for carries */
- mask = (((mp_digit)1) << d) - 1;
+ mask = ((mp_digit)1 << d) - (mp_digit)1;
/* shift for msbs */
- shift = DIGIT_BIT - d;
+ shift = (mp_digit)DIGIT_BIT - d;
/* alias */
tmpc = c->dp;
@@ -71,7 +71,7 @@ int mp_mul_2d(const mp_int *a, int b, mp_int *c)
}
/* set final carry */
- if (r != 0) {
+ if (r != 0u) {
c->dp[(c->used)++] = r;
}
}
diff --git a/libtommath/bn_mp_mul_d.c b/libtommath/bn_mp_mul_d.c
index 0f6d03e..13f94a2 100644
--- a/libtommath/bn_mp_mul_d.c
+++ b/libtommath/bn_mp_mul_d.c
@@ -50,10 +50,10 @@ int mp_mul_d(const mp_int *a, mp_digit b, mp_int *c)
r = (mp_word)u + ((mp_word)*tmpa++ * (mp_word)b);
/* mask off higher bits to get a single digit */
- *tmpc++ = (mp_digit)(r & ((mp_word)MP_MASK));
+ *tmpc++ = (mp_digit)(r & (mp_word)MP_MASK);
/* send carry into next iteration */
- u = (mp_digit)(r >> ((mp_word)DIGIT_BIT));
+ u = (mp_digit)(r >> (mp_word)DIGIT_BIT);
}
/* store final carry [if any] and increment ix offset */
diff --git a/libtommath/bn_mp_n_root_ex.c b/libtommath/bn_mp_n_root_ex.c
index ca50649..60c9929 100644
--- a/libtommath/bn_mp_n_root_ex.c
+++ b/libtommath/bn_mp_n_root_ex.c
@@ -31,7 +31,7 @@ int mp_n_root_ex(const mp_int *a, mp_digit b, mp_int *c, int fast)
int res;
/* input must be positive if b is even */
- if (((b & 1) == 0) && (a->sign == MP_NEG)) {
+ if (((b & 1u) == 0u) && (a->sign == MP_NEG)) {
return MP_VAL;
}
@@ -52,7 +52,7 @@ int mp_n_root_ex(const mp_int *a, mp_digit b, mp_int *c, int fast)
a_.sign = MP_ZPOS;
/* t2 = 2 */
- mp_set(&t2, 2);
+ mp_set(&t2, 2uL);
do {
/* t1 = t2 */
@@ -63,7 +63,7 @@ int mp_n_root_ex(const mp_int *a, mp_digit b, mp_int *c, int fast)
/* t2 = t1 - ((t1**b - a) / (b * t1**(b-1))) */
/* t3 = t1**(b-1) */
- if ((res = mp_expt_d_ex(&t1, b - 1, &t3, fast)) != MP_OKAY) {
+ if ((res = mp_expt_d_ex(&t1, b - 1u, &t3, fast)) != MP_OKAY) {
goto LBL_T3;
}
@@ -101,7 +101,7 @@ int mp_n_root_ex(const mp_int *a, mp_digit b, mp_int *c, int fast)
}
if (mp_cmp(&t2, &a_) == MP_GT) {
- if ((res = mp_sub_d(&t1, 1, &t1)) != MP_OKAY) {
+ if ((res = mp_sub_d(&t1, 1uL, &t1)) != MP_OKAY) {
goto LBL_T3;
}
} else {
diff --git a/libtommath/bn_mp_prime_fermat.c b/libtommath/bn_mp_prime_fermat.c
index 9c15435..e71e0ae 100644
--- a/libtommath/bn_mp_prime_fermat.c
+++ b/libtommath/bn_mp_prime_fermat.c
@@ -32,7 +32,7 @@ int mp_prime_fermat(const mp_int *a, const mp_int *b, int *result)
*result = MP_NO;
/* ensure b > 1 */
- if (mp_cmp_d(b, 1) != MP_GT) {
+ if (mp_cmp_d(b, 1uL) != MP_GT) {
return MP_VAL;
}
diff --git a/libtommath/bn_mp_prime_is_divisible.c b/libtommath/bn_mp_prime_is_divisible.c
index c1e1158..c49fdd2 100644
--- a/libtommath/bn_mp_prime_is_divisible.c
+++ b/libtommath/bn_mp_prime_is_divisible.c
@@ -35,7 +35,7 @@ int mp_prime_is_divisible(const mp_int *a, int *result)
}
/* is the residue zero? */
- if (res == 0) {
+ if (res == 0u) {
*result = MP_YES;
return MP_OKAY;
}
diff --git a/libtommath/bn_mp_prime_miller_rabin.c b/libtommath/bn_mp_prime_miller_rabin.c
index 5de5f05..34c4d1c 100644
--- a/libtommath/bn_mp_prime_miller_rabin.c
+++ b/libtommath/bn_mp_prime_miller_rabin.c
@@ -31,7 +31,7 @@ int mp_prime_miller_rabin(const mp_int *a, const mp_int *b, int *result)
*result = MP_NO;
/* ensure b > 1 */
- if (mp_cmp_d(b, 1) != MP_GT) {
+ if (mp_cmp_d(b, 1uL) != MP_GT) {
return MP_VAL;
}
@@ -39,7 +39,7 @@ int mp_prime_miller_rabin(const mp_int *a, const mp_int *b, int *result)
if ((err = mp_init_copy(&n1, a)) != MP_OKAY) {
return err;
}
- if ((err = mp_sub_d(&n1, 1, &n1)) != MP_OKAY) {
+ if ((err = mp_sub_d(&n1, 1uL, &n1)) != MP_OKAY) {
goto LBL_N1;
}
@@ -67,7 +67,7 @@ int mp_prime_miller_rabin(const mp_int *a, const mp_int *b, int *result)
}
/* if y != 1 and y != n1 do */
- if ((mp_cmp_d(&y, 1) != MP_EQ) && (mp_cmp(&y, &n1) != MP_EQ)) {
+ if ((mp_cmp_d(&y, 1uL) != MP_EQ) && (mp_cmp(&y, &n1) != MP_EQ)) {
j = 1;
/* while j <= s-1 and y != n1 */
while ((j <= (s - 1)) && (mp_cmp(&y, &n1) != MP_EQ)) {
@@ -76,7 +76,7 @@ int mp_prime_miller_rabin(const mp_int *a, const mp_int *b, int *result)
}
/* if y == 1 then composite */
- if (mp_cmp_d(&y, 1) == MP_EQ) {
+ if (mp_cmp_d(&y, 1uL) == MP_EQ) {
goto LBL_Y;
}
diff --git a/libtommath/bn_mp_prime_next_prime.c b/libtommath/bn_mp_prime_next_prime.c
index f383cbb..b106a74 100644
--- a/libtommath/bn_mp_prime_next_prime.c
+++ b/libtommath/bn_mp_prime_next_prime.c
@@ -46,10 +46,10 @@ int mp_prime_next_prime(mp_int *a, int t, int bbs_style)
* however, the prime must be
* congruent to 3 mod 4
*/
- if ((ltm_prime_tab[x + 1] & 3) != 3) {
+ if ((ltm_prime_tab[x + 1] & 3u) != 3u) {
/* scan upwards for a prime congruent to 3 mod 4 */
for (y = x + 1; y < PRIME_SIZE; y++) {
- if ((ltm_prime_tab[y] & 3) == 3) {
+ if ((ltm_prime_tab[y] & 3u) == 3u) {
mp_set(a, ltm_prime_tab[y]);
return MP_OKAY;
}
@@ -62,8 +62,8 @@ int mp_prime_next_prime(mp_int *a, int t, int bbs_style)
}
}
/* at this point a maybe 1 */
- if (mp_cmp_d(a, 1) == MP_EQ) {
- mp_set(a, 2);
+ if (mp_cmp_d(a, 1uL) == MP_EQ) {
+ mp_set(a, 2uL);
return MP_OKAY;
}
/* fall through to the sieve */
@@ -80,15 +80,15 @@ int mp_prime_next_prime(mp_int *a, int t, int bbs_style)
if (bbs_style == 1) {
/* if a mod 4 != 3 subtract the correct value to make it so */
- if ((a->dp[0] & 3) != 3) {
- if ((err = mp_sub_d(a, (a->dp[0] & 3) + 1, a)) != MP_OKAY) {
+ if ((a->dp[0] & 3u) != 3u) {
+ if ((err = mp_sub_d(a, (a->dp[0] & 3u) + 1u, a)) != MP_OKAY) {
return err;
};
}
} else {
if (mp_iseven(a) == MP_YES) {
/* force odd */
- if ((err = mp_sub_d(a, 1, a)) != MP_OKAY) {
+ if ((err = mp_sub_d(a, 1uL, a)) != MP_OKAY) {
return err;
}
}
@@ -127,11 +127,11 @@ int mp_prime_next_prime(mp_int *a, int t, int bbs_style)
}
/* set flag if zero */
- if (res_tab[x] == 0) {
+ if (res_tab[x] == 0u) {
y = 1;
}
}
- } while ((y == 1) && (step < ((((mp_digit)1) << DIGIT_BIT) - kstep)));
+ } while ((y == 1) && (step < (((mp_digit)1 << DIGIT_BIT) - kstep)));
/* add the step */
if ((err = mp_add_d(a, step, a)) != MP_OKAY) {
@@ -139,7 +139,7 @@ int mp_prime_next_prime(mp_int *a, int t, int bbs_style)
}
/* if didn't pass sieve and step == MAX then skip test */
- if ((y == 1) && (step >= ((((mp_digit)1) << DIGIT_BIT) - kstep))) {
+ if ((y == 1) && (step >= (((mp_digit)1 << DIGIT_BIT) - kstep))) {
continue;
}
diff --git a/libtommath/bn_mp_prime_random_ex.c b/libtommath/bn_mp_prime_random_ex.c
index d3d6f3d..1ae2934 100644
--- a/libtommath/bn_mp_prime_random_ex.c
+++ b/libtommath/bn_mp_prime_random_ex.c
@@ -49,7 +49,7 @@ int mp_prime_random_ex(mp_int *a, int t, int size, int flags, ltm_prime_callback
bsize = (size>>3) + ((size&7)?1:0);
/* we need a buffer of bsize bytes */
- tmp = OPT_CAST(unsigned char) XMALLOC(bsize);
+ tmp = OPT_CAST(unsigned char) XMALLOC((size_t)bsize);
if (tmp == NULL) {
return MP_MEM;
}
@@ -86,12 +86,12 @@ int mp_prime_random_ex(mp_int *a, int t, int size, int flags, ltm_prime_callback
tmp[bsize-1] |= maskOR_lsb;
/* read it in */
- if ((err = mp_read_unsigned_bin(a, tmp, bsize)) != MP_OKAY) {
+ if ((err = mp_read_unsigned_bin(a, tmp, bsize)) != MP_OKAY) {
goto error;
}
/* is it prime? */
- if ((err = mp_prime_is_prime(a, t, &res)) != MP_OKAY) {
+ if ((err = mp_prime_is_prime(a, t, &res)) != MP_OKAY) {
goto error;
}
if (res == MP_NO) {
@@ -100,15 +100,15 @@ int mp_prime_random_ex(mp_int *a, int t, int size, int flags, ltm_prime_callback
if ((flags & LTM_PRIME_SAFE) != 0) {
/* see if (a-1)/2 is prime */
- if ((err = mp_sub_d(a, 1, a)) != MP_OKAY) {
+ if ((err = mp_sub_d(a, 1uL, a)) != MP_OKAY) {
goto error;
}
- if ((err = mp_div_2(a, a)) != MP_OKAY) {
+ if ((err = mp_div_2(a, a)) != MP_OKAY) {
goto error;
}
/* is it prime? */
- if ((err = mp_prime_is_prime(a, t, &res)) != MP_OKAY) {
+ if ((err = mp_prime_is_prime(a, t, &res)) != MP_OKAY) {
goto error;
}
}
@@ -116,10 +116,10 @@ int mp_prime_random_ex(mp_int *a, int t, int size, int flags, ltm_prime_callback
if ((flags & LTM_PRIME_SAFE) != 0) {
/* restore a to the original value */
- if ((err = mp_mul_2(a, a)) != MP_OKAY) {
+ if ((err = mp_mul_2(a, a)) != MP_OKAY) {
goto error;
}
- if ((err = mp_add_d(a, 1, a)) != MP_OKAY) {
+ if ((err = mp_add_d(a, 1uL, a)) != MP_OKAY) {
goto error;
}
}
diff --git a/libtommath/bn_mp_radix_smap.c b/libtommath/bn_mp_radix_smap.c
index 4c6e57c..5d449f1 100644
--- a/libtommath/bn_mp_radix_smap.c
+++ b/libtommath/bn_mp_radix_smap.c
@@ -17,6 +17,20 @@
/* chars used in radix conversions */
const char *mp_s_rmap = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz+/";
+const unsigned char mp_s_rmap_reverse[] = {
+ 0xff, 0xff, 0xff, 0x3e, 0xff, 0xff, 0xff, 0x3f, /* ()*+,-./ */
+ 0x00, 0x01, 0x02, 0x03, 0x04, 0x05, 0x06, 0x07, /* 01234567 */
+ 0x08, 0x09, 0xff, 0xff, 0xff, 0xff, 0xff, 0xff, /* 89:;<=>? */
+ 0xff, 0x0a, 0x0b, 0x0c, 0x0d, 0x0e, 0x0f, 0x10, /* @ABCDEFG */
+ 0x11, 0x12, 0x13, 0x14, 0x15, 0x16, 0x17, 0x18, /* HIJKLMNO */
+ 0x19, 0x1a, 0x1b, 0x1c, 0x1d, 0x1e, 0x1f, 0x20, /* PQRSTUVW */
+ 0x21, 0x22, 0x23, 0xff, 0xff, 0xff, 0xff, 0xff, /* XYZ[\]^_ */
+ 0xff, 0x24, 0x25, 0x26, 0x27, 0x28, 0x29, 0x2a, /* `abcdefg */
+ 0x2b, 0x2c, 0x2d, 0x2e, 0x2f, 0x30, 0x31, 0x32, /* hijklmno */
+ 0x33, 0x34, 0x35, 0x36, 0x37, 0x38, 0x39, 0x3a, /* pqrstuvw */
+ 0x3b, 0x3c, 0x3d, 0xff, 0xff, 0xff, 0xff, 0xff, /* xyz{|}~. */
+};
+const size_t mp_s_rmap_reverse_sz = sizeof(mp_s_rmap_reverse);
#endif
/* ref: $Format:%D$ */
diff --git a/libtommath/bn_mp_rand.c b/libtommath/bn_mp_rand.c
index 92a9a97..2ed665e 100644
--- a/libtommath/bn_mp_rand.c
+++ b/libtommath/bn_mp_rand.c
@@ -15,7 +15,10 @@
* Tom St Denis, tstdenis82@gmail.com, http://libtom.org
*/
-#if MP_GEN_RANDOM_MAX == 0xffffffff
+#if defined(MP_8BIT) || defined(MP_16BIT)
+#define MP_GEN_RANDOM_SHIFT DIGIT_BIT
+#else
+#if MP_GEN_RANDOM_MAX == 0xffffffffu
#define MP_GEN_RANDOM_SHIFT 32
#elif MP_GEN_RANDOM_MAX == 32767
/* SHRT_MAX */
@@ -26,6 +29,7 @@
#elif !defined(MP_GEN_RANDOM_SHIFT)
#error Thou shalt define their own valid MP_GEN_RANDOM_SHIFT
#endif
+#endif
/* makes a pseudo-random int of a given size */
static mp_digit s_gen_random(void)
@@ -54,7 +58,7 @@ int mp_rand(mp_int *a, int digits)
/* first place a random non-zero digit */
do {
d = s_gen_random();
- } while (d == 0);
+ } while (d == 0u);
if ((res = mp_add_d(a, d, a)) != MP_OKAY) {
return res;
diff --git a/libtommath/bn_mp_read_radix.c b/libtommath/bn_mp_read_radix.c
index bc31cc5..55c5ee1 100644
--- a/libtommath/bn_mp_read_radix.c
+++ b/libtommath/bn_mp_read_radix.c
@@ -19,6 +19,7 @@
int mp_read_radix(mp_int *a, const char *str, int radix)
{
int y, res, neg;
+ unsigned pos;
char ch;
/* zero the digit bignum */
@@ -49,31 +50,30 @@ int mp_read_radix(mp_int *a, const char *str, int radix)
* [e.g. in hex]
*/
ch = (radix <= 36) ? (char)toupper((int)*str) : *str;
- for (y = 0; y < 64; y++) {
- if (ch == mp_s_rmap[y]) {
- break;
- }
+ pos = (unsigned)(ch - '(');
+ if (mp_s_rmap_reverse_sz < pos) {
+ break;
}
+ y = (int)mp_s_rmap_reverse[pos];
/* if the char was found in the map
* and is less than the given radix add it
* to the number, otherwise exit the loop.
*/
- if (y < radix) {
- if ((res = mp_mul_d(a, (mp_digit)radix, a)) != MP_OKAY) {
- return res;
- }
- if ((res = mp_add_d(a, (mp_digit)y, a)) != MP_OKAY) {
- return res;
- }
- } else {
+ if ((y == 0xff) || (y >= radix)) {
break;
}
+ if ((res = mp_mul_d(a, (mp_digit)radix, a)) != MP_OKAY) {
+ return res;
+ }
+ if ((res = mp_add_d(a, (mp_digit)y, a)) != MP_OKAY) {
+ return res;
+ }
++str;
}
/* if an illegal character was found, fail. */
- if (!(*str == '\0' || *str == '\r' || *str == '\n')) {
+ if (!((*str == '\0') || (*str == '\r') || (*str == '\n'))) {
mp_zero(a);
return MP_VAL;
}
diff --git a/libtommath/bn_mp_read_signed_bin.c b/libtommath/bn_mp_read_signed_bin.c
index eabc803..17bc6ce 100644
--- a/libtommath/bn_mp_read_signed_bin.c
+++ b/libtommath/bn_mp_read_signed_bin.c
@@ -26,7 +26,7 @@ int mp_read_signed_bin(mp_int *a, const unsigned char *b, int c)
}
/* first byte is 0 for positive, non-zero for negative */
- if (b[0] == 0) {
+ if (b[0] == (unsigned char)0) {
a->sign = MP_ZPOS;
} else {
a->sign = MP_NEG;
diff --git a/libtommath/bn_mp_read_unsigned_bin.c b/libtommath/bn_mp_read_unsigned_bin.c
index ad9f05f..6398c43 100644
--- a/libtommath/bn_mp_read_unsigned_bin.c
+++ b/libtommath/bn_mp_read_unsigned_bin.c
@@ -41,7 +41,7 @@ int mp_read_unsigned_bin(mp_int *a, const unsigned char *b, int c)
a->used += 1;
#else
a->dp[0] = (*b & MP_MASK);
- a->dp[1] |= ((*b++ >> 7U) & 1);
+ a->dp[1] |= ((*b++ >> 7) & 1u);
a->used += 2;
#endif
}
diff --git a/libtommath/bn_mp_reduce.c b/libtommath/bn_mp_reduce.c
index bbc521f..5b1d405 100644
--- a/libtommath/bn_mp_reduce.c
+++ b/libtommath/bn_mp_reduce.c
@@ -33,7 +33,7 @@ int mp_reduce(mp_int *x, const mp_int *m, const mp_int *mu)
mp_rshd(&q, um - 1);
/* according to HAC this optimization is ok */
- if (((mp_digit) um) > (((mp_digit)1) << (DIGIT_BIT - 1))) {
+ if ((mp_digit)um > ((mp_digit)1 << (DIGIT_BIT - 1))) {
if ((res = mp_mul(&q, mu, &q)) != MP_OKAY) {
goto CLEANUP;
}
@@ -73,8 +73,8 @@ int mp_reduce(mp_int *x, const mp_int *m, const mp_int *mu)
}
/* If x < 0, add b**(k+1) to it */
- if (mp_cmp_d(x, 0) == MP_LT) {
- mp_set(&q, 1);
+ if (mp_cmp_d(x, 0uL) == MP_LT) {
+ mp_set(&q, 1uL);
if ((res = mp_lshd(&q, um + 1)) != MP_OKAY)
goto CLEANUP;
if ((res = mp_add(x, &q, x)) != MP_OKAY)
diff --git a/libtommath/bn_mp_reduce_2k.c b/libtommath/bn_mp_reduce_2k.c
index 2922cad..e1e2bc8 100644
--- a/libtommath/bn_mp_reduce_2k.c
+++ b/libtommath/bn_mp_reduce_2k.c
@@ -32,7 +32,7 @@ top:
goto ERR;
}
- if (d != 1) {
+ if (d != 1u) {
/* q = q * d */
if ((res = mp_mul_d(&q, d, &q)) != MP_OKAY) {
goto ERR;
diff --git a/libtommath/bn_mp_reduce_is_2k.c b/libtommath/bn_mp_reduce_is_2k.c
index 932521e..f59d535 100644
--- a/libtommath/bn_mp_reduce_is_2k.c
+++ b/libtommath/bn_mp_reduce_is_2k.c
@@ -32,7 +32,7 @@ int mp_reduce_is_2k(const mp_int *a)
/* Test every bit from the second digit up, must be 1 */
for (ix = DIGIT_BIT; ix < iy; ix++) {
- if ((a->dp[iw] & iz) == 0) {
+ if ((a->dp[iw] & iz) == 0u) {
return MP_NO;
}
iz <<= 1;
diff --git a/libtommath/bn_mp_set.c b/libtommath/bn_mp_set.c
index eaf7fed..952d080 100644
--- a/libtommath/bn_mp_set.c
+++ b/libtommath/bn_mp_set.c
@@ -20,7 +20,7 @@ void mp_set(mp_int *a, mp_digit b)
{
mp_zero(a);
a->dp[0] = b & MP_MASK;
- a->used = (a->dp[0] != 0) ? 1 : 0;
+ a->used = (a->dp[0] != 0u) ? 1 : 0;
}
#endif
diff --git a/libtommath/bn_mp_set_int.c b/libtommath/bn_mp_set_int.c
index 4c71180..006f263 100644
--- a/libtommath/bn_mp_set_int.c
+++ b/libtommath/bn_mp_set_int.c
@@ -30,7 +30,7 @@ int mp_set_int(mp_int *a, unsigned long b)
}
/* OR in the top four bits of the source */
- a->dp[0] |= (b >> 28) & 15;
+ a->dp[0] |= (mp_digit)(b >> 28) & 15uL;
/* shift the source up to the next four bits */
b <<= 4;
diff --git a/libtommath/bn_mp_shrink.c b/libtommath/bn_mp_shrink.c
index 8ac1f33..3e4dde0 100644
--- a/libtommath/bn_mp_shrink.c
+++ b/libtommath/bn_mp_shrink.c
@@ -26,7 +26,7 @@ int mp_shrink(mp_int *a)
}
if (a->alloc != used) {
- if ((tmp = OPT_CAST(mp_digit) XREALLOC(a->dp, sizeof(mp_digit) * used)) == NULL) {
+ if ((tmp = OPT_CAST(mp_digit) XREALLOC(a->dp, sizeof(mp_digit) * (size_t)used)) == NULL) {
return MP_MEM;
}
a->dp = tmp;
diff --git a/libtommath/bn_mp_sqr.c b/libtommath/bn_mp_sqr.c
index 2b71097..a98f16c 100644
--- a/libtommath/bn_mp_sqr.c
+++ b/libtommath/bn_mp_sqr.c
@@ -35,9 +35,9 @@ int mp_sqr(const mp_int *a, mp_int *b)
{
#ifdef BN_FAST_S_MP_SQR_C
/* can we use the fast comba multiplier? */
- if ((((a->used * 2) + 1) < MP_WARRAY) &&
+ if ((((a->used * 2) + 1) < (int)MP_WARRAY) &&
(a->used <
- (1 << (((sizeof(mp_word) * CHAR_BIT) - (2 * DIGIT_BIT)) - 1)))) {
+ (int)(1u << (((sizeof(mp_word) * (size_t)CHAR_BIT) - (2u * (size_t)DIGIT_BIT)) - 1u)))) {
res = fast_s_mp_sqr(a, b);
} else
#endif
diff --git a/libtommath/bn_mp_sqrtmod_prime.c b/libtommath/bn_mp_sqrtmod_prime.c
index 261723e..d4cf3de 100644
--- a/libtommath/bn_mp_sqrtmod_prime.c
+++ b/libtommath/bn_mp_sqrtmod_prime.c
@@ -22,11 +22,11 @@ int mp_sqrtmod_prime(const mp_int *n, const mp_int *prime, mp_int *ret)
mp_digit i;
/* first handle the simple cases */
- if (mp_cmp_d(n, 0) == MP_EQ) {
+ if (mp_cmp_d(n, 0uL) == MP_EQ) {
mp_zero(ret);
return MP_OKAY;
}
- if (mp_cmp_d(prime, 2) == MP_EQ) return MP_VAL; /* prime must be odd */
+ if (mp_cmp_d(prime, 2uL) == MP_EQ) return MP_VAL; /* prime must be odd */
if ((res = mp_jacobi(n, prime, &legendre)) != MP_OKAY) return res;
if (legendre == -1) return MP_VAL; /* quadratic non-residue mod prime */
@@ -38,9 +38,9 @@ int mp_sqrtmod_prime(const mp_int *n, const mp_int *prime, mp_int *ret)
* compute directly: res = n^(prime+1)/4 mod prime
* Handbook of Applied Cryptography algorithm 3.36
*/
- if ((res = mp_mod_d(prime, 4, &i)) != MP_OKAY) goto cleanup;
- if (i == 3) {
- if ((res = mp_add_d(prime, 1, &t1)) != MP_OKAY) goto cleanup;
+ if ((res = mp_mod_d(prime, 4uL, &i)) != MP_OKAY) goto cleanup;
+ if (i == 3u) {
+ if ((res = mp_add_d(prime, 1uL, &t1)) != MP_OKAY) goto cleanup;
if ((res = mp_div_2(&t1, &t1)) != MP_OKAY) goto cleanup;
if ((res = mp_div_2(&t1, &t1)) != MP_OKAY) goto cleanup;
if ((res = mp_exptmod(n, &t1, prime, ret)) != MP_OKAY) goto cleanup;
@@ -52,30 +52,30 @@ int mp_sqrtmod_prime(const mp_int *n, const mp_int *prime, mp_int *ret)
/* factor out powers of 2 from prime-1, defining Q and S as: prime-1 = Q*2^S */
if ((res = mp_copy(prime, &Q)) != MP_OKAY) goto cleanup;
- if ((res = mp_sub_d(&Q, 1, &Q)) != MP_OKAY) goto cleanup;
+ if ((res = mp_sub_d(&Q, 1uL, &Q)) != MP_OKAY) goto cleanup;
/* Q = prime - 1 */
mp_zero(&S);
/* S = 0 */
while (mp_iseven(&Q) != MP_NO) {
if ((res = mp_div_2(&Q, &Q)) != MP_OKAY) goto cleanup;
/* Q = Q / 2 */
- if ((res = mp_add_d(&S, 1, &S)) != MP_OKAY) goto cleanup;
+ if ((res = mp_add_d(&S, 1uL, &S)) != MP_OKAY) goto cleanup;
/* S = S + 1 */
}
/* find a Z such that the Legendre symbol (Z|prime) == -1 */
- if ((res = mp_set_int(&Z, 2)) != MP_OKAY) goto cleanup;
+ if ((res = mp_set_int(&Z, 2uL)) != MP_OKAY) goto cleanup;
/* Z = 2 */
while (1) {
if ((res = mp_jacobi(&Z, prime, &legendre)) != MP_OKAY) goto cleanup;
if (legendre == -1) break;
- if ((res = mp_add_d(&Z, 1, &Z)) != MP_OKAY) goto cleanup;
+ if ((res = mp_add_d(&Z, 1uL, &Z)) != MP_OKAY) goto cleanup;
/* Z = Z + 1 */
}
if ((res = mp_exptmod(&Z, &Q, prime, &C)) != MP_OKAY) goto cleanup;
/* C = Z ^ Q mod prime */
- if ((res = mp_add_d(&Q, 1, &t1)) != MP_OKAY) goto cleanup;
+ if ((res = mp_add_d(&Q, 1uL, &t1)) != MP_OKAY) goto cleanup;
if ((res = mp_div_2(&t1, &t1)) != MP_OKAY) goto cleanup;
/* t1 = (Q + 1) / 2 */
if ((res = mp_exptmod(n, &t1, prime, &R)) != MP_OKAY) goto cleanup;
@@ -84,24 +84,24 @@ int mp_sqrtmod_prime(const mp_int *n, const mp_int *prime, mp_int *ret)
/* T = n ^ Q mod prime */
if ((res = mp_copy(&S, &M)) != MP_OKAY) goto cleanup;
/* M = S */
- if ((res = mp_set_int(&two, 2)) != MP_OKAY) goto cleanup;
+ if ((res = mp_set_int(&two, 2uL)) != MP_OKAY) goto cleanup;
res = MP_VAL;
while (1) {
if ((res = mp_copy(&T, &t1)) != MP_OKAY) goto cleanup;
i = 0;
while (1) {
- if (mp_cmp_d(&t1, 1) == MP_EQ) break;
+ if (mp_cmp_d(&t1, 1uL) == MP_EQ) break;
if ((res = mp_exptmod(&t1, &two, prime, &t1)) != MP_OKAY) goto cleanup;
i++;
}
- if (i == 0) {
+ if (i == 0u) {
if ((res = mp_copy(&R, ret)) != MP_OKAY) goto cleanup;
res = MP_OKAY;
goto cleanup;
}
if ((res = mp_sub_d(&M, i, &t1)) != MP_OKAY) goto cleanup;
- if ((res = mp_sub_d(&t1, 1, &t1)) != MP_OKAY) goto cleanup;
+ if ((res = mp_sub_d(&t1, 1uL, &t1)) != MP_OKAY) goto cleanup;
if ((res = mp_exptmod(&two, &t1, prime, &t1)) != MP_OKAY) goto cleanup;
/* t1 = 2 ^ (M - i - 1) */
if ((res = mp_exptmod(&C, &t1, prime, &t1)) != MP_OKAY) goto cleanup;
diff --git a/libtommath/bn_mp_sub_d.c b/libtommath/bn_mp_sub_d.c
index 4d66a90..e5fbfff 100644
--- a/libtommath/bn_mp_sub_d.c
+++ b/libtommath/bn_mp_sub_d.c
@@ -67,13 +67,13 @@ int mp_sub_d(const mp_int *a, mp_digit b, mp_int *c)
/* subtract first digit */
*tmpc = *tmpa++ - b;
- mu = *tmpc >> ((sizeof(mp_digit) * CHAR_BIT) - 1);
+ mu = *tmpc >> ((sizeof(mp_digit) * (size_t)CHAR_BIT) - 1u);
*tmpc++ &= MP_MASK;
/* handle rest of the digits */
for (ix = 1; ix < a->used; ix++) {
*tmpc = *tmpa++ - mu;
- mu = *tmpc >> ((sizeof(mp_digit) * CHAR_BIT) - 1);
+ mu = *tmpc >> ((sizeof(mp_digit) * (size_t)CHAR_BIT) - 1u);
*tmpc++ &= MP_MASK;
}
}
diff --git a/libtommath/bn_mp_to_signed_bin_n.c b/libtommath/bn_mp_to_signed_bin_n.c
index 1447624..f1d7c8b 100644
--- a/libtommath/bn_mp_to_signed_bin_n.c
+++ b/libtommath/bn_mp_to_signed_bin_n.c
@@ -21,7 +21,7 @@ int mp_to_signed_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen)
if (*outlen < (unsigned long)mp_signed_bin_size(a)) {
return MP_VAL;
}
- *outlen = mp_signed_bin_size(a);
+ *outlen = (unsigned long)mp_signed_bin_size(a);
return mp_to_signed_bin(a, b);
}
#endif
diff --git a/libtommath/bn_mp_to_unsigned_bin.c b/libtommath/bn_mp_to_unsigned_bin.c
index 9339cce..a53f711 100644
--- a/libtommath/bn_mp_to_unsigned_bin.c
+++ b/libtommath/bn_mp_to_unsigned_bin.c
@@ -28,9 +28,9 @@ int mp_to_unsigned_bin(const mp_int *a, unsigned char *b)
x = 0;
while (mp_iszero(&t) == MP_NO) {
#ifndef MP_8BIT
- b[x++] = (unsigned char)(t.dp[0] & 255);
+ b[x++] = (unsigned char)(t.dp[0] & 255u);
#else
- b[x++] = (unsigned char)(t.dp[0] | ((t.dp[1] & 0x01) << 7));
+ b[x++] = (unsigned char)(t.dp[0] | ((t.dp[1] & 1u) << 7));
#endif
if ((res = mp_div_2d(&t, 8, &t, NULL)) != MP_OKAY) {
mp_clear(&t);
diff --git a/libtommath/bn_mp_to_unsigned_bin_n.c b/libtommath/bn_mp_to_unsigned_bin_n.c
index 707dc82..e7d303c 100644
--- a/libtommath/bn_mp_to_unsigned_bin_n.c
+++ b/libtommath/bn_mp_to_unsigned_bin_n.c
@@ -21,7 +21,7 @@ int mp_to_unsigned_bin_n(const mp_int *a, unsigned char *b, unsigned long *outle
if (*outlen < (unsigned long)mp_unsigned_bin_size(a)) {
return MP_VAL;
}
- *outlen = mp_unsigned_bin_size(a);
+ *outlen = (unsigned long)mp_unsigned_bin_size(a);
return mp_to_unsigned_bin(a, b);
}
#endif
diff --git a/libtommath/bn_mp_toom_mul.c b/libtommath/bn_mp_toom_mul.c
index 3554ea8..00b6bfb 100644
--- a/libtommath/bn_mp_toom_mul.c
+++ b/libtommath/bn_mp_toom_mul.c
@@ -219,7 +219,7 @@ int mp_toom_mul(const mp_int *a, const mp_int *b, mp_int *c)
goto ERR;
}
/* 3r2 - r1 - r3 */
- if ((res = mp_mul_d(&w2, 3, &w2)) != MP_OKAY) {
+ if ((res = mp_mul_d(&w2, 3uL, &w2)) != MP_OKAY) {
goto ERR;
}
if ((res = mp_sub(&w2, &w1, &w2)) != MP_OKAY) {
diff --git a/libtommath/bn_mp_toom_sqr.c b/libtommath/bn_mp_toom_sqr.c
index b985435..183de20 100644
--- a/libtommath/bn_mp_toom_sqr.c
+++ b/libtommath/bn_mp_toom_sqr.c
@@ -162,7 +162,7 @@ int mp_toom_sqr(const mp_int *a, mp_int *b)
goto ERR;
}
/* 3r2 - r1 - r3 */
- if ((res = mp_mul_d(&w2, 3, &w2)) != MP_OKAY) {
+ if ((res = mp_mul_d(&w2, 3uL, &w2)) != MP_OKAY) {
goto ERR;
}
if ((res = mp_sub(&w2, &w1, &w2)) != MP_OKAY) {
diff --git a/libtommath/bn_mp_unsigned_bin_size.c b/libtommath/bn_mp_unsigned_bin_size.c
index 04107fe..2b9ce8a 100644
--- a/libtommath/bn_mp_unsigned_bin_size.c
+++ b/libtommath/bn_mp_unsigned_bin_size.c
@@ -19,7 +19,7 @@
int mp_unsigned_bin_size(const mp_int *a)
{
int size = mp_count_bits(a);
- return (size / 8) + (((size & 7) != 0) ? 1 : 0);
+ return (size / 8) + ((((unsigned)size & 7u) != 0u) ? 1 : 0);
}
#endif
diff --git a/libtommath/bn_prime_tab.c b/libtommath/bn_prime_tab.c
index c8fadcd..bcd23ed 100644
--- a/libtommath/bn_prime_tab.c
+++ b/libtommath/bn_prime_tab.c
@@ -14,6 +14,7 @@
*
* Tom St Denis, tstdenis82@gmail.com, http://libtom.org
*/
+
const mp_digit ltm_prime_tab[] = {
0x0002, 0x0003, 0x0005, 0x0007, 0x000B, 0x000D, 0x0011, 0x0013,
0x0017, 0x001D, 0x001F, 0x0025, 0x0029, 0x002B, 0x002F, 0x0035,
diff --git a/libtommath/bn_s_mp_add.c b/libtommath/bn_s_mp_add.c
index 2046722..3f908ef 100644
--- a/libtommath/bn_s_mp_add.c
+++ b/libtommath/bn_s_mp_add.c
@@ -67,7 +67,7 @@ int s_mp_add(const mp_int *a, const mp_int *b, mp_int *c)
*tmpc = *tmpa++ + *tmpb++ + u;
/* U = carry bit of T[i] */
- u = *tmpc >> ((mp_digit)DIGIT_BIT);
+ u = *tmpc >> (mp_digit)DIGIT_BIT;
/* take away carry bit from T[i] */
*tmpc++ &= MP_MASK;
@@ -82,7 +82,7 @@ int s_mp_add(const mp_int *a, const mp_int *b, mp_int *c)
*tmpc = x->dp[i] + u;
/* U = carry bit of T[i] */
- u = *tmpc >> ((mp_digit)DIGIT_BIT);
+ u = *tmpc >> (mp_digit)DIGIT_BIT;
/* take away carry bit from T[i] */
*tmpc++ &= MP_MASK;
diff --git a/libtommath/bn_s_mp_exptmod.c b/libtommath/bn_s_mp_exptmod.c
index a886361..a954757 100644
--- a/libtommath/bn_s_mp_exptmod.c
+++ b/libtommath/bn_s_mp_exptmod.c
@@ -14,6 +14,7 @@
*
* Tom St Denis, tstdenis82@gmail.com, http://libtom.org
*/
+
#ifdef MP_LOW_MEM
# define TAB_SIZE 32
#else
@@ -25,7 +26,7 @@ int s_mp_exptmod(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y, i
mp_int M[TAB_SIZE], res, mu;
mp_digit buf;
int err, bitbuf, bitcpy, bitcnt, mode, digidx, x, y, winsize;
- int (*redux)(mp_int *, const mp_int *, const mp_int *);
+ int (*redux)(mp_int *x, const mp_int *m, const mp_int *mu);
/* find window size */
x = mp_count_bits(X);
@@ -133,7 +134,7 @@ int s_mp_exptmod(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y, i
if ((err = mp_init(&res)) != MP_OKAY) {
goto LBL_MU;
}
- mp_set(&res, 1);
+ mp_set(&res, 1uL);
/* set initial mode and bit cnt */
mode = 0;
diff --git a/libtommath/bn_s_mp_mul_digs.c b/libtommath/bn_s_mp_mul_digs.c
index af13a02..214ae31 100644
--- a/libtommath/bn_s_mp_mul_digs.c
+++ b/libtommath/bn_s_mp_mul_digs.c
@@ -28,9 +28,9 @@ int s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs)
mp_digit tmpx, *tmpt, *tmpy;
/* can we use the fast multiplier? */
- if (((digs) < MP_WARRAY) &&
+ if ((digs < (int)MP_WARRAY) &&
(MIN(a->used, b->used) <
- (1 << ((CHAR_BIT * sizeof(mp_word)) - (2 * DIGIT_BIT))))) {
+ (int)(1u << (((size_t)CHAR_BIT * sizeof(mp_word)) - (2u * (size_t)DIGIT_BIT))))) {
return fast_s_mp_mul_digs(a, b, c, digs);
}
@@ -66,10 +66,10 @@ int s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs)
(mp_word)u;
/* the new column is the lower part of the result */
- *tmpt++ = (mp_digit)(r & ((mp_word) MP_MASK));
+ *tmpt++ = (mp_digit)(r & (mp_word)MP_MASK);
/* get the carry word from the result */
- u = (mp_digit)(r >> ((mp_word) DIGIT_BIT));
+ u = (mp_digit)(r >> (mp_word)DIGIT_BIT);
}
/* set carry if it is placed below digs */
if ((ix + iy) < digs) {
diff --git a/libtommath/bn_s_mp_mul_high_digs.c b/libtommath/bn_s_mp_mul_high_digs.c
index 37c108e..3c0418a 100644
--- a/libtommath/bn_s_mp_mul_high_digs.c
+++ b/libtommath/bn_s_mp_mul_high_digs.c
@@ -28,8 +28,8 @@ int s_mp_mul_high_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs)
/* can we use the fast multiplier? */
#ifdef BN_FAST_S_MP_MUL_HIGH_DIGS_C
- if (((a->used + b->used + 1) < MP_WARRAY)
- && (MIN(a->used, b->used) < (1 << ((CHAR_BIT * sizeof(mp_word)) - (2 * DIGIT_BIT))))) {
+ if (((a->used + b->used + 1) < (int)MP_WARRAY)
+ && (MIN(a->used, b->used) < (int)(1u << (((size_t)CHAR_BIT * sizeof(mp_word)) - (2u * (size_t)DIGIT_BIT))))) {
return fast_s_mp_mul_high_digs(a, b, c, digs);
}
#endif
@@ -61,10 +61,10 @@ int s_mp_mul_high_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs)
(mp_word)u;
/* get the lower part */
- *tmpt++ = (mp_digit)(r & ((mp_word) MP_MASK));
+ *tmpt++ = (mp_digit)(r & (mp_word)MP_MASK);
/* carry the carry */
- u = (mp_digit)(r >> ((mp_word) DIGIT_BIT));
+ u = (mp_digit)(r >> (mp_word)DIGIT_BIT);
}
*tmpt = u;
}
diff --git a/libtommath/bn_s_mp_sqr.c b/libtommath/bn_s_mp_sqr.c
index aae06eb..71bbccd 100644
--- a/libtommath/bn_s_mp_sqr.c
+++ b/libtommath/bn_s_mp_sqr.c
@@ -38,10 +38,10 @@ int s_mp_sqr(const mp_int *a, mp_int *b)
((mp_word)a->dp[ix] * (mp_word)a->dp[ix]);
/* store lower part in result */
- t.dp[ix+ix] = (mp_digit)(r & ((mp_word)MP_MASK));
+ t.dp[ix+ix] = (mp_digit)(r & (mp_word)MP_MASK);
/* get the carry */
- u = (mp_digit)(r >> ((mp_word)DIGIT_BIT));
+ u = (mp_digit)(r >> (mp_word)DIGIT_BIT);
/* left hand side of A[ix] * A[iy] */
tmpx = a->dp[ix];
@@ -51,24 +51,24 @@ int s_mp_sqr(const mp_int *a, mp_int *b)
for (iy = ix + 1; iy < pa; iy++) {
/* first calculate the product */
- r = ((mp_word)tmpx) * ((mp_word)a->dp[iy]);
+ r = (mp_word)tmpx * (mp_word)a->dp[iy];
/* now calculate the double precision result, note we use
* addition instead of *2 since it's easier to optimize
*/
- r = ((mp_word) *tmpt) + r + r + ((mp_word) u);
+ r = (mp_word)*tmpt + r + r + (mp_word)u;
/* store lower part */
- *tmpt++ = (mp_digit)(r & ((mp_word) MP_MASK));
+ *tmpt++ = (mp_digit)(r & (mp_word)MP_MASK);
/* get carry */
- u = (mp_digit)(r >> ((mp_word) DIGIT_BIT));
+ u = (mp_digit)(r >> (mp_word)DIGIT_BIT);
}
/* propagate upwards */
- while (u != ((mp_digit) 0)) {
- r = ((mp_word) *tmpt) + ((mp_word) u);
- *tmpt++ = (mp_digit)(r & ((mp_word) MP_MASK));
- u = (mp_digit)(r >> ((mp_word) DIGIT_BIT));
+ while (u != 0uL) {
+ r = (mp_word)*tmpt + (mp_word)u;
+ *tmpt++ = (mp_digit)(r & (mp_word)MP_MASK);
+ u = (mp_digit)(r >> (mp_word)DIGIT_BIT);
}
}
diff --git a/libtommath/bn_s_mp_sub.c b/libtommath/bn_s_mp_sub.c
index 52b8096..c8472af 100644
--- a/libtommath/bn_s_mp_sub.c
+++ b/libtommath/bn_s_mp_sub.c
@@ -53,7 +53,7 @@ int s_mp_sub(const mp_int *a, const mp_int *b, mp_int *c)
* if a carry does occur it will propagate all the way to the
* MSB. As a result a single shift is enough to get the carry
*/
- u = *tmpc >> ((mp_digit)((CHAR_BIT * sizeof(mp_digit)) - 1));
+ u = *tmpc >> (((size_t)CHAR_BIT * sizeof(mp_digit)) - 1u);
/* Clear carry from T[i] */
*tmpc++ &= MP_MASK;
@@ -65,7 +65,7 @@ int s_mp_sub(const mp_int *a, const mp_int *b, mp_int *c)
*tmpc = *tmpa++ - u;
/* U = carry bit of T[i] */
- u = *tmpc >> ((mp_digit)((CHAR_BIT * sizeof(mp_digit)) - 1));
+ u = *tmpc >> (((size_t)CHAR_BIT * sizeof(mp_digit)) - 1u);
/* Clear carry from T[i] */
*tmpc++ &= MP_MASK;
diff --git a/libtommath/makefile b/libtommath/makefile
index 64d8fcd..5eddae4 100644
--- a/libtommath/makefile
+++ b/libtommath/makefile
@@ -102,10 +102,6 @@ test_standalone: $(LIBNAME) demo/demo.o
mtest:
cd mtest ; $(CC) $(CFLAGS) -O0 mtest.c $(LFLAGS) -o mtest
-travis_mtest: test mtest
- @ for i in `seq 1 10` ; do sleep 500 && echo alive; done &
- ./mtest/mtest 666666 | ./test > test.log
-
timing: $(LIBNAME)
$(CC) $(CFLAGS) -DTIMER demo/timing.c $(LIBNAME) $(LFLAGS) -o ltmtest
@@ -148,7 +144,7 @@ new_file:
perl dep.pl
perlcritic:
- perlcritic *.pl
+ perlcritic *.pl doc/*.pl
astyle:
- astyle --options=astylerc $(OBJECTS:.o=.c)
+ astyle --options=astylerc $(OBJECTS:.o=.c) tommath*.h demo/*.c etc/*.c mtest/mtest.c
diff --git a/libtommath/makefile_include.mk b/libtommath/makefile_include.mk
index 3a599e8..45a4895 100644
--- a/libtommath/makefile_include.mk
+++ b/libtommath/makefile_include.mk
@@ -60,6 +60,9 @@ endif # COMPILE_DEBUG
ifneq ($(findstring clang,$(CC)),)
CFLAGS += -Wno-typedef-redefinition -Wno-tautological-compare -Wno-builtin-requires-header
endif
+ifneq ($(findstring mingw,$(CC)),)
+CFLAGS += -Wno-shadow
+endif
ifeq ($(PLATFORM), Darwin)
CFLAGS += -Wno-nullability-completeness
endif
diff --git a/libtommath/tommath.h b/libtommath/tommath.h
index 50a3a81..51f703b 100644
--- a/libtommath/tommath.h
+++ b/libtommath/tommath.h
@@ -26,6 +26,11 @@
extern "C" {
#endif
+/* MS Visual C++ doesn't have a 128bit type for words, so fall back to 32bit MPI's (where words are 64bit) */
+#if defined(_MSC_VER) || defined(__LLP64__)
+# define MP_32BIT
+#endif
+
/* detect 64-bit mode if possible */
#if defined(__x86_64__) || defined(_M_X64) || defined(_M_AMD64) || \
defined(__powerpc64__) || defined(__ppc64__) || defined(__PPC64__) || \
@@ -65,9 +70,7 @@ typedef uint32_t mp_word;
#elif defined(MP_64BIT)
/* for GCC only on supported platforms */
typedef uint64_t mp_digit;
-# if defined(_WIN32)
-typedef unsigned __int128 mp_word;
-# elif defined(__GNUC__)
+# if defined(__GNUC__)
typedef unsigned long mp_word __attribute__((mode(TI)));
# else
/* it seems you have a problem
@@ -104,7 +107,7 @@ typedef mp_digit mp_min_u32;
/* use arc4random on platforms that support it */
#if defined(__FreeBSD__) || defined(__OpenBSD__) || defined(__NetBSD__) || defined(__DragonFly__)
# define MP_GEN_RANDOM() arc4random()
-# define MP_GEN_RANDOM_MAX 0xffffffff
+# define MP_GEN_RANDOM_MAX 0xffffffffu
#endif
/* use rand() as fall-back if there's no better rand function */
@@ -159,7 +162,7 @@ extern int KARATSUBA_MUL_CUTOFF,
#endif
/* size of comba arrays, should be at least 2 * 2**(BITS_PER_WORD - BITS_PER_DIGIT*2) */
-#define MP_WARRAY (1 << (((sizeof(mp_word) * CHAR_BIT) - (2 * DIGIT_BIT)) + 1))
+#define MP_WARRAY (1u << (((sizeof(mp_word) * CHAR_BIT) - (2 * DIGIT_BIT)) + 1))
/* the infamous mp_int structure */
typedef struct {
@@ -394,7 +397,7 @@ int mp_n_root_ex(const mp_int *a, mp_digit b, mp_int *c, int fast);
int mp_sqrt(const mp_int *arg, mp_int *ret);
/* special sqrt (mod prime) */
-int mp_sqrtmod_prime(const mp_int *arg, const mp_int *prime, mp_int *ret);
+int mp_sqrtmod_prime(const mp_int *n, const mp_int *prime, mp_int *ret);
/* is number a square? */
int mp_is_square(const mp_int *arg, int *ret);
@@ -407,13 +410,13 @@ int mp_reduce_setup(mp_int *a, const mp_int *b);
/* Barrett Reduction, computes a (mod b) with a precomputed value c
*
- * Assumes that 0 < a <= b*b, note if 0 > a > -(b*b) then you can merely
- * compute the reduction as -1 * mp_reduce(mp_abs(a)) [pseudo code].
+ * Assumes that 0 < x <= m*m, note if 0 > x > -(m*m) then you can merely
+ * compute the reduction as -1 * mp_reduce(mp_abs(x)) [pseudo code].
*/
-int mp_reduce(mp_int *a, const mp_int *b, const mp_int *c);
+int mp_reduce(mp_int *x, const mp_int *m, const mp_int *mu);
/* setups the montgomery reduction */
-int mp_montgomery_setup(const mp_int *a, mp_digit *mp);
+int mp_montgomery_setup(const mp_int *n, mp_digit *rho);
/* computes a = B**n mod b without division or multiplication useful for
* normalizing numbers in a Montgomery system.
@@ -421,7 +424,7 @@ int mp_montgomery_setup(const mp_int *a, mp_digit *mp);
int mp_montgomery_calc_normalization(mp_int *a, const mp_int *b);
/* computes x/R == x (mod N) via Montgomery Reduction */
-int mp_montgomery_reduce(mp_int *a, const mp_int *m, mp_digit mp);
+int mp_montgomery_reduce(mp_int *x, const mp_int *n, mp_digit rho);
/* returns 1 if a is a valid DR modulus */
int mp_dr_is_modulus(const mp_int *a);
@@ -429,8 +432,8 @@ int mp_dr_is_modulus(const mp_int *a);
/* sets the value of "d" required for mp_dr_reduce */
void mp_dr_setup(const mp_int *a, mp_digit *d);
-/* reduces a modulo b using the Diminished Radix method */
-int mp_dr_reduce(mp_int *a, const mp_int *b, mp_digit mp);
+/* reduces a modulo n using the Diminished Radix method */
+int mp_dr_reduce(mp_int *x, const mp_int *n, mp_digit k);
/* returns true if a can be reduced with mp_reduce_2k */
int mp_reduce_is_2k(const mp_int *a);
@@ -450,8 +453,8 @@ int mp_reduce_2k_setup_l(const mp_int *a, mp_int *d);
/* reduces a modulo b where b is of the form 2**p - k [0 <= a] */
int mp_reduce_2k_l(mp_int *a, const mp_int *n, const mp_int *d);
-/* d = a**b (mod c) */
-int mp_exptmod(const mp_int *a, const mp_int *b, const mp_int *c, mp_int *d);
+/* Y = G**X (mod P) */
+int mp_exptmod(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y);
/* ---> Primes <--- */
diff --git a/libtommath/tommath_private.h b/libtommath/tommath_private.h
index be065cd..fd25141 100644
--- a/libtommath/tommath_private.h
+++ b/libtommath/tommath_private.h
@@ -76,6 +76,8 @@ int s_mp_exptmod(const mp_int *G, const mp_int *X, const mp_int *P, mp_int *Y, i
void bn_reverse(unsigned char *s, int len);
extern const char *mp_s_rmap;
+extern const unsigned char mp_s_rmap_reverse[];
+extern const size_t mp_s_rmap_reverse_sz;
/* Fancy macro to set an MPI from another type.
* There are several things assumed:
@@ -99,7 +101,7 @@ int func_name (mp_int * a, type b) \
} \
\
/* OR in the top four bits of the source */ \
- a->dp[0] |= (b >> ((sizeof(type) * 8u) - 4u)) & 15u; \
+ a->dp[0] |= (mp_digit)(b >> ((sizeof(type) * 8u) - 4u)) & 15uL;\
\
/* shift the source up to the next four bits */ \
b <<= 4; \
diff --git a/tests/assemble.test b/tests/assemble.test
index 6e5308d..d7c47a9 100644
--- a/tests/assemble.test
+++ b/tests/assemble.test
@@ -1584,6 +1584,12 @@ test assemble-15.7 {listIndexImm} {
}
-result c
}
+test assemble-15.8 {listIndexImm} {
+ assemble {push {a b c}; listIndexImm end+2}
+} {}
+test assemble-15.9 {listIndexImm} {
+ assemble {push {a b c}; listIndexImm -1-1}
+} {}
# assemble-16 - invokeStk
diff --git a/tests/basic.test b/tests/basic.test
index d47613a..0e4ddea 100644
--- a/tests/basic.test
+++ b/tests/basic.test
@@ -893,21 +893,17 @@ test basic-48.16.$noComp {expansion: testing for leaks} -setup {
rename stress {}
} -result 0
-test basic-48.17.$noComp {expansion: object safety} -setup {
- set old_precision $::tcl_precision
- set ::tcl_precision 4
- } -constraints $constraints -body {
+test basic-48.17.$noComp {expansion: object safety} -constraints $constraints -body {
set third [expr {1.0/3.0}]
set l [list $third $third]
set x [run {list $third {*}$l $third}]
- set res [list]
+ set res [list]
foreach t $x {
lappend res [expr {$t * 3.0}]
}
set res
} -cleanup {
- set ::tcl_precision $old_precision
- unset old_precision res t l x third
+ unset res t l x third
} -result {1.0 1.0 1.0 1.0}
test basic-48.18.$noComp {expansion: list semantics} -constraints $constraints -body {
diff --git a/tests/chanio.test b/tests/chanio.test
index 8c74566..97e7e70 100644
--- a/tests/chanio.test
+++ b/tests/chanio.test
@@ -5345,7 +5345,7 @@ test chan-io-40.2 {POSIX open access modes: CREAT} -setup {
lappend x [chan gets $f]
} -cleanup {
chan close $f
-} -result {0600 {line 1}}
+} -result {0o600 {line 1}}
test chan-io-40.3 {POSIX open access modes: CREAT} -setup {
file delete $path(test3)
} -constraints {unix umask} -body {
@@ -5353,7 +5353,7 @@ test chan-io-40.3 {POSIX open access modes: CREAT} -setup {
chan close [open $path(test3) {WRONLY CREAT}]
file stat $path(test3) stats
format "%#o" [expr $stats(mode)&0o777]
-} -result [format %#4o [expr {0o666 & ~ $umaskValue}]]
+} -result [format %#5o [expr {0o666 & ~ $umaskValue}]]
test chan-io-40.4 {POSIX open access modes: CREAT} -setup {
file delete $path(test3)
} -body {
@@ -5866,6 +5866,8 @@ test chan-io-47.6 {file events on shared files, deleting file events} -setup {
testfevent delete
chan close $f
} -result {{script 1} {}}
+unset path(foo)
+removeFile foo
set path(bar) [makeFile {} bar]
@@ -5961,6 +5963,9 @@ test chan-io-48.3 {testing readability conditions} -setup {
} -cleanup {
chan close $f
} -result {done {0 1 0 1 0 1 0 1 0 1 0 1 0 0}}
+unset path(bar)
+removeFile bar
+
test chan-io-48.4 {lf write, testing readability, ^Z termination, auto read mode} -setup {
file delete $path(test1)
set c 0
@@ -6790,8 +6795,6 @@ test chan-io-52.11 {TclCopyChannel & encodings} -setup {
chan close $in
chan close $out
file size $path(kyrillic.txt)
-} -cleanup {
- file delete $path(utf8-fcopy.txt)
} -result 3
test chan-io-53.1 {CopyData} -setup {
diff --git a/tests/cmdIL.test b/tests/cmdIL.test
index df59e6e..b9444b6 100644
--- a/tests/cmdIL.test
+++ b/tests/cmdIL.test
@@ -160,6 +160,12 @@ test cmdIL-1.39 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} fullutf {
test cmdIL-1.40 {Tcl_LsortObjCmd procedure, Bug 8e1e31eac0fd6b6c} fullutf {
lsort -ascii -nocase [list \0 \x7f \x80 \U01ffff \uffff]
} [list \0 \x7f \x80 \uffff \U01ffff]
+test cmdIL-1.41 {lsort -stride and -index} -body {
+ lsort -stride 2 -index -2 {a 2 b 1}
+} -returnCodes error -result {index "-2" cannot select an element from any list}
+test cmdIL-1.42 {lsort -stride and-index} -body {
+ lsort -stride 2 -index -1-1 {a 2 b 1}
+} -returnCodes error -result {index "-1-1" cannot select an element from any list}
# Can't think of any good tests for the MergeSort and MergeLists procedures,
# except a bunch of random lists to sort.
@@ -216,6 +222,33 @@ test cmdIL-3.4.1 {SortCompare procedure, -index option} -body {
test cmdIL-3.5 {SortCompare procedure, -index option} -body {
lsort -integer -index 2 {{20 10 13} {15}}
} -returnCodes error -result {element 2 missing from sublist "15"}
+test cmdIL-3.5.1 {SortCompare procedure, -index option (out of range, calculated index)} -body {
+ lsort -index 1+3 {{1 . c} {2 . b} {3 . a}}
+} -returnCodes error -result {element 4 missing from sublist "1 . c"}
+test cmdIL-3.5.2 {SortCompare procedure, -index option (out of range, calculated index)} -body {
+ lsort -index -1-1 {{1 . c} {2 . b} {3 . a}}
+} -returnCodes error -result {index "-1-1" cannot select an element from any list}
+test cmdIL-3.5.3 {SortCompare procedure, -index option (out of range, calculated index)} -body {
+ lsort -index -2 {{1 . c} {2 . b} {3 . a}}
+} -returnCodes error -result {index "-2" cannot select an element from any list}
+test cmdIL-3.5.4 {SortCompare procedure, -index option (out of range, calculated index)} -body {
+ lsort -index end-4 {{1 . c} {2 . b} {3 . a}}
+} -returnCodes error -result {element -2 missing from sublist "1 . c"}
+test cmdIL-3.5.5 {SortCompare procedure, -index option} {
+ lsort -index {} {a b}
+} {a b}
+test cmdIL-3.5.6 {SortCompare procedure, -index option} {
+ lsort -index {} [list a \{]
+} {a \{}
+test cmdIL-3.5.7 {SortCompare procedure, -index option (out of range, calculated index)} -body {
+ lsort -index end--1 {{1 . c} {2 . b} {3 . a}}
+} -returnCodes error -result {index "end--1" cannot select an element from any list}
+test cmdIL-3.5.8 {SortCompare procedure, -index option (out of range, calculated index)} -body {
+ lsort -index end+1 {{1 . c} {2 . b} {3 . a}}
+} -returnCodes error -result {index "end+1" cannot select an element from any list}
+test cmdIL-3.5.9 {SortCompare procedure, -index option (out of range, calculated index)} -body {
+ lsort -index end+2 {{1 . c} {2 . b} {3 . a}}
+} -returnCodes error -result {index "end+2" cannot select an element from any list}
test cmdIL-3.6 {SortCompare procedure, -index option} {
lsort -integer -index 2 {{1 15 30} {2 5 25} {3 25 20}}
} {{3 25 20} {2 5 25} {1 15 30}}
diff --git a/tests/compExpr-old.test b/tests/compExpr-old.test
index bae26a0..0136ccd 100644
--- a/tests/compExpr-old.test
+++ b/tests/compExpr-old.test
@@ -20,12 +20,6 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
-if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} {
- testConstraint testmathfunctions 0
-} else {
- testConstraint testmathfunctions 1
-}
-
# Big test for correct ordering of data in [expr]
proc testIEEE {} {
@@ -602,22 +596,6 @@ test compExpr-old-15.5 {CompileMathFuncCall: too few arguments} -body {
test compExpr-old-15.6 {CompileMathFuncCall: missing ')'} -body {
expr sin(1
} -returnCodes error -match glob -result *
-test compExpr-old-15.7 {CompileMathFuncCall: call registered math function} testmathfunctions {
- expr 2*T1()
-} 246
-test compExpr-old-15.8 {CompileMathFuncCall: call registered math function} testmathfunctions {
- expr T2()*3
-} 1035
-test compExpr-old-15.9 {CompileMathFuncCall: call registered math function} testmathfunctions {
- expr T3(21, 37)
-} 37
-test compExpr-old-15.10 {CompileMathFuncCall: call registered math function} testmathfunctions {
- expr T3(21.2, 37)
-} 37.0
-test compExpr-old-15.11 {CompileMathFuncCall: call registered math function} testmathfunctions {
- expr T3(-21.2, -17.5)
-} -17.5
-
test compExpr-old-16.1 {GetToken: checks whether integer token starting with "0x" (e.g., "0x$") is invalid} {
catch {unset a}
set a(VALUE) ff15
diff --git a/tests/compExpr.test b/tests/compExpr.test
index 14c875d..3b44af8 100644
--- a/tests/compExpr.test
+++ b/tests/compExpr.test
@@ -16,12 +16,6 @@ if {"::tcltest" ni [namespace children]} {
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
-if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} {
- testConstraint testmathfunctions 0
-} else {
- testConstraint testmathfunctions 1
-}
-
# Constrain memory leak tests
testConstraint memory [llength [info commands memory]]
@@ -319,12 +313,6 @@ test compExpr-5.1 {CompileMathFuncCall procedure, math function found} {
test compExpr-5.2 {CompileMathFuncCall procedure, math function not found} -body {
expr {do_it()}
} -returnCodes error -match glob -result {* "*do_it"}
-test compExpr-5.3 {CompileMathFuncCall: call registered math function} testmathfunctions {
- expr 3*T1()-1
-} 368
-test compExpr-5.4 {CompileMathFuncCall: call registered math function} testmathfunctions {
- expr T2()*3
-} 1035
test compExpr-5.5 {CompileMathFuncCall procedure, too few arguments} -body {
expr {atan2(1.0)}
} -returnCodes error -match glob -result {too few arguments for math function*}
diff --git a/tests/coroutine.test b/tests/coroutine.test
index 07feb53..8217a92 100644
--- a/tests/coroutine.test
+++ b/tests/coroutine.test
@@ -739,6 +739,8 @@ test coroutine-7.12 {coro floor above street level #3008307} -body {
}
boom ; # does not crash: the coro floor is a good insulator
list
+} -cleanup {
+ rename boom {}; rename cc {}; rename c {}
} -result {}
test coroutine-8.0.0 {coro inject executed} -body {
diff --git a/tests/exec.test b/tests/exec.test
index dffd960..3d1cd56 100644
--- a/tests/exec.test
+++ b/tests/exec.test
@@ -300,7 +300,6 @@ test exec-6.3 {redirecting stderr through a pipeline} {exec stdio} {
# I/O redirection: combinations.
set path(gorp.file2) [makeFile {} gorp.file2]
-file delete $path(gorp.file2)
test exec-7.1 {multiple I/O redirections} {exec} {
exec << "command input" > $path(gorp.file2) [interpreter] $path(cat) < $path(gorp.file)
diff --git a/tests/expr-old.test b/tests/expr-old.test
index 8c159b2..a73b77a 100644
--- a/tests/expr-old.test
+++ b/tests/expr-old.test
@@ -24,12 +24,6 @@ testConstraint testexprdouble [llength [info commands testexprdouble]]
testConstraint testexprstring [llength [info commands testexprstring]]
testConstraint longIs32bit [expr {int(0x80000000) < 0}]
-if {[catch {expr T1()} msg] && $msg eq {invalid command name "tcl::mathfunc::T1"}} {
- testConstraint testmathfunctions 0
-} else {
- testConstraint testmathfunctions 1
-}
-
# Big test for correct ordering of data in [expr]
proc testIEEE {} {
@@ -847,12 +841,6 @@ test expr-old-32.41 {math functions in expressions} {
test expr-old-32.42 {math functions in expressions} {
list [catch {expr hypot(5*.8,3)} msg] $msg
} {0 5.0}
-test expr-old-32.43 {math functions in expressions} testmathfunctions {
- expr 2*T1()
-} 246
-test expr-old-32.44 {math functions in expressions} testmathfunctions {
- expr T2()*3
-} 1035
test expr-old-32.45 {math functions in expressions} {
expr (0 <= rand()) && (rand() < 1)
} {1}
@@ -952,11 +940,6 @@ test expr-old-34.15 {errors in math functions} {
test expr-old-34.16 {errors in math functions} {
expr round(-1.0e30)
} -1000000000000000019884624838656
-test expr-old-34.17 {errors in math functions} -constraints testmathfunctions \
- -body {
- list [catch {expr T1(4)} msg] $msg
- } -match glob -result {1 {too many arguments for math function*}}
-
test expr-old-36.1 {ExprLooksLikeInt procedure} -body {
expr 0o289
} -returnCodes error -match glob -result {*invalid octal number*}
diff --git a/tests/expr.test b/tests/expr.test
index 8e083c5..de6eb4a 100644
--- a/tests/expr.test
+++ b/tests/expr.test
@@ -18,10 +18,6 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
::tcltest::loadTestedCommands
catch [list package require -exact Tcltest [info patchlevel]]
-testConstraint testmathfunctions [expr {
- ([catch {expr T1()} msg] != 1) || ($msg ne {invalid command name "tcl::mathfunc::T1"})
-}]
-
# Determine if "long int" type is a 32 bit number and if the wide
# type is a 64 bit number on this machine.
@@ -685,41 +681,6 @@ test expr-15.5 {CompileMathFuncCall: too few arguments} -body {
test expr-15.6 {CompileMathFuncCall: missing ')'} -body {
expr sin(1
} -returnCodes error -match glob -result *
-test expr-15.7 {CompileMathFuncCall: call registered math function} {testmathfunctions} {
- expr 2*T1()
-} 246
-test expr-15.8 {CompileMathFuncCall: call registered math function} {testmathfunctions} {
- expr T2()*3
-} 1035
-test expr-15.9 {CompileMathFuncCall: call registered math function} {testmathfunctions} {
- expr T3(21, 37)
-} 37
-test expr-15.10 {CompileMathFuncCall: call registered math function} {testmathfunctions} {
- expr T3(21.2, 37)
-} 37.0
-test expr-15.11 {CompileMathFuncCall: call registered math function} {testmathfunctions} {
- expr T3(-21.2, -17.5)
-} -17.5
-test expr-15.12 {ExprCallMathFunc: call registered math function} {testmathfunctions} {
- expr T3(21, wide(37))
-} 37
-test expr=15.13 {ExprCallMathFunc: call registered math function} {testmathfunctions} {
- expr T3(wide(21), 37)
-} 37
-test expr=15.14 {ExprCallMathFunc: call registered math function} {testmathfunctions} {
- expr T3(wide(21), wide(37))
-} 37
-test expr-15.15 {ExprCallMathFunc: call registered math function} {testmathfunctions} {
- expr T3(21.0, wide(37))
-} 37.0
-test expr-15.16 {ExprCallMathFunc: call registered math function} {testmathfunctions} {
- expr T3(wide(21), 37.0)
-} 37.0
-test expr-15.17 {ExprCallMathFunc: non-numeric arg} -constraints {
- testmathfunctions
-} -body {
- expr T3(0,"a")
-} -returnCodes error -result {argument to math function didn't have numeric value}
test expr-16.1 {GetToken: checks whether integer token starting with "0x" (e.g., "0x$") is invalid} {
@@ -5838,6 +5799,15 @@ test expr-32.5 {Bug 1585704} {
test expr-32.6 {Bug 1585704} {
expr -(1<<32)%(1<<63)
} [expr (1<<63)-(1<<32)]
+test expr-32.7 {bignum regression} {
+ expr {0%(1<<63)}
+} 0
+test expr-32.8 {bignum regression} {
+ expr {0%-(1<<63)}
+} 0
+test expr-32.9 {bignum regression} {
+ expr {0%-(1+(1<<63))}
+} 0
test expr-33.1 {parse largest long value} longIs32bit {
set max_long_str 2147483647
diff --git a/tests/foreach.test b/tests/foreach.test
index 6fd5476..84af4bd 100644
--- a/tests/foreach.test
+++ b/tests/foreach.test
@@ -212,14 +212,16 @@ test foreach-6.4 {break tests} {
set msg
} {wrong # args: should be "break"}
# Check for bug #406709
-test foreach-6.5 {break tests} {
+test foreach-6.5 {break tests} -body {
proc a {} {
set a 1
foreach b b {list [concat a; break]; incr a}
incr a
}
a
-} {2}
+} -cleanup {
+ rename a {}
+} -result {2}
# Test for incorrect "double evaluation" semantics
test foreach-7.1 {delayed substitution of body} {
diff --git a/tests/format.test b/tests/format.test
index 094b7b3..ed8676a 100644
--- a/tests/format.test
+++ b/tests/format.test
@@ -28,7 +28,7 @@ test format-1.1 {integer formatting} {
} { 34 16923 -12 -1}
test format-1.2 {integer formatting} {
format "%4d %4d %4d %4d %d %#x %#X" 6 34 16923 -12 -1 14 12
-} { 6 34 16923 -12 -1 0xe 0XC}
+} { 6 34 16923 -12 -1 0xe 0xC}
test format-1.3 {integer formatting} longIs32bit {
format "%4u %4u %4u %4u %d %#o" 6 34 16923 -12 -1 0
} { 6 34 16923 4294967284 -1 0}
@@ -54,40 +54,40 @@ test format-1.7.1 {integer formatting} longIs64bit {
} { 6 22 421b fffffffffffffff4}
test format-1.8 {integer formatting} longIs32bit {
format "%#x %#x %#X %#X %#x" 0 6 34 16923 -12 -1
-} {0x0 0x6 0X22 0X421B 0xfffffff4}
+} {0 0x6 0x22 0x421B 0xfffffff4}
test format-1.8.1 {integer formatting} longIs64bit {
format "%#x %#x %#X %#X %#x" 0 6 34 16923 -12 -1
-} {0x0 0x6 0X22 0X421B 0xfffffffffffffff4}
+} {0 0x6 0x22 0x421B 0xfffffffffffffff4}
test format-1.9 {integer formatting} longIs32bit {
format "%#5x %#20x %#20x %#20x %#20x" 0 6 34 16923 -12 -1
-} { 0x0 0x6 0x22 0x421b 0xfffffff4}
+} { 0 0x6 0x22 0x421b 0xfffffff4}
test format-1.9.1 {integer formatting} longIs64bit {
format "%#5x %#20x %#20x %#20x %#20x" 0 6 34 16923 -12 -1
-} { 0x0 0x6 0x22 0x421b 0xfffffffffffffff4}
+} { 0 0x6 0x22 0x421b 0xfffffffffffffff4}
test format-1.10 {integer formatting} longIs32bit {
format "%-#5x %-#20x %-#20x %-#20x %-#20x" 0 6 34 16923 -12 -1
-} {0x0 0x6 0x22 0x421b 0xfffffff4 }
+} {0 0x6 0x22 0x421b 0xfffffff4 }
test format-1.10.1 {integer formatting} longIs64bit {
format "%-#5x %-#20x %-#20x %-#20x %-#20x" 0 6 34 16923 -12 -1
-} {0x0 0x6 0x22 0x421b 0xfffffffffffffff4 }
+} {0 0x6 0x22 0x421b 0xfffffffffffffff4 }
test format-1.11 {integer formatting} longIs32bit {
format "%-#5o %-#20o %#-20o %#-20o %#-20o" 0 6 34 16923 -12 -1
-} {0 06 042 041033 037777777764 }
+} {0 0o6 0o42 0o41033 0o37777777764 }
test format-1.11.1 {integer formatting} longIs64bit {
format "%-#5o %-#20o %#-20o %#-20o %#-20o" 0 6 34 16923 -12 -1
-} {0 06 042 041033 01777777777777777777764}
+} {0 0o6 0o42 0o41033 0o1777777777777777777764}
test format-1.12 {integer formatting} {
format "%b %#b %#b %llb" 5 0 5 [expr {2**100}]
-} {101 0b0 0b101 10000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000}
+} {101 0 0b101 10000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000}
test format-1.13 {integer formatting} {
- format "%#d %#d %#d %#d %#d" 0 6 34 16923 -12 -1
-} {0d0 0d6 0d34 0d16923 -0d12}
+ format "%#0d %#0d %#0d %#0d %#0d" 0 6 34 16923 -12 -1
+} {0 0d6 0d34 0d16923 -0d12}
test format-1.14 {integer formatting} {
- format "%#5d %#20d %#20d %#20d %#20d" 0 6 34 16923 -12 -1
-} { 0d0 0d6 0d34 0d16923 -0d12}
+ format "%#05d %#020d %#020d %#020d %#020d" 0 6 34 16923 -12 -1
+} {00000 0d000000000000000006 0d000000000000000034 0d000000000000016923 -0d00000000000000012}
test format-1.15 {integer formatting} {
- format "%-#5d %-#20d %-#20d %-#20d %-#20d" 0 6 34 16923 -12 -1
-} {0d0 0d6 0d34 0d16923 -0d12 }
+ format "%-#05d %-#020d %-#020d %-#020d %-#020d" 0 6 34 16923 -12 -1
+} {00000 0d000000000000000006 0d000000000000000034 0d000000000000016923 -0d00000000000000012}
test format-2.1 {string formatting} {
@@ -561,7 +561,7 @@ test format-17.4 {testing %l with non-integer} {
} 1.000000
test format-17.5 {testing %llu with positive bignum} -body {
format %llu 0xabcdef0123456789abcdef
-} -returnCodes 1 -result {unsigned bignum format is invalid}
+} -result 207698809136909011942886895
test format-17.6 {testing %llu with negative number} -body {
format %llu -1
} -returnCodes 1 -result {unsigned bignum format is invalid}
diff --git a/tests/httpold.test b/tests/httpold.test
deleted file mode 100644
index dda0189..0000000
--- a/tests/httpold.test
+++ /dev/null
@@ -1,300 +0,0 @@
-# -*- tcl -*-
-# Commands covered: http_config, http_get, http_wait, http_reset
-#
-# This file contains a collection of tests for the http script library.
-# Sourcing this file into Tcl runs the tests and
-# generates output for errors. No output means no errors were found.
-#
-# Copyright (c) 1991-1993 The Regents of the University of California.
-# Copyright (c) 1994-1996 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
-#
-# See the file "license.terms" for information on usage and redistribution
-# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-
-if {[lsearch [namespace children] ::tcltest] == -1} {
- package require tcltest
- namespace import -force ::tcltest::*
-}
-
-if {[catch {package require http 1.0}]} {
- if {[info exists httpold]} {
- catch {puts "Cannot load http 1.0 package"}
- ::tcltest::cleanupTests
- return
- } else {
- catch {puts "Running http 1.0 tests in slave interp"}
- set interp [interp create httpold]
- $interp eval [list set httpold "running"]
- $interp eval [list set argv $argv]
- $interp eval [list source [info script]]
- interp delete $interp
- ::tcltest::cleanupTests
- return
- }
-}
-
-if {$::tcl_platform(os) eq "Darwin"} {
- # Name resolution often a problem on OSX; not focus of HTTP package anyway
- set HOST localhost
-} else {
- set HOST [info hostname]
-}
-
-set bindata "This is binary data\x0d\x0amore\x0dmore\x0amore\x00null"
-catch {unset data}
-
-##
-## The httpd script implement a stub http server
-##
-source [file join [file dirname [info script]] httpd]
-
-if [catch {httpd_init 0} listen] {
- puts "Cannot start http server, http test skipped"
- catch {unset port}
- ::tcltest::cleanupTests
- return
-}
-
-test httpold-1.1 {http_config} {
- http_config
-} {-accept */* -proxyfilter httpProxyRequired -proxyhost {} -proxyport {} -useragent {Tcl http client package 1.0}}
-
-test httpold-1.2 {http_config} {
- http_config -proxyfilter
-} httpProxyRequired
-
-test httpold-1.3 {http_config} {
- catch {http_config -junk}
-} 1
-
-test httpold-1.4 {http_config} {
- http_config -proxyhost nowhere.come -proxyport 8080 -proxyfilter myFilter -useragent "Tcl Test Suite"
- set x [http_config]
- http_config -proxyhost {} -proxyport {} -proxyfilter httpProxyRequired \
- -useragent "Tcl http client package 1.0"
- set x
-} {-accept */* -proxyfilter myFilter -proxyhost nowhere.come -proxyport 8080 -useragent {Tcl Test Suite}}
-
-test httpold-1.5 {http_config} {
- catch {http_config -proxyhost {} -junk 8080}
-} 1
-
-test httpold-2.1 {http_reset} {
- catch {http_reset http#1}
-} 0
-
-test httpold-3.1 {http_get} {
- catch {http_get -bogus flag}
-} 1
-test httpold-3.2 {http_get} {
- catch {http_get http:junk} err
- set err
-} {Unsupported URL: http:junk}
-
-set url ${::HOST}:$port
-test httpold-3.3 {http_get} {
- set token [http_get $url]
- http_data $token
-} "<html><head><title>HTTP/1.0 TEST</title></head><body>
-<h1>Hello, World!</h1>
-<h2>GET /</h2>
-</body></html>"
-
-set tail /a/b/c
-set url ${::HOST}:$port/a/b/c
-set binurl ${::HOST}:$port/binary
-
-test httpold-3.4 {http_get} {
- set token [http_get $url]
- http_data $token
-} "<html><head><title>HTTP/1.0 TEST</title></head><body>
-<h1>Hello, World!</h1>
-<h2>GET $tail</h2>
-</body></html>"
-
-proc selfproxy {host} {
- global port
- return [list ${::HOST} $port]
-}
-test httpold-3.5 {http_get} {
- http_config -proxyfilter selfproxy
- set token [http_get $url]
- http_config -proxyfilter httpProxyRequired
- http_data $token
-} "<html><head><title>HTTP/1.0 TEST</title></head><body>
-<h1>Hello, World!</h1>
-<h2>GET http://$url</h2>
-</body></html>"
-
-test httpold-3.6 {http_get} {
- http_config -proxyfilter bogus
- set token [http_get $url]
- http_config -proxyfilter httpProxyRequired
- http_data $token
-} "<html><head><title>HTTP/1.0 TEST</title></head><body>
-<h1>Hello, World!</h1>
-<h2>GET $tail</h2>
-</body></html>"
-
-test httpold-3.7 {http_get} {
- set token [http_get $url -headers {Pragma no-cache}]
- http_data $token
-} "<html><head><title>HTTP/1.0 TEST</title></head><body>
-<h1>Hello, World!</h1>
-<h2>GET $tail</h2>
-</body></html>"
-
-test httpold-3.8 {http_get} {
- set token [http_get $url -query Name=Value&Foo=Bar]
- http_data $token
-} "<html><head><title>HTTP/1.0 TEST</title></head><body>
-<h1>Hello, World!</h1>
-<h2>POST $tail</h2>
-<h2>Query</h2>
-<dl>
-<dt>Name<dd>Value
-<dt>Foo<dd>Bar
-</dl>
-</body></html>"
-
-test httpold-3.9 {http_get} {
- set token [http_get $url -validate 1]
- http_code $token
-} "HTTP/1.0 200 OK"
-
-
-test httpold-4.1 {httpEvent} {
- set token [http_get $url]
- upvar #0 $token data
- array set meta $data(meta)
- expr ($data(totalsize) == $meta(Content-Length))
-} 1
-
-test httpold-4.2 {httpEvent} {
- set token [http_get $url]
- upvar #0 $token data
- array set meta $data(meta)
- string compare $data(type) [string trim $meta(Content-Type)]
-} 0
-
-test httpold-4.3 {httpEvent} {
- set token [http_get $url]
- http_code $token
-} {HTTP/1.0 200 Data follows}
-
-test httpold-4.4 {httpEvent} {
- set testfile [makeFile "" testfile]
- set out [open $testfile w]
- set token [http_get $url -channel $out]
- close $out
- set in [open $testfile]
- set x [read $in]
- close $in
- removeFile $testfile
- set x
-} "<html><head><title>HTTP/1.0 TEST</title></head><body>
-<h1>Hello, World!</h1>
-<h2>GET $tail</h2>
-</body></html>"
-
-test httpold-4.5 {httpEvent} {
- set testfile [makeFile "" testfile]
- set out [open $testfile w]
- set token [http_get $url -channel $out]
- close $out
- upvar #0 $token data
- removeFile $testfile
- expr $data(currentsize) == $data(totalsize)
-} 1
-
-test httpold-4.6 {httpEvent} {
- set testfile [makeFile "" testfile]
- set out [open $testfile w]
- set token [http_get $binurl -channel $out]
- close $out
- set in [open $testfile]
- fconfigure $in -translation binary
- set x [read $in]
- close $in
- removeFile $testfile
- set x
-} "$bindata$binurl"
-
-proc myProgress {token total current} {
- global progress httpLog
- if {[info exists httpLog] && $httpLog} {
- puts "progress $total $current"
- }
- set progress [list $total $current]
-}
-if 0 {
- # This test hangs on Windows95 because the client never gets EOF
- set httpLog 1
- test httpold-4.6 {httpEvent} {
- set token [http_get $url -blocksize 50 -progress myProgress]
- set progress
- } {111 111}
-}
-test httpold-4.7 {httpEvent} {
- set token [http_get $url -progress myProgress]
- set progress
-} {111 111}
-test httpold-4.8 {httpEvent} {
- set token [http_get $url]
- http_status $token
-} {ok}
-test httpold-4.9 {httpEvent} {
- set token [http_get $url -progress myProgress]
- http_code $token
-} {HTTP/1.0 200 Data follows}
-test httpold-4.10 {httpEvent} {
- set token [http_get $url -progress myProgress]
- http_size $token
-} {111}
-test httpold-4.11 {httpEvent} {
- set token [http_get $url -timeout 1 -command {#}]
- http_reset $token
- http_status $token
-} {reset}
-test httpold-4.12 {httpEvent} {
- update
- set x {}
- after 500 {lappend x ok}
- set token [http_get $url -timeout 1 -command {lappend x fail}]
- vwait x
- list [http_status $token] $x
-} {timeout ok}
-
-test httpold-5.1 {http_formatQuery} {
- http_formatQuery name1 value1 name2 "value two"
-} {name1=value1&name2=value+two}
-
-test httpold-5.2 {http_formatQuery} {
- http_formatQuery name1 ~bwelch name2 \xa1\xa2\xa2
-} {name1=%7ebwelch&name2=%a1%a2%a2}
-
-test httpold-5.3 {http_formatQuery} {
- http_formatQuery lines "line1\nline2\nline3"
-} {lines=line1%0d%0aline2%0d%0aline3}
-
-test httpold-6.1 {httpProxyRequired} {
- update
- http_config -proxyhost ${::HOST} -proxyport $port
- set token [http_get $url]
- http_wait $token
- http_config -proxyhost {} -proxyport {}
- upvar #0 $token data
- set data(body)
-} "<html><head><title>HTTP/1.0 TEST</title></head><body>
-<h1>Hello, World!</h1>
-<h2>GET http://$url</h2>
-</body></html>"
-
-# cleanup
-catch {unset url}
-catch {unset port}
-catch {unset data}
-close $listen
-::tcltest::cleanupTests
-return
diff --git a/tests/info.test b/tests/info.test
index fd89b47..8176ad3 100644
--- a/tests/info.test
+++ b/tests/info.test
@@ -2398,7 +2398,7 @@ test info-33.35 {{*}, literal, simple, bytecompiled} -body {
# -------------------------------------------------------------------------
unset -nocomplain res
-test info-39.0 {Bug 4b61afd660} -setup {
+test info-39.2 {Bug 4b61afd660} -setup {
proc probe {} {
return [dict get [info frame -1] line]
}
diff --git a/tests/io.test b/tests/io.test
index 3fc370d..20bb565 100644
--- a/tests/io.test
+++ b/tests/io.test
@@ -5638,7 +5638,7 @@ test io-40.2 {POSIX open access modes: CREAT} {unix} {
file delete $path(test3)
set f [open $path(test3) {WRONLY CREAT} 0o600]
file stat $path(test3) stats
- set x [format "0o%o" [expr $stats(mode)&0o777]]
+ set x [format "%#o" [expr $stats(mode)&0o777]]
puts $f "line 1"
close $f
set f [open $path(test3) r]
@@ -5653,7 +5653,7 @@ test io-40.3 {POSIX open access modes: CREAT} {unix umask} {
close $f
file stat $path(test3) stats
format "%#o" [expr $stats(mode)&0o777]
-} [format %#4o [expr {0o666 & ~ $umaskValue}]]
+} [format %#5o [expr {0o666 & ~ $umaskValue}]]
test io-40.4 {POSIX open access modes: CREAT} {
file delete $path(test3)
set f [open $path(test3) w]
@@ -6163,6 +6163,8 @@ test io-47.6 {file events on shared files, deleting file events} {testfevent fil
close $f
set x
} {{script 1} {}}
+unset path(foo)
+removeFile foo
set path(bar) [makeFile {} bar]
@@ -6265,6 +6267,9 @@ test io-48.3 {testing readability conditions} {stdio unix nonBlockFiles openpipe
close $f
list $x $l
} {done {0 1 0 1 0 1 0 1 0 1 0 1 0 0}}
+unset path(bar)
+removeFile bar
+
test io-48.4 {lf write, testing readability, ^Z termination, auto read mode} {fileevent} {
file delete $path(test1)
set f [open $path(test1) w]
diff --git a/tests/ioCmd.test b/tests/ioCmd.test
index cd89a02..cab4e97 100644
--- a/tests/ioCmd.test
+++ b/tests/ioCmd.test
@@ -384,7 +384,6 @@ test iocmd-10.5 {fblocked command} {
set path(test4) [makeFile {} test4]
set path(test5) [makeFile {} test5]
-file delete $path(test5)
test iocmd-11.1 {I/O to command pipelines} {unixOrPc unixExecs} {
set f [open $path(test4) w]
close $f
@@ -2058,6 +2057,8 @@ test iocmd-32.0 {origin interpreter of moved channel gone} -match glob -body {
lappend res [catch {interp eval $idb [list close $chan]} msg] $msg
set res
+} -cleanup {
+ interp delete $idb
} -constraints {testchannel} \
-result {1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}}
@@ -2100,6 +2101,8 @@ test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -m
set res
}]
set res
+} -cleanup {
+ interp delete $idb
} -constraints {testchannel} -result {Owner lost}
test iocmd-32.2 {delete interp of reflected chan} {
@@ -3836,8 +3839,6 @@ foreach file [list test1 test2 test3 test4] {
}
# delay long enough for background processes to finish
after 500
-foreach file [list test5] {
- removeFile $file
-}
+removeFile test5
cleanupTests
return
diff --git a/tests/ioTrans.test b/tests/ioTrans.test
index 63a609f..75752f7 100644
--- a/tests/ioTrans.test
+++ b/tests/ioTrans.test
@@ -1200,6 +1200,7 @@ test iortrans-11.0 {origin interpreter of moved transform gone} -setup {
# without invoking the transform handler.
} -cleanup {
tempdone
+ interp delete $idb
} -result {1 {Owner lost} 0 0 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}}
test iortrans-11.1 {origin interpreter of moved transform destroyed during access} -setup {
set ida [interp create]; #puts <<$ida>>
@@ -1240,6 +1241,7 @@ test iortrans-11.1 {origin interpreter of moved transform destroyed during acces
}]
} -cleanup {
tempdone
+ interp delete $idb
} -result {Owner lost}
test iortrans-11.2 {delete interp of reflected transform} -setup {
interp create slave
diff --git a/tests/join.test b/tests/join.test
index 4abe233..4aeb093 100644
--- a/tests/join.test
+++ b/tests/join.test
@@ -45,6 +45,11 @@ test join-3.1 {joinString is binary ok} {
test join-3.2 {join is binary ok} {
string length [join "a\0b a\0b a\0b"]
} 11
+
+test join-4.1 {shimmer segfault prevention} {
+ set l {0 0}
+ join $l $l
+} {00 00}
# cleanup
::tcltest::cleanupTests
diff --git a/tests/lindex.test b/tests/lindex.test
index 29eb898..bb3f005 100644
--- a/tests/lindex.test
+++ b/tests/lindex.test
@@ -79,6 +79,15 @@ test lindex-3.7 {indexes don't shimmer wide ints} {
set x [expr {(wide(1)<<31) - 2}]
list $x [lindex {1 2 3} $x] [incr x] [incr x]
} {2147483646 {} 2147483647 2147483648}
+test lindex-3.8 {compiled with static indices out of range, negative} {
+ list [lindex {a b c} -1] [lindex {a b c} -2] [lindex {a b c} -3]
+} [lrepeat 3 {}]
+test lindex-3.9 {compiled with calculated indices out of range, negative constant} {
+ list [lindex {a b c} -1-1] [lindex {a b c} -2+0] [lindex {a b c} -2+1]
+} [lrepeat 3 {}]
+test lindex-3.10 {compiled with calculated indices out of range, after end} {
+ list [lindex {a b c} end+1] [lindex {a b c} end+2] [lindex {a b c} end+3]
+} [lrepeat 3 {}]
# Indices relative to end
diff --git a/tests/lrange.test b/tests/lrange.test
index 02b9c65..a5367a4 100644
--- a/tests/lrange.test
+++ b/tests/lrange.test
@@ -90,6 +90,24 @@ test lrange-3.1 {Bug 3588366: end-offsets before start} {
lrange $l 0 end-5
}} {1 2 3 4 5}
} {}
+
+test lrange-3.2 {compiled with static indices out of range, negative} {
+ list [lrange {a b c} -1 -2] [lrange {a b c} -2 -1] [lrange {a b c} -3 -2] [lrange {a b c} -2 -3]
+} [lrepeat 4 {}]
+test lrange-3.3 {compiled with calculated indices out of range, negative constant} {
+ list [lrange {a b c} 0-1 -1-1] [lrange {a b c} -2+0 0-1] [lrange {a b c} -2-1 -2+1] [lrange {a b c} -2+1 -2-1]
+} [lrepeat 4 {}]
+test lrange-3.4 {compiled with calculated indices out of range, after end} {
+ list [lrange {a b c} end+1 end+2] [lrange {a b c} end+2 end+1] [lrange {a b c} end+2 end+3] [lrange {a b c} end+3 end+2]
+} [lrepeat 4 {}]
+
+test lrange-3.5 {compiled with calculated indices, start out of range (negative)} {
+ list [lrange {a b c} -1 1] [lrange {a b c} -1+0 end-1] [lrange {a b c} -2 1] [lrange {a b c} -2+0 0+1]
+} [lrepeat 4 {a b}]
+test lrange-3.6 {compiled with calculated indices, end out of range (after end)} {
+ list [lrange {a b c} 1 end+1] [lrange {a b c} 1+0 2+1] [lrange {a b c} 1 end+1] [lrange {a b c} end-1 3+1]
+} [lrepeat 4 {b c}]
+
# cleanup
::tcltest::cleanupTests
diff --git a/tests/lreplace.test b/tests/lreplace.test
index d7f8226..4a6b853 100644
--- a/tests/lreplace.test
+++ b/tests/lreplace.test
@@ -98,12 +98,18 @@ test lreplace-1.26 {lreplace command} {
[set foo [lreplace $foo end end]] \
[set foo [lreplace $foo end end]]
} {a {} {}}
-test lreplace-1.27 {lreplace command} {
+test lreplace-1.27 {lreplace command} -body {
lreplace x 1 1
-} x
-test lreplace-1.28 {lreplace command} {
+} -returnCodes 1 -result {list doesn't contain element 1}
+test lreplace-1.28 {lreplace command} -body {
lreplace x 1 1 y
-} {x y}
+} -returnCodes 1 -result {list doesn't contain element 1}
+test lreplace-1.29 {lreplace command} -body {
+ lreplace x 1 1 [error foo]
+} -returnCodes 1 -result {foo}
+test lreplace-1.30 {lreplace command} -body {
+ lreplace {not {}alist} 0 0 [error foo]
+} -returnCodes 1 -result {foo}
test lreplace-2.1 {lreplace errors} {
list [catch lreplace msg] $msg
diff --git a/tests/lsearch.test b/tests/lsearch.test
index b2c1812..e401581 100644
--- a/tests/lsearch.test
+++ b/tests/lsearch.test
@@ -59,7 +59,7 @@ test lsearch-2.9 {search modes} {
} 1
test lsearch-2.10 {search modes} -returnCodes error -body {
lsearch -glib {b.x bx xy bcx} b.x
-} -result {bad option "-glib": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices}
+} -result {bad option "-glib": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, -stride, or -subindices}
test lsearch-2.11 {search modes with -nocase} {
lsearch -exact -nocase {a b c A B C} A
} 0
@@ -87,10 +87,10 @@ test lsearch-3.2 {lsearch errors} -returnCodes error -body {
} -result {wrong # args: should be "lsearch ?-option value ...? list pattern"}
test lsearch-3.3 {lsearch errors} -returnCodes error -body {
lsearch a b c
-} -result {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices}
+} -result {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, -stride, or -subindices}
test lsearch-3.4 {lsearch errors} -returnCodes error -body {
lsearch a b c d
-} -result {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, or -subindices}
+} -result {bad option "a": must be -all, -ascii, -bisect, -decreasing, -dictionary, -exact, -glob, -increasing, -index, -inline, -integer, -nocase, -not, -real, -regexp, -sorted, -start, -stride, or -subindices}
test lsearch-3.5 {lsearch errors} -returnCodes error -body {
lsearch "\{" b
} -result {unmatched open brace in list}
@@ -418,6 +418,34 @@ test lsearch-17.6 {lsearch -index option, basic functionality} {
test lsearch-17.7 {lsearch -index option, basic functionality} {
lsearch -all -index 1 -regexp {{ab cb} {ab bb} {ab ab}} {[cb]b}
} {0 1}
+test lsearch-17.8 {lsearch -index option, empty argument} {
+ lsearch -index {} a a
+} 0
+test lsearch-17.9 {lsearch -index option, empty argument} {
+ lsearch -index {} a a
+} [lsearch a a]
+test lsearch-17.10 {lsearch -index option, empty argument} {
+ lsearch -index {} [list \{] \{
+} 0
+test lsearch-17.11 {lsearch -index option, empty argument} {
+ lsearch -index {} [list \{] \{
+} [lsearch [list \{] \{]
+test lsearch-17.12 {lsearch -index option, encoding aliasing} -body {
+ lsearch -index -2 a a
+} -returnCodes error -result {index "-2" cannot select an element from any list}
+test lsearch-17.13 {lsearch -index option, encoding aliasing} -body {
+ lsearch -index -1-1 a a
+} -returnCodes error -result {index "-1-1" cannot select an element from any list}
+test lsearch-17.14 {lsearch -index option, encoding aliasing} -body {
+ lsearch -index end--1 a a
+} -returnCodes error -result {index "end--1" cannot select an element from any list}
+test lsearch-17.15 {lsearch -index option, encoding aliasing} -body {
+ lsearch -index end+1 a a
+} -returnCodes error -result {index "end+1" cannot select an element from any list}
+test lsearch-17.16 {lsearch -index option, encoding aliasing} -body {
+ lsearch -index end+2 a a
+} -returnCodes error -result {index "end+2" cannot select an element from any list}
+
test lsearch-18.1 {lsearch -index option, list as index basic functionality} {
lsearch -index {0 0} {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a
@@ -435,21 +463,30 @@ test lsearch-18.5 {lsearch -index option, list as index basic functionality} {
lsearch -all -index {0 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a
} {0 1}
-test lsearch-19.1 {lsearch -sunindices option} {
+test lsearch-19.1 {lsearch -subindices option} {
lsearch -subindices -index {0 0} {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a
} {1 0 0}
-test lsearch-19.2 {lsearch -sunindices option} {
+test lsearch-19.2 {lsearch -subindices option} {
lsearch -subindices -index {2 0} -exact {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a
} {0 2 0}
-test lsearch-19.3 {lsearch -sunindices option} {
+test lsearch-19.3 {lsearch -subindices option} {
lsearch -subindices -index {1 1} -glob {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} b*
} {0 1 1}
-test lsearch-19.4 {lsearch -sunindices option} {
+test lsearch-19.4 {lsearch -subindices option} {
lsearch -subindices -index {0 1} -regexp {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} {[cb]b}
} {0 0 1}
-test lsearch-19.5 {lsearch -sunindices option} {
+test lsearch-19.5 {lsearch -subindices option} {
lsearch -subindices -all -index {0 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a
} {{0 0 0} {1 0 0}}
+test lsearch-19.6 {lsearch -subindices option} {
+ lsearch -subindices -all -index {1 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a
+} {{0 1 0} {1 1 0}}
+test lsearch-19.7 {lsearch -subindices option} {
+ lsearch -subindices -index end {{1 a}} a
+} {0 1}
+test lsearch-19.8 {lsearch -subindices option} {
+ lsearch -subindices -all -index end {{1 a}} a
+} {{0 1}}
test lsearch-20.1 {lsearch -index option, index larger than sublists} -body {
lsearch -index 2 {{a c} {a b} {a a}} a
@@ -509,6 +546,149 @@ test lsearch-22.5 {lsearch -bisect, all equal} {
test lsearch-22.6 {lsearch -sorted, all equal} {
lsearch -sorted -integer {5 5 5 5} 5
} {0}
+
+test lsearch-23.1 {lsearch -stride option, errors} -body {
+ lsearch -stride {a b} a
+} -returnCodes error -result {"-stride" option must be followed by stride length}
+test lsearch-23.2 {lsearch -stride option, errors} -body {
+ lsearch -stride 0 {a b} a
+} -returnCodes error -result {stride length must be at least 1}
+test lsearch-23.3 {lsearch -stride option, errors} -body {
+ lsearch -stride 2 {a b c} a
+} -returnCodes error -result {list size must be a multiple of the stride length}
+test lsearch-23.4 {lsearch -stride option, errors} -body {
+ lsearch -stride 5 {a b c} a
+} -returnCodes error -result {list size must be a multiple of the stride length}
+test lsearch-23.5 {lsearch -stride option, errors} -body {
+ # Stride equal to length is ok
+ lsearch -stride 3 {a b c} a
+} -result 0
+
+test lsearch-24.1 {lsearch -stride option} -body {
+ lsearch -stride 2 {a b c d e f g h} d
+} -result -1
+test lsearch-24.2 {lsearch -stride option} -body {
+ lsearch -stride 2 {a b c d e f g h} e
+} -result 4
+test lsearch-24.3 {lsearch -stride option} -body {
+ lsearch -stride 3 {a b c d e f g h i} e
+} -result -1
+test lsearch-24.4 {lsearch -stride option} -body {
+ # Result points first in group
+ lsearch -stride 3 -index 1 {a b c d e f g h i} e
+} -result 3
+test lsearch-24.5 {lsearch -stride option} -body {
+ lsearch -inline -stride 2 {a b c d e f g h} d
+} -result {}
+test lsearch-24.6 {lsearch -stride option} -body {
+ # Inline result is a "single element" strided list
+ lsearch -inline -stride 2 {a b c d e f g h} e
+} -result "e f"
+test lsearch-24.7 {lsearch -stride option} -body {
+ lsearch -inline -stride 3 {a b c d e f g h i} e
+} -result {}
+test lsearch-24.8 {lsearch -stride option} -body {
+ lsearch -inline -stride 3 -index 1 {a b c d e f g h i} e
+} -result "d e f"
+test lsearch-24.9 {lsearch -stride option} -body {
+ lsearch -all -inline -stride 3 -index 1 {a b c d e f g e i} e
+} -result "d e f g e i"
+test lsearch-24.10 {lsearch -stride option} -body {
+ lsearch -all -inline -stride 3 -index 0 {a b c d e f a e i} a
+} -result "a b c a e i"
+test lsearch-24.11 {lsearch -stride option} -body {
+ # Stride 1 is same as no stride
+ lsearch -stride 1 {a b c d e f g h} d
+} -result 3
+
+# 25* mimics 19* but with -inline added to -subindices
+test lsearch-25.1 {lsearch -subindices option} {
+ lsearch -inline -subindices -index {0 0} {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a
+} {a}
+test lsearch-25.2 {lsearch -subindices option} {
+ lsearch -inline -subindices -index {2 0} -exact {{{x x} {x b} {a d}} {{a c} {a b} {a a}}} a
+} {a}
+test lsearch-25.3 {lsearch -subindices option} {
+ lsearch -inline -subindices -index {1 1} -glob {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} b*
+} {bb}
+test lsearch-25.4 {lsearch -subindices option} {
+ lsearch -inline -subindices -index {0 1} -regexp {{{ab cb} {ab bb} {ab ab}} {{ab cb} {ab bb} {ab ab}}} {[cb]b}
+} {cb}
+test lsearch-25.5 {lsearch -subindices option} {
+ lsearch -inline -subindices -all -index {0 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a
+} {a a}
+test lsearch-25.6 {lsearch -subindices option} {
+ lsearch -inline -subindices -all -index {1 0} -exact {{{a c} {a b} {d a}} {{a c} {a b} {d a}}} a
+} {a a}
+
+# 26* mimics 19* but with -stride added
+test lsearch-26.1 {lsearch -stride + -subindices option} {
+ lsearch -stride 3 -subindices -index {0 0} {{x x} {x b} {a d} {a c} {a b} {a a}} a
+} {3 0}
+test lsearch-26.2 {lsearch -stride + -subindices option} {
+ lsearch -stride 3 -subindices -index {2 0} -exact {{x x} {x b} {a d} {a c} {a b} {a a}} a
+} {2 0}
+test lsearch-26.3 {lsearch -stride + -subindices option} {
+ lsearch -stride 3 -subindices -index {1 1} -glob {{ab cb} {ab bb} {ab ab} {ab cb} {ab bb} {ab ab}} b*
+} {1 1}
+test lsearch-26.4 {lsearch -stride + -subindices option} {
+ lsearch -stride 3 -subindices -index {0 1} -regexp {{ab cb} {ab bb} {ab ab} {ab cb} {ab bb} {ab ab}} {[cb]b}
+} {0 1}
+test lsearch-26.5 {lsearch -stride + -subindices option} {
+ lsearch -stride 3 -subindices -all -index {0 0} -exact {{a c} {a b} {d a} {a c} {a b} {d a}} a
+} {{0 0} {3 0}}
+test lsearch-26.6 {lsearch -stride + -subindices option} {
+ lsearch -stride 3 -subindices -all -index {1 0} -exact {{a c} {a b} {d a} {x c} {a b} {d a}} a
+} {{1 0} {4 0}}
+
+# 27* mimics 25* but with -stride added
+test lsearch-27.1 {lsearch -stride + -subindices option} {
+ lsearch -inline -stride 3 -subindices -index {0 0} {{x x} {x b} {a d} {a c} {a b} {a a}} a
+} {a}
+test lsearch-27.2 {lsearch -stride + -subindices option} {
+ lsearch -inline -stride 3 -subindices -index {2 0} -exact {{x x} {x b} {a d} {a c} {a b} {a a}} a
+} {a}
+test lsearch-27.3 {lsearch -stride + -subindices option} {
+ lsearch -inline -stride 3 -subindices -index {1 1} -glob {{ab cb} {ab bb} {ab ab} {ab cb} {ab bb} {ab ab}} b*
+} {bb}
+test lsearch-27.4 {lsearch -stride + -subindices option} {
+ lsearch -inline -stride 3 -subindices -index {0 1} -regexp {{ab cb} {ab bb} {ab ab} {ab cb} {ab bb} {ab ab}} {[cb]b}
+} {cb}
+test lsearch-27.5 {lsearch -stride + -subindices option} {
+ lsearch -inline -stride 3 -subindices -all -index {0 0} -exact {{a c} {a b} {d a} {a c} {a b} {d a}} a
+} {a a}
+test lsearch-27.6 {lsearch -stride + -subindices option} {
+ lsearch -inline -stride 3 -subindices -all -index {1 0} -exact {{a c} {a b} {d a} {x c} {a b} {d a}} a
+} {a a}
+
+test lsearch-28.1 {lsearch -sorted with -stride} -body {
+ lsearch -sorted -stride 2 {5 3 7 8 9 2} 5
+} -result 0
+test lsearch-28.2 {lsearch -sorted with -stride} -body {
+ lsearch -sorted -stride 2 {5 3 7 8 9 2} 3
+} -result -1
+test lsearch-28.3 {lsearch -sorted with -stride} -body {
+ lsearch -sorted -stride 2 {5 3 7 8 9 2} 7
+} -result 2
+test lsearch-28.4 {lsearch -sorted with -stride} -body {
+ lsearch -sorted -stride 2 {5 3 7 8 9 2} 8
+} -result -1
+test lsearch-28.5 {lsearch -sorted with -stride} -body {
+ lsearch -sorted -stride 2 {5 3 7 8 9 2} 9
+} -result 4
+test lsearch-28.6 {lsearch -sorted with -stride} -body {
+ lsearch -sorted -stride 2 {5 3 7 8 9 2} 2
+} -result -1
+test lsearch-28.7 {lsearch -sorted with -stride} -body {
+ lsearch -sorted -stride 2 -index 0 -subindices {5 3 7 8 9 2} 9
+} -result 4
+test lsearch-28.8 {lsearch -sorted with -stride} -body {
+ lsearch -sorted -stride 2 -index 1 -subindices {3 5 8 7 2 9} 9
+} -result 5
+test lsearch-28.9 {lsearch -sorted with -stride} -body {
+ lsearch -sorted -stride 2 -index 1 -subindices -inline {3 5 8 7 2 9} 9
+} -result 9
+
# cleanup
catch {unset res}
diff --git a/tests/msgcat.test b/tests/msgcat.test
index 1c3ce58..0d2f928 100644
--- a/tests/msgcat.test
+++ b/tests/msgcat.test
@@ -55,8 +55,13 @@ namespace eval ::msgcat::test {
set result [string tolower [lindex $setVars 0]]
if {[string length $result] == 0} {
if {[info exists ::tcl::mac::locale]} {
+if {[package vsatisfies [package provide msgcat] 1.7]} {
+ set result [string tolower \
+ [msgcat::mcutil::ConvertLocale $::tcl::mac::locale]]
+} else {
set result [string tolower \
[msgcat::ConvertLocale $::tcl::mac::locale]]
+}
} else {
if {([info sharedlibextension] eq ".dll")
&& ![catch {package require registry}]} {
@@ -194,6 +199,28 @@ namespace eval ::msgcat::test {
mclocale looks/ok/../../../../but/is/path/to/evil/code
} -returnCodes error -match glob -result {invalid newLocale value *}
+ test msgcat-1.14 {mcpreferences, custom locale preferences} -setup {
+ variable locale [mclocale]
+ mclocale en
+ mcpreferences fr en {}
+ } -cleanup {
+ mclocale $locale
+ } -body {
+ mcpreferences
+ } -result {fr en {}}
+
+ test msgcat-1.15 {mcpreferences, overwrite custom locale preferences}\
+ -setup {
+ variable locale [mclocale]
+ mcpreferences fr en {}
+ mclocale en
+ } -cleanup {
+ mclocale $locale
+ } -body {
+ mcpreferences
+ } -result {en {}}
+
+
# Tests msgcat-2.*: [mcset], [mcmset], namespace partitioning
test msgcat-2.1 {mcset, global scope} {
@@ -688,7 +715,7 @@ namespace eval ::msgcat::test {
test msgcat-9.1 {mcexists no parameter} -body {
mcexists
} -returnCodes 1\
- -result {wrong # args: should be "mcexists ?-exactnamespace? ?-exactlocale? src"}
+ -result {wrong # args: should be "mcexists ?-exactnamespace? ?-exactlocale? ?-namespace ns? src"}
test msgcat-9.2 {mcexists unknown option} -body {
mcexists -unknown src
@@ -724,12 +751,34 @@ namespace eval ::msgcat::test {
mcset foo k1 v1
} -cleanup {
mclocale $locale
+ namespace delete ::foo
} -body {
- namespace eval ::msgcat::test::sub {
+ namespace eval ::foo {
list [::msgcat::mcexists k1]\
- [::msgcat::mcexists -exactnamespace k1]
+ [::msgcat::mcexists -namespace ::msgcat::test k1]
}
- } -result {1 0}
+ } -result {0 1}
+
+ test msgcat-9.6 {mcexists -namespace ns parameter} -setup {
+ mcforgetpackage
+ variable locale [mclocale]
+ mclocale foo_bar
+ mcset foo k1 v1
+ } -cleanup {
+ mclocale $locale
+ namespace delete ::foo
+ } -body {
+ namespace eval ::foo {
+ list [::msgcat::mcexists k1]\
+ [::msgcat::mcexists -namespace ::msgcat::test k1]
+ }
+ } -result {0 1}
+
+ test msgcat-9.7 {mcexists -namespace - ns argument missing} -body {
+ mcexists -namespace src
+ } -returnCodes 1\
+ -result {Argument missing for switch "-namespace"}
+
# Tests msgcat-10.*: [mcloadedlocales]
@@ -811,13 +860,18 @@ namespace eval ::msgcat::test {
test msgcat-12.1 {mcpackagelocale no subcommand} -body {
mcpackagelocale
} -returnCodes 1\
- -result {wrong # args: should be "mcpackagelocale subcommand ?locale?"}
+ -result {wrong # args: should be "mcpackagelocale subcommand ?arg ...?"}
test msgcat-12.2 {mclpackagelocale wrong subcommand} -body {
mcpackagelocale junk
} -returnCodes 1\
-result {unknown subcommand "junk": must be clear, get, isset, loaded, present, set, or unset}
+ test msgcat-12.2.1 {mclpackagelocale set multiple args} -body {
+ mcpackagelocale set a b
+ } -returnCodes 1\
+ -result {wrong # args: should be "mcpackagelocale set ?locale?"}
+
test msgcat-12.3 {mcpackagelocale set} -setup {
variable locale [mclocale]
} -cleanup {
@@ -922,6 +976,30 @@ namespace eval ::msgcat::test {
list [mcpackagelocale present foo] [mcpackagelocale present bar]
} -result {0 1}
+ test msgcat-12.11 {mcpackagelocale custom preferences} -setup {
+ variable locale [mclocale]
+ } -cleanup {
+ mclocale $locale
+ mcforgetpackage
+ } -body {
+ mclocale foo
+ set res [list [mcpackagelocale preferences]]
+ mcpackagelocale preferences bar {}
+ lappend res [mcpackagelocale preferences]
+ } -result {{foo {}} {bar {}}}
+
+ test msgcat-12.12 {mcpackagelocale preferences -> no isset} -setup {
+ variable locale [mclocale]
+ } -cleanup {
+ mclocale $locale
+ mcforgetpackage
+ } -body {
+ mclocale foo
+ mcpackagelocale preferences
+ mcpackagelocale isset
+ } -result {0}
+
+
# Tests msgcat-13.*: [mcpackageconfig subcmds]
test msgcat-13.1 {mcpackageconfig no subcommand} -body {
@@ -1073,8 +1151,212 @@ namespace eval ::msgcat::test {
} -returnCodes 1\
-result {fail}
+
+ # Tests msgcat-15.*: tcloo coverage
+
+ # There are 4 use-cases, where 3 must be tested now:
+ # - namespace defined, in class definition, class defined oo, classless
+
+ test msgcat-15.1 {mc in class setup} -setup {
+ # full namespace is ::msgcat::test:bar
+ namespace eval bar {
+ ::msgcat::mcset foo_BAR con2 con2bar
+ oo::class create ClassCur
+ }
+ variable locale [mclocale]
+ mclocale foo_BAR
+ } -cleanup {
+ mclocale $locale
+ namespace eval bar {::msgcat::mcforgetpackage}
+ namespace delete bar
+ } -body {
+ oo::define bar::ClassCur msgcat::mc con2
+ } -result con2bar
+
+ test msgcat-15.2 {mc in class} -setup {
+ # full namespace is ::msgcat::test:bar
+ namespace eval bar {
+ ::msgcat::mcset foo_BAR con2 con2bar
+ oo::class create ClassCur
+ oo::define ClassCur method method1 {} {::msgcat::mc con2}
+ }
+ # full namespace is ::msgcat::test:baz
+ namespace eval baz {
+ set ObjCur [::msgcat::test::bar::ClassCur new]
+ }
+ variable locale [mclocale]
+ mclocale foo_BAR
+ } -cleanup {
+ mclocale $locale
+ namespace eval bar {::msgcat::mcforgetpackage}
+ namespace delete bar baz
+ } -body {
+ $baz::ObjCur method1
+ } -result con2bar
+
+ test msgcat-15.3 {mc in classless object} -setup {
+ # full namespace is ::msgcat::test:bar
+ namespace eval bar {
+ ::msgcat::mcset foo_BAR con2 con2bar
+ oo::object create ObjCur
+ oo::objdefine ObjCur method method1 {} {::msgcat::mc con2}
+ }
+ variable locale [mclocale]
+ mclocale foo_BAR
+ } -cleanup {
+ mclocale $locale
+ namespace eval bar {::msgcat::mcforgetpackage}
+ namespace delete bar
+ } -body {
+ bar::ObjCur method1
+ } -result con2bar
+
+ test msgcat-15.4 {mc in classless object with explicite namespace eval}\
+ -setup {
+ # full namespace is ::msgcat::test:bar
+ namespace eval bar {
+ ::msgcat::mcset foo_BAR con2 con2bar
+ oo::object create ObjCur
+ oo::objdefine ObjCur method method1 {} {
+ namespace eval ::msgcat::test::baz {
+ ::msgcat::mc con2
+ }
+ }
+ }
+ namespace eval baz {
+ ::msgcat::mcset foo_BAR con2 con2baz
+ }
+ variable locale [mclocale]
+ mclocale foo_BAR
+ } -cleanup {
+ mclocale $locale
+ namespace eval bar {::msgcat::mcforgetpackage}
+ namespace eval baz {::msgcat::mcforgetpackage}
+ namespace delete bar baz
+ } -body {
+ bar::ObjCur method1
+ } -result con2baz
+
+ # Test msgcat-16.*: command mcpackagenamespaceget
+
+ test msgcat-16.1 {mcpackagenamespaceget in namespace procedure} -body {
+ namespace eval baz {msgcat::mcpackagenamespaceget}
+ } -result ::msgcat::test::baz
+
+ test msgcat-16.2 {mcpackagenamespaceget in class setup} -setup {
+ namespace eval bar {
+ oo::class create ClassCur
+ oo::define ClassCur variable a
+ }
+ } -cleanup {
+ namespace delete bar
+ } -body {
+ oo::define bar::ClassCur msgcat::mcpackagenamespaceget
+ } -result ::msgcat::test::bar
+
+ test msgcat-16.3 {mcpackagenamespaceget in class} -setup {
+ namespace eval bar {
+ oo::class create ClassCur
+ oo::define ClassCur method method1 {} {msgcat::mcpackagenamespaceget}
+ }
+ namespace eval baz {
+ set ObjCur [::msgcat::test::bar::ClassCur new]
+ }
+ } -cleanup {
+ namespace delete bar baz
+ } -body {
+ $baz::ObjCur method1
+ } -result ::msgcat::test::bar
+
+ test msgcat-16.4 {mcpackagenamespaceget in classless object} -setup {
+ namespace eval bar {
+ oo::object create ObjCur
+ oo::objdefine ObjCur method method1 {} {msgcat::mcpackagenamespaceget}
+ }
+ } -cleanup {
+ namespace delete bar
+ } -body {
+ bar::ObjCur method1
+ } -result ::msgcat::test::bar
+
+ test msgcat-16.5\
+ {mcpackagenamespaceget in classless object with explicite namespace eval}\
+ -setup {
+ namespace eval bar {
+ oo::object create ObjCur
+ oo::objdefine ObjCur method method1 {} {
+ namespace eval ::msgcat::test::baz {
+ msgcat::mcpackagenamespaceget
+ }
+ }
+ }
+ } -cleanup {
+ namespace delete bar baz
+ } -body {
+ bar::ObjCur method1
+ } -result ::msgcat::test::baz
+
+
+ # Test msgcat-17.*: mcn command
+
+ test msgcat-17.1 {mcn no parameters} -body {
+ mcn
+ } -returnCodes 1\
+ -result {wrong # args: should be "mcn ns src ?arg ...?"}
+
+ test msgcat-17.2 {mcn} -setup {
+ namespace eval bar {::msgcat::mcset foo_BAR con1 con1bar}
+ variable locale [mclocale]
+ mclocale foo_BAR
+ } -cleanup {
+ mclocale $locale
+ } -body {
+ ::msgcat::mcn [namespace current]::bar con1
+ } -result con1bar
+
+
interp bgerror {} $bgerrorsaved
+ # Tests msgcat-15.*: [mcutil]
+
+ test msgcat-15.1 {mcutil - no argument} -body {
+ mcutil
+ } -returnCodes 1\
+ -result {wrong # args: should be "mcutil subcommand ?arg ...?"}
+
+ test msgcat-15.2 {mcutil - wrong argument} -body {
+ mcutil junk
+ } -returnCodes 1\
+ -result {unknown subcommand "junk": must be getpreferences, or getsystemlocale}
+
+ test msgcat-15.3 {mcutil - partial argument} -body {
+ mcutil getsystem
+ } -returnCodes 1\
+ -result {unknown subcommand "getsystem": must be getpreferences, or getsystemlocale}
+
+ test msgcat-15.4 {mcutil getpreferences - no argument} -body {
+ mcutil getpreferences
+ } -returnCodes 1\
+ -result {wrong # args: should be "mcutil getpreferences locale"}
+
+ test msgcat-15.5 {mcutil getpreferences - DE_de} -body {
+ mcutil getpreferences DE_de
+ } -result {de_de de {}}
+
+ test msgcat-15.6 {mcutil getsystemlocale - wrong argument} -body {
+ mcutil getsystemlocale DE_de
+ } -returnCodes 1\
+ -result {wrong # args: should be "mcutil getsystemlocale"}
+
+ # The result is system dependent
+ # So just test if it runs
+ # The environment variable version was test with test 0.x
+ test msgcat-15.7 {mcutil getsystemlocale} -body {
+ mcutil getsystemlocale
+ set ok ok
+ } -result {ok}
+
+
cleanupTests
}
namespace delete ::msgcat::test
diff --git a/tests/obj.test b/tests/obj.test
index 833c906..cb62d3f 100644
--- a/tests/obj.test
+++ b/tests/obj.test
@@ -30,7 +30,6 @@ test obj-1.1 {Tcl_AppendAllObjTypes, and InitTypeTable, Tcl_RegisterObjType} tes
bytecode
cmdName
dict
- end-offset
regexp
string
} {
@@ -52,15 +51,6 @@ test obj-2.2 {Tcl_GetObjType and Tcl_ConvertToType} testobj {
lappend result [testobj refcount 1]
} {{} 12 12 bytearray 3}
-test obj-3.1 {Tcl_ConvertToType error} testobj {
- list [testdoubleobj set 1 12.34] \
- [catch {testobj convert 1 end-offset} msg] \
- $msg
-} {12.34 1 {bad index "12.34": must be end?[+-]integer?}}
-test obj-3.2 {Tcl_ConvertToType error, "empty string" object} testobj {
- list [testobj newobj 1] [catch {testobj convert 1 end-offset} msg] $msg
-} {{} 1 {bad index "": must be end?[+-]integer?}}
-
test obj-4.1 {Tcl_NewObj and AllocateFreeObjects} testobj {
set result ""
lappend result [testobj freeallvars]
@@ -551,43 +541,6 @@ test obj-30.1 {Ref counting and object deletion, simple types} testobj {
} {{} 1024 1024 int 4 4 0 int 3 2}
-test obj-31.1 {regenerate string rep of "end"} testobj {
- testobj freeallvars
- teststringobj set 1 end
- testobj convert 1 end-offset
- testobj invalidateStringRep 1
-} end
-test obj-31.2 {regenerate string rep of "end-1"} testobj {
- testobj freeallvars
- teststringobj set 1 end-0x1
- testobj convert 1 end-offset
- testobj invalidateStringRep 1
-} end-1
-test obj-31.3 {regenerate string rep of "end--1"} testobj {
- testobj freeallvars
- teststringobj set 1 end--0x1
- testobj convert 1 end-offset
- testobj invalidateStringRep 1
-} end--1
-test obj-31.4 {regenerate string rep of "end-bigInteger"} testobj {
- testobj freeallvars
- teststringobj set 1 end-0x7fffffff
- testobj convert 1 end-offset
- testobj invalidateStringRep 1
-} end-2147483647
-test obj-31.5 {regenerate string rep of "end--bigInteger"} testobj {
- testobj freeallvars
- teststringobj set 1 end--0x7fffffff
- testobj convert 1 end-offset
- testobj invalidateStringRep 1
-} end--2147483647
-test obj-31.6 {regenerate string rep of "end--bigInteger"} {testobj longIs32bit} {
- testobj freeallvars
- teststringobj set 1 end--0x80000000
- testobj convert 1 end-offset
- testobj invalidateStringRep 1
-} end--2147483648
-
test obj-32.1 {freeing very large object trees} {
set x {}
for {set i 0} {$i<100000} {incr i} {
diff --git a/tests/oo.test b/tests/oo.test
index b9c5067..2d23a3c 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -13,6 +13,13 @@ if {"::tcltest" in [namespace children]} {
namespace import -force ::tcltest::*
}
+
+# The foundational objects oo::object and oo::class are sensitive to reference
+# counting errors and are deallocated only when an interp is deleted, so in
+# this test suite, interp creation and interp deletion are often used in
+# leaktests in order to leverage this sensitivity.
+
+
testConstraint memory [llength [info commands memory]]
if {[testConstraint memory]} {
proc getbytes {} {
@@ -47,7 +54,7 @@ test oo-0.2 {basic test of OO's ability to clean up its initial state} {
} {}
test oo-0.3 {basic test of OO's ability to clean up its initial state} -body {
leaktest {
- [oo::object new] destroy
+ [oo::object new] destroy
}
} -constraints memory -result 0
test oo-0.4 {basic test of OO's ability to clean up its initial state} -body {
@@ -57,7 +64,13 @@ test oo-0.4 {basic test of OO's ability to clean up its initial state} -body {
foo destroy
}
} -constraints memory -result 0
-test oo-0.5 {testing literal leak on interp delete} memory {
+test oo-0.5.1 {testing object foundation cleanup} memory {
+ leaktest {
+ interp create foo
+ interp delete foo
+ }
+} 0
+test oo-0.5.2 {testing literal leak on interp delete} memory {
leaktest {
interp create foo
foo eval {oo::object new}
@@ -131,6 +144,10 @@ test oo-1.4 {basic test of OO functionality} -body {
test oo-1.4.1 {fully-qualified nested name} -body {
oo::object create ::one::two::three
} -result {::one::two::three}
+test oo-1.4.2 {automatic command name has same name as namespace} -body {
+ set obj [oo::object new]
+ expr {[info object namespace $obj] == $obj}
+} -result 1
test oo-1.5 {basic test of OO functionality} -body {
oo::object doesnotexist
} -returnCodes 1 -result {unknown method "doesnotexist": must be create, destroy or new}
@@ -261,7 +278,21 @@ test oo-1.18 {OO: create object in NS with same name as global cmd} -setup {
rename test-oo-1.18 {}
A destroy
} -result ::C
-test oo-1.18.1 {Bug 75b8433707: memory leak in oo-1.18} -setup {
+test oo-1.18.1 {no memory leak: superclass} -setup {
+} -constraints memory -body {
+
+ leaktest {
+ interp create t
+ t eval {
+ oo::class create A {
+ superclass oo::class
+ }
+ }
+ interp delete t
+ }
+} -cleanup {
+} -result 0
+test oo-1.18.2 {Bug 75b8433707: memory leak in oo-1.18} -setup {
proc test-oo-1.18 {} return
} -constraints memory -body {
leaktest {
@@ -274,7 +305,7 @@ test oo-1.18.1 {Bug 75b8433707: memory leak in oo-1.18} -setup {
} -cleanup {
rename test-oo-1.18 {}
} -result 0
-test oo-1.18.2 {Bug 21c144f0f5} -setup {
+test oo-1.18.3 {Bug 21c144f0f5} -setup {
interp create slave
} -body {
slave eval {
@@ -1498,7 +1529,56 @@ test oo-11.5 {OO: cleanup} {
return done
} done
-test oo-11.6 {
+test oo-11.6.1 {
+ OO: cleanup of when an class is mixed into itself
+} -constraints memory -body {
+ leaktest {
+ interp create interp1
+ oo::class create obj1
+ ::oo::define obj1 {self mixin [uplevel 1 {namespace which obj1}]}
+ rename obj1 {}
+ interp delete interp1
+ }
+} -result 0 -cleanup {
+}
+
+test oo-11.6.2 {
+ OO: cleanup ReleaseClassContents() where class is mixed into one of its
+ instances
+} -constraints memory -body {
+ leaktest {
+ interp create interp1
+ interp1 eval {
+ oo::class create obj1
+ ::oo::copy obj1 obj2
+ rename obj2 {}
+ rename obj1 {}
+ }
+ interp delete interp1
+ }
+} -result 0 -cleanup {
+}
+
+test oo-11.6.3 {
+ OO: cleanup ReleaseClassContents() where class is mixed into one of its
+ instances
+} -constraints memory -body {
+ leaktest {
+ interp create interp1
+ interp1 eval {
+ oo::class create obj1
+ ::oo::define obj1 {self mixin [uplevel 1 {namespace which obj1}]}
+
+ ::oo::copy obj1 obj2
+ rename obj2 {}
+ rename obj1 {}
+ }
+ interp delete interp1
+ }
+} -result 0 -cleanup {
+}
+
+test oo-11.6.4 {
OO: cleanup ReleaseClassContents() where class is mixed into one of its
instances
} -body {
@@ -1514,9 +1594,9 @@ test oo-11.6 {
# No segmentation fault
return done
-} -cleanup {
+} -result done -cleanup {
rename obj1 {}
-} -result done
+}
test oo-12.1 {OO: filters} {
oo::class create Aclass
@@ -1703,13 +1783,13 @@ test oo-13.2 {OO: changing an object's class} -body {
oo::objdefine foo class oo::class
} -cleanup {
foo destroy
-} -returnCodes 1 -result {may not change a non-class object into a class object}
+} -result {}
test oo-13.3 {OO: changing an object's class} -body {
oo::class create foo
oo::objdefine foo class oo::object
} -cleanup {
foo destroy
-} -returnCodes 1 -result {may not change a class object into a non-class object}
+} -result {}
test oo-13.4 {OO: changing an object's class} -body {
oo::class create foo {
method m {} {
@@ -2061,7 +2141,20 @@ test oo-15.12 {OO: object cloning with target NS} -setup {
Super destroy
catch {namespace delete ::existing}
} -result {::existing refers to an existing namespace}
-test oo-15.13 {OO: object cloning with target NS} -setup {
+test oo-15.13.1 {
+ OO: object cloning with target NS
+ Valgrind will report a leak if the reference count of the namespace isn't
+ properly incremented.
+} -setup {
+ oo::class create Cls {}
+} -body {
+ oo::copy Cls Cls2 ::dupens
+ return done
+} -cleanup {
+ Cls destroy
+ Cls2 destroy
+} -result done
+test oo-15.13.2 {OO: object cloning with target NS} -setup {
oo::class create Super
oo::class create Cls {superclass Super}
} -body {
@@ -3657,99 +3750,110 @@ test oo-31.2 {Bug 3111059: when objects and coroutines entangle} -setup {
cls destroy
} -result {0 {}}
-oo::class create SampleSlot {
- superclass oo::Slot
- constructor {} {
- variable contents {a b c} ops {}
- }
- method contents {} {variable contents; return $contents}
- method ops {} {variable ops; return $ops}
- method Get {} {
- variable contents
- variable ops
- lappend ops [info level] Get
- return $contents
- }
- method Set {lst} {
- variable contents $lst
- variable ops
- lappend ops [info level] Set $lst
- return
+proc SampleSlotSetup script {
+ set script0 {
+ oo::class create SampleSlot {
+ superclass oo::Slot
+ constructor {} {
+ variable contents {a b c} ops {}
+ }
+ method contents {} {variable contents; return $contents}
+ method ops {} {variable ops; return $ops}
+ method Get {} {
+ variable contents
+ variable ops
+ lappend ops [info level] Get
+ return $contents
+ }
+ method Set {lst} {
+ variable contents $lst
+ variable ops
+ lappend ops [info level] Set $lst
+ return
+ }
+ }
}
+ append script0 \n$script
}
-test oo-32.1 {TIP 380: slots - class test} -setup {
+proc SampleSlotCleanup script {
+ set script0 {
+ SampleSlot destroy
+ }
+ append script \n$script0
+}
+
+test oo-32.1 {TIP 380: slots - class test} -setup [SampleSlotSetup {
SampleSlot create sampleSlot
-} -body {
+}] -body {
list [info level] [sampleSlot contents] [sampleSlot ops]
-} -cleanup {
+} -cleanup [SampleSlotCleanup {
rename sampleSlot {}
-} -result {0 {a b c} {}}
-test oo-32.2 {TIP 380: slots - class test} -setup {
+}] -result {0 {a b c} {}}
+test oo-32.2 {TIP 380: slots - class test} -setup [SampleSlotSetup {
SampleSlot create sampleSlot
-} -body {
+}] -body {
list [info level] [sampleSlot -clear] \
[sampleSlot contents] [sampleSlot ops]
-} -cleanup {
+} -cleanup [SampleSlotCleanup {
rename sampleSlot {}
-} -result {0 {} {} {1 Set {}}}
-test oo-32.3 {TIP 380: slots - class test} -setup {
+}] -result {0 {} {} {1 Set {}}}
+test oo-32.3 {TIP 380: slots - class test} -setup [SampleSlotSetup {
SampleSlot create sampleSlot
-} -body {
+}] -body {
list [info level] [sampleSlot -append g h i] \
[sampleSlot contents] [sampleSlot ops]
-} -cleanup {
+} -cleanup [SampleSlotCleanup {
rename sampleSlot {}
-} -result {0 {} {a b c g h i} {1 Get 1 Set {a b c g h i}}}
-test oo-32.4 {TIP 380: slots - class test} -setup {
+}] -result {0 {} {a b c g h i} {1 Get 1 Set {a b c g h i}}}
+test oo-32.4 {TIP 380: slots - class test} -setup [SampleSlotSetup {
SampleSlot create sampleSlot
-} -body {
+}] -body {
list [info level] [sampleSlot -set d e f] \
[sampleSlot contents] [sampleSlot ops]
-} -cleanup {
+} -cleanup [SampleSlotCleanup {
rename sampleSlot {}
-} -result {0 {} {d e f} {1 Set {d e f}}}
-test oo-32.5 {TIP 380: slots - class test} -setup {
+}] -result {0 {} {d e f} {1 Set {d e f}}}
+test oo-32.5 {TIP 380: slots - class test} -setup [SampleSlotSetup {
SampleSlot create sampleSlot
-} -body {
+}] -body {
list [info level] [sampleSlot -set d e f] [sampleSlot -append g h i] \
[sampleSlot contents] [sampleSlot ops]
-} -cleanup {
+} -cleanup [SampleSlotCleanup {
rename sampleSlot {}
-} -result {0 {} {} {d e f g h i} {1 Set {d e f} 1 Get 1 Set {d e f g h i}}}
+}] -result {0 {} {} {d e f g h i} {1 Set {d e f} 1 Get 1 Set {d e f g h i}}}
-test oo-33.1 {TIP 380: slots - defaulting} -setup {
+test oo-33.1 {TIP 380: slots - defaulting} -setup [SampleSlotSetup {
set s [SampleSlot new]
-} -body {
+}] -body {
list [$s x y] [$s contents]
-} -cleanup {
+} -cleanup [SampleSlotCleanup {
rename $s {}
-} -result {{} {a b c x y}}
-test oo-33.2 {TIP 380: slots - defaulting} -setup {
+}] -result {{} {a b c x y}}
+test oo-33.2 {TIP 380: slots - defaulting} -setup [SampleSlotSetup {
set s [SampleSlot new]
-} -body {
+}] -body {
list [$s destroy; $s unknown] [$s contents]
-} -cleanup {
+} -cleanup [SampleSlotCleanup {
rename $s {}
-} -result {{} {a b c destroy unknown}}
-test oo-33.3 {TIP 380: slots - defaulting} -setup {
+}] -result {{} {a b c destroy unknown}}
+test oo-33.3 {TIP 380: slots - defaulting} -setup [SampleSlotSetup {
set s [SampleSlot new]
-} -body {
+}] -body {
oo::objdefine $s forward --default-operation my -set
list [$s destroy; $s unknown] [$s contents] [$s ops]
-} -cleanup {
+} -cleanup [SampleSlotCleanup {
rename $s {}
-} -result {{} unknown {1 Set destroy 1 Set unknown}}
-test oo-33.4 {TIP 380: slots - errors} -setup {
+}] -result {{} unknown {1 Set destroy 1 Set unknown}}
+test oo-33.4 {TIP 380: slots - errors} -setup [SampleSlotSetup {
set s [SampleSlot new]
-} -body {
+}] -body {
# Method names beginning with "-" are special to slots
$s -grill q
-} -returnCodes error -cleanup {
+} -returnCodes error -cleanup [SampleSlotCleanup {
rename $s {}
-} -result {unknown method "-grill": must be -append, -clear, -set, contents or ops}
-
-SampleSlot destroy
+}] -result \
+ {unknown method "-grill": must be -append, -clear, -set, contents or ops}
test oo-34.1 {TIP 380: slots - presence} -setup {
set obj [oo::object new]
@@ -3891,9 +3995,6 @@ test oo-35.6 {
rename obj {}
} -result done
-
-
-
test oo-36.1 {TIP #470: introspection within oo::define} {
oo::define oo::object self
} ::oo::object
diff --git a/tests/package.test b/tests/package.test
index bb938b8..2843701 100644
--- a/tests/package.test
+++ b/tests/package.test
@@ -625,6 +625,18 @@ test pkg-3.53 {Tcl_PkgRequire procedure, picking best stable version} -constrain
package require t
set x
} -result {1.1}
+test package-3.54 {Tcl_PkgRequire procedure, coroutine support} -setup {
+ package forget t
+} -body {
+ coroutine coro1 apply {{} {
+ package ifneeded t 2.1 {
+ yield
+ package provide t 2.1
+ }
+ package require t 2.1
+ }}
+ list [catch {coro1} msg] $msg
+} -match glob -result {0 2.1}
test package-4.1 {Tcl_PackageCmd procedure} -returnCodes error -body {
diff --git a/tests/process.test b/tests/process.test
new file mode 100644
index 0000000..fb3a5e2
--- /dev/null
+++ b/tests/process.test
@@ -0,0 +1,31 @@
+# process.test --
+#
+# This file contains a collection of tests for the tcl::process ensemble.
+# Sourcing this file into Tcl runs the tests and generates output for
+# errors. No output means no errors were found.
+#
+# Copyright (c) 2017 Frederic Bonnet
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ package require tcltest 2
+ namespace import -force ::tcltest::*
+}
+
+test process-1.1 {tcl::process command basic syntax} -returnCodes error -body {
+ tcl::process
+} -result {wrong # args: should be "tcl::process subcommand ?arg ...?"}
+test process-1.2 {tcl::process command basic syntax} -returnCodes error -body {
+ tcl::process ?
+} -match glob -result {unknown or ambiguous subcommand "?": must be autopurge, list, purge, or status}
+
+test process-2.1 {tcl::process autopurge get} {tcl::process autopurge} {1}
+test process-2.2 {tcl::process autopurge set true} {
+ tcl::process autopurge true
+ tcl::process autopurge
+} {1}
+test process-2.3 {tcl::process autopurge set false} {
+ tcl::process autopurge false
+ tcl::process autopurge
+} {0}
diff --git a/tests/safe.test b/tests/safe.test
index 33ee166..df60de6 100644
--- a/tests/safe.test
+++ b/tests/safe.test
@@ -180,17 +180,17 @@ test safe-6.3 {test safe interpreters knowledge of the world} {
# leaking infos, but they still do...
# high level general test
-test safe-7.1 {tests that everything works at high level} {
+test safe-7.1 {tests that everything works at high level} -body {
set i [safe::interpCreate]
# no error shall occur:
# (because the default access_path shall include 1st level sub dirs so
# package require in a slave works like in the master)
- set v [interp eval $i {package require http 1}]
+ set v [interp eval $i {package require http 2}]
# no error shall occur:
- interp eval $i {http_config}
+ interp eval $i {http::config}
safe::interpDelete $i
set v
-} 1.0
+} -match glob -result 2.*
test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -body {
set i [safe::interpCreate -nostat -nested 1 -accessPath [list [info library]]]
# should not add anything (p0)
diff --git a/tests/scan.test b/tests/scan.test
index 98c581b..1f32b9f 100644
--- a/tests/scan.test
+++ b/tests/scan.test
@@ -557,8 +557,8 @@ test scan-5.19 {bigint scanning invalid} -setup {
set a {};
} -body {
list [scan "207698809136909011942886895" \
- %llu a] $a
-} -returnCodes 1 -result {unsigned bignum scans are invalid}
+ %llu a] $a
+} -result {1 207698809136909011942886895}
test scan-6.1 {floating-point scanning} -setup {
set a {}; set b {}; set c {}; set d {}
diff --git a/tests/string.test b/tests/string.test
index cebaf4c..f4b94de 100644
--- a/tests/string.test
+++ b/tests/string.test
@@ -24,6 +24,7 @@ catch [list package require -exact Tcltest [info patchlevel]]
testConstraint testobj [expr {[info commands testobj] != {}}]
testConstraint testindexobj [expr {[info commands testindexobj] != {}}]
+testConstraint fullutf [expr {[format %c 0x010000] != "\ufffd"}]
# Used for constraining memory leak tests
testConstraint memory [llength [info commands memory]]
@@ -1203,6 +1204,9 @@ test string-11.54 {string match, failure} {
[string match *a*l*\u0000*cba* $longString] \
[string match *===* $longString]
} {0 1 1 1 0 0}
+test string-11.55 {string match, invalid binary optimization} {
+ [format string] match \u0141 [binary format c 65]
+} 0
test string-12.1 {string range} {
list [catch {string range} msg] $msg
@@ -1288,6 +1292,9 @@ test string-12.22 {string range, shimmering binary/index} {
binary scan $s a* x
string range $s $s end
} 000000001
+test string-12.23 {string range, surrogates, bug [11ae2be95dac9417]} fullutf {
+ list [string range a\U100000b 1 1] [string range a\U100000b 2 2] [string range a\U100000b 3 3]
+} [list \U100000 {} b]
test string-13.1 {string repeat} {
list [catch {string repeat} msg] $msg
@@ -1386,6 +1393,9 @@ test string-14.17 {string replace} {
test string-14.18 {string replace} {
string replace abcdefghijklmnop 10 9 XXX
} {abcdefghijklmnop}
+test string-14.19 {string replace} {
+ string replace {} -1 0 A
+} A
test string-15.1 {string tolower too few args} {
list [catch {string tolower} msg] $msg
diff --git a/tests/unixFCmd.test b/tests/unixFCmd.test
index 183c145..08eb664 100644
--- a/tests/unixFCmd.test
+++ b/tests/unixFCmd.test
@@ -221,12 +221,12 @@ test unixFCmd-2.5 {TclpCopyFile: copy attributes} -setup {
cleanup
} -constraints {unix notRoot} -body {
close [open tf1 a]
- file attributes tf1 -permissions 0472
+ file attributes tf1 -permissions 0o472
file copy tf1 tf2
file attributes tf2 -permissions
} -cleanup {
cleanup
-} -result 00472 ;# i.e. perms field of [exec ls -l tf2] is -r--rwx-w-
+} -result 0o472 ;# i.e. perms field of [exec ls -l tf2] is -r--rwx-w-
test unixFCmd-3.1 {CopyFile not done} {emptyTest unix notRoot} {
} {}
@@ -375,11 +375,11 @@ proc permcheck {testnum permList expected} {
set result
} $expected
}
-permcheck unixFCmd-17.5 rwxrwxrwx 00777
-permcheck unixFCmd-17.6 r--r---w- 00442
-permcheck unixFCmd-17.7 {0 u+rwx,g+r u-w o+rwx} {00000 00740 00540 00547}
-permcheck unixFCmd-17.11 --x--x--x 00111
-permcheck unixFCmd-17.12 {0 a+rwx} {00000 00777}
+permcheck unixFCmd-17.5 rwxrwxrwx 0o777
+permcheck unixFCmd-17.6 r--r---w- 0o442
+permcheck unixFCmd-17.7 {0 u+rwx,g+r u-w o+rwx} {00000 0o740 0o540 0o547}
+permcheck unixFCmd-17.11 --x--x--x 0o111
+permcheck unixFCmd-17.12 {0 a+rwx} {00000 0o777}
file delete -force -- foo.test
test unixFCmd-18.1 {Unix pwd} -constraints {unix notRoot nonPortable} -setup {
diff --git a/unix/Makefile.in b/unix/Makefile.in
index f3b9782..83a8aed 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -303,7 +303,7 @@ GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \
tclLiteral.o tclLoad.o tclMain.o tclNamesp.o tclNotify.o \
tclObj.o tclOptimize.o tclPanic.o tclParse.o tclPathObj.o tclPipe.o \
tclPkg.o tclPkgConfig.o tclPosixStr.o \
- tclPreserve.o tclProc.o tclRegexp.o \
+ tclPreserve.o tclProc.o tclProcess.o tclRegexp.o \
tclResolve.o tclResult.o tclScan.o tclStringObj.o \
tclStrToD.o tclThread.o \
tclThreadAlloc.o tclThreadJoin.o tclThreadStorage.o tclStubInit.o \
@@ -444,6 +444,7 @@ GENERIC_SRCS = \
$(GENERIC_DIR)/tclPosixStr.c \
$(GENERIC_DIR)/tclPreserve.c \
$(GENERIC_DIR)/tclProc.c \
+ $(GENERIC_DIR)/tclProcess.c \
$(GENERIC_DIR)/tclRegexp.c \
$(GENERIC_DIR)/tclResolve.c \
$(GENERIC_DIR)/tclResult.c \
@@ -829,7 +830,7 @@ install-libraries: libraries
else true; \
fi; \
done;
- @for i in opt0.4 http1.0 encoding ../tcl8 ../tcl8/8.4 ../tcl8/8.4/platform ../tcl8/8.5 ../tcl8/8.6; \
+ @for i in opt0.4 encoding ../tcl8 ../tcl8/8.4 ../tcl8/8.4/platform ../tcl8/8.5 ../tcl8/8.6; \
do \
if [ ! -d "$(SCRIPT_INSTALL_DIR)"/$$i ] ; then \
echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \
@@ -843,11 +844,6 @@ install-libraries: libraries
do \
$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"; \
done;
- @echo "Installing package http1.0 files to $(SCRIPT_INSTALL_DIR)/http1.0/";
- @for i in $(TOP_DIR)/library/http1.0/*.tcl ; \
- do \
- $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/http1.0; \
- done;
@echo "Installing package http 2.8.12 as a Tcl Module";
@$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.6/http-2.8.12.tm;
@echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/";
@@ -855,8 +851,8 @@ install-libraries: libraries
do \
$(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/opt0.4; \
done;
- @echo "Installing package msgcat 1.6.1 as a Tcl Module";
- @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.6.1.tm;
+ @echo "Installing package msgcat 1.7.0 as a Tcl Module";
+ @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.7/msgcat-1.7.0.tm;
@echo "Installing package tcltest 2.4.1 as a Tcl Module";
@$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.4.1.tm;
@@ -1293,6 +1289,9 @@ tclPreserve.o: $(GENERIC_DIR)/tclPreserve.c
tclProc.o: $(GENERIC_DIR)/tclProc.c $(COMPILEHDR) $(NREHDR)
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclProc.c
+tclProcess.o: $(GENERIC_DIR)/tclProcess.c
+ $(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclProcess.c
+
tclRegexp.o: $(GENERIC_DIR)/tclRegexp.c $(TCLREHDRS)
$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclRegexp.c
@@ -2010,7 +2009,7 @@ dist: $(UNIX_DIR)/configure $(UNIX_DIR)/tclConfig.h.in $(UNIX_DIR)/tcl.pc.in $(M
@mkdir $(DISTDIR)/library
cp -p $(TOP_DIR)/license.terms $(TOP_DIR)/library/*.tcl \
$(TOP_DIR)/library/tclIndex $(DISTDIR)/library
- for i in http1.0 http opt msgcat reg dde tcltest platform; \
+ for i in http opt msgcat reg dde tcltest platform; \
do \
mkdir $(DISTDIR)/library/$$i ;\
cp -p $(TOP_DIR)/library/$$i/*.tcl $(DISTDIR)/library/$$i; \
diff --git a/unix/configure b/unix/configure
index e3e1b42..afc6842 100755
--- a/unix/configure
+++ b/unix/configure
@@ -4260,8 +4260,6 @@ $as_echo "#define TCL_CFGVAL_ENCODING \"iso8859-1\"" >>confdefs.h
#--------------------------------------------------------------------
# On a few very rare systems, all of the libm.a stuff is
# already in libc.a. Set compiler flags accordingly.
- # Also, Linux requires the "ieee" library for math to work
- # right (and it must appear before "-lm").
#--------------------------------------------------------------------
ac_fn_c_check_func "$LINENO" "sin" "ac_cv_func_sin"
@@ -4271,40 +4269,6 @@ else
MATH_LIBS="-lm"
fi
- { $as_echo "$as_me:${as_lineno-$LINENO}: checking for main in -lieee" >&5
-$as_echo_n "checking for main in -lieee... " >&6; }
-if ${ac_cv_lib_ieee_main+:} false; then :
- $as_echo_n "(cached) " >&6
-else
- ac_check_lib_save_LIBS=$LIBS
-LIBS="-lieee $LIBS"
-cat confdefs.h - <<_ACEOF >conftest.$ac_ext
-/* end confdefs.h. */
-
-
-int
-main ()
-{
-return main ();
- ;
- return 0;
-}
-_ACEOF
-if ac_fn_c_try_link "$LINENO"; then :
- ac_cv_lib_ieee_main=yes
-else
- ac_cv_lib_ieee_main=no
-fi
-rm -f core conftest.err conftest.$ac_objext \
- conftest$ac_exeext conftest.$ac_ext
-LIBS=$ac_check_lib_save_LIBS
-fi
-{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_lib_ieee_main" >&5
-$as_echo "$ac_cv_lib_ieee_main" >&6; }
-if test "x$ac_cv_lib_ieee_main" = xyes; then :
- MATH_LIBS="-lieee $MATH_LIBS"
-fi
-
#--------------------------------------------------------------------
# Interactive UNIX requires -linet instead of -lsocket, plus it
@@ -6908,7 +6872,7 @@ else
tcl_type_64bit="long long"
fi
rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext
- # See if we should use long anyway Note that we substitute in the
+ # See if we could use long anyway Note that we substitute in the
# type that is our current guess for a 64-bit type inside this check
# program, so it should be modified only carefully...
cat confdefs.h - <<_ACEOF >conftest.$ac_ext
@@ -6934,8 +6898,8 @@ fi
$as_echo "#define TCL_WIDE_INT_IS_LONG 1" >>confdefs.h
- { $as_echo "$as_me:${as_lineno-$LINENO}: result: using long" >&5
-$as_echo "using long" >&6; }
+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5
+$as_echo "yes" >&6; }
else
cat >>confdefs.h <<_ACEOF
diff --git a/unix/tcl.m4 b/unix/tcl.m4
index fa7601e..a6abef1 100644
--- a/unix/tcl.m4
+++ b/unix/tcl.m4
@@ -2370,12 +2370,9 @@ AC_DEFUN([SC_TCL_LINK_LIBS], [
#--------------------------------------------------------------------
# On a few very rare systems, all of the libm.a stuff is
# already in libc.a. Set compiler flags accordingly.
- # Also, Linux requires the "ieee" library for math to work
- # right (and it must appear before "-lm").
#--------------------------------------------------------------------
AC_CHECK_FUNC(sin, MATH_LIBS="", MATH_LIBS="-lm")
- AC_CHECK_LIB(ieee, main, [MATH_LIBS="-lieee $MATH_LIBS"])
#--------------------------------------------------------------------
# Interactive UNIX requires -linet instead of -lsocket, plus it
@@ -2492,15 +2489,15 @@ AC_DEFUN([SC_TCL_64BIT_FLAGS], [
# See if the compiler knows natively about __int64
AC_TRY_COMPILE(,[__int64 value = (__int64) 0;],
tcl_type_64bit=__int64, tcl_type_64bit="long long")
- # See if we should use long anyway Note that we substitute in the
+ # See if we could use long anyway Note that we substitute in the
# type that is our current guess for a 64-bit type inside this check
# program, so it should be modified only carefully...
AC_TRY_COMPILE(,[switch (0) {
case 1: case (sizeof(]${tcl_type_64bit}[)==sizeof(long)): ;
}],tcl_cv_type_64bit=${tcl_type_64bit})])
if test "${tcl_cv_type_64bit}" = none ; then
- AC_DEFINE(TCL_WIDE_INT_IS_LONG, 1, [Are wide integers to be implemented with C 'long's?])
- AC_MSG_RESULT([using long])
+ AC_DEFINE(TCL_WIDE_INT_IS_LONG, 1, [Do 'long' and 'long long' have the same size (64-bit)?])
+ AC_MSG_RESULT([yes])
else
AC_DEFINE_UNQUOTED(TCL_WIDE_INT_TYPE,${tcl_cv_type_64bit},
[What type should be used to define wide integers?])
diff --git a/unix/tclConfig.h.in b/unix/tclConfig.h.in
index 4902083..c284cba 100644
--- a/unix/tclConfig.h.in
+++ b/unix/tclConfig.h.in
@@ -394,7 +394,7 @@
/* Does this platform have wide high-resolution clicks? */
#undef TCL_WIDE_CLICKS
-/* Are wide integers to be implemented with C 'long's? */
+/* Do Tcl_WideInt, 'long' and 'long long' all have the same size (64-bit) ? */
#undef TCL_WIDE_INT_IS_LONG
/* What type should be used to define wide integers? */
diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c
index cc66569..630460a 100644
--- a/unix/tclUnixInit.c
+++ b/unix/tclUnixInit.c
@@ -577,12 +577,6 @@ TclpSetInitialEncodings(void)
Tcl_DStringFree(&encodingName);
}
-void
-TclpSetInterfaces(void)
-{
- /* do nothing */
-}
-
static const char *
SearchKnownEncodings(
const char *encoding)
diff --git a/unix/tclUnixPort.h b/unix/tclUnixPort.h
index d464f05..86f1dd0 100644
--- a/unix/tclUnixPort.h
+++ b/unix/tclUnixPort.h
@@ -87,8 +87,8 @@ typedef off_t Tcl_SeekOffset;
typedef unsigned short WCHAR;
__declspec(dllimport) extern __stdcall int GetModuleHandleExW(unsigned int, const char *, void *);
__declspec(dllimport) extern __stdcall int GetModuleFileNameW(void *, const char *, int);
- __declspec(dllimport) extern __stdcall int WideCharToMultiByte(int, int, const char *, int,
- const char *, int, const char *, const char *);
+ __declspec(dllimport) extern __stdcall int WideCharToMultiByte(int, int, const void *, int,
+ char *, int, const char *, void *);
__declspec(dllimport) extern __stdcall int MultiByteToWideChar(int, int, const char *, int,
WCHAR *, int);
__declspec(dllimport) extern __stdcall void OutputDebugStringW(const WCHAR *);
diff --git a/win/Makefile.in b/win/Makefile.in
index a3275ba..56ccb4d 100644
--- a/win/Makefile.in
+++ b/win/Makefile.in
@@ -285,6 +285,7 @@ GENERIC_OBJS = \
tclPosixStr.$(OBJEXT) \
tclPreserve.$(OBJEXT) \
tclProc.$(OBJEXT) \
+ tclProcess.$(OBJEXT) \
tclRegexp.$(OBJEXT) \
tclResolve.$(OBJEXT) \
tclResult.$(OBJEXT) \
@@ -630,7 +631,7 @@ install-libraries: libraries install-tzdata install-msgs
else true; \
fi; \
done;
- @for i in http1.0 opt0.4 encoding ../tcl8 ../tcl8/8.4 ../tcl8/8.4/platform ../tcl8/8.5 ../tcl8/8.6; \
+ @for i in opt0.4 encoding ../tcl8 ../tcl8/8.4 ../tcl8/8.4/platform ../tcl8/8.5 ../tcl8/8.6; \
do \
if [ ! -d $(SCRIPT_INSTALL_DIR)/$$i ] ; then \
echo "Making directory $(SCRIPT_INSTALL_DIR)/$$i"; \
@@ -652,11 +653,6 @@ install-libraries: libraries install-tzdata install-msgs
do \
$(COPY) "$$i" "$(SCRIPT_INSTALL_DIR)"; \
done;
- @echo "Installing library http1.0 directory";
- @for j in $(ROOT_DIR)/library/http1.0/*.tcl; \
- do \
- $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \
- done;
@echo "Installing package http 2.8.12 as a Tcl Module";
@$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.6/http-2.8.12.tm;
@echo "Installing library opt0.4 directory";
@@ -664,8 +660,8 @@ install-libraries: libraries install-tzdata install-msgs
do \
$(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/opt0.4"; \
done;
- @echo "Installing package msgcat 1.6.1 as a Tcl Module";
- @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.6.1.tm;
+ @echo "Installing package msgcat 1.7.0 as a Tcl Module";
+ @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.7/msgcat-1.7.0.tm;
@echo "Installing package tcltest 2.4.0 as a Tcl Module";
@$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.4.0.tm;
@echo "Installing package platform 1.0.14 as a Tcl Module";
diff --git a/win/buildall.vc.bat b/win/buildall.vc.bat
index deb9e39..cb136be 100644
--- a/win/buildall.vc.bat
+++ b/win/buildall.vc.bat
@@ -38,7 +38,9 @@ if defined WINDOWSSDKDIR (goto :startBuilding)
:: might not be correct. You should call it yourself prior to running
:: this batchfile.
::
-call "C:\Program Files\Microsoft Developer Studio\vc98\bin\vcvars32.bat"
+REM call "C:\Program Files\Microsoft Developer Studio\vc98\bin\vcvars32.bat"
+set "VSCMD_START_DIR=%CD%"
+call "C:\Program Files (x86)\Microsoft Visual Studio\2017\Community\Common7\Tools\VsDevCmd.bat"
if errorlevel 1 (goto no_vcvars)
:startBuilding
diff --git a/win/makefile.vc b/win/makefile.vc
index de80452..7ed4c63 100644
--- a/win/makefile.vc
+++ b/win/makefile.vc
@@ -218,6 +218,7 @@ COREOBJS = \
$(TMP_DIR)\tclPosixStr.obj \
$(TMP_DIR)\tclPreserve.obj \
$(TMP_DIR)\tclProc.obj \
+ $(TMP_DIR)\tclProcess.obj \
$(TMP_DIR)\tclRegexp.obj \
$(TMP_DIR)\tclResolve.obj \
$(TMP_DIR)\tclResult.obj \
@@ -860,9 +861,6 @@ install-libraries: tclConfig tcl-nmake install-msgs install-tzdata
@$(CPY) "$(WINDIR)\targets.vc" "$(LIB_INSTALL_DIR)\nmake\"
@$(CPY) "$(WINDIR)\nmakehlp.c" "$(LIB_INSTALL_DIR)\nmake\"
@$(CPY) "$(OUT_DIR)\tcl.nmake" "$(LIB_INSTALL_DIR)\nmake\"
- @echo Installing library http1.0 directory
- @$(CPY) "$(ROOT)\library\http1.0\*.tcl" \
- "$(SCRIPT_INSTALL_DIR)\http1.0\"
@echo Installing library opt0.4 directory
@$(CPY) "$(ROOT)\library\opt\*.tcl" \
"$(SCRIPT_INSTALL_DIR)\opt0.4\"
@@ -871,7 +869,7 @@ install-libraries: tclConfig tcl-nmake install-msgs install-tzdata
"$(SCRIPT_INSTALL_DIR)\..\tcl8\8.6\http-$(PKG_HTTP_VER).tm"
@echo Installing package msgcat $(PKG_MSGCAT_VER) as a Tcl Module
@$(COPY) "$(ROOT)\library\msgcat\msgcat.tcl" \
- "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.5\msgcat-$(PKG_MSGCAT_VER).tm"
+ "$(SCRIPT_INSTALL_DIR)\..\tcl8\8.7\msgcat-$(PKG_MSGCAT_VER).tm"
@echo Installing package tcltest $(PKG_TCLTEST_VER) as a Tcl Module
@$(COPY) "$(ROOT)\library\tcltest\tcltest.tcl" \
"$(SCRIPT_INSTALL_DIR)\..\tcl8\8.5\tcltest-$(PKG_TCLTEST_VER).tm"
diff --git a/win/nmakehlp.c b/win/nmakehlp.c
index 025bb99..b759020 100644
--- a/win/nmakehlp.c
+++ b/win/nmakehlp.c
@@ -14,13 +14,8 @@
#define _CRT_SECURE_NO_DEPRECATE
#include <windows.h>
-#define NO_SHLWAPI_GDI
-#define NO_SHLWAPI_STREAM
-#define NO_SHLWAPI_REG
-#include <shlwapi.h>
#pragma comment (lib, "user32.lib")
#pragma comment (lib, "kernel32.lib")
-#pragma comment (lib, "shlwapi.lib")
#include <stdio.h>
#include <math.h>
@@ -74,7 +69,7 @@ main(
char msg[300];
DWORD dwWritten;
int chars;
- char *s;
+ const char *s;
/*
* Make sure children (cl.exe and link.exe) are kept quiet.
@@ -688,6 +683,17 @@ SubstituteFile(
return 0;
}
+BOOL FileExists(LPCTSTR szPath)
+{
+#ifndef INVALID_FILE_ATTRIBUTES
+ #define INVALID_FILE_ATTRIBUTES ((DWORD)-1)
+#endif
+ DWORD pathAttr = GetFileAttributes(szPath);
+ return (pathAttr != INVALID_FILE_ATTRIBUTES &&
+ !(pathAttr & FILE_ATTRIBUTE_DIRECTORY));
+}
+
+
/*
* QualifyPath --
*
@@ -701,13 +707,8 @@ QualifyPath(
const char *szPath)
{
char szCwd[MAX_PATH + 1];
- char szTmp[MAX_PATH + 1];
- char *p;
- GetCurrentDirectory(MAX_PATH, szCwd);
- while ((p = strchr(szPath, '/')) && *p)
- *p = '\\';
- PathCombine(szTmp, szCwd, szPath);
- PathCanonicalize(szCwd, szTmp);
+
+ GetFullPathName(szPath, sizeof(szCwd)-1, szCwd, NULL);
printf("%s\n", szCwd);
return 0;
}
@@ -765,7 +766,7 @@ static int LocateDependencyHelper(const char *dir, const char *keypath)
strncpy(path+dirlen+1, finfo.cFileName, sublen);
path[dirlen+1+sublen] = '\\';
strncpy(path+dirlen+1+sublen+1, keypath, keylen+1);
- if (PathFileExists(path)) {
+ if (FileExists(path)) {
/* Found a match, print to stdout */
path[dirlen+1+sublen] = '\0';
QualifyPath(path);
diff --git a/win/rules-ext.vc b/win/rules-ext.vc
index 58c70fa..531e070 100644
--- a/win/rules-ext.vc
+++ b/win/rules-ext.vc
@@ -35,7 +35,7 @@ macro to the name of the project makefile.
!endif
# First locate the Tcl directory that we are working with.
-!ifdef TCLDIR
+!if "$(TCLDIR)" != ""
_RULESDIR = $(TCLDIR:/=\)
diff --git a/win/rules.vc b/win/rules.vc
index 0dda1f1..f93400c 100644
--- a/win/rules.vc
+++ b/win/rules.vc
@@ -24,7 +24,7 @@ _RULES_VC = 1
# For modifications that are not backward-compatible, you *must* change
# the major version.
RULES_VERSION_MAJOR = 1
-RULES_VERSION_MINOR = 1
+RULES_VERSION_MINOR = 2
# The PROJECT macro must be defined by parent makefile.
!if "$(PROJECT)" == ""
@@ -393,7 +393,7 @@ MSG = ^
!endif
-# If INSTALLDIR set to tcl installation root dir then reset to the
+# If INSTALLDIR set to Tcl installation root dir then reset to the
# lib dir for installing extensions
!if exist("$(_INSTALLDIR)\include\tcl.h")
_INSTALLDIR=$(_INSTALLDIR)\lib
@@ -1188,7 +1188,7 @@ RESFILE = $(TMP_DIR)\$(PROJECT).res
# SCRIPT_INSTALL_DIR - where scripts should be installed
# INCLUDE_INSTALL_DIR - where C include files should be installed
# DEMO_INSTALL_DIR - where demos should be installed
-# PRJ_INSTALL_DIR - where package will be installed (not set for tcl and tk)
+# PRJ_INSTALL_DIR - where package will be installed (not set for Tcl and Tk)
!if $(DOING_TCL) || $(DOING_TK)
LIB_INSTALL_DIR = $(_INSTALLDIR)\lib
@@ -1210,7 +1210,7 @@ BIN_INSTALL_DIR = $(PRJ_INSTALL_DIR)
DOC_INSTALL_DIR = $(PRJ_INSTALL_DIR)
SCRIPT_INSTALL_DIR = $(PRJ_INSTALL_DIR)
DEMO_INSTALL_DIR = $(PRJ_INSTALL_DIR)\demos
-INCLUDE_INSTALL_DIR = $(_TCLDIR)\include
+INCLUDE_INSTALL_DIR = $(_INSTALLDIR)\..\include
!endif
diff --git a/win/tcl.dsp b/win/tcl.dsp
index ad9c764..ab9ec26 100644
--- a/win/tcl.dsp
+++ b/win/tcl.dsp
@@ -1264,6 +1264,10 @@ SOURCE=..\generic\tclProc.c
# End Source File
# Begin Source File
+SOURCE=..\generic\tclProcess.c
+# End Source File
+# Begin Source File
+
SOURCE=..\generic\tclRegexp.c
# End Source File
# Begin Source File
diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c
index 95b8193..599c126 100644
--- a/win/tclWin32Dll.c
+++ b/win/tclWin32Dll.c
@@ -32,8 +32,6 @@ static HINSTANCE hInstance; /* HINSTANCE of this DLL. */
#define cpuid __asm __emit 0fh __asm __emit 0a2h
#endif
-static Tcl_Encoding winTCharEncoding = NULL;
-
/*
* The following declaration is for the VC++ DLL entry point.
*/
@@ -194,8 +192,6 @@ TclWinInit(
if (os.dwPlatformId != VER_PLATFORM_WIN32_NT) {
Tcl_Panic("Windows NT is the only supported platform");
}
-
- TclWinResetInterfaces();
}
/*
@@ -232,36 +228,10 @@ TclWinNoBackslash(
/*
*---------------------------------------------------------------------------
*
- * TclpSetInterfaces --
- *
- * A helper proc that initializes winTCharEncoding.
- *
- * Results:
- * None.
- *
- * Side effects:
- * None.
- *
- *---------------------------------------------------------------------------
- */
-
-void
-TclpSetInterfaces(void)
-{
- TclWinResetInterfaces();
- winTCharEncoding = Tcl_GetEncoding(NULL, "unicode");
-}
-
-/*
- *---------------------------------------------------------------------------
- *
* TclWinEncodingsCleanup --
*
- * Called during finalization to free up any encodings we use.
- *
- * We also clean up any memory allocated in our mount point map which is
- * used to follow certain kinds of symlinks. That code should never be
- * used once encodings are taken down.
+ * Called during finalization to clean up any memory allocated in our
+ * mount point map which is used to follow certain kinds of symlinks.
*
* Results:
* None.
@@ -277,8 +247,6 @@ TclWinEncodingsCleanup(void)
{
MountPointMap *dlIter, *dlIter2;
- TclWinResetInterfaces();
-
/*
* Clean up the mount point map.
*/
@@ -295,30 +263,6 @@ TclWinEncodingsCleanup(void)
}
/*
- *---------------------------------------------------------------------------
- *
- * TclWinResetInterfaces --
- *
- * Called during finalization to reset us to a safe state for reuse.
- *
- * Results:
- * None.
- *
- * Side effects:
- * None.
- *
- *---------------------------------------------------------------------------
- */
-void
-TclWinResetInterfaces(void)
-{
- if (winTCharEncoding != NULL) {
- Tcl_FreeEncoding(winTCharEncoding);
- winTCharEncoding = NULL;
- }
-}
-
-/*
*--------------------------------------------------------------------
*
* TclWinDriveLetterForVolMountPoint
@@ -481,39 +425,32 @@ TclWinDriveLetterForVolMountPoint(
*
* Tcl_WinUtfToTChar, Tcl_WinTCharToUtf --
*
- * Convert between UTF-8 and Unicode when running Windows NT or the
- * current ANSI code page when running Windows 95.
+ * Convert between UTF-8 and Unicode when running Windows.
*
- * On Mac, Unix, and Windows 95, all strings exchanged between Tcl and
- * the OS are "char" oriented. We need only one Tcl_Encoding to convert
- * between UTF-8 and the system's native encoding. We use NULL to
- * represent that encoding.
+ * On Mac and Unix, all strings exchanged between Tcl and the OS are
+ * "char" oriented. We need only one Tcl_Encoding to convert between
+ * UTF-8 and the system's native encoding. We use NULL to represent
+ * that encoding.
*
- * On NT, some strings exchanged between Tcl and the OS are "char"
+ * On Windows, some strings exchanged between Tcl and the OS are "char"
* oriented, while others are in Unicode. We need two Tcl_Encoding APIs
* depending on whether we are targeting a "char" or Unicode interface.
*
- * Calling Tcl_UtfToExternal() or Tcl_ExternalToUtf() with an encoding of
- * NULL should always used to convert between UTF-8 and the system's
+ * Calling Tcl_UtfToExternal() or Tcl_ExternalToUtf() with an encoding
+ * of NULL should always used to convert between UTF-8 and the system's
* "char" oriented encoding. The following two functions are used in
- * Windows-specific code to convert between UTF-8 and Unicode strings
- * (NT) or "char" strings(95). This saves you the trouble of writing the
+ * Windows-specific code to convert between UTF-8 and Unicode strings.
+ * This saves you the trouble of writing the
* following type of fragment over and over:
*
- * if (running NT) {
- * encoding <- Tcl_GetEncoding("unicode");
- * nativeBuffer <- UtfToExternal(encoding, utfBuffer);
- * Tcl_FreeEncoding(encoding);
- * } else {
- * nativeBuffer <- UtfToExternal(NULL, utfBuffer);
- * }
- *
- * By convention, in Windows a TCHAR is a character in the ANSI code page
- * on Windows 95, a Unicode character on Windows NT. If you plan on
- * targeting a Unicode interfaces when running on NT and a "char"
- * oriented interface while running on 95, these functions should be
- * used. If you plan on targetting the same "char" oriented function on
- * both 95 and NT, use Tcl_UtfToExternal() with an encoding of NULL.
+ * encoding <- Tcl_GetEncoding("unicode");
+ * nativeBuffer <- UtfToExternal(encoding, utfBuffer);
+ * Tcl_FreeEncoding(encoding);
+ *
+ * By convention, in Windows a TCHAR is a Unicode character. If you plan
+ * on targeting a Unicode interface when running on Windows, these
+ * functions should be used. If you plan on targetting a "char" oriented
+ * function on Windows, use Tcl_UtfToExternal() with an encoding of NULL.
*
* Results:
* The result is a pointer to the string in the desired target encoding.
@@ -529,26 +466,47 @@ TclWinDriveLetterForVolMountPoint(
TCHAR *
Tcl_WinUtfToTChar(
const char *string, /* Source string in UTF-8. */
- int len, /* Source string length in bytes, or < 0 for
+ int len, /* Source string length in bytes, or -1 for
* strlen(). */
Tcl_DString *dsPtr) /* Uninitialized or free DString in which the
* converted string is stored. */
{
- return (TCHAR *) Tcl_UtfToExternalDString(winTCharEncoding,
- string, len, dsPtr);
+ TCHAR *wp;
+ int size = MultiByteToWideChar(CP_UTF8, 0, string, len, 0, 0);
+
+ Tcl_DStringInit(dsPtr);
+ Tcl_DStringSetLength(dsPtr, 2*size+2);
+ wp = (TCHAR *)Tcl_DStringValue(dsPtr);
+ MultiByteToWideChar(CP_UTF8, 0, string, len, wp, size+1);
+ if (len == -1) --size; /* account for 0-byte at string end */
+ Tcl_DStringSetLength(dsPtr, 2*size);
+ wp[size] = 0;
+ return wp;
}
char *
Tcl_WinTCharToUtf(
- const TCHAR *string, /* Source string in Unicode when running NT,
- * ANSI when running 95. */
- int len, /* Source string length in bytes, or < 0 for
+ const TCHAR *string, /* Source string in Unicode. */
+ int len, /* Source string length in bytes, or -1 for
* platform-specific string length. */
Tcl_DString *dsPtr) /* Uninitialized or free DString in which the
* converted string is stored. */
{
- return Tcl_ExternalToUtfDString(winTCharEncoding,
- (const char *) string, len, dsPtr);
+ char *p;
+ int size;
+
+ if (len > 0) {
+ len /= 2;
+ }
+ size = WideCharToMultiByte(CP_UTF8, 0, string, len, 0, 0, NULL, NULL);
+ Tcl_DStringInit(dsPtr);
+ Tcl_DStringSetLength(dsPtr, size+1);
+ p = (char *)Tcl_DStringValue(dsPtr);
+ WideCharToMultiByte(CP_UTF8, 0, string, len, p, size, NULL, NULL);
+ if (len == -1) --size; /* account for 0-byte at string end */
+ Tcl_DStringSetLength(dsPtr, size);
+ p[size] = 0;
+ return p;
}
/*
diff --git a/win/tclWinChan.c b/win/tclWinChan.c
index 2898db0..8ffb31f 100644
--- a/win/tclWinChan.c
+++ b/win/tclWinChan.c
@@ -1379,7 +1379,7 @@ TclWinOpenFileChannel(
infoPtr->flags = appendMode;
infoPtr->handle = handle;
infoPtr->dirty = 0;
- sprintf(channelName, "file%" TCL_I_MODIFIER "x", (size_t) infoPtr);
+ sprintf(channelName, "file%" TCL_Z_MODIFIER "x", (size_t) infoPtr);
infoPtr->channel = Tcl_CreateChannel(&fileChannelType, channelName,
infoPtr, permissions);
diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c
index d148872..92643cf 100644
--- a/win/tclWinConsole.c
+++ b/win/tclWinConsole.c
@@ -1320,7 +1320,7 @@ TclWinOpenConsoleChannel(
* for instance).
*/
- sprintf(channelName, "file%" TCL_I_MODIFIER "x", (size_t) infoPtr);
+ sprintf(channelName, "file%" TCL_Z_MODIFIER "x", (size_t) infoPtr);
infoPtr->channel = Tcl_CreateChannel(&consoleChannelType, channelName,
infoPtr, permissions);
diff --git a/win/tclWinDde.c b/win/tclWinDde.c
index 2589630..381db65 100644
--- a/win/tclWinDde.c
+++ b/win/tclWinDde.c
@@ -152,13 +152,6 @@ Dde_Init(
return TCL_ERROR;
}
-#ifdef UNICODE
- if (TclWinGetPlatformId() < VER_PLATFORM_WIN32_NT) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- "Win32s and Windows 9x are not supported platforms", -1));
- return TCL_ERROR;
- }
-#endif
Tcl_CreateObjCommand(interp, "dde", DdeObjCmd, NULL, NULL);
Tcl_CreateExitHandler(DdeExitProc, NULL);
return Tcl_PkgProvide(interp, TCL_DDE_PACKAGE_NAME, TCL_DDE_VERSION);
diff --git a/win/tclWinInit.c b/win/tclWinInit.c
index dc8bba7..91f149b 100644
--- a/win/tclWinInit.c
+++ b/win/tclWinInit.c
@@ -487,18 +487,11 @@ TclpSetInitialEncodings(void)
{
Tcl_DString encodingName;
- TclpSetInterfaces();
Tcl_SetSystemEncoding(NULL,
Tcl_GetEncodingNameFromEnvironment(&encodingName));
Tcl_DStringFree(&encodingName);
}
-void TclWinSetInterfaces(
- int dummy) /* Not used. */
-{
- TclpSetInterfaces();
-}
-
const char *
Tcl_GetEncodingNameFromEnvironment(
Tcl_DString *bufPtr)
diff --git a/win/tclWinInt.h b/win/tclWinInt.h
index d72cc43..08d80fb 100644
--- a/win/tclWinInt.h
+++ b/win/tclWinInt.h
@@ -40,12 +40,6 @@ typedef struct TclWinProcs {
MODULE_SCOPE TclWinProcs tclWinProcs;
-#ifdef _WIN64
-# define TCL_I_MODIFIER "I"
-#else
-# define TCL_I_MODIFIER ""
-#endif
-
/*
* Declarations of functions that are not accessible by way of the
* stubs table.
diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c
index 55e4d73..a357412 100644
--- a/win/tclWinPipe.c
+++ b/win/tclWinPipe.c
@@ -869,7 +869,7 @@ TclpGetPid(
Tcl_MutexLock(&pipeMutex);
for (infoPtr = procList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) {
- if (infoPtr->hProcess == (HANDLE) pid) {
+ if (infoPtr->dwProcessId == (DWORD) pid) {
Tcl_MutexUnlock(&pipeMutex);
return infoPtr->dwProcessId;
}
@@ -1163,7 +1163,7 @@ TclpCreateProcess(
WaitForInputIdle(procInfo.hProcess, 5000);
CloseHandle(procInfo.hThread);
- *pidPtr = (Tcl_Pid) procInfo.hProcess;
+ *pidPtr = (Tcl_Pid) procInfo.dwProcessId;
if (*pidPtr != 0) {
TclWinAddProcess(procInfo.hProcess, procInfo.dwProcessId);
}
@@ -1606,7 +1606,7 @@ TclpCreateCommandChannel(
* unique, in case channels share handles (stdin/stdout).
*/
- sprintf(channelName, "file%" TCL_I_MODIFIER "x", (size_t) infoPtr);
+ sprintf(channelName, "file%" TCL_Z_MODIFIER "x", (size_t) infoPtr);
infoPtr->channel = Tcl_CreateChannel(&pipeChannelType, channelName,
infoPtr, infoPtr->validMask);
@@ -2347,7 +2347,7 @@ Tcl_WaitPid(
prevPtrPtr = &procList;
for (infoPtr = procList; infoPtr != NULL;
prevPtrPtr = &infoPtr->nextPtr, infoPtr = infoPtr->nextPtr) {
- if (infoPtr->hProcess == (HANDLE) pid) {
+ if (infoPtr->dwProcessId == (DWORD) pid) {
*prevPtrPtr = infoPtr->nextPtr;
break;
}
diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c
index acfeecb..d77a609 100644
--- a/win/tclWinSerial.c
+++ b/win/tclWinSerial.c
@@ -1442,7 +1442,7 @@ TclWinOpenSerialChannel(
* are shared between multiple channels (stdin/stdout).
*/
- sprintf(channelName, "file%" TCL_I_MODIFIER "x", (size_t) infoPtr);
+ sprintf(channelName, "file%" TCL_Z_MODIFIER "x", (size_t) infoPtr);
infoPtr->channel = Tcl_CreateChannel(&serialChannelType, channelName,
infoPtr, permissions);