aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorPoul-Henning Kamp <phk@FreeBSD.org>1997-10-01 13:19:13 +0000
committerPoul-Henning Kamp <phk@FreeBSD.org>1997-10-01 13:19:13 +0000
commit539e1e66ff6f99c987c8e03872ddaea5260db8f7 (patch)
treebca582e352640f318b35228d0c250ddde3bd0e0b
parent3d33409926539d866dcea9fc5cb14113b312adf0 (diff)
downloadsrc-539e1e66ff6f99c987c8e03872ddaea5260db8f7.tar.gz
src-539e1e66ff6f99c987c8e03872ddaea5260db8f7.zip
Upgrade to 8.0 release.
Notes
Notes: svn path=/vendor/tcl/dist/; revision=30037
-rw-r--r--contrib/tcl/README71
-rw-r--r--contrib/tcl/changes193
-rw-r--r--contrib/tcl/doc/CrtInterp.36
-rw-r--r--contrib/tcl/doc/CrtObjCmd.311
-rw-r--r--contrib/tcl/doc/CrtSlave.326
-rw-r--r--contrib/tcl/doc/GetIndex.35
-rw-r--r--contrib/tcl/doc/Object.34
-rw-r--r--contrib/tcl/doc/RecEvalObj.355
-rw-r--r--contrib/tcl/doc/RecordEval.314
-rw-r--r--contrib/tcl/doc/WrongNumArgs.328
-rw-r--r--contrib/tcl/doc/bgerror.n7
-rw-r--r--contrib/tcl/doc/expr.n6
-rw-r--r--contrib/tcl/doc/history.n106
-rw-r--r--contrib/tcl/doc/http.n109
-rw-r--r--contrib/tcl/doc/interp.n62
-rw-r--r--contrib/tcl/doc/namespace.n290
-rw-r--r--contrib/tcl/doc/registry.n10
-rw-r--r--contrib/tcl/doc/rename.n16
-rw-r--r--contrib/tcl/doc/resource.n116
-rw-r--r--contrib/tcl/doc/safe.n529
-rw-r--r--contrib/tcl/doc/tclvars.n80
-rw-r--r--contrib/tcl/doc/uplevel.n20
-rw-r--r--contrib/tcl/doc/upvar.n20
-rw-r--r--contrib/tcl/doc/variable.n20
-rw-r--r--contrib/tcl/generic/tcl.h82
-rw-r--r--contrib/tcl/generic/tclAlloc.c456
-rw-r--r--contrib/tcl/generic/tclBasic.c526
-rw-r--r--contrib/tcl/generic/tclBinary.c20
-rw-r--r--contrib/tcl/generic/tclClock.c14
-rw-r--r--contrib/tcl/generic/tclCmdAH.c315
-rw-r--r--contrib/tcl/generic/tclCmdIL.c61
-rw-r--r--contrib/tcl/generic/tclCmdMZ.c99
-rw-r--r--contrib/tcl/generic/tclCompExpr.c99
-rw-r--r--contrib/tcl/generic/tclCompile.c1242
-rw-r--r--contrib/tcl/generic/tclCompile.h162
-rw-r--r--contrib/tcl/generic/tclEnv.c444
-rw-r--r--contrib/tcl/generic/tclEvent.c11
-rw-r--r--contrib/tcl/generic/tclExecute.c967
-rw-r--r--contrib/tcl/generic/tclFileName.c6
-rw-r--r--contrib/tcl/generic/tclHistory.c1081
-rw-r--r--contrib/tcl/generic/tclIO.c30
-rw-r--r--contrib/tcl/generic/tclIOCmd.c78
-rw-r--r--contrib/tcl/generic/tclIndexObj.c71
-rw-r--r--contrib/tcl/generic/tclInt.h131
-rw-r--r--contrib/tcl/generic/tclInterp.c269
-rw-r--r--contrib/tcl/generic/tclListObj.c12
-rw-r--r--contrib/tcl/generic/tclLoad.c6
-rw-r--r--contrib/tcl/generic/tclMain.c97
-rw-r--r--contrib/tcl/generic/tclMath.h27
-rw-r--r--contrib/tcl/generic/tclNamesp.c155
-rw-r--r--contrib/tcl/generic/tclObj.c122
-rw-r--r--contrib/tcl/generic/tclParse.c38
-rw-r--r--contrib/tcl/generic/tclProc.c43
-rw-r--r--contrib/tcl/generic/tclStringObj.c4
-rw-r--r--contrib/tcl/generic/tclTest.c124
-rw-r--r--contrib/tcl/generic/tclTimer.c241
-rw-r--r--contrib/tcl/generic/tclUtil.c320
-rw-r--r--contrib/tcl/generic/tclVar.c594
-rw-r--r--contrib/tcl/library/history.tcl369
-rw-r--r--contrib/tcl/library/http1.0/http.tcl10
-rw-r--r--contrib/tcl/library/http2.0/http.tcl460
-rw-r--r--contrib/tcl/library/http2.0/pkgIndex.tcl11
-rw-r--r--contrib/tcl/library/init.tcl106
-rw-r--r--contrib/tcl/library/opt0.1/optparse.tcl1067
-rw-r--r--contrib/tcl/library/opt0.1/pkgIndex.tcl7
-rw-r--r--contrib/tcl/library/safe.tcl710
-rw-r--r--contrib/tcl/library/tclIndex37
-rw-r--r--contrib/tcl/tests/all10
-rw-r--r--contrib/tcl/tests/basic.test39
-rw-r--r--contrib/tcl/tests/binary.test58
-rw-r--r--contrib/tcl/tests/cmdAH.test157
-rw-r--r--contrib/tcl/tests/cmdIL.test6
-rw-r--r--contrib/tcl/tests/compile.test44
-rw-r--r--contrib/tcl/tests/defs65
-rw-r--r--contrib/tcl/tests/env.test73
-rw-r--r--contrib/tcl/tests/error.test22
-rw-r--r--contrib/tcl/tests/eval.test4
-rw-r--r--contrib/tcl/tests/event.test145
-rw-r--r--contrib/tcl/tests/exec.test415
-rw-r--r--contrib/tcl/tests/execute.test3
-rw-r--r--contrib/tcl/tests/expr-old.test38
-rw-r--r--contrib/tcl/tests/expr.test25
-rw-r--r--contrib/tcl/tests/fCmd.test7
-rw-r--r--contrib/tcl/tests/fileName.test163
-rw-r--r--contrib/tcl/tests/for.test10
-rw-r--r--contrib/tcl/tests/foreach.test11
-rw-r--r--contrib/tcl/tests/format.test64
-rw-r--r--contrib/tcl/tests/history.test227
-rw-r--r--contrib/tcl/tests/http.test246
-rw-r--r--contrib/tcl/tests/httpold.test411
-rw-r--r--contrib/tcl/tests/if.test14
-rw-r--r--contrib/tcl/tests/incr.test8
-rw-r--r--contrib/tcl/tests/info.test15
-rw-r--r--contrib/tcl/tests/interp.test323
-rw-r--r--contrib/tcl/tests/io.test272
-rw-r--r--contrib/tcl/tests/ioCmd.test11
-rw-r--r--contrib/tcl/tests/misc.test10
-rw-r--r--contrib/tcl/tests/namespace.test42
-rw-r--r--contrib/tcl/tests/obj.test28
-rw-r--r--contrib/tcl/tests/opt.test236
-rw-r--r--contrib/tcl/tests/parse.test2
-rw-r--r--contrib/tcl/tests/pkg.test18
-rw-r--r--contrib/tcl/tests/proc-old.test6
-rw-r--r--contrib/tcl/tests/proc.test16
-rw-r--r--contrib/tcl/tests/pwd.test22
-rw-r--r--contrib/tcl/tests/registry.test19
-rw-r--r--contrib/tcl/tests/resource.test105
-rw-r--r--contrib/tcl/tests/safe.test595
-rw-r--r--contrib/tcl/tests/scan.test27
-rw-r--r--contrib/tcl/tests/set-old.test4
-rw-r--r--contrib/tcl/tests/socket.test101
-rw-r--r--contrib/tcl/tests/source.test4
-rw-r--r--contrib/tcl/tests/split.test15
-rw-r--r--contrib/tcl/tests/string.test7
-rw-r--r--contrib/tcl/tests/trace.test40
-rw-r--r--contrib/tcl/tests/unixFCmd.test25
-rw-r--r--contrib/tcl/tests/util.test80
-rw-r--r--contrib/tcl/tests/var.test49
-rw-r--r--contrib/tcl/tests/while.test6
-rw-r--r--contrib/tcl/tests/winFCmd.test83
-rw-r--r--contrib/tcl/tests/winPipe.test28
-rw-r--r--contrib/tcl/unix/Makefile.in37
-rwxr-xr-xcontrib/tcl/unix/configure246
-rwxr-xr-xcontrib/tcl/unix/configure.in19
-rwxr-xr-xcontrib/tcl/unix/mkLinks8
-rw-r--r--contrib/tcl/unix/tclConfig.sh.in5
-rw-r--r--contrib/tcl/unix/tclUnixFile.c16
-rw-r--r--contrib/tcl/unix/tclUnixInit.c9
-rw-r--r--contrib/tcl/unix/tclUnixNotfy.c4
-rw-r--r--contrib/tcl/unix/tclUnixPort.h9
-rw-r--r--contrib/tcl/unix/tclUnixSock.c27
131 files changed, 11501 insertions, 5861 deletions
diff --git a/contrib/tcl/README b/contrib/tcl/README
index 8c091b2db8f5..640f075d2ba1 100644
--- a/contrib/tcl/README
+++ b/contrib/tcl/README
@@ -1,22 +1,21 @@
Tcl
-SCCS: @(#) README 1.45 97/06/25 11:02:14
+SCCS: @(#) README 1.49 97/08/14 08:47:31
1. Introduction
---------------
This directory and its descendants contain the sources and documentation
for Tcl, an embeddable scripting language. The information here
-corresponds to release 8.0b2, the second (and probably final) beta
-release for Tcl 8.0. Tcl 8.0 is a major new release that replaces the
-core of the interpreter with an on-the-fly bytecode compiler to improve
-execution speed. It also includes several other new features such as
-namespaces and binary I/O, plus many bug fixes. The compiler introduces
-a few incompatibilities that may affect existing Tcl scripts; the
-incompatibilities are relatively obscure but may require modifications
-to some old scripts before they can run with this version. The compiler
-introduces many new C-level APIs, but the old APIs are still supported.
-See below for more details.
+corresponds to release 8.0. Tcl 8.0 is a major new release that replaces
+the core of the interpreter with an on-the-fly bytecode compiler to
+improve execution speed. It also includes several other new features
+such as namespaces and binary I/O, plus many bug fixes. The compiler
+introduces a few incompatibilities that may affect existing Tcl scripts;
+the incompatibilities are relatively obscure but may require
+modifications to some old scripts before they can run with this version.
+The compiler introduces many new C-level APIs, but the old APIs are
+still supported. See below for more details.
2. Documentation
----------------
@@ -166,8 +165,9 @@ changes, there are several smaller changes and bug fixes. See the file
mechanism, implemented with the Tcl commands "interp hide", "interp
expose", "interp invokehidden", and "interp hidden" and the C APIs
Tcl_HideCommand and Tcl_ExposeCommand. There is now support for
- loadable security policies, including new library procedures such as
- tcl_safeCreateInterp.
+ safe packages and extension loading, including new library
+ procedures such as safe::interpCreate (see the manual entry safe.n
+ for details).
6. There is a new package "registry" available under Windows for
accessing the Windows registry.
@@ -224,9 +224,12 @@ scripts that worked under Tcl 7.6 and earlier releases:
are no longer supported; all of these features are now available on
all platforms via the "file" command.
- 5. Support for the variable tcl_precision is mostly removed; when
- real values are converted back to strings, the full 17 digits of
- precision are always used.
+ 5. The variable tcl_precision is now shared between interpreters
+ and defaults to 12 digits instead of 6; safe interpreters cannot
+ modify tcl_precision. The new object system in Tcl 8.0 causes
+ floating-to-string conversions (and the associated rounding) to
+ occur much less often than in Tcl 7.6, which can sometimes cause
+ behavioral changes.
6. The C APIs associated with the notifier have changed substantially.
@@ -270,7 +273,39 @@ in the directory "/pub/tcl". The archive also contains several FAQ
("frequently asked questions") documents that provide solutions to problems
that are commonly encountered by TCL newcomers.
-7. Support and bug fixes
+7. Mailing lists
+----------------
+
+A couple of Mailing List have been set up to discuss Macintosh or
+Windows related Tcl issues. In order to use these Mailing Lists you
+must have access to the internet. If you have access to the WWW the
+home pages for these mailing lists are located at the following URLs:
+
+ http://www.sunlabs.com/research/tcl/lists/mactcl-list.html
+
+ -and-
+
+ http://www.sunlabs.com/research/tcl/lists/wintcl-list.html
+
+The home pages contain information about the lists and an HTML archive
+of all the past messages on the list. To subscribe send a message to:
+
+ listserv@sunlabs.sun.com
+
+In the body of the message (the subject will be ignored) put:
+
+ subscribe mactcl Joe Blow
+
+Replacing Joe Blow with your real name, of course. (Use wintcl
+instead of mactcl if your interested in the Windows list.) If you
+would just like to receive more information about the list without
+subscribing put the line:
+
+ information mactcl
+
+in the body instead (or wintcl).
+
+8. Support and bug fixes
------------------------
We're very interested in receiving bug reports and suggestions for
@@ -304,7 +339,7 @@ In addition, Tcl support and training are available commercially from
NeoSoft (info@neosoft.com), Computerized Processes Unlimited
(gwl@cpu.com), and Data Kinetics (education@dkl.com).
-8. Tcl version numbers
+9. Tcl version numbers
----------------------
Each Tcl release is identified by two numbers separated by a dot, e.g.
diff --git a/contrib/tcl/changes b/contrib/tcl/changes
index 9390e86a0649..c54526b8a1d6 100644
--- a/contrib/tcl/changes
+++ b/contrib/tcl/changes
@@ -1,6 +1,6 @@
Recent user-visible changes to Tcl:
-SCCS: @(#) changes 1.251 97/06/30 08:48:28
+SCCS: @(#) changes 1.293 97/08/13 17:50:35
1. No more [command1] [command2] construct for grouping multiple
commands on a single command line.
@@ -2494,11 +2494,9 @@ following new library commands are provided:
policy mechanism.
tcl_safeDeleteInterp -- deletes a slave and deinitializes the
policy mechanism.
- tcl_safeAutoPath -- manages per slave path for package
- finding and auto-loading.
- tcl_safePolicyPath -- manages global search path for finding
- security policies.
Added a new file to the library, safeinit.tcl, to hold implementation. (JL)
+On 7/9/97, removed the policy loading mechanism from the Safe Base. Left
+only the Safe Base aliases dealing with auto-loading and source. (JL)
12/6/96 (new feature) Implemented Tcl_Finalize, an API that should be
called by a process when it is done using Tcl. This API runs all the exit
@@ -2934,8 +2932,8 @@ and to get the vector back later. (JL)
leave an object result instead of a string result. (JL)
5/14/97 (feature change) Improved the handling of the interpreter result.
-This is still either an object or a string, but the two values are now
-kept consistent unless some C code has set interp->result directly. See
+This is still either an object or a string, but the two values are now kept
+consistent unless some C code reads or writes interp->result directly. See
the SetResult man page for details. Removed the Tcl_ResetObjResult
procedure. (BL)
*** POTENTIAL INCOMPATIBILITY with Tcl 8.0a2 ***
@@ -3094,3 +3092,184 @@ Tcl_ExprObj. (BL)
*** POTENTIAL INCOMPATIBILITY with Tcl 8.0b1, but not with Tcl 7.6 ***
----------------- Released 8.0b2, 6/30/97 -----------------------
+
+7/1/97 (new feature) TCL_BUILD_SHARED flag set in tclConfig.sh
+when Tcl has been built with --enable-shared. A new tclLibObjs
+make target, echoing the list of the .o's needed to build a tcl
+library, is now provided. (DL)
+
+7/1/97 (feature change) compat/getcwd.c removed and changed the
+only place where getcwd is used so a new USEGETWD flag selects
+the use of the replacement "getwd". Adding this flag is recommended
+for Solaris (because getcwd on solaris uses a pipe to pwd(1)!).(DL)
+
+7/7/97 (feature change) The split command now supports binary data (i.e.,
+null characters in strings). (BL)
+
+7/7/97 (bug fix) string first returned the wrong result if the first
+argument string was empty. (BL)
+
+7/8/97 (bug fix) Fixed core dump in fcopy that could occur when a command
+callback was supplied and an error or eof condition caused no background
+activity. A refcount bug triggered a panic in Tcl_ListObjAppendElement. (BW)
+
+7/8/97 (bug fix) Relaxed the pattern matching on http_get so you do not
+need a trailing path component. You can now get away with just
+http_get sunscript.sun.com (BW)
+
+7/9/97 (bug fix) Creating anonymous interpreters no longer smashes existing
+commands with names similar to the generated name. Previously creating an
+anonymous interpreter could smash an existing command, now it skips until
+it finds a command name that isn't being used. (JL)
+
+7/9/97 (feature change) Removed the policy management mechanism from the
+Safe Base; left the aliases to source and load modules, and to do a limited
+form of the "file" command. See entry of 11/15/96. (JL)
+
+7/9/97 (bug fixes) Fixed various compilation-related bugs:
+ - Line numbers in errorInfo now are the same as those in Tcl7.6 unless
+there are compilation errors. Compilation error messages now include the
+entire command in error.
+ - Trailing ::s after namespace names weren't being ignored.
+ - Could not refer to an namespace variable with an empty name using a
+name of the form "n::". (BL)
+
+7/9/97 (bug fix) Fixed bug in Tcl_Export that prevented you from exporting
+from other than the current namespace. (BL)
+
+7/9/97 (bug fix) env.test was removing env var needed for proper finding
+of libraries in child process. (DL)
+
+7/10/97 (bug fixes/new feature) Cleanup in Tcl_MakeSafe. Less information
+is leaked to safe interps. Error message fixes for interp sub commands.
+Likewise changes in safealias.tcl; tcl_safeCreateInterp can now be called
+without argument to generate the slave name (like in interp create). (DL)
+
+7/10/97 (bug fixes) Bytecode compiler now generates more detailed
+command location information: subcommands as well as commands now have
+location information. This means command trace procedures now get the
+correct source string for each command in their command parameter. (BL)
+
+7/22/97 (bug fixes) Performance improvement in Safe interpreters
+handling. Added new mask value to (tclInt.h) Interp.flags record. (DL)
+
+7/22/97 (bug fix) Fixed panic in 'interp target {} foo'. This bug
+was present since Tcl 7.6. (JL)
+
+7/22/97 (bug fix) Fixed bug in compilation of procedures in namespaces: the
+procedure's namespace must be used to look up compile procedures, not the
+current namespace. (BL)
+
+7/22/97 (bug fix) Use of the -channel option of http_get was not setting
+the end of line translations mode on the channel, so copying binary data
+with the -channel option was corrupting the result on non-unix platforms. (BW)
+
+7/22/97 (bug fixes) file commands and ~user (seg fault and other
+improper returns). (DL)
+
+7/23/97 (feature change) Reenabled "vwait" in Safe Base. (JL)
+
+7/23/97 (bug fixes) Fixed two bugs involving read traces on array variables
+in procedures: trace procedures were sometimes not called, and reading
+nonexistant array elements didn't create undefined element variables that
+could later be defined by trace procedures. (BL)
+
+7/24/97 (bug fix) Windows memory allocation performance was
+superlinear in some cases. Made the Mac allocator generic and changed
+both the Mac and Windows platforms to use the new allocator instead of
+malloc and free. (SS)
+
+7/24/97 - 8/12/97 (bug fixes/change of features) Completely revamped safe
+sourcing/loading (see safe.n) to hide pathnames, use virtual
+paths tokens instead, improved security in several respects and made it
+more tunable. Multi level interp loading can work too now. Package auto
+loading now works in safe interps as long as the package directory is in
+the auto_path (no deep crawling allowed in safe interps). (DL)
+*** POTENTIAL INCOMPATIBILITY with previous alpha and beta releases ***
+
+7/24/97 (bug fixes) Made Tcl_SetVar* and Tcl_NewString* treat a NULL value
+as an empty string. (This fixes hairy crash case where you would crash
+because load command for other interps assumed presence of
+errorInfo...). (DL)
+
+7/28/97 (bug fix) Fixed pkg_mkIndex to understand namespaces. It will
+use the export list of a namespace and create auto_index entries for
+all export commands. Those names are in their fully qualified form in the
+auto_index. Therefore, I tweaked unknown to try both $cmd and ::$cmd.
+Also fixed pkg_mkIndex so you can have "package require" commands inside
+your packages. These commands are ignored, which is mostly ok except
+when you must load another package before loading yours because of
+linking dependencies. (BW)
+
+7/28/97 (bug fix) A variable created by the variable command now persists
+until the namespace is destroyed or the variable is unset. This is true even
+if the variable has not been initialized; these variables used to be
+destroyed if an error occurred when accessing them. In addition, the "info
+vars" command lists uninitialized namespace variables, while the "info
+exists" command returns 0 for them. (BL)
+
+7/29/97 (feature change) Changed the http package to use the ::http
+namespace. http_get renamed to http::geturl, http_config renamed to
+http::config, http_formatQuery renamed to http::formatQuery.
+It now provides the 2.0 version of the package.
+The 1.0 version is still available with the old names.
+*** POTENTIAL INCOMPATIBILITY with Tcl 8.0b2 but not with Tcl 7.6 ***
+
+7/29/97 (bug fix, new feature) Tcl_Main now uses Tcl objects internally to
+preserve NULLs in commands and command output. Added new API procedure
+Tcl_RecordAndEvalObj that resembles Tcl_RecordAndEval but takes an object
+containing a command. (BL)
+
+7/30/97 (bug fix) Tcl freed strings in the environ array even if it
+did not allocate them. (SS)
+
+7/30/97 (bug fix) If a procedure is renamed into a different namespace, it
+now executes in the context of that namespace. (BL)
+
+7/30/97 (bug fix) Prevent renaming of commands into and from namespaces as
+part of hiding them. (JL)
+
+7/31/97 (feature change) Moved the history command from C to tcl.
+This uses the ::history namespace. The "words" and "substitute" options
+are no longer supported. In addition, the "keep" option without a value
+returns the current keep limit. There is a new "clear" option.
+The unknown command now supports !! again. (BW)
+*** POTENTIAL INCOMPATIBILTY ***
+
+7/30/97 (bug fix) Made sure that a slave can not fool the master into
+hiding the wrong command. Made sure we don't crash in hiding + namespaces
+issues. (DL)
+
+8/4/97 (bug fix) Concat, eval, uplevel, and similar commands were
+incorrectly trimming trailing space characters from their arguments
+even when the space characters were preceded by a backslash. (JO)
+
+8/4/97 (bug fix) Removed the hard link between bgerror and tkerror.
+Only bgerror is supported in tcl core. Tk will still look for a
+tkerror but using regular tcl code for that feature. (DL)
+*** POTENTIAL INCOMPATIBILTY with code relying on the hard link ***
+
+8/6/97 (bug fix) Reduced size required for compiled bytecodes by using a
+more compact encoding for the command pc-to-source map. (BL)
+
+8/6/97 (new feature) Added support for additional compilation and execution
+statistics when Tcl is compiled with the TCL_COMPILE_STATS flag. (BL)
+
+8/7/97 (bug fix) Expressions not in {}s that have a comparison operator as
+the topmost operator must be compiled out-of-line (call the expr cmd at
+runtime) to properly support expr's two-level substitution semantics. An
+example is "set a 2; set b {$a}; puts [expr $b == 2]". (BL)
+
+8/11/97 (bug fix) The catch command would sometimes crash if a variable name
+was given and the bytecode evaluation stack was grown when executing the
+argument script. (BL)
+
+8/12/97 (feature change) Reinstated the variable tcl_precision to control
+the number of digits used when floating-point values are converted to
+strings, with default of 12 digits. However, had to make tcl_precision
+shared among all interpreters (except that safe interpreters can't
+modify it). This makes the Tcl 8.0 behavior almost identical to 7.6
+except that the default precision is 12 instead of 6. (JO)
+*** POTENTIAL INCOMPATIBILITY ***
+
+----------------- Released 8.0, 8/13/97 -----------------------
diff --git a/contrib/tcl/doc/CrtInterp.3 b/contrib/tcl/doc/CrtInterp.3
index b50d34e5bae1..bcca39d5def5 100644
--- a/contrib/tcl/doc/CrtInterp.3
+++ b/contrib/tcl/doc/CrtInterp.3
@@ -5,7 +5,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" SCCS: @(#) CrtInterp.3 1.14 96/03/26 15:14:45
+'\" SCCS: @(#) CrtInterp.3 1.15 97/07/09 14:53:31
'\"
.so man.macros
.TH Tcl_CreateInterp 3 7.5 Tcl "Tcl Library Procedures"
@@ -100,8 +100,8 @@ When a new interpreter is created and used in a call to \fBTcl_Eval\fR,
\fBTcl_Release\fR should be wrapped around all uses of the interpreter.
Remember that it is unsafe to use the interpreter once \fBTcl_Release\fR
has been called. To ensure that the interpreter is properly deleted when
-it is no longer needed, call \fBTcl_InterpDeleted\fB to test if some other
-code already called \fBTcl_DeleteInterp\fB; if not, call
+it is no longer needed, call \fBTcl_InterpDeleted\fR to test if some other
+code already called \fBTcl_DeleteInterp\fR; if not, call
\fBTcl_DeleteInterp\fR before calling \fBTcl_Release\fB in your own code.
Do not call \fBTcl_DeleteInterp\fR on an interpreter for which
\fBTcl_InterpDeleted\fR returns nonzero.
diff --git a/contrib/tcl/doc/CrtObjCmd.3 b/contrib/tcl/doc/CrtObjCmd.3
index e5108894eeea..78fe6f8b7322 100644
--- a/contrib/tcl/doc/CrtObjCmd.3
+++ b/contrib/tcl/doc/CrtObjCmd.3
@@ -4,7 +4,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" SCCS: @(#) @(#) CrtObjCmd.3 1.9 97/06/04 17:23:37
+'\" SCCS: @(#) @(#) CrtObjCmd.3 1.10 97/07/31 14:10:38
'\"
.so man.macros
.TH Tcl_CreateObjCommand 3 8.0 Tcl "Tcl Library Procedures"
@@ -54,7 +54,6 @@ The command must not have been deleted.
Pointer to structure containing various information about a
Tcl command.
.BE
-
.SH DESCRIPTION
.PP
\fBTcl_CreateObjCommand\fR defines a new command in \fIinterp\fR
@@ -130,8 +129,8 @@ Call \fBTcl_SetObjResult\fR if you want
to return something from the \fIobjv\fR array.
.PP
\fIDeleteProc\fR will be invoked when (if) \fIname\fR is deleted.
-This can occur through a call to \fBTcl_DeleteCommand\fR
-or \fBTcl_DeleteInterp\fR,
+This can occur through a call to \fBTcl_DeleteCommand\fR,
+\fBTcl_DeleteCommandFromToken\fR, or \fBTcl_DeleteInterp\fR,
or by replacing \fIname\fR in another call to \fBTcl_CreateObjCommand\fR.
\fIDeleteProc\fR is invoked before the command is deleted, and gives the
application an opportunity to release any structures associated
@@ -154,10 +153,10 @@ a built-in command, an application-specific command, or a Tcl procedure.
If \fIname\fR contains any \fB::\fR namespace qualifiers,
the command is deleted from the specified namespace.
.PP
-Given a token returned by \fBTcl_CreateObjCommand\fR
-when the command was created,
+Given a token returned by \fBTcl_CreateObjCommand\fR,
\fBTcl_DeleteCommandFromToken\fR deletes the command
from a command interpreter.
+It will delete a command even if that command has been renamed.
Once the call completes, attempts to invoke the command in
\fIinterp\fR will result in errors.
If the command corresponding to \fItoken\fR
diff --git a/contrib/tcl/doc/CrtSlave.3 b/contrib/tcl/doc/CrtSlave.3
index 3b3d7b82f4b9..fe18a557e472 100644
--- a/contrib/tcl/doc/CrtSlave.3
+++ b/contrib/tcl/doc/CrtSlave.3
@@ -4,7 +4,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" SCCS: @(#) CrtSlave.3 1.22 97/06/10 17:52:33
+'\" SCCS: @(#) CrtSlave.3 1.26 97/07/31 18:00:14
'\"
.so man.macros
.TH Tcl_CreateSlave 3 7.6 Tcl "Tcl Library Procedures"
@@ -107,7 +107,8 @@ called function.
.AP char *cmdName in
Name of an exposed command to hide or create.
.AP char *hiddenCmdName in
-Name of a hidden command to create or expose.
+Name under which a hidden command is stored and with which it can be
+exposed or invoked.
.VE
.BE
@@ -187,9 +188,11 @@ returns a pointer to a vector of Tcl_Obj structures instead of a vector of
strings.
.PP
\fBTcl_ExposeCommand\fR moves the command named \fIhiddenCmdName\fR from
-the set of hidden commands to the set of exposed commands, renaming it to
-\fIcmdName\fR. \fIHiddenCmdName\fR must be the name of an existing hidden
-command, or the operation will return \fBTCL_ERROR\fR and deposit an error
+the set of hidden commands to the set of exposed commands, putting
+it under the name
+\fIcmdName\fR.
+\fIHiddenCmdName\fR must be the name of an existing hidden
+command, or the operation will return \fBTCL_ERROR\fR and leave an error
message in the \fIresult\fR field in \fIinterp\fR.
If an exposed command named \fIcmdName\fR already exists,
the operation returns \fBTCL_ERROR\fR and leaves an error message in the
@@ -199,11 +202,18 @@ After executing this command, attempts to use \fIcmdName\fR in a call to
\fBTcl_Eval\fR or with the Tcl \fBeval\fR command will again succeed.
.PP
\fBTcl_HideCommand\fR moves the command named \fIcmdName\fR from the set of
-exposed commands to the set of hidden commands, renaming it to
-\fIhiddenCmdName\fR. \fICmdName\fR must be the name of an existing exposed
+exposed commands to the set of hidden commands, under the name
+\fIhiddenCmdName\fR.
+\fICmdName\fR must be the name of an existing exposed
command, or the operation will return \fBTCL_ERROR\fR and leave an error
message in the object result of \fIinterp\fR.
-If a hidden command named \fIhiddenCmdName\fR already
+Currently both \fIcmdName\fR and \fIhiddenCmdName\fR must not contain
+namespace qualifiers, or the operation will return \fBTCL_ERROR\fR and
+leave an error message in the object result of \fIinterp\fR.
+The \fICmdName\fR will be looked up in the global namespace, and not
+relative to the current namespace, even if the current namespace is not the
+global one.
+If a hidden command whose name is \fIhiddenCmdName\fR already
exists, the operation also returns \fBTCL_ERROR\fR and the \fIresult\fR
field in \fIinterp\fR contains an error message.
If the operation succeeds, it returns \fBTCL_OK\fR.
diff --git a/contrib/tcl/doc/GetIndex.3 b/contrib/tcl/doc/GetIndex.3
index 66782576e2f8..9ca7927836ce 100644
--- a/contrib/tcl/doc/GetIndex.3
+++ b/contrib/tcl/doc/GetIndex.3
@@ -4,7 +4,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" SCCS: @(#) @(#) GetIndex.3 1.2 97/02/11 13:25:45
+'\" SCCS: @(#) @(#) GetIndex.3 1.3 97/07/30 16:21:05
'\"
.so man.macros
.TH Tcl_GetIndexFromObj 3 8.0 Tcl "Tcl Library Procedures"
@@ -70,5 +70,8 @@ the matching index immediately without having to redo the lookup
operation. Note: \fBTcl_GetIndexFromObj\fR assumes that the entries
in \fItablePtr\fR are static: they must not change between invocations.
+.SH "SEE ALSO"
+Tcl_WrongNumArgs
+
.SH KEYWORDS
index, object, table lookup
diff --git a/contrib/tcl/doc/Object.3 b/contrib/tcl/doc/Object.3
index e564de9cd907..1fed7a6b7aaf 100644
--- a/contrib/tcl/doc/Object.3
+++ b/contrib/tcl/doc/Object.3
@@ -4,7 +4,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" SCCS: @(#) @(#) Object.3 1.9 97/06/13 18:36:20
+'\" SCCS: @(#) @(#) Object.3 1.10 97/07/22 11:40:10
'\"
.so man.macros
.TH Tcl_Obj 3 8.0 Tcl "Tcl Library Procedures"
@@ -309,7 +309,7 @@ by calling \fBTcl_IsShared\fR.
If the object is shared they must copy the object
by using \fBTcl_DuplicateObj\fR;
this returns a new duplicate of the original object
-that has \fIrefCount\fR 1.
+that has \fIrefCount\fR 0.
If the object is not shared,
the command procedure "owns" the object and can safely modify it directly.
For example, the following code appears in the command procedure
diff --git a/contrib/tcl/doc/RecEvalObj.3 b/contrib/tcl/doc/RecEvalObj.3
new file mode 100644
index 000000000000..7f3bdc9d7238
--- /dev/null
+++ b/contrib/tcl/doc/RecEvalObj.3
@@ -0,0 +1,55 @@
+'\"
+'\" Copyright (c) 1997 Sun Microsystems, Inc.
+'\"
+'\" See the file "license.terms" for information on usage and redistribution
+'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+'\" SCCS: SCCS: @(#) RecEvalObj.3 1.1 97/07/29 18:31:21
+'\"
+.so man.macros
+.TH Tcl_RecordAndEvalObj 3 8.0 Tcl "Tcl Library Procedures"
+.BS
+.SH NAME
+Tcl_RecordAndEvalObj \- save command on history list before evaluating
+.SH SYNOPSIS
+.nf
+\fB#include <tcl.h>\fR
+.sp
+int
+\fBTcl_RecordAndEvalObj\fR(\fIinterp, cmdPtr, flags\fR)
+.SH ARGUMENTS
+.AS Tcl_Interp *interp;
+.AP Tcl_Interp *interp in
+Tcl interpreter in which to evaluate command.
+.AP Tcl_Obj *cmdPtr in
+Points to a Tcl object containing a command (or sequence of commands)
+to execute.
+.AP int flags in
+An OR'ed combination of flag bits. TCL_NO_EVAL means record the
+command but don't evaluate it. TCL_EVAL_GLOBAL means evaluate
+the command at global level instead of the current stack level.
+.BE
+
+.SH DESCRIPTION
+.PP
+\fBTcl_RecordAndEvalObj\fR is invoked to record a command as an event
+on the history list and then execute it using \fBTcl_EvalObj\fR
+(or \fBTcl_GlobalEvalObj\fR if the TCL_EVAL_GLOBAL bit is set
+in \fIflags\fR).
+It returns a completion code such as TCL_OK just like \fBTcl_EvalObj\fR,
+as well as a result object containing additional information
+(a result value or error message)
+that can be retrieved using \fBTcl_GetObjResult\fR.
+If you don't want the command recorded on the history list then
+you should invoke \fBTcl_EvalObj\fR instead of \fBTcl_RecordAndEvalObj\fR.
+Normally \fBTcl_RecordAndEvalObj\fR is only called with top-level
+commands typed by the user, since the purpose of history is to
+allow the user to re-issue recently-invoked commands.
+If the \fIflags\fR argument contains the TCL_NO_EVAL bit then
+the command is recorded without being evaluated.
+
+.SH "SEE ALSO"
+Tcl_EvalObj, Tcl_GetObjResult
+
+.SH KEYWORDS
+command, event, execute, history, interpreter, object, record
diff --git a/contrib/tcl/doc/RecordEval.3 b/contrib/tcl/doc/RecordEval.3
index 6e6fb27e67dd..17d353dc8b6c 100644
--- a/contrib/tcl/doc/RecordEval.3
+++ b/contrib/tcl/doc/RecordEval.3
@@ -1,11 +1,11 @@
'\"
'\" Copyright (c) 1989-1993 The Regents of the University of California.
-'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
+'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" SCCS: @(#) RecordEval.3 1.17 96/08/26 12:59:47
+'\" SCCS: @(#) RecordEval.3 1.18 97/07/29 18:25:13
'\"
.so man.macros
.TH Tcl_RecordAndEval 3 7.4 Tcl "Tcl Library Procedures"
@@ -17,7 +17,7 @@ Tcl_RecordAndEval \- save command on history list before evaluating
\fB#include <tcl.h>\fR
.sp
int
-\fBTcl_RecordAndEval\fR(\fIinterp, cmd, eval\fR)
+\fBTcl_RecordAndEval\fR(\fIinterp, cmd, flags\fR)
.SH ARGUMENTS
.AS Tcl_Interp *interp;
.AP Tcl_Interp *interp in
@@ -44,6 +44,14 @@ commands typed by the user, since the purpose of history is to
allow the user to re-issue recently-invoked commands.
If the \fIflags\fR argument contains the TCL_NO_EVAL bit then
the command is recorded without being evaluated.
+.PP
+Note that \fBTcl_RecordAndEval\fR has been largely replaced by the
+object-based procedure \fBTcl_RecordAndEvalObj\fR.
+That object-based procedure records and optionally executes
+a command held in a Tcl object instead of a string.
+
+.SH "SEE ALSO"
+Tcl_RecordAndEvalObj
.SH KEYWORDS
command, event, execute, history, interpreter, record
diff --git a/contrib/tcl/doc/WrongNumArgs.3 b/contrib/tcl/doc/WrongNumArgs.3
index 528ebc827511..61b68cefcc3a 100644
--- a/contrib/tcl/doc/WrongNumArgs.3
+++ b/contrib/tcl/doc/WrongNumArgs.3
@@ -4,7 +4,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" SCCS: @(#) @(#) WrongNumArgs.3 1.3 97/03/18 11:53:25
+'\" SCCS: @(#) @(#) WrongNumArgs.3 1.5 97/07/30 16:20:07
'\"
.so man.macros
.TH Tcl_WrongNumArgs 3 8.0 Tcl "Tcl Library Procedures"
@@ -30,7 +30,7 @@ Arguments to command that had the wrong number of arguments.
.AP char *message in
Additional error information to print after leading arguments
from \fIobjv\fR. This typically gives the acceptable syntax
-of the command.
+of the command. This argument may be NULL.
.BE
.SH DESCRIPTION
@@ -52,8 +52,28 @@ If \fIobjc\fR is 2, the result will be set to the following string:
.CS
wrong # args: should be "foo bar fileName count"
.CE
-\fIObjc\fR is usually 1, but may be 2 or more for commands like \fBstring\fR
-and the Tk widget commands, which use the first argument as a subcommand.
+\fIObjc\fR is usually 1, but may be 2 or more for commands like
+\fBstring\fR and the Tk widget commands, which use the first argument
+as a subcommand.
+.PP
+Some of the objects in the \fIobjv\fR array may be abbreviations for
+a subcommand. The command
+\fBTcl_GetIndexFromObj\fR will convert the abbreviated string object
+into an \fIindexObject\fR. If an error occurs in the parsing of the
+subcommand we would like to use the full subcommand name rather than
+the abbreviation. If the \fBTcl_WrongNumArgs\fR command finds any
+\fIindexObjects\fR in the \fIobjv\fR array it will use the full subcommand
+name in the error message instead of the abbreviated name that was
+origionally passed in. Using the above example, lets assume that
+\fIbar\fR is actually an abbreviation for \fIbarfly\fR and the object
+is now an indexObject becasue it was passed to
+\fBTcl_GetIndexFromObj\fR. In this case the error message would be:
+.CS
+wrong # args: should be "foo barfly fileName count"
+.CE
+
+.SH "SEE ALSO"
+Tcl_GetIndexFromObj
.SH KEYWORDS
command, error message, wrong number of arguments
diff --git a/contrib/tcl/doc/bgerror.n b/contrib/tcl/doc/bgerror.n
index 6875bcf819a9..9f3e0c1f1c9d 100644
--- a/contrib/tcl/doc/bgerror.n
+++ b/contrib/tcl/doc/bgerror.n
@@ -5,7 +5,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" SCCS: @(#) bgerror.n 1.3 96/03/25 20:10:12
+'\" SCCS: @(#) bgerror.n 1.5 97/08/04 17:49:35
'\"
.so man.macros
.TH bgerror n 7.5 Tcl "Tcl Built-In Commands"
@@ -58,8 +58,9 @@ However, if \fBbgerror\fR returns with a break exception, then
any remaining errors are skipped without calling \fBbgerror\fR.
.PP
Tcl has no default implementation for \fBbgerror\fR.
-However, in applications using Tk there will be a default
-\fBbgerror\fR procedure that posts a dialog box containing
+However, in applications using Tk there is a default
+\fBbgerror\fR procedure
+which posts a dialog box containing
the error message and offers the user a chance to see a stack
trace showing where the error occurred.
diff --git a/contrib/tcl/doc/expr.n b/contrib/tcl/doc/expr.n
index e7dda17681fd..f4532cc18a7a 100644
--- a/contrib/tcl/doc/expr.n
+++ b/contrib/tcl/doc/expr.n
@@ -5,7 +5,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" SCCS: @(#) expr.n 1.25 97/04/29 10:11:52
+'\" SCCS: @(#) expr.n 1.27 97/08/12 11:31:30
'\"
.so man.macros
.TH expr n 8.0 Tcl "Tcl Built-In Commands"
@@ -285,6 +285,7 @@ operands could be arbitrary; it's better in these cases to use the
\fBstring compare\fR command instead.
.SH "PERFORMANCE CONSIDERATIONS"
+.VS
.PP
Enclose expressions in braces for the best speed and the smallest
storage requirements.
@@ -315,6 +316,7 @@ The most expensive code is required for
unbraced expressions that contain command substitutions.
These expressions must be implemented by generating new code
each time the expression is executed.
+.VE
.SH KEYWORDS
-arithmetic, boolean, compare, expression
+arithmetic, boolean, compare, expression, fuzzy comparison
diff --git a/contrib/tcl/doc/history.n b/contrib/tcl/doc/history.n
index a93e2fd0c227..e58ea3a770ed 100644
--- a/contrib/tcl/doc/history.n
+++ b/contrib/tcl/doc/history.n
@@ -1,11 +1,11 @@
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
-'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
+'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" SCCS: @(#) history.n 1.6 96/03/25 20:16:25
+'\" SCCS: @(#) history.n 1.11 97/08/07 16:44:49
'\"
.so man.macros
.TH history n "" Tcl "Tcl Built-In Commands"
@@ -29,7 +29,7 @@ A number: if positive, it refers to the event with
that number (all events are numbered starting at 1). If the number
is negative, it selects an event relative to the current event
(\fB\-1\fR refers to the previous event, \fB\-2\fR to the one before that, and
-so on).
+so on). Event \fB0\fP refers to the current event.
.IP [2]
A string: selects the most recent event that matches the string.
An event is considered to match the string either if the string is
@@ -57,10 +57,13 @@ substitution and wish to replace the current event (which invokes the
substitution) with the command created through substitution. The return
value is an empty string.
.TP
+\fBhistory clear\fR
+Erase the history list. The current keep limit is retained.
+The history event numbers are reset.
+.TP
\fBhistory event\fR ?\fIevent\fR?
Returns the value of the event given by \fIevent\fR. \fIEvent\fR
-defaults to \fB\-1\fR. This command causes history revision to occur:
-see below for details.
+defaults to \fB\-1\fR.
.TP
\fBhistory info \fR?\fIcount\fR?
Returns a formatted string (intended for humans to read) giving
@@ -68,10 +71,10 @@ the event number and contents for each of the events in the history
list except the current event. If \fIcount\fR is specified
then only the most recent \fIcount\fR events are returned.
.TP
-\fBhistory keep \fIcount\fR
+\fBhistory keep \fR?\fIcount\fR?
This command may be used to change the size of the history list to
\fIcount\fR events. Initially, 20 events are retained in the history
-list. This command returns an empty string.
+list. If \fIcount\fR is not specified, the current keep limit is returned.
.TP
\fBhistory nextid\fR
Returns the number of the next event to be recorded
@@ -82,87 +85,20 @@ event number in command-line prompts.
Re-executes the command indicated by \fIevent\fR and return its result.
\fIEvent\fR defaults to \fB\-1\fR. This command results in history
revision: see below for details.
-.TP
-\fBhistory substitute \fIold new \fR?\fIevent\fR?
-Retrieves the command given by \fIevent\fR
-(\fB\-1\fR by default), replace any occurrences of \fIold\fR by
-\fInew\fR in the command (only simple character equality is supported;
-no wild cards), execute the resulting command, and return the result
-of that execution. This command results in history
-revision: see below for details.
-.TP
-\fBhistory words \fIselector\fR ?\fIevent\fR?
-Retrieves from the command given by \fIevent\fR (\fB\-1\fR by default)
-the words given by \fIselector\fR, and return those words in a string
-separated by spaces. The \fBselector\fR argument has three forms.
-If it is a single number then it selects the word given by that
-number (\fB0\fR for the command name, \fB1\fR for its first argument,
-and so on). If it consists of two numbers separated by a dash,
-then it selects all the arguments between those two. Otherwise
-\fBselector\fR is treated as a pattern; all words matching that
-pattern (in the sense of \fBstring match\fR) are returned. In
-the numeric forms \fB$\fR may be used
-to select the last word of a command.
-For example, suppose the most recent command in the history list is
-.RS
-.CS
-\fBformat {%s is %d years old} Alice [expr $ageInMonths/12]\fR
-.CE
-Below are some history commands and the results they would produce:
-.DS
-.ta 4c
-.fi
-.UL Command " "
-.UL Result
-.nf
-
-\fBhistory words $ [expr $ageInMonths/12]\fR
-\fBhistory words 1-2 {%s is %d years old} Alice\fR
-\fBhistory words *a*o* {%s is %d years old} [expr $ageInMonths/12]\fR
-.DE
-\fBHistory words\fR results in history revision: see below for details.
-.RE
.SH "HISTORY REVISION"
.PP
-The history options \fBevent\fR, \fBredo\fR, \fBsubstitute\fR,
-and \fBwords\fR result in ``history revision''.
-When one of these options is invoked then the current event
+Pre-8.0 Tcl had a complex history revision mechanism.
+The current mechanism is more limited, and the old
+history operations \fBsubstitute\fP and \fBwords\fP have been removed.
+(As a consolation, the \fBclear\fP operation was added.)
+.PP
+The history option \fBredo\fR results in much simpler ``history revision''.
+When this option is invoked then the most recent event
is modified to eliminate the history command and replace it with
the result of the history command.
-For example, suppose that the most recent command in the history
-list is
-.CS
-\fBset a [expr $b+2]\fR
-.CE
-and suppose that the next command invoked is one of the ones on
-the left side of the table below. The command actually recorded in
-the history event will be the corresponding one on the right side
-of the table.
-.ne 1.5c
-.DS
-.ta 4c
-.fi
-.UL "Command Typed" " "
-.UL "Command Recorded"
-.nf
-
-\fBhistory redo set a [expr $b+2]\fR
-\fBhistory s a b set b [expr $b+2]\fR
-\fBset c [history w 2] set c [expr $b+2]\fR
-.DE
-History revision is needed because event specifiers like \fB\-1\fR
-are only valid at a particular time: once more events have been
-added to the history list a different event specifier would be
-needed.
-History revision occurs even when \fBhistory\fR is invoked
-indirectly from the current event (e.g. a user types a command
-that invokes a Tcl procedure that invokes \fBhistory\fR): the
-top-level command whose execution eventually resulted in a
-\fBhistory\fR command is replaced.
-If you wish to invoke commands like \fBhistory words\fR without
-history revision, you can use \fBhistory event\fR to save the
-current history event and then use \fBhistory change\fR to
-restore it later.
+If you want to redo an event without modifying history, then use
+the \fBevent\fP operation to retrieve some event,
+and the \fBadd\fP operation to add it to history and execute it.
.SH KEYWORDS
-event, history, record, revision
+event, history, record
diff --git a/contrib/tcl/doc/http.n b/contrib/tcl/doc/http.n
index 5a5b2d28b246..36227ce9d354 100644
--- a/contrib/tcl/doc/http.n
+++ b/contrib/tcl/doc/http.n
@@ -4,7 +4,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" SCCS: @(#) http.n 1.10 97/06/24 17:15:09
+'\" SCCS: @(#) http.n 1.11 97/08/07 16:45:02
'\"
.so man.macros
.TH "Http" n 8.0 Tcl "Tcl Built-In Commands"
@@ -13,25 +13,25 @@
.SH NAME
Http \- Client-side implementation of the HTTP/1.0 protocol.
.SH SYNOPSIS
-\fBpackage require http ?1.0?\fP
+\fBpackage require http ?2.0?\fP
.sp
-\fBhttp_config \fI?options?\fR
+\fB::http::config \fI?options?\fR
.sp
-\fBhttp_get \fIurl ?options?\fR
+\fB::http::geturl \fIurl ?options?\fR
.sp
-\fBhttp_formatQuery \fIlist\fR
+\fB::http::formatQuery \fIlist\fR
.sp
-\fBhttp_reset \fItoken\fR
+\fB::http::reset \fItoken\fR
.sp
-\fBhttp_wait \fItoken\fR
+\fB::http::wait \fItoken\fR
.sp
-\fBhttp_status \fItoken\fR
+\fB::http::status \fItoken\fR
.sp
-\fBhttp_size \fItoken\fR
+\fB::http::size \fItoken\fR
.sp
-\fBhttp_code \fItoken\fR
+\fB::http::code \fItoken\fR
.sp
-\fBhttp_data \fItoken\fR
+\fB::http::data \fItoken\fR
.BE
.SH DESCRIPTION
@@ -43,26 +43,27 @@ firewalls. The package is compatible with the \fBSafesock\fR security
policy, so it can be used by untrusted applets to do URL fetching from
a restricted set of hosts.
.PP
-The \fBhttp_get\fR procedure does a HTTP transaction.
+The \fB::http::geturl\fR procedure does a HTTP transaction.
Its \fIoptions \fR determine whether a GET, POST, or HEAD transaction
is performed.
-The return value of \fBhttp_get\fR is a token for the transaction.
-The value is also the name of a global array that contains state
+The return value of \fB::http::geturl\fR is a token for the transaction.
+The value is also the name of an array in the ::http namespace
+ that contains state
information about the transaction. The elements of this array are
described in the STATE ARRAY section.
.PP
If the \fB-command\fP option is specified, then
the HTTP operation is done in the background.
-\fBhttp_get\fR returns immediately after generating the
+\fB::http::geturl\fR returns immediately after generating the
HTTP request and the callback is invoked
when the transaction completes. For this to work, the Tcl event loop
must be active. In Tk applications this is always true. For pure-Tcl
-applications, the caller can use \fBhttp_wait\fR after calling
-\fBhttp_get\fR to start the event loop.
+applications, the caller can use \fB::http::wait\fR after calling
+\fB::http::geturl\fR to start the event loop.
.SH COMMANDS
.TP
-\fBhttp_config\fP ?\fIoptions\fR?
-The \fBhttp_config\fR command is used to set and query the name of the
+\fB::http::config\fP ?\fIoptions\fR?
+The \fB::http::config\fR command is used to set and query the name of the
proxy server and port, and the User-Agent name used in the HTTP
requests. If no options are specified, then the current configuration
is returned. If a single argument is specified, then it should be one
@@ -86,7 +87,7 @@ The proxy port number.
.TP
\fB\-proxyfilter\fP \fIcommand\fP
The command is a callback that is made during
-\fBhttp_get\fR
+\fB::http::geturl\fR
to determine if a proxy is required for a given host. One argument, a
host name, is added to \fIcommand\fR when it is invoked. If a proxy
is required, the callback should return a two element list containing
@@ -97,20 +98,20 @@ non-empty.
.TP
\fB\-useragent\fP \fIstring\fP
The value of the User-Agent header in the HTTP request. The default
-is \fB"Tcl http client package 1.0."\fR
+is \fB"Tcl http client package 2.0."\fR
.RE
.TP
-\fBhttp_get\fP \fIurl\fP ?\fIoptions\fP?
-The \fBhttp_get \fR command is the main procedure in the package.
+\fB::http::geturl\fP \fIurl\fP ?\fIoptions\fP?
+The \fB::http::geturl \fR command is the main procedure in the package.
The \fB\-query\fR option causes a POST operation and
the \fB\-validate\fR option causes a HEAD operation;
-otherwise, a GET operation is performed. The \fBhttp_get\fR command
+otherwise, a GET operation is performed. The \fB::http::geturl\fR command
returns a \fItoken\fR value that can be used to get
information about the transaction. See the STATE ARRAY section for
-details. The \fBhttp_get\fR command blocks until the operation
+details. The \fB::http::geturl\fR command blocks until the operation
completes, unless the \fB\-command\fR option specifies a callback
that is invoked when the HTTP transaction completes.
-\fBhttp_get\fR takes several options:
+\fB::http::geturl\fR takes several options:
.RS
.TP
\fB\-blocksize\fP \fIsize\fP
@@ -127,9 +128,9 @@ Copy the URL contents to channel \fIname\fR instead of saving it in
.TP
\fB\-command\fP \fIcallback\fP
Invoke \fIcallback\fP after the HTTP transaction completes.
-This option causes \fBhttp_get\fP to return immediately.
+This option causes \fB::http::geturl\fP to return immediately.
The \fIcallback\fP gets an additional argument that is the \fItoken\fR returned
-from \fBhttp_get\fR. This token is the name of a global array that is
+from \fB::http::geturl\fR. This token is the name of an array that is
described in the STATE ARRAY section. Here is a template for the
callback:
.RS
@@ -145,7 +146,7 @@ proc httpCallback {token} {
Invoke \fIcallback\fP whenever HTTP data is available; if present, nothing
else will be done with the HTTP data. This procedure gets two additional
arguments: the socket for the HTTP data and the \fItoken\fR returned from
-\fBhttp_get\fR. The token is the name of a global array that is described
+\fB::http::geturl\fR. The token is the name of a global array that is described
in the STATE ARRAY section. The procedure is expected to return the number
of bytes read from the socket. Here is a template for the callback:
.RS
@@ -176,7 +177,7 @@ Pragma: no-cache
\fB\-progress\fP \fIcallback\fP
The \fIcallback\fR is made after each transfer of data from the URL.
The callback gets three additional arguments: the \fItoken\fR from
-\fBhttp_get\fR, the expected total size of the contents from the
+\fB::http::geturl\fR, the expected total size of the contents from the
\fBContent-Length\fR meta-data, and the current number of bytes
transferred so far. The expected total size may be unknown, in which
case zero is passed to the callback. Here is a template for the
@@ -190,60 +191,60 @@ proc httpProgress {token total current} {
.RE
.TP
\fB\-query\fP \fIquery\fP
-This flag causes \fBhttp_get\fR to do a POST request that passes the
+This flag causes \fB::http::geturl\fR to do a POST request that passes the
\fIquery\fR to the server. The \fIquery\fR must be a x-url-encoding
-formatted query. The \fBhttp_formatQuery\fR procedure can be used to
+formatted query. The \fB::http::formatQuery\fR procedure can be used to
do the formatting.
.TP
\fB\-timeout\fP \fImilliseconds\fP
-If \fImilliseconds\fR is non-zero, then \fBhttp_get\fR sets up a timeout
+If \fImilliseconds\fR is non-zero, then \fB::http::geturl\fR sets up a timeout
to occur after the specified number of milliseconds.
-A timeout results in a call to \fBhttp_reset\fP and to
+A timeout results in a call to \fB::http::reset\fP and to
the \fB-command\fP callback, if specified.
-The return value of \fBhttp_status\fP is \fBtimeout\fP
+The return value of \fB::http::status\fP is \fBtimeout\fP
after a timeout has occurred.
.TP
\fB\-validate\fP \fIboolean\fP
-If \fIboolean\fR is non-zero, then \fBhttp_get\fR does an HTTP HEAD
+If \fIboolean\fR is non-zero, then \fB::http::geturl\fR does an HTTP HEAD
request. This request returns meta information about the URL, but the
contents are not returned. The meta information is available in the
\fBstate(meta) \fR variable after the transaction. See the STATE
ARRAY section for details.
.RE
.TP
-\fBhttp_formatQuery\fP \fIkey value\fP ?\fIkey value\fP ...?
+\fB::http::formatQuery\fP \fIkey value\fP ?\fIkey value\fP ...?
This procedure does x-url-encoding of query data. It takes an even
number of arguments that are the keys and values of the query. It
encodes the keys and values, and generates one string that has the
proper & and = separators. The result is suitable for the
-\fB\-query\fR value passed to \fBhttp_get\fR.
+\fB\-query\fR value passed to \fB::http::geturl\fR.
.TP
-\fBhttp_reset\fP \fItoken\fP ?\fIwhy\fP?
+\fB::http::reset\fP \fItoken\fP ?\fIwhy\fP?
This command resets the HTTP transaction identified by \fItoken\fR, if
any. This sets the \fBstate(status)\fP value to \fIwhy\fP, which defaults to \fBreset\fR, and then calls the registered \fB\-command\fR callback.
.TP
-\fBhttp_wait\fP \fItoken\fP
+\fB::http::wait\fP \fItoken\fP
This is a convenience procedure that blocks and waits for the
transaction to complete. This only works in trusted code because it
uses \fBvwait\fR.
.TP
-\fBhttp_data\fP \fItoken\fP
+\fB::http::data\fP \fItoken\fP
This is a convenience procedure that returns the \fBbody\fP element
(i.e., the URL data) of the state array.
.TP
-\fBhttp_status\fP \fItoken\fP
+\fB::http::status\fP \fItoken\fP
This is a convenience procedure that returns the \fBstatus\fP element of
the state array.
.TP
-\fBhttp_code\fP \fItoken\fP
+\fB::http::code\fP \fItoken\fP
This is a convenience procedure that returns the \fBhttp\fP element of the
state array.
.TP
-\fBhttp_size\fP \fItoken\fP
+\fB::http::size\fP \fItoken\fP
This is a convenience procedure that returns the \fBcurrentsize\fP
element of the state array.
.SH "STATE ARRAY"
-The \fBhttp_get\fR procedure returns a \fItoken\fR that can be used to
+The \fB::http::geturl\fR procedure returns a \fItoken\fR that can be used to
get to the state of the HTTP transaction in the form of a Tcl array.
Use this construct to create an easy-to-use array variable:
.CS
@@ -254,11 +255,11 @@ The following elements of the array are supported:
.TP
\fBbody\fR
The contents of the URL. This will be empty if the \fB\-channel\fR
-option has been specified. This value is returned by the \fBhttp_data\fP command.
+option has been specified. This value is returned by the \fB::http::data\fP command.
.TP
\fBcurrentsize\fR
The current number of bytes fetched from the URL.
-This value is returned by the \fBhttp_size\fP command.
+This value is returned by the \fB::http::size\fP command.
.TP
\fBerror\fR
If defined, this is the error string seen when the HTTP transaction
@@ -266,7 +267,7 @@ was aborted.
.TP
\fBhttp\fR
The HTTP status reply from the server. This value
-is returned by the \fBhttp_code\fP command. The format of this value is:
+is returned by the \fB::http::code\fP command. The format of this value is:
.RS
.CS
\fIcode string\fP
@@ -297,7 +298,7 @@ The type of the URL contents. Examples include \fBtext/html\fR,
.TP
\fBContent-Length\fR
The advertised size of the contents. The actual size obtained by
-\fBhttp_get\fR is available as \fBstate(size)\fR.
+\fB::http::geturl\fR is available as \fBstate(size)\fR.
.TP
\fBLocation\fR
An alternate URL that contains the requested data.
@@ -320,12 +321,12 @@ The requested URL.
.SH EXAMPLE
.DS
# Copy a URL to a file and print meta-data
-proc Http_Copy { url file {chunk 4096} } {
+proc ::http::copy { url file {chunk 4096} } {
set out [open $file w]
- set token [http_get $url -channel $out -progress HttpProgress \\
+ set token [geturl $url -channel $out -progress ::http::Progress \\
-blocksize $chunk]
close $out
- # This ends the line started by HttpProgress
+ # This ends the line started by http::Progress
puts stderr ""
upvar #0 $token state
set max 0
@@ -336,7 +337,7 @@ proc Http_Copy { url file {chunk 4096} } {
if {[regexp -nocase ^location$ $name]} {
# Handle URL redirects
puts stderr "Location:$value"
- return [Http_Copy [string trim $value] $file $chunk]
+ return [copy [string trim $value] $file $chunk]
}
}
incr max
@@ -346,7 +347,7 @@ proc Http_Copy { url file {chunk 4096} } {
return $token
}
-proc HttpProgress {args} {
+proc ::http::Progress {args} {
puts -nonewline stderr . ; flush stderr
}
diff --git a/contrib/tcl/doc/interp.n b/contrib/tcl/doc/interp.n
index a7dda337b0b8..023681833e0d 100644
--- a/contrib/tcl/doc/interp.n
+++ b/contrib/tcl/doc/interp.n
@@ -4,7 +4,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" SCCS: @(#) interp.n 1.29 97/03/06 17:41:39
+'\" SCCS: @(#) interp.n 1.35 97/07/31 18:04:06
'\"
.so man.macros
.TH interp n 7.6 Tcl "Tcl Built-In Commands"
@@ -169,18 +169,29 @@ exists in this master, \fB0\fR otherwise. If \fIpath\fR is omitted, the
invoking interpreter is used.
.VS BR
.TP
-\fBinterp \fBexpose \fIpath\fR \fIhiddenCmdName\fR ?\fIexposedCmdName\fR?
-Makes the hidden command \fIhiddenCmdName\fR exposed, potentially renaming
-it to \fIexposedCmdName\fR, in the interpreter denoted by \fIpath\fR.
+\fBinterp \fBexpose \fIpath\fR \fIhiddenName\fR ?\fIexposedCmdName\fR?
+Makes the hidden command \fIhiddenName\fR exposed, eventually bringing
+it back under a new \fIexposedCmdName\fR name (this name is currently
+accepted only if it is a valid global name space name without any ::),
+in the interpreter
+denoted by \fIpath\fR.
If an exposed command with the targetted name already exists, this command
fails.
Hidden commands are explained in more detail in HIDDEN COMMANDS, below.
.TP
\fBinterp \fBhide \fIpath\fR \fIexposedCmdName\fR ?\fIhiddenCmdName\fR?
-Makes the exposed command \fIexposedCmdName\fR hidden, potentially renaming
-it to \fIhiddenCmdName\fR, in the interpreter denoted by \fIpath\fR.
+Makes the exposed command \fIexposedCmdName\fR hidden, renaming
+it to the hidden command \fIhiddenCmdName\fR, or keeping the same name if
+\fIhiddenCmdName\fR is not given, in the interpreter denoted
+by \fIpath\fR.
If a hidden command with the targetted name already exists, this command
fails.
+Currently both \fIexposedCmdName\fR and \fIhiddenCmdName\fR can
+not contain namespace qualifiers, or an error is raised.
+Commands to be hidden by \fBinterp hide\fR are looked up in the global
+namespace even if the current namespace is not the global one. This
+prevents slaves from fooling a master interpreter into hiding the wrong
+command, by making the current namespace be different from the global one.
Hidden commands are explained in more detail in HIDDEN COMMANDS, below.
.TP
\fBinterp \fBhidden \fIpath\fR
@@ -291,25 +302,34 @@ such as the \fBerrorInfo\fR and \fBerrorCode\fR variables, if an
error occurs) is returned to the invoking interpreter.
.VS BR
.TP
-\fIslave \fBexpose \fIhiddenCmdName \fR?\fIexposedCmdName\fR?
-This command exposes the hidden command \fIhiddenCmdName\fR, potentially
-renaming it to \fIexposedCmdName\fR, in \fIslave\fR.
-If an exposed command with the targeted name already exists, this command
+\fIslave \fBexpose \fIhiddenName \fR?\fIexposedCmdName\fR?
+This command exposes the hidden command \fIhiddenName\fR, eventually bringing
+it back under a new \fIexposedCmdName\fR name (this name is currently
+accepted only if it is a valid global name space name without any ::),
+in \fIslave\fR.
+If an exposed command with the targetted name already exists, this command
fails.
For more details on hidden commands, see HIDDEN COMMANDS, below.
.TP
-\fIslave \fBhide \fIexposedCmdName \fR?\fIhiddenCmdName\fR?
-This command hides the exposed command \fIexposedCmdName\fR, potentially
-renaming it to \fIhiddenCmdName\fR, in \fIslave\fR.
-If a hidden command with the targeted name already exists, this command
+\fIslave \fBhide \fIexposedCmdName\fR ?\fIhiddenCmdName\fR?
+This command hides the exposed command \fIexposedCmdName\fR, renaming it to
+the hidden command \fIhiddenCmdName\fR, or keeping the same name if the
+the argument is not given, in the \fIslave\fR interpreter.
+If a hidden command with the targetted name already exists, this command
fails.
+Currently both \fIexposedCmdName\fR and \fIhiddenCmdName\fR can
+not contain namespace qualifiers, or an error is raised.
+Commands to be hidden are looked up in the global
+namespace even if the current namespace is not the global one. This
+prevents slaves from fooling a master interpreter into hiding the wrong
+command, by making the current namespace be different from the global one.
For more details on hidden commands, see HIDDEN COMMANDS, below.
.TP
\fIslave \fBhidden\fR
Returns a list of the names of all hidden commands in \fIslave\fR.
.TP
-\fIslave \fBinvokehidden\fR ?\fB-global\fR \fIhiddenCmdName \fR?\fIarg ..\fR?
-This command invokes the hidden command \fIhiddenCmdName\fR with the
+\fIslave \fBinvokehidden\fR ?\fB-global\fR \fIhiddenName \fR?\fIarg ..\fR?
+This command invokes the hidden command \fIhiddenName\fR with the
supplied arguments, in \fIslave\fR. No substitutions or evaluations are
applied to the arguments.
If the \fB-global\fR flag is given, the command is invoked at the global
@@ -494,11 +514,19 @@ interpreter using \fBinterp expose\fR and \fBinterp hide\fR. The \fBinterp
expose\fR command moves a hidden command to the
set of exposed commands in the interpreter identified by \fIpath\fR,
potentially renaming the command in the process. If an exposed command by
-the targeted name already exists, the operation fails. Similarly,
+the targetted name already exists, the operation fails. Similarly,
\fBinterp hide\fR moves an exposed command to the set of hidden commands in
that interpreter. Safe interpreters are not allowed to move commands
between the set of hidden and exposed commands, in either themselves or
their descendants.
+.PP
+Currently, the names of hidden commands cannot contain namespace
+qualifiers, and you must first rename a command in a namespace to the
+global namespace before you can hide it.
+Commands to be hidden by \fBinterp hide\fR are looked up in the global
+namespace even if the current namespace is not the global one. This
+prevents slaves from fooling a master interpreter into hiding the wrong
+command, by making the current namespace be different from the global one.
.VE
.SH CREDITS
.PP
diff --git a/contrib/tcl/doc/namespace.n b/contrib/tcl/doc/namespace.n
index 4be685a7527c..5bf787d87bec 100644
--- a/contrib/tcl/doc/namespace.n
+++ b/contrib/tcl/doc/namespace.n
@@ -5,7 +5,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" SCCS: @(#) namespace.n 1.8 97/06/20 16:48:18
+'\" SCCS: @(#) namespace.n 1.9 97/08/13 17:08:25
'\"
.so man.macros
.TH namespace n 8.0 Tcl "Tcl Built-In Commands"
@@ -14,7 +14,7 @@
.SH NAME
namespace \- create and manipulate contexts for commands and variables
.SH SYNOPSIS
-\fBnamespace ?\fIsubcommand\fR? ?\fIarg ...\fR?
+\fBnamespace \fR?\fIoption\fR? ?\fIarg ...\fR?
.BE
.SH DESCRIPTION
@@ -23,38 +23,45 @@ The \fBnamespace\fR command lets you create, access, and destroy
separate contexts for commands and variables.
See the section \fBWHAT IS A NAMESPACE?\fR below
for a brief overview of namespaces.
-The legal \fIsubcommand\fR's are listed below.
-Note that you can abbreviate the names of subcommands.
+The legal \fIoption\fR's are listed below.
+Note that you can abbreviate the \fIoption\fR's.
.TP
-\fBnamespace children \fR?\fIname\fR? ?\fIpattern\fR?
+\fBnamespace children \fR?\fInamespace\fR? ?\fIpattern\fR?
Returns a list of all child namespaces that belong to the
-namespace \fIname\fR.
-If \fIname\fR is not specified,
+namespace \fInamespace\fR.
+If \fInamespace\fR is not specified,
then the children are returned for the current namespace.
-This command returns fully-qualified names which start with \fB::\fR.
+This command returns fully-qualified names,
+which start with \fB::\fR.
If the optional \fIpattern\fR is given,
then this command returns only the names that match the glob-style pattern.
The actual pattern used is determined as follows:
a pattern that starts with \fB::\fR is used directly,
-otherwise the namespace \fIname\fR
+otherwise the namespace \fInamespace\fR
(or the fully-qualified name of the current namespace)
is prepended onto the the pattern.
.TP
-\fBnamespace code \fIarg\fR
+\fBnamespace code \fIscript\fR
Captures the current namespace context for later execution
-of the script \fIarg\fR.
-It returns a new Tcl scoped command that can be evaluated later
-to execute \fIarg\fR in the current namespace.
-It is typically used to create callback scripts,
-where the \fIarg\fR argument is a list containing a script.
-The command it produces is equivalent to that produced by
-\fBlist namespace inscope [namespace current] $arg\fR
-If \fIarg\fR is itself a scoped command starting with
-\fBnamespace inscope\fR,
-the result is just \fIarg\fR.
-.br
-.sp
-Extensions like Tk normally execute callback scripts
+of the script \fIscript\fR.
+It returns a new script in which \fIscript\fR has been wrapped
+in a \fBnamespace code\fR command.
+The new script has two important properties.
+First, it can be evaluated in any namespace and will cause
+\fIscript\fR to be evaluated in the current namespace
+(the one where the \fBnamespace code\fR command was invoked).
+Second, additional arguments can be appended to the resulting script
+and they will be passed to \fIscript\fR as additional arguments.
+For example, suppose the command
+\fBset script [namespace code {foo bar}]\fR
+is invoked in namespace \fB::a::b\fR.
+Then \fBeval "$script x y"\fR
+can be executed in any namespace (assuming the value of
+\fBscript\fR has been passed in properly)
+and will have the same effect as the command
+\fBnamespace eval ::a::b {foo bar x y}\fR.
+This command is needed because
+extensions like Tk normally execute callback scripts
in the global namespace.
A scoped command captures a command together with its namespace context
in a way that allows it to be executed properly later.
@@ -67,19 +74,11 @@ The actual name of the global namespace is ``''
(i.e., an empty string),
but this command returns \fB::\fR for the global namespace
as a convenience to programmers.
-Tcl treats ``'' and \fB::\fR as synonyms
-for the name of the global namespace.
-This make it easier to manipulate namespace names
-and ensures that commands like
-\fBset [namespace current]::x\fR
-always work.
.TP
-\fBnamespace delete \fR?\fIname name ...\fR?
-Each namespace \fIname\fR is deleted
+\fBnamespace delete \fR?\fInamespace namespace ...\fR?
+Each namespace \fInamespace\fR is deleted
and all variables, procedures, and child namespaces
contained in the namespace are deleted.
-\fIname\fR may include a sequence of namespace qualifiers
-separated by \fB::\fRs.
If a procedure is currently executing inside the namespace,
the namespace will be kept alive until the procedure returns;
however, the namespace is marked to prevent other code from
@@ -87,42 +86,21 @@ looking it up by name.
If a namespace doesn't exist, this command returns an error.
If no namespace names are given, this command does nothing.
.TP
-\fBnamespace eval\fR \fIname arg\fR ?\fIarg ...\fR?
-Activates a namespace called \fIname\fR and evaluates some code
+\fBnamespace eval\fR \fInamespace arg\fR ?\fIarg ...\fR?
+Activates a namespace called \fInamespace\fR and evaluates some code
in that context.
If the namespace does not already exist, it is created.
-This command is normally used to define the
-commands and variables in a namespace.
If more than one \fIarg\fR argument is specified,
the arguments are concatenated together with a space between each one
-in the same fashion as the \fBconcat\fR command,
+in the same fashion as the \fBeval\fR command,
and the result is evaluated.
.br
.sp
-If a \fBnamespace eval\fR command creates a new namespace \fIname\fR,
-then \fIname\fR determines its parent namespace and
-the new namespace's position in the hierarchy of namespaces.
-If \fIname\fR includes a sequence of namespace qualifiers
-separated by \fB::\fRs,
-it is created as a child of the specified parent namespace;
-otherwise, the namespace is created as a child of the current namespace.
-If \fIname\fR has leading namespace qualifiers
+If \fInamespace\fR has leading namespace qualifiers
and any leading namespaces do not exist,
they are automatically created.
-.br
-.sp
-\fBnamespace eval\fR is another way (besides procedure calls)
-that the Tcl naming context can change.
-It adds a call frame to the stack to represent the namespace context.
-This means each \fBnamespace eval\fR command
-counts as another call level for \fBuplevel\fR and \fBupvar\fR commands.
-For example, \fBinfo level 1\fR will return a list
-describing a command that is either
-the outermost procedure call or the outermost \fBnamespace eval\fR command.
-Also, \fBuplevel #0\fR evaluates a script
-at top-level in the outermost namespace (the global namespace).
.TP
-\fBnamespace export \fR?\fB-clear\fR? ?\fIpattern pattern ...\fR?
+\fBnamespace export \fR?\-\fBclear\fR? ?\fIpattern pattern ...\fR?
Specifies which commands are exported from a namespace.
The exported commands are those that can be later imported
into another namespace using a \fBnamespace import\fR command.
@@ -136,15 +114,15 @@ but it may not include any namespace qualifiers.
That is, the pattern can only specify commands
in the current (exporting) namespace.
Each \fIpattern\fR is appended onto the namespace's list of export patterns.
-If the \fB-clear\fR flag is given,
+If the \-\fBclear\fR flag is given,
the namespace's export pattern list is reset to empty before any
\fIpattern\fR arguments are appended.
-If no \fIpattern\fRs are given and the \fB-clear\fR flag isn't given,
+If no \fIpattern\fRs are given and the \-\fBclear\fR flag isn't given,
this command returns the namespace's current export list.
.TP
\fBnamespace forget \fR?\fIpattern pattern ...\fR?
Removes previously imported commands from a namespace.
-Each \fIpattern\fR is a \fIqualified name\fR like
+Each \fIpattern\fR is a qualified name such as
\fBfoo::x\fR or \fBa::b::p*\fR.
Qualified names contain \fB::\fRs and qualify a name
with the name of one or more namespaces.
@@ -155,10 +133,10 @@ Glob characters may not appear in a namespace name.
This command first finds the matching exported commands.
It then checks whether any of those those commands
were previously imported by the current namespace.
-If so, this command deletes the corresponding imported command.
+If so, this command deletes the corresponding imported commands.
In effect, this un-does the action of a \fBnamespace import\fR command.
.TP
-\fBnamespace import \fR?\fB-force\fR? ?\fIpattern\fR \fIpattern ...\fR?
+\fBnamespace import \fR?\fB\-force\fR? ?\fIpattern\fR \fIpattern ...\fR?
Imports commands into a namespace.
Each \fIpattern\fR is a qualified name like
\fBfoo::x\fR or \fBa::p*\fR.
@@ -167,17 +145,24 @@ and may have glob-style special characters in the command name
at the end of the qualified name.
Glob characters may not appear in a namespace name.
All the commands that match a \fIpattern\fR string
-and which are exported from their namespace
+and which are currently exported from their namespace
are added to the current namespace.
This is done by creating a new command in the current namespace
that points to the exported command in its original namespace;
when the new imported command is called, it invokes the exported command.
This command normally returns an error
if an imported command conflicts with an existing command.
-However, if the \fB-force\fR option is given,
+However, if the \-\fBforce\fR option is given,
imported commands will silently replace existing commands.
+The \fBnamespace import\fR command has snapshot semantics:
+that is, only requested commands that are currently defined
+in the exporting namespace are imported.
+In other words, you can import only the commands that are in a namespace
+at the time when the \fBnamespace import\fR command is executed.
+If another command is defined and exported in this namespace later on,
+it will not be imported.
.TP
-\fBnamespace inscope\fR \fIname arg\fR ?\fIarg ...\fR?
+\fBnamespace inscope\fR \fInamespace arg\fR ?\fIarg ...\fR?
Executes a script in the context of a particular namespace.
This command is not expected to be used directly by programmers;
calls to it are generated implicitly when applications
@@ -195,9 +180,9 @@ is equivalent to
This \fBlappend\fR semantics is important because many callback scripts
are actually prefixes.
.TP
-\fBnamespace origin name\fR
+\fBnamespace origin \fIcommand\fR
Returns the fully-qualified name of the original command
-to which the imported command \fIname\fR refers.
+to which the imported command \fIcommand\fR refers.
When a command is imported into a namespace,
a new command is created in that namespace
that points to the actual command in the exporting namespace.
@@ -206,13 +191,13 @@ If a command is imported into a sequence of namespaces
just imports the command from the previous namespace,
this command returns the fully-qualified name of the original command
in the first namespace, \fIa\fR.
-If \fIname\fR does not refer to an imported command,
+If \fIcommand\fR does not refer to an imported command,
the command's own fully-qualified name is returned.
.TP
-\fBnamespace parent\fR ?\fIname\fR?
+\fBnamespace parent\fR ?\fInamespace\fR?
Returns the fully-qualified name of the parent namespace
-for namespace \fIname\fR.
-If \fIname\fR is not specified,
+for namespace \fInamespace\fR.
+If \fInamespace\fR is not specified,
the fully-qualified name of the current namespace's parent is returned.
.TP
\fBnamespace qualifiers\fR \fIstring\fR
@@ -236,7 +221,7 @@ This command is the complement of the \fBnamespace qualifiers\fR command.
It does not check whether the namespace names are, in fact,
the names of currently defined namespaces.
.TP
-\fBnamespace which\fR ?\fB-command\fR? ?\fB-variable\fR? \fIname\fR
+\fBnamespace which\fR ?\-\fBcommand\fR? ?\-\fBvariable\fR? \fIname\fR
Looks up \fIname\fR as either a command or variable
and returns its fully-qualified name.
For example, if \fIname\fR does not exist in the current namespace
@@ -274,7 +259,7 @@ the procedure \fBBump\fR.
The commands and variables in this namespace are separate from
other commands and variables in the same program.
If there is a command named \fBBump\fR in the global namespace,
-for example, it will not interfere with the command \fBBump\fR
+for example, it will be different from the command \fBBump\fR
in the \fBCounter\fR namespace.
.PP
Namespace variables resemble global variables in Tcl.
@@ -283,8 +268,8 @@ but can be accessed in a procedure via the \fBvariable\fR command,
as shown in the example above.
.PP
Namespaces are dynamic.
-You can add and delete commands and variables at any time.
-So you can build up the contents of a
+You can add and delete commands and variables at any time,
+so you can build up the contents of a
namespace over time using a series of \fBnamespace eval\fR commands.
For example, the following series of commands has the same effect
as the namespace definition shown above:
@@ -312,66 +297,37 @@ Namespaces can have other namespaces within them,
so they nest hierarchically.
A nested namespace is encapsulated inside its parent namespace
and can not interfere with other namespaces.
-If namespaces are used to represent packages,
-this feature lets one package contain its own copy of another package.
.SH "QUALIFIED NAMES"
-Procedures execute in the context of the namespace that contains them.
-So in the following namespace,
-.CS
-\fBnamespace eval Counter {
- namespace export Bump Reset
- variable num 0
-
- proc Bump {{by 1}} {
- variable num
- return [incr num $by]
- }
- proc Reset {} {
- variable num
- set num 0
- }
-}\fR
-.CE
-procedures like \fBBump\fR and \fBReset\fR execute in the context of
-namespace \fBCounter\fR.
.PP
-In this context, you can access the commands and variables that
-reside in the namespace using simple names.
-In the example above,
-we access the \fBnum\fR variable with the command \fBvariable num\fR.
-(We can't use \fBglobal num\fR since that would only
-look up \fBnum\fR in the global namespace.)
-We can access the \fBBump\fR and \fBReset\fR procedures in
-another procedure like this:
-.CS
-\fBnamespace eval Counter {
- namespace export Rebump
- proc Rebump {{by 1}} {
- Reset
- Bump $by
- }
-}\fR
-.CE
-This is the real benefit of namespaces.
-The commands and variables in a namespace fit together as a module.
+Each namespace has a textual name such as
+\fBhistory\fR or \fB::safe::interp\fR.
+Since namespaces may nest,
+qualified names are used to refer to
+commands, variables, and child namespaces contained inside namespaces.
+Qualified names are similar to the hierarchical path names for
+Unix files or Tk widgets,
+except that \fB::\fR is used as the separator
+instead of \fB/\fR or \fB.\fR.
+The topmost or global namespace has the name ``'' (i.e., an empty string),
+although \fB::\fR is a synonym.
+As an example, the name \fB::safe::interp::create\fR
+refers to the command \fBcreate\fR in the namespace \fBinterp\fR
+that is a child of of namespace \fB::safe\fR,
+which in turn is a child of the global namespace \fB::\fR.
.PP
If you want to access commands and variables from another namespace,
you must use some extra syntax.
Names must be qualified by the namespace that contains them.
-The \fB::\fR string acts as a separator
-between the various qualifiers in a name.
From the global namespace,
we might access the \fBCounter\fR procedures like this:
.CS
\fBCounter::Bump 5
-Counter::Reset
-Counter::Rebump 10\fR
+Counter::Reset\fR
.CE
We could access the current count like this:
.CS
-\fBputs "count = $Counter::num"
-set Counter::num 35\fR
+\fBputs "count = $Counter::num"\fR
.CE
When one namespace contains another, you may need more than one
qualifier to reach its elements.
@@ -381,23 +337,6 @@ from the global namespace like this:
.CS
\fBFoo::Counter::Bump 3\fR
.CE
-You can think of namespaces like directories in a file system.
-When you are sitting in a particular directory context,
-you can access files with simple names.
-But from another context, you must use a proper path name.
-A name like \fBFoo::Counter::Bump\fR
-is just like a file name \fBFoo/Counter/Bump\fR,
-except that we have used \fB::\fR instead of \fB/\fR as the separator.
-Just as the file system has a root directory \fB/\fR,
-all namespaces are rooted in the global namespace named \fB::\fR.
-So all names can be given with an absolute path that begins with \fB::\fR.
-For example, we can say:
-.CS
-\fB::Foo::Counter::Bump 3\fR
-.CE
-With this name, you can be sure that you'll get the \fBBump\fR procedure
-in the \fBCounter\fR namespace, in the \fBFoo\fR namespace, in the global
-namespace\-no matter what the current namespace context may be.
.PP
You can also use qualified names when you create and rename commands.
For example, you could add a procedure to the \fBFoo\fR
@@ -412,8 +351,9 @@ And you could move the same procedure to another namespace like this:
.PP
There are a few remaining points about qualified names
that we should cover.
-\fB::\fR is disallowed in both simple command and variable names except
-as a namespace separator.
+Namespaces have nonempty names except for the global namespace.
+\fB::\fR is disallowed in simple command, variable, and namespace names
+except as a namespace separator.
Extra \fB:\fRs in a qualified name are ignored;
that is, two or more \fB:\fRs are treated as a namespace separator.
A trailing \fB::\fR in a qualified variable or command name
@@ -471,27 +411,15 @@ You can use the \fBnamespace which\fR command to clear up any question
about name resolution.
For example, the command:
.CS
-\fBnamespace eval Foo::Debug {namespace which -variable traceLevel}\fR
+\fBnamespace eval Foo::Debug {namespace which \-variable traceLevel}\fR
.CE
returns \fB::traceLevel\fR.
On the other hand, the command,
.CS
-\fBnamespace eval Foo {namespace which -variable traceLevel}\fR
+\fBnamespace eval Foo {namespace which \-variable traceLevel}\fR
.CE
returns \fB::Foo::traceLevel\fR.
.PP
-Although Tcl always follows the
-``look in the current then in the global namespace''
-rule for variables and commands,
-there is a question of how to resolve a
-qualified name like \fBfoo::bar::cmd\fR.
-A relative name like this might resolve to either
-\fB[namespace current]::foo::bar::cmd\fR
-or to \fB::foo::bar::cmd\fR.
-If \fBcmd\fR does not appear in \fB[namespace current]::foo::bar\fR
-but does appear in \fB::foo::bar\fR,
-Tcl assumes it refers to the latter command.
-.PP
As mentioned above,
namespace names are looked up differently
than the names of variables and commands.
@@ -508,7 +436,7 @@ by the name resolution rule above,
you can access the element.
.PP
You can access a namespace variable
-within a procedure in the same namespace
+from a procedure in the same namespace
by using the \fBvariable\fR command.
Much like the \fBglobal\fR command,
this creates a local link to the namespace variable.
@@ -529,7 +457,7 @@ For example, suppose that all of the commands in a package
like BLT are contained in a namespace called \fBBlt\fR.
Then you might access these commands like this:
.CS
-\fBBlt::graph .g -background red
+\fBBlt::graph .g \-background red
Blt::table . .g 0,0\fR
.CE
If you use the \fBgraph\fR and \fBtable\fR commands frequently,
@@ -539,12 +467,16 @@ like this:
.CS
\fBnamespace import Blt::*\fR
.CE
-This adds all commands from the \fBBlt\fR namespace into the current
-namespace context, so you can write code like this:
+This adds all exported commands from the \fBBlt\fR namespace
+into the current namespace context, so you can write code like this:
.CS
-\fBgraph .g -background red
+\fBgraph .g \-background red
table . .g 0,0\fR
.CE
+The \fBnamespace import\fR command only imports commands
+from a namespace that that namespace exported
+with a \fBnamespace export\fR command.
+.PP
Importing \fIevery\fR command from a namespace is generally
a bad idea since you don't know what you will get.
It is better to import just the specific commands you need.
@@ -555,23 +487,15 @@ For example, the command
imports only the \fBgraph\fR and \fBtable\fR commands into the
current context.
.PP
-The \fBnamespace import\fR command has snapshot semantics:
-that is, only requested commands that are currently defined
-in the exporting namespace are imported.
-In other words, you can import only the commands that are in a namespace
-like \fBBlt\fR at the time when the \fBnamespace import\fR command is
-executed. If another command appears in this namespace later on, it
-will not be imported.
-.PP
If you try to import a command that already exists, you will get an
error. This prevents you from importing the same command from two
different packages. But from time to time (perhaps when debugging),
you may want to get around this restriction. You may want to
reissue the \fBnamespace import\fR command to pick up new commands
that have appeared in a namespace. In that case, you can use the
-\fB-force\fR option, and existing commands will be silently overwritten:
+\fB\-force\fR option, and existing commands will be silently overwritten:
.CS
-\fBnamespace import -force Blt::graph Blt::table\fR
+\fBnamespace import \-force Blt::graph Blt::table\fR
.CE
If for some reason, you want to stop using the imported commands,
you can remove them with an \fBnamespace forget\fR command, like this:
@@ -632,30 +556,6 @@ may be imported by other namespaces.
If a \fBnamespace import\fR command specifies a command
that is not exported, the command is not imported.
-.SH "SCOPED VALUES"
-.PP
-Extensions like Tk execute ordinary code fragments in the global
-namespace.
-A scoped command captures a script together with
-its namespace in a way that allows it to be executed properly later.
-It is needed, for example, to wrap up script
-when a Tk widget is used within a namespace.
-It is also needed for commands such as \fBafter\fR that
-execute a script at the global level at some future time.
-If a \fBafter\fR command is executed in a namespace,
-a \fBnamespace code\fR command is needed to ensure
-its script executes in the correct context:
-.CS
-\fBnamespace eval Foo {
- variable v 123
- proc report {msg} {
- puts "$msg"
- }
-
- after 2000 [namespace code {report "Hello World, v = $v"}]
-}\fR
-.CE
-
.SH "SEE ALSO"
variable(n)
diff --git a/contrib/tcl/doc/registry.n b/contrib/tcl/doc/registry.n
index 6e35f2dab528..52c2e4e17a2b 100644
--- a/contrib/tcl/doc/registry.n
+++ b/contrib/tcl/doc/registry.n
@@ -1,7 +1,10 @@
'\"
-'\" Copyright (c) 1997 by Sun Microsystems, Inc. All rights reserved.
+'\" Copyright (c) 1997 Sun Microsystems, Inc.
'\"
-'\" SCCS: @(#) registry.n 1.3 97/06/23 14:41:04
+'\" See the file "license.terms" for information on usage and redistribution
+'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\"
+'\" SCCS: @(#) registry.n 1.5 97/08/11 19:33:27
'\"
.so man.macros
.TH registry n 8.0 Tcl "Tcl Built-In Commands"
@@ -65,7 +68,8 @@ data, see SUPPORTED TYPES, below.
If \fIpattern\fR isn't specified, returns a list of names of all the
subkeys of \fIkeyName\fR. If \fIpattern\fR is specified, only those
names matching \fIpattern\fR are returned. Matching is determined
-using the same rules as for \fBstring\fR \fBmatch\fR.
+using the same rules as for \fBstring\fR \fBmatch\fR. If the
+specified \fIkeyName\fR does not exist, then an error is generated.
.TP
\fBregistry set \fIkeyName\fR ?\fIvalueName data \fR?\fItype\fR??
.
diff --git a/contrib/tcl/doc/rename.n b/contrib/tcl/doc/rename.n
index a3e185d9ba30..8962bd0ed6b1 100644
--- a/contrib/tcl/doc/rename.n
+++ b/contrib/tcl/doc/rename.n
@@ -1,11 +1,11 @@
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
-'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
+'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" SCCS: @(#) rename.n 1.5 96/03/25 20:22:11
+'\" SCCS: @(#) rename.n 1.6 97/07/30 17:37:26
'\"
.so man.macros
.TH rename n "" Tcl "Tcl Built-In Commands"
@@ -20,9 +20,13 @@ rename \- Rename or delete a command
.SH DESCRIPTION
.PP
Rename the command that used to be called \fIoldName\fR so that it
-is now called \fInewName\fR. If \fInewName\fR is an empty string
-then \fIoldName\fR is deleted. The \fBrename\fR command
-returns an empty string as result.
+is now called \fInewName\fR.
+If \fInewName\fR is an empty string then \fIoldName\fR is deleted.
+\fIoldName\fR and \fInewName\fR may include namespace qualifiers
+(names of containing namespaces).
+If a command is renamed into a different namespace,
+future invocations of it will execute in the new namespace.
+The \fBrename\fR command returns an empty string as result.
.SH KEYWORDS
-command, delete, rename
+command, delete, namespace, rename
diff --git a/contrib/tcl/doc/resource.n b/contrib/tcl/doc/resource.n
new file mode 100644
index 000000000000..1ccd50cc065d
--- /dev/null
+++ b/contrib/tcl/doc/resource.n
@@ -0,0 +1,116 @@
+'\"
+'\" Copyright (c) 1997 Sun Microsystems, Inc.
+'\"
+'\" See the file "license.terms" for information on usage and redistribution
+'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+'\" SCCS: @(#) resource.n 1.3 97/07/25 10:24:23
+'\"
+.so man.macros
+.TH resource n 8.0 Tcl "Tcl Built-In Commands"
+.BS
+'\" Note: do not modify the .SH NAME line immediately below!
+.SH NAME
+resource \- Manipulate Macintosh resources
+.SH SYNOPSIS
+\fBresource \fIoption\fR ?\fIarg arg ...\fR?
+.BE
+
+.SH DESCRIPTION
+.PP
+The \fBresource\fR command provides some generic operations for
+dealing with Macintosh resources. This command is only supported on
+the Macintosh platform. Each Macintosh file consists of two
+\fIforks\fR: a \fIdata\fR fork and a \fIresource\fR fork. You use the
+normal open, puts, close, etc. commands to manipulate the data fork.
+You must use this command, however, to interact with the resource
+fork. \fIOption\fR indicates what resource command to perform. Any
+unique abbreviation for \fIoption\fR is acceptable. The valid options
+are:
+.TP
+\fBresource close \fIrsrcRef\fR
+Closes the given resource reference (obtained from \fBresource
+open\fR). Resources from that resource file will no longer be
+available.
+.TP
+\fBresource list \fIresourceType\fR ?\fIresourceRef\fR?
+List all of the resources ids of type \fIresourceType\fR (see RESOURCE
+TYPES below). If \fIresourceRef\fR is specified then the command will
+limit the search to that particular resource file. Otherwise, all
+resource files currently opened by the application will be searched.
+A Tcl list of either the resource name's or resource id's of the found
+resources will be returned. See the RESOURCE IDS section below for
+more details about what a resource id is.
+.TP
+\fBresource open \fIfileName\fR ?\fIpermissions\fR?
+Open the resource for the file \fIfileName\fR. Standard file
+permissions may also be specified (see the manual entry for \fBopen\fR
+for details). A resource reference (\fIresourceRef\fR) is returned
+that can be used by the other resource commands. An error can occur
+if the file doesn't exist or the file does not have a resource fork.
+However, if you open the file with write permissions the file and/or
+resource fork will be created instead of generating an error.
+.TP
+\fBresource read \fIresourceType\fR \fIresourceId\fR ?\fIresourceRef\fR?
+Read the entire resource of type \fIresourceType\fR (see RESOURCE
+TYPES below) and the name or id of \fIresourceId\fR (see RESOURCE IDS
+below) into memory and return the result. If \fIresourceRef\fR is
+specified we limit our search to that resource file, otherwise we
+search all open resource forks in the application. It is important to
+note that most Macintosh resource use a binary format and the data
+returned from this command may have embedded NULLs or other non-ASCII
+data.
+.TP
+\fBresource types ?\fIresourceRef\fR?
+This command returns a Tcl list of all resource types (see RESOURCE
+TYPES below) found in the resource file pointed to by
+\fIresourceRef\fR. If \fIresourceRef\fR is not specified it will
+return all the resource types found in every resource file currently
+opened by the application.
+.TP
+\fBresource write\fR ?\fIoptions\fR? \fIresourceType\fR \fIdata\fR
+This command will write the passed in \fIdata\fR as a new resource of
+type \fIresourceType\fR (see RESOURCE TYPES below). Several options
+are available that describe where and how the resource is stored.
+.RS
+.TP
+\fB\-id\fR \fIresourceId\fR
+If the \fB-id\fR option is given the id \fIresourceId\fR (see RESOURCE
+IDS below) is used for the new resource, otherwise a unique id will be
+generated that will not conflict with any existing resource. However,
+the id must be a number - to specify a name use the \fB\-name\fR option.
+.TP
+\fB\-name\fR \fIresourceName\fR
+If \fB-name\fR is specified the resource will be named
+\fIresourceName\fR, otherwise it will have the empty string as the
+name.
+.TP
+\fB\-file\fR \fIresourceRef\fR
+If the \fB-file\fR option is specified then the resource will be
+written in the file pointed to by \fIresourceRef\fR, otherwise the
+most resently open resource will be used.
+.RE
+
+.SH "RESOURCE TYPES"
+Resource types are defined as a four character string that is then
+mapped to an underlying id. For example, \fBTEXT\fR refers to the
+Macintosh resource type for text. The type \fBSTR#\fR is a list of
+counted strings. All Macintosh resources must be of some type. See
+Macintosh documentation for a more complete list of resource types
+that are commonly used.
+
+.SH "RESOURCE IDS"
+For this command the notion of a resource id actually refers to two
+ideas in Macintosh resources. Every place you can use a resource Id
+you can use either the resource name or a resource number. Names are
+always searched or returned in preference to numbers. For example,
+the \fBresource list\fR command will return names if they exist or
+numbers if the name is NULL.
+
+.SH "SEE ALSO"
+open
+
+.SH "PORTABILITY ISSUES"
+The resource command is only available on Macintosh.
+
+.SH KEYWORDS
+open, resource
diff --git a/contrib/tcl/doc/safe.n b/contrib/tcl/doc/safe.n
index acc50ed7a18e..03adf0f38b63 100644
--- a/contrib/tcl/doc/safe.n
+++ b/contrib/tcl/doc/safe.n
@@ -4,300 +4,299 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" SCCS: @(#) safe.n 1.10 97/03/24 09:21:12
+'\" SCCS: @(#) safe.n 1.3 97/08/13 12:44:45
'\"
.so man.macros
-.TH "Safe Tcl" n 7.7 Tcl "Tcl Built-In Commands"
+.TH "Safe Tcl" n 8.0 Tcl "Tcl Built-In Commands"
.BS
'\" Note: do not modify the .SH NAME line immediately below!
.SH NAME
-Safe Tcl \- A mechanism for managing security policies.
+Safe Base \- A mechanism for creating and manipulating safe interpreters.
.SH SYNOPSIS
-.nf
-\fBtcl_safeCreateInterp\fR \fIslave\fR
+.PP
+\fB::safe::interpCreate\fR ?\fIslave\fR? ?\fIoptions...\fR?
+.sp
+\fB::safe::interpInit\fR \fIslave\fR ?\fIoptions...\fR?
.sp
-\fBtcl_safeInitInterp\fR \fIslave\fR
+\fB::safe::interpConfigure\fR \fIslave\fR ?\fIoptions...\fR?
.sp
-\fBtcl_safeDeleteInterp\fR \fIslave\fR
+\fB::safe::interpDelete\fR \fIslave\fR
.sp
-\fIpolicy\fB_policyInit\fR \fIslave\fR
+\fB::safe::interpAddToAccessPath\fR \fIslave\fR \fIdirectory\fR
.sp
-\fIpolicy\fB_policyFinalize\fR \fIslave\fR
-.fi
+\fB::safe::interpFindInAccessPath\fR \fIslave\fR \fIdirectory\fR
+.sp
+\fB::safe::setLogCmd\fR ?\fIcmd arg...\fR?
+.SH OPTIONS
+.PP
+?\fB\-accessPath\fR \fIpathList\fR? ?\fB\-noStatics\fR? ?\fB\-nestedLoadOk\fR? ?\fB\-deleteHook\fR \fIscript\fR?
.BE
.SH DESCRIPTION
+Safe Tcl is a mechanism for executing untrusted Tcl scripts
+safely and for providing mediated access by such scripts to
+potentially dangerous functionality.
.PP
-This manual entry describes \fBSafe Tcl\fR, a mechanism and collection of
-library procedures for managing security policies. \fBSafe Tcl\fR is used
-in \fBapplications\fR that want to provide a flexible, extensible safe
-hosting environment for untrusted guest scripts, \fBtclets\fR. It
-provides a mechanism to ensure that tclets cannot harm the hosting
-application, and a way to extend limited degrees of trust to such tclets,
-to allow them to have access to unsafe features.
+The Safe Base ensures that untrusted Tcl scripts cannot harm the
+hosting application.
+The Safe Base prevents integrity and privacy attacks. Untrusted Tcl
+scripts are prevented from corrupting the state of the hosting
+application or computer. Untrusted scripts are also prevented from
+disclosing information stored on the hosting computer or in the
+hosting application to any party.
.PP
-The content of this manual entry is of interest to four different
-audiences: authors of tclets will primarily be interested in the sections
-on the \fBSAFE BASE\fR and on \fBUSING SAFE TCL IN TCLETS\fR.
-Application authors will find relevant information in the section on
-\fBUSING SAFE TCL IN APPLICATIONS\fR. To create a new security
-policy, e.g. to enable tclets to have access to a new feature, read the
-section on \fBWRITING SECURITY POLICIES\fB. Finally, system administrators
-and people installing \fBSafe Tcl\fR will find useful information in the
-section on \fBINSTALLING SECURITY POLICIES\fR.
+The Safe Base allows a master interpreter to create safe, restricted
+interpreters that contain a set of predefined aliases for the \fBsource\fR,
+\fBload\fR, \fBfile\fR and \fBexit\fR commands and
+are able to use the auto-loading and package mechanisms.
.PP
-\fBSecurity policies\fR are collections of procedures, aliases, hidden
-commands and variable settings that together implement a controlled way for
-an application to allow a tclet to have restricted access to unsafe features.
-For a complete description of aliases, hidden commands and how to use
-multiple interpreters in an application, see the manual entry for the
-\fBinterp\fR command.
+No knowledge of the file system structure is leaked to the
+safe interpreter, because it has access only to a virtualized path
+containing tokens. When the safe interpreter requests to source a file, it
+uses the token in the virtual path as part of the file name to source; the
+master interpreter translates the token into a real directory name and
+executes the requested operation.
+Different levels of security can be selected by using the optional flags
+of the commands described below.
.PP
-Packaging collections of features into security policies has several
-advantages: First, it allows these collections to have names. This
-facilitates the formation of a common, agreed upon, understanding of what
-features are included in each policy. Second, it enables a reasoned
-approach to developing extensions that make restricted features available
-to untrusted tclets.
-Third, because the feature set is delineated clearly, a security policy can
-be subjected to analysis to determine what risks it exposes its user to.
+All commands provided in the master interpreter by the Safe Base reside in
+the \fBsafe\fR namespace.
+\fB::safe::interpCreate\fR creates a new safe interpreter with options,
+described in the section \fBOPTIONS\fR.
+The return value is the name of the new safe interpreter created.
+\fB::safe::interpInit\fR is similar to \fB::safe::interpCreate\fR except that
+it requires as its first argument the name of a safe interpreter that was
+previously created directly using the \fBinterp\fR command.
+\fB::safe::interpDelete\fR deletes the interpreter named by its argument.
+\fB::safe::interpConfigure\fR can be used to set or get options for the named
+safe interpreters; the options are described in the section \fBOPTIONS\fR.
.PP
-The \fBSafe Tcl\fR approach to safe execution of untrusted code is further
-discussed in \fBThe Safe\-Tcl Security Model\fR
-(http://www.sunlabs.com/people/john.ousterhout/SafeTcl.ps).
-This paper provides a detailed discussion of the underlying
-motivations and philosophy, and compares the \fBSafe Tcl\fR model with
-other current efforts.
-
-.SH "SAFE BASE"
-.PP
-This section describes the environment in which tclets start execution in
-an application using \fBSafe Tcl\fR. This environment is known as the
-\fBSafe Base\fR, as it provides the basis on which further security
-policies are built.
+A virtual path is maintained in the master interpreter for each safe
+interpreter created by \fB::safe::interpCreate\fR or initialized by
+\fB::safe::interpInit\fR.
+The path maps tokens accessible in the safe interpreter into real path
+names on the local file system.
+This prevents safe interpreters from gaining knowledge about the
+structure of the file system of the host on which the interpeter is
+executing.
+When a token is used in a safe interpreter in a request to source or
+load a file, the token is translated to a real path name and the file to be
+sourced or loaded is located on the file system.
+The safe interpreter never gains knowledge of the actual path name under
+which the file is stored on the file system.
+Commands are provided in the master interpreter to manipulate the virtual
+path for a safe interpreter.
+\fB::safe::interpConfigure\fR can be used to set a new path for a safe
+interpreter.
+\fB::safe::interpAddToAccessPath\fR adds a directory to the virtual path for
+the named safe interpreter and returns the token by which that directory
+will be accessible in the safe interpreter.
+\fB::safe::interpFindInAccessPath\fR finds the
+requested directory in the virtual path for the named safe interpreter and
+returns the token by which that directory can be accessed in the safe
+interpreter.
+If the path is not found, an error is raised.
.PP
-When a tclet starts execution in an environment using \fBSafe Tcl\fR,
-its interpreter will contain aliases for the following commands:
-.DS
-.ta 1.2i 2.4i 3.6i
-\fBexit file load source
-tclPkgUnknown\fR
-.DE
-The \fBexit\fR alias terminates the execution of the
-invoking slave.
-\fBFile\fR allows access to a subset of the sub\-commands of the full
-\fBfile\fR command.
-\fBload\fR and \fBsource\fR make extensions available to the tclet in a
-controlled manner.
-The \fBtclPkgUnknown\fR alias allows the application to interpose on
-\fBpackage require\fR invocations by the tclet.
+\fB::safe::setLogCommand\fR installs a script to be called when interesting
+life cycle events happen.
+This script will be called with one argument, a string describing the event.
+.SH ALIASES
.PP
-The following \fBTcl\fR commands are hidden in the Safe Base:
-.DS
-.ta 1.2i 2.4i 3.6i
-\fBcd exec exit fconfigure
-file glob load open
-pwd socket source vwait\fR
-.DE
+The following aliases are provided in a safe interpreter:
+.TP
+\fBsource\fB \fIfileName\fR
+The requested file, a Tcl source file, is sourced into the safe interpreter
+if it is found.
+The \fBsource\fR alias can only source files from directories in
+the virtual path for the safe interpreter. The \fBsource\fR alias requires
+the safe interpreter to
+use one of the token names in its virtual path to denote the directory in
+which the file to be sourced can be found.
+See the section on \fBSECURITY\fR for more discussion of restrictions on
+valid filenames.
+.TP
+\fBload\fR \fIfileName\fR
+The requested file, a shared object file, in dynamically loaded into the
+safe interpreter if it is found.
+The filename must contain a token name mentioned in the virtual path for
+the safe interpreter for it to be found successfully.
+Additionally, the shared object file must contain a safe entry point; see
+the manual page for the \fBload\fR command for more details.
+.TP
+\fBfile\fR ?\fIoptions\fR?
+The \fBfile\fR alias provides access to a safe subset of the subcommands of
+the \fBfile\fR command; it allows only \fBdirname\fR, \fBjoin\fR,
+\fBextension\fR, \fBroot\fR, \fBtail\fR, \fBpathname\fR and \fBsplit\fR
+subcommands. For more details on what these subcommands do see the manual
+page for the \fBfile\fR command.
+.TP
+\fBexit\fR
+The calling interpreter is deleted and its computation is stopped, but the
+Tcl process in which this interpreter exists is not terminated.
.PP
-A tclet can also request to load packages using \fBpackage require\fR.
-Please read the manual page on the \fBpackage\fR and \fBload\fR commands
-for a discussion of package loading and special restrictions on loading
-into safe interpreters.
+.SH COMMANDS
.PP
-Tclets can use auto-loading to obtain the definitions for procedures as
-needed. The auto-loading mechanism in the Safe Base supports tclIndex files
-generated by \fBauto_mkindex\fR Version 2 and later.
+The following commands are provided in the master interpreter:
+.TP
+\fB::safe::interpCreate\fR ?\fIslave\fR? ?\fIoptions...\fR?
+Creates a safe interpreter, installs the aliases described in the section
+\fBALIASES\fR and initializes the auto-loading and package mechanism as
+specified by the supplied \fBoptions\fR.
+See the \fBOPTIONS\fR section below for a description of the common
+optional arguments.
+If the \fIslave\fR argument is omitted, a name will be generated.
+\fB::safe::interpCreate\fR always returns the interpreter name.
+.TP
+\fB::safe::interpInit\fR \fIslave\fR ?\fIoptions...\fR?
+This command is similar to \fBinterpCreate\fR except it that does not
+create the safe interpreter. \fIslave\fR must have been created by some
+other means, like \fB::interp create \-safe\fR.
+.TP
+\fB::safe::interpConfigure\fR \fIslave\fR ?\fIoptions...\fR?
+If no \fIoptions\fR are given, returns the settings for all options for the
+named safe interpreter.
+If \fIoptions\fR are supplied, sets the options for the named safe
+interpreter. See the section on \fBOPTIONS\fR below.
+.TP
+\fB::safe::interpDelete\fR \fIslave\fR
+Deletes the safe interpreter and cleans up the corresponding
+master interpreter data structures.
+If a \fIdeletehook\fR script was specified for this interpreter it is
+evaluated before the interpreter is deleted, with the name of the
+interpreter as an additional argument.
+.TP
+\fB::safe::interpFindInAccessPath\fR \fIslave\fR \fIdirectory\fR
+This command finds and returns the token for the real directory
+\fIdirectory\fR in the safe interpreter's current virtual access path.
+It generates an error if the directory is not found.
+Example of use:
+.CS
+$slave eval [list set tk_library [::safe::interpFindInAccessPath $name $tk_library]]
+.CE
+.TP
+\fB::safe::interpAddToAccessPath\fR \fIslave\fR \fIdirectory\fR
+This command adds \fIdirectory\fR to the virtual path maintained for the
+safe interpreter in the master, and returns the token that can be used in
+the safe interpreter to obtain access to files in that directory.
+If the directory is already in the virtual path, it only returns the token
+without adding the directory to the virtual path again.
+Example of use:
+.CS
+$slave eval [list set tk_library [::safe::interpAddToAccessPath $name $tk_library]]
+.CE
+.TP
+\fB::safe::setLogCmd\fR ?\fIcmd arg...\fR?
+This command installs a script that will be called when interesting
+lifecycle events occur for a safe interpreter.
+When called with no arguments, it returns the currently installed script.
+When called with one argument, an empty string, the currently installed
+script is removed and logging is turned off.
+The script will be invoked with one additional argument, a string
+describing the event of interest.
+The main purpose is to help in debugging safe interpreters.
+Using this facility you can get complete error messages while the safe
+interpreter gets only generic error messages.
+This prevents a safe interpreter from seeing messages about failures
+and other events that might contain sensitive information such as real
+directory names.
+.RS
+Example of use:
+.CS
+::safe::setLogCmd puts stderr
+.CE
+Below is the output of a sample session in which a safe interpreter
+attempted to source a file not found in its virtual access path.
+Note that the safe interpreter only received an error message saying that
+the file was not found:
+.CS
+NOTICE for slave interp10 : Created
+NOTICE for slave interp10 : Setting accessPath=(/foo/bar) staticsok=1 nestedok=0 deletehook=()
+NOTICE for slave interp10 : auto_path in interp10 has been set to {$p(:0:)}
+ERROR for slave interp10 : /foo/bar/init.tcl: no such file or directory
+.CE
+.RE
-.SH "USING SAFE TCL IN TCLETS"
-.PP
-Tclets start executing in the environment described in the previous
-section, on the \fBSAFE BASE\fR. If they need access to unsafe features,
-tclets can request to use a named security policy by invoking \fBpackage
-require\fR with the policy name. If the request is denied by the
-application's master interpreter, an error is returned.
-A tclet can \fBcatch\fR the error and request to use a different named
-policy, until a request is granted.
-.PP
-A tclet can only use one security policy during its lifetime. Once an
-invocation of \fBpackage require\fR to load a security policy succeeds,
-Safe Tcl prevents subsequent invocations of \fBpackage require\fR from
-succeeding if the requested package is a security policy. There is also no
-mechanism for a tclet to stop using a security policy, once it is loaded.
-Invocations of \fBpackage require\fR to load other packages unrelated to
-security policies will still succeed.
-.PP
-These restrictions are designed to prevent a tclet from composing security
-policies either concurrently or sequentially, in ways not supported or
-forseen by the authors of the policies. Allowing such composition would
-expose the application to unknown security risks, because a security policy
-that is safe in isolation is not necessarily safe when used in conjunction
-with other security policies.
-For example, a security policy that allows read\-only access to the local
-file system can not disclose private data belonging to the application if
-it does not have access to network communication commands such as
-\fBsocket\fR. However, when used in conjunction with another security
-policy that enables the \fBsocket\fR command, this policy is no longer
-safe.
+.SH OPTIONS
+The following options are common to
+\fB::safe::interpCreate\fR, \fB::safe::interpInit\fR,
+and \fB::safe::interpConfigure\fR.
+Any option name can be abbreviated to its minimal
+non-ambiguous name.
+Option names are not case sensitive.
+.TP
+\fB\-accessPath\fR ?\fIdirectoryList\fR?
+This option sets the list of directories from which the safe interpreter
+can \fBsource\fR and \fBload\fR files, and returns a list of tokens that
+will allow the safe interpreter access to these directories.
+If a value for \fBdirectoryList\fR is not given, or if it is given as the
+empty list, the safe interpreter will use the same directories than its
+master for auto-loading.
+See the section \fBSECURITY\fR below for more detail about virtual paths,
+tokens and access control.
+.TP
+\fB\-noStatics\fR
+This option specifies that the safe interpreter will not be allowed
+to load statically linked packages (like \fBload {} Tk\fR).
+The default is that safe interpreters are allowed to load statically linked
+packages.
+.TP
+\fB\-nestedLoadOk\fR
+This option specifies that the safe interpreter will be allowed
+to load packages into its own subinterpreters.
+The default is that safe interpreters are not allowed to load packages into
+their own subinterpreters.
+.TP
+\fB\-deleteHook\fR ?\fIscript\fR?
+If \fIscript\fR is given, it is evaluated in the master with the name of
+the safe interpreter as an additional argument just before deleting the
+safe interpreter.
+If no value is given for \fIscript\fR any currently installed deletion hook
+script for that safe interpreter is removed; it will no longer be called
+when the interpreter is deleted.
+There is no deletion hook script installed by default.
-.SH "USING SAFE TCL IN APPLICATIONS"
-.PP
-An application using Safe Tcl is usually structured as one or more unsafe
-interpreters in which trusted code belonging to the application is
-executed. Each such \fBmaster interpreter\fR controls one or more safe
-\fBslave interpreters\fR in which tclets are executed.
-Tclets communicate with their master interpreter via the aliases provided
-by the Safe Base and via additional mechanisms installed by each security
-policy.
-This section describes the procedures an application invokes to use Safe
-Tcl and to manage slave interpreters.
-.PP
-An application invokes \fBtcl_safeCreateInterp\fR \fIslave\fR to create a
-new slave interpreter; this new interpreter will contain the aliases
-provided by the Safe Base. A new command named \fBslave\fR is also created
-in the invoking interpreter, to allow the application to manipulate the new
-slave interpreter.
-.PP
-An application can use \fBtcl_safeInitInterp\fR \fIslave\fR to initialize
-an existing slave interpreter with the Safe-Tcl security policy mechanism.
-This procedure is useful when an application already has a safe slave
-interpreter created with \fBinterp create -safe\fR and wishes to enable it
-to use security policies.
-.PP
-An application should invoke \fBtcl_safeDeleteInterp\fR \fIslave\fR to
-delete an interpreter previously created by \fBtcl_safeCreateInterp\fR. This
-procedure terminates the execution of the tclet in the \fIslave\fR
-interpreter and cleans up associated state maintained by the Safe Tcl
-mechanism.
-.PP
-Security policies are installed on the file system of the system on which
-the application is executing. Security policies are found in the
-\fIpolicies\fR sub-directories of directories mentioned in the
-application's \fBauto_path\fR, and in sub-directories of these
-\fIpolicies\fR directories.
+.SH SECURITY
.PP
-Safe Tcl will invoke, on behalf of an application, additional procedures
-provided by individual security policies to manage the lifecycle of those
-policies. These additional procedures are described in the next section.
+The Safe Base does not attempt to completely prevent annoyance and
+denial of service attacks. These forms of attack prevent the
+application or user from temporarily using the computer to perform
+useful work, for example by consuming all available CPU time or
+all available screen real estate.
+These attacks, while agravating, are deemed to be of lesser importance
+in general than integrity and privacy attacks that the Safe Base
+is to prevent.
-.SH "WRITING SECURITY POLICIES"
+The commands available in a safe interpreter, in addition to
+the safe set as defined in \fBinterp\fR manual page, are mediated aliases
+for \fBsource\fR, \fBload\fR, \fBexit\fR, and a safe subset of \fBfile\fR.
+The safe interpreter can also auto-load code and it can request to load
+packages.
+Because some of these commands access the local file system, there is a
+potential for information leakage about its directory structure.
+To prevent this, commands which take file names as arguments in a safe
+interpreter use tokens instead of the real directory names.
+These tokens are translated to the real directory name while a request to,
+e.g., source a file is mediated by the master interpreter.
.PP
-Writing a security policy is a complex effort that should not be undertaken
-lightly. It involves careful design, exhaustive testing, public review and
-analysis and continuous debugging.
-In addition to considering what features a security policy should provide,
-the implementer has to constantly keep in mind the security risks to which
-an application using the policy may be exposed.
-Actively considering each feature to see if it can be used to compromise an
-application will help to minimize the chance of a security mishap later on.
+To further prevent potential information leakage from sensitive files that
+are accidentally included in the set of files that can be sourced by a safe
+interpreter, the \fBsource\fR alias is restricted so that it can only
+source files with names that have the extension \fB.tcl\fR, that contain
+only one dot and that are forteen characters long or shorter.
.PP
-A security policy is a Tcl script or a shared library that is loaded into
-an unsafe master interpreter.
-A security policy consists of two parts: a \fBmanagement\fR part, concerned
-with installing the policy into safe slaves and cleaning up after a slave
-is destroyed, and a \fBruntime\fR part, concerned with actually
-implementing the features of the policy.
-.PP
-The management part of a security policy consists of two Tcl procedures or
-commands, one for installing the security policy features into a safe
-slave, and the other for cleaning up any associated state when a slave is
-destroyed.
-The names of these procedures or commands are \fIpolicy\fB_policyInit\fR
-and \fIpolicy\fB_policyFinalize, where \fIpolicy\fR is the name of the
-policy as used by the slave interpreter in the \fBpackage require\fR
-invocation.
-.PP
-The policy initialization procedure \fIpolicy\fB_policyInit\fR called in
-the master interpreter with one argument, the name of the slave
-interpreter, when a slave requests to use the \fIpolicy\fR security policy.
-Error returns indicate that the slave was denied permission to use this
-policy; the error is propagated back to the slave interpreter. Successful
-return indicates that the policy is now available in the requesting slave.
-If it decides to allow the slave to use the requested policy,
-\fIpolicy\fB_policyInit\fR should install new aliases and command into the
-slave, initialize variables both in the master interpreter and in the
-slave, and do any other initialization work to make the policy features
-available in the slave.
-Policy initialization procedures may also perform other tasks, such as
-creating policy specific state data for the new slave using this policy.
-.PP
-Policy initialization procedures should be careful to leave a clean state
-in the slave interpreter if a failure occurs during initialization; the
-rule is that if an error is returned, no changes in any variables,
-procedures or aliases should be detectable in the slave.
-For example, if use of a security policy requires creation
-of a socket to a remote host at initialization time, and if that host is
-not accessible, all aliases created in the slave to use the policy
-should be removed. Otherwise, these aliases might open security holes when
-used in conjunction with another security policy subsequently requested by
-the slave. Without this, a malicious tclet could purposely cause a failure
-during initialization in one security policy and compose features provided
-by that policy in an unsafe manner with another security policy requested
-later.
-.PP
-When an application invokes \fBtcl_safeDeleteInterp\fR to delete a slave
-interpreter, the policy finalization procedure
-\fIpolicy\fB_policyFinalize\fR for the policy in use by the slave is called.
-It receives one argument, the name of the slave interpreter being deleted.
-This procedure should ensure that subsequently if a slave by the
-same name is re\-created, the new slave will be able to use this policy.
-It may also wish to remove any policy specific state data created by
-\fIpolicy\fB_policyInit\fR.
-.PP
-During initialization, a number of aliases may be created in the slave;
-when these aliases are invoke, they cause commands defined in the master to
-execute. The runtime part of a security policy consists of implementations
-of all the target commands that handle the invocation of aliases in the
-slave. Because these commands execute in a trusted interpreter, they have
-full access to all the capabilities of Tcl and any extensions loaded into
-the master interpreter.
-.PP
-A security policy must provide a \fBtclIndex\fR file in addition to files
-containing Tcl procedures and shared libraries implementing the policy.
-To generate a \fBtclIndex\fR file, use the Tcl command \fBauto_mkindex\fR
-which is described in the manual page for the Tcl library.
-
-.SH "INSTALLING SECURITY POLICIES"
-.PP
-Safe Tcl uses a platform dependent mechanism for obtaining the initial
-setting for the search path for finding security policies.
-On \fBUnix\fR, the environment variable \fBTCL_POLICY_PATH\fR is consulted.
-On \fBWin32\fR systems and on \fBMacOS\fR there is currently no mechanism
-provided to obtain the initial value; each application should provide its
-own mechanism for obtaining the initial search path. Such mechanisms will
-be provided shortly.
-.PP
-The search path is searched in reverse order of the order in which entries
-appear. Thus, if two or more policies by the same name occur in the path,
-the last policy by that name will be used by Safe Tcl.
-This enable system administrators to install system wide security policies
-in a centralized directory and then require users to include that directory
-as the last component in the search path. Doing so will ensure that system
-wide policies are used in preference of policies installed by individual
-users.
-.PP
-To install a policy, create a sub\-directory of one of the directories
-mentioned in the policy search path, and copy all the files comprising the
-policy into the new directory.
-Applications should be able, in most situations, to use the newly available
-policy immediately, without having to restart.
-If a security policy uses the same name as a regular package, a \fBpackage
-require\fR invocation in a slave interpreter will preferentially use the
-security policy over the regular package.
-However, if a security policy is installed after the first invocation of
-\fBpackage require\fR in an application, and a regular package exists by
-the same name, the security policy will not be available for use in that
-application. In this case you must restart the application for the policy
-to become available.
-
-.SH CREDITS
-.PP
-The security policy mechanism extends and expands on the Safe-Tcl prototype
-first implemented by Nathaniel Borenstein and Marshall Rose.
+The default value of the Tcl variable \fBauto_path\fR in a safe interpreter
+is a virtualized token list for the directories in the value of its
+master's \fBauto_path\fR variable and their immediate subdirectories.
+The first token in this list is also assigned to the Tcl varibale
+\fBtcl_library\fR in the safe interpreter.
+You can always specify a more
+restrictive path for which sub directories will never be searched by
+explicitly specifying your directory list with the \fB\-accessPath\fR flag
+instead of relying on this default mechanism.
.SH "SEE ALSO"
interp(n), library(n), load(n), package(n), source(n), unknown(n)
-
+
.SH KEYWORDS
-alias, auto\-loading, auto_mkindex, load, master interpreter, security
-policy, safe interpreter, slave interpreter, source
+alias, auto\-loading, auto_mkindex, load, master interpreter, safe
+interpreter, slave interpreter, source
diff --git a/contrib/tcl/doc/tclvars.n b/contrib/tcl/doc/tclvars.n
index 9270fcf0c899..9a7fa6ca2b34 100644
--- a/contrib/tcl/doc/tclvars.n
+++ b/contrib/tcl/doc/tclvars.n
@@ -5,7 +5,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" SCCS: @(#) tclvars.n 1.30 97/05/02 13:06:45
+'\" SCCS: @(#) tclvars.n 1.33 97/08/13 17:50:20
'\"
.so man.macros
.TH tclvars n 8.0 Tcl "Tcl Built-In Commands"
@@ -44,6 +44,64 @@ PATH variable could be exported by the operating system as ``path'',
support many special cases. All other environment variables inherited by
Tcl are left unmodified.
.RE
+.RS
+On the Macintosh, the environment variable is constructed by Tcl as no
+global environment variable exists. The environment variables that
+are created for Tcl include:
+.TP
+\fBLOGIN\fR
+This holds the Chooser name of the Macintosh.
+.TP
+\fBUSER\fR
+This also holds the Chooser name of the Macintosh.
+.TP
+\fBSYS_FOLDER\fR
+The path to the system directory.
+.TP
+\fBAPPLE_M_FOLDER\fR
+The path to the Apple Menu directory.
+.TP
+\fBCP_FOLDER\fR
+The path to the control panels directory.
+.TP
+\fBDESK_FOLDER\fR
+The path to the desk top directory.
+.TP
+\fBEXT_FOLDER\fR
+The path to the system extensions directory.
+.TP
+\fBPREF_FOLDER\fR
+The path to the preferences directory.
+.TP
+\fBPRINT_MON_FOLDER\fR
+The path to the print monitor directory.
+.TP
+\fBSHARED_TRASH_FOLDER\fR
+The path to the network trash directory.
+.TP
+\fBTRASH_FOLDER\fR
+The path to the trash directory.
+.TP
+\fBSTART_UP_FOLDER\fR
+The path to the start up directory.
+.TP
+\fBPWD\fR
+The path to the application's default directory.
+.PP
+You can also create your own environment variables for the Macintosh.
+A file named \fITcl Environment Variables\fR may be placed in the
+preferences folder in the Mac system folder. Each line of this file
+should be of the form \fIVAR_NAME=var_data\fR.
+.PP
+The last alternative is to place environment variables in a 'STR#'
+resource named \fITcl Environment Variables\fR of the application. This
+is considered a little more ``Mac like'' than a Unix style Environment
+Variable file. Each entry in the 'STR#' resource has the same format
+as above. The source code file \fItclMacEnv.c\fR contains the
+implementation of the env mechanisms. This file contains many
+#define's that allow customization of the env mechanisms to fit your
+applications needs.
+.RE
.TP
\fBerrorCode\fR
After an error has occurred, this variable will be set to hold
@@ -213,15 +271,21 @@ general operating environment of the machine.
.TP
\fBtcl_precision\fR
.VS
-In Tcl versions before 8.0, this variable controlled the
-number of significant digits to include when converting floating-point
-values to strings.
-If the variable was not set then 6 digits were included.
+This variable controls the number of digits to generate
+when converting floating-point values to strings. It defaults
+to 12.
17 digits is ``perfect'' for IEEE floating-point in that it allows
double-precision values to be converted to strings and back to
-binary with no loss of precision.
-As of Tcl 8.0 this variable is ignored and all conversions use the
-full 17 digits.
+binary with no loss of information. However, using 17 digits prevents
+any rounding, which produces longer, less intuitive results. For example,
+\fBexpr 1.4\fR returns 1.3999999999999999 with \fBtcl_precision\fR
+set to 17, vs. 1.4 if \fBtcl_precision\fR is 12.
+.RS
+All interpreters in a process share a single \fBtcl_precision\fR value:
+changing it in one interpreter will affect all other interpreters as
+well. However, safe interpreters are not allowed to modify the
+variable.
+.RE
.VE
.TP
\fBtcl_rcFileName\fR
diff --git a/contrib/tcl/doc/uplevel.n b/contrib/tcl/doc/uplevel.n
index 574900e8c07c..0332ca1c103a 100644
--- a/contrib/tcl/doc/uplevel.n
+++ b/contrib/tcl/doc/uplevel.n
@@ -1,11 +1,11 @@
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
-'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
+'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" SCCS: @(#) uplevel.n 1.7 96/03/25 20:26:46
+'\" SCCS: @(#) uplevel.n 1.8 97/08/13 13:41:36
'\"
.so man.macros
.TH uplevel n "" Tcl "Tcl Built-In Commands"
@@ -61,6 +61,20 @@ be used to obtain the level of the current procedure.
\fBUplevel\fR makes it possible to implement new control
constructs as Tcl procedures (for example, \fBuplevel\fR could
be used to implement the \fBwhile\fR construct as a Tcl procedure).
+.PP
+\fBnamespace eval\fR is another way (besides procedure calls)
+that the Tcl naming context can change.
+It adds a call frame to the stack to represent the namespace context.
+This means each \fBnamespace eval\fR command
+counts as another call level for \fBuplevel\fR and \fBupvar\fR commands.
+For example, \fBinfo level 1\fR will return a list
+describing a command that is either
+the outermost procedure call or the outermost \fBnamespace eval\fR command.
+Also, \fBuplevel #0\fR evaluates a script
+at top-level in the outermost namespace (the global namespace).
+
+.SH "SEE ALSO"
+namespace(n)
.SH KEYWORDS
-context, stack frame, variables
+context, level, namespace, stack frame, variables
diff --git a/contrib/tcl/doc/upvar.n b/contrib/tcl/doc/upvar.n
index e6e47ce0e5b0..1920d37bd7f8 100644
--- a/contrib/tcl/doc/upvar.n
+++ b/contrib/tcl/doc/upvar.n
@@ -1,11 +1,11 @@
'\"
'\" Copyright (c) 1993 The Regents of the University of California.
-'\" Copyright (c) 1994-1996 Sun Microsystems, Inc.
+'\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
'\"
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" SCCS: @(#) upvar.n 1.15 96/08/26 13:00:19
+'\" SCCS: @(#) upvar.n 1.16 97/08/13 13:43:34
'\"
.so man.macros
.TH upvar n "" Tcl "Tcl Built-In Commands"
@@ -57,6 +57,17 @@ Although \fBadd2\fR could have been implemented using \fBuplevel\fR
instead of \fBupvar\fR, \fBupvar\fR makes it simpler for \fBadd2\fR
to access the variable in the caller's procedure frame.
.PP
+\fBnamespace eval\fR is another way (besides procedure calls)
+that the Tcl naming context can change.
+It adds a call frame to the stack to represent the namespace context.
+This means each \fBnamespace eval\fR command
+counts as another call level for \fBuplevel\fR and \fBupvar\fR commands.
+For example, \fBinfo level 1\fR will return a list
+describing a command that is either
+the outermost procedure call or the outermost \fBnamespace eval\fR command.
+Also, \fBuplevel #0\fR evaluates a script
+at top-level in the outermost namespace (the global namespace).
+.PP
.VS
If an upvar variable is unset (e.g. \fBx\fR in \fBadd2\fR above), the
\fBunset\fR operation affects the variable it is linked to, not the
@@ -74,5 +85,8 @@ invoked). In particular, if the array is \fBenv\fR, then changes
made to \fImyVar\fR will not be passed to subprocesses correctly.
.VE
+.SH "SEE ALSO"
+namespace(n)
+
.SH KEYWORDS
-context, frame, global, level, procedure, variable
+context, frame, global, level, namespace, procedure, variable
diff --git a/contrib/tcl/doc/variable.n b/contrib/tcl/doc/variable.n
index 1475d47b5976..186e40fd97b6 100644
--- a/contrib/tcl/doc/variable.n
+++ b/contrib/tcl/doc/variable.n
@@ -5,7 +5,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" SCCS: @(#) variable.n 1.2 97/05/18 15:20:28
+'\" SCCS: @(#) variable.n 1.4 97/08/13 16:57:57
'\"
.so man.macros
.TH variable n 8.0 Tcl "Tcl Built-In Commands"
@@ -25,9 +25,13 @@ within a namespace.
Each variable \fIname\fR is initialized with \fIvalue\fR.
The \fIvalue\fR for the last variable is optional.
.PP
-If a variable \fIname\fR does not exist,
-it is created and given the optional \fIvalue\fR.
-If it already exists, it is simply set to the optional \fIvalue\fR.
+If a variable \fIname\fR does not exist, it is created.
+In this case, if \fIvalue\fR is specified,
+it is assigned to the newly created variable.
+If no \fIvalue\fR is specified, the new variable is left undefined.
+If the variable already exists,
+it is set to \fIvalue\fR if \fIvalue\fR is specified
+or left unchanged if no \fIvalue\fR is given.
Normally, \fIname\fR is unqualified
(does not include the names of any containing namespaces),
and the variable is created in the current namespace.
@@ -51,14 +55,6 @@ and the initialization \fIvalue\fR should be left off.
After the variable has been declared,
elements within the array can be set using ordinary
\fBset\fR or \fBarray\fR commands.
-.PP
-It is generally best to provide a \fIvalue\fR to initialize each variable,
-or to initialize it immediately after the \fBvariable\fR command.
-This is because a namespace variable declared by a \fBvariable\fR command
-is not actually created until it is given a value.
-A declared but not yet initialized namespace variable
-will not appear in the output of an \fBinfo vars\fR command,
-for example.
.SH "SEE ALSO"
global(n), namespace(n)
diff --git a/contrib/tcl/generic/tcl.h b/contrib/tcl/generic/tcl.h
index 22331af4e955..2d773da703ab 100644
--- a/contrib/tcl/generic/tcl.h
+++ b/contrib/tcl/generic/tcl.h
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tcl.h 1.318 97/06/26 13:43:02
+ * SCCS: @(#) tcl.h 1.324 97/08/07 10:26:49
*/
#ifndef _TCL
@@ -37,11 +37,11 @@
#define TCL_MAJOR_VERSION 8
#define TCL_MINOR_VERSION 0
-#define TCL_RELEASE_LEVEL 1
-#define TCL_RELEASE_SERIAL 2
+#define TCL_RELEASE_LEVEL 2
+#define TCL_RELEASE_SERIAL 0
#define TCL_VERSION "8.0"
-#define TCL_PATCH_LEVEL "8.0b2"
+#define TCL_PATCH_LEVEL "8.0"
/*
* The following definitions set up the proper options for Windows
@@ -410,12 +410,25 @@ typedef struct Tcl_Obj {
* expression that is expensive to compute or has side effects.
*/
-#define Tcl_IncrRefCount(objPtr) \
- ++(objPtr)->refCount
-#define Tcl_DecrRefCount(objPtr) \
- if (--(objPtr)->refCount <= 0) TclFreeObj(objPtr)
-#define Tcl_IsShared(objPtr) \
- ((objPtr)->refCount > 1)
+EXTERN void Tcl_IncrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr));
+EXTERN void Tcl_DecrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr));
+EXTERN int Tcl_IsShared _ANSI_ARGS_((Tcl_Obj *objPtr));
+
+#ifdef TCL_MEM_DEBUG
+# define Tcl_IncrRefCount(objPtr) \
+ Tcl_DbIncrRefCount(objPtr, __FILE__, __LINE__)
+# define Tcl_DecrRefCount(objPtr) \
+ Tcl_DbDecrRefCount(objPtr, __FILE__, __LINE__)
+# define Tcl_IsShared(objPtr) \
+ Tcl_DbIsShared(objPtr, __FILE__, __LINE__)
+#else
+# define Tcl_IncrRefCount(objPtr) \
+ ++(objPtr)->refCount
+# define Tcl_DecrRefCount(objPtr) \
+ if (--(objPtr)->refCount <= 0) TclFreeObj(objPtr)
+# define Tcl_IsShared(objPtr) \
+ ((objPtr)->refCount > 1)
+#endif
/*
* Macros and definitions that help to debug the use of Tcl objects.
@@ -511,17 +524,18 @@ typedef struct Tcl_CallFrame {
} Tcl_CallFrame;
/*
- * Information about commands that is returned by Tcl_GetCmdInfo and passed
- * to Tcl_SetCmdInfo. objProc is an objc/objv object-based command procedure
- * while proc is a traditional Tcl argc/argv string-based procedure.
- * Tcl_CreateObjCommand and Tcl_CreateCommand ensure that both objProc and
- * proc are non-NULL and can be called to execute the command. However,
- * it may be faster to call one instead of the other. The member
- * isNativeObjectProc is set to 1 if an object-based procedure was
- * registered by Tcl_CreateObjCommand, and to 0 if a string-based procedure
- * was registered by Tcl_CreateCommand. The other procedure is typically set
- * to a compatibility wrapper that does string-to-object or object-to-string
- * argument conversions then calls the other procedure.
+ * Information about commands that is returned by Tcl_GetCommandInfo and
+ * passed to Tcl_SetCommandInfo. objProc is an objc/objv object-based
+ * command procedure while proc is a traditional Tcl argc/argv
+ * string-based procedure. Tcl_CreateObjCommand and Tcl_CreateCommand
+ * ensure that both objProc and proc are non-NULL and can be called to
+ * execute the command. However, it may be faster to call one instead of
+ * the other. The member isNativeObjectProc is set to 1 if an
+ * object-based procedure was registered by Tcl_CreateObjCommand, and to
+ * 0 if a string-based procedure was registered by Tcl_CreateCommand.
+ * The other procedure is typically set to a compatibility wrapper that
+ * does string-to-object or object-to-string argument conversions then
+ * calls the other procedure.
*/
typedef struct Tcl_CmdInfo {
@@ -985,7 +999,7 @@ EXTERN int Tcl_AsyncInvoke _ANSI_ARGS_((Tcl_Interp *interp,
EXTERN void Tcl_AsyncMark _ANSI_ARGS_((Tcl_AsyncHandler async));
EXTERN int Tcl_AsyncReady _ANSI_ARGS_((void));
EXTERN void Tcl_BackgroundError _ANSI_ARGS_((Tcl_Interp *interp));
-EXTERN char Tcl_Backslash _ANSI_ARGS_((char *src,
+EXTERN char Tcl_Backslash _ANSI_ARGS_((CONST char *src,
int *readPtr));
EXTERN int Tcl_BadChannelOption _ANSI_ARGS_((Tcl_Interp *interp,
char *optionName, char *optionList));
@@ -1003,9 +1017,9 @@ EXTERN int Tcl_CommandComplete _ANSI_ARGS_((char *cmd));
EXTERN char * Tcl_Concat _ANSI_ARGS_((int argc, char **argv));
EXTERN Tcl_Obj * Tcl_ConcatObj _ANSI_ARGS_((int objc,
Tcl_Obj *CONST objv[]));
-EXTERN int Tcl_ConvertCountedElement _ANSI_ARGS_((char *src,
+EXTERN int Tcl_ConvertCountedElement _ANSI_ARGS_((CONST char *src,
int length, char *dst, int flags));
-EXTERN int Tcl_ConvertElement _ANSI_ARGS_((char *src,
+EXTERN int Tcl_ConvertElement _ANSI_ARGS_((CONST char *src,
char *dst, int flags));
EXTERN int Tcl_ConvertToType _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr, Tcl_ObjType *typePtr));
@@ -1059,6 +1073,12 @@ EXTERN int Tcl_DbCkfree _ANSI_ARGS_((char *ptr,
char *file, int line));
EXTERN char * Tcl_DbCkrealloc _ANSI_ARGS_((char *ptr,
unsigned int size, char *file, int line));
+EXTERN void Tcl_DbDecrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr,
+ char *file, int line));
+EXTERN void Tcl_DbIncrRefCount _ANSI_ARGS_((Tcl_Obj *objPtr,
+ char *file, int line));
+EXTERN int Tcl_DbIsShared _ANSI_ARGS_((Tcl_Obj *objPtr,
+ char *file, int line));
EXTERN Tcl_Obj * Tcl_DbNewBooleanObj _ANSI_ARGS_((int boolValue,
char *file, int line));
EXTERN Tcl_Obj * Tcl_DbNewDoubleObj _ANSI_ARGS_((double doubleValue,
@@ -1109,9 +1129,9 @@ EXTERN int Tcl_DoOneEvent _ANSI_ARGS_((int flags));
EXTERN void Tcl_DoWhenIdle _ANSI_ARGS_((Tcl_IdleProc *proc,
ClientData clientData));
EXTERN char * Tcl_DStringAppend _ANSI_ARGS_((Tcl_DString *dsPtr,
- char *string, int length));
+ CONST char *string, int length));
EXTERN char * Tcl_DStringAppendElement _ANSI_ARGS_((
- Tcl_DString *dsPtr, char *string));
+ Tcl_DString *dsPtr, CONST char *string));
EXTERN void Tcl_DStringEndSublist _ANSI_ARGS_((Tcl_DString *dsPtr));
EXTERN void Tcl_DStringFree _ANSI_ARGS_((Tcl_DString *dsPtr));
EXTERN void Tcl_DStringGetResult _ANSI_ARGS_((Tcl_Interp *interp,
@@ -1137,7 +1157,7 @@ EXTERN int Tcl_EvalObj _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
EXTERN void Tcl_Exit _ANSI_ARGS_((int status));
EXTERN int Tcl_ExposeCommand _ANSI_ARGS_((Tcl_Interp *interp,
- char *hiddenCmdName, char *cmdName));
+ char *hiddenCmdToken, char *cmdName));
EXTERN int Tcl_ExprBoolean _ANSI_ARGS_((Tcl_Interp *interp,
char *string, int *ptr));
EXTERN int Tcl_ExprBooleanObj _ANSI_ARGS_((Tcl_Interp *interp,
@@ -1245,7 +1265,7 @@ EXTERN int Tcl_GlobalEvalObj _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
EXTERN char * Tcl_HashStats _ANSI_ARGS_((Tcl_HashTable *tablePtr));
EXTERN int Tcl_HideCommand _ANSI_ARGS_((Tcl_Interp *interp,
- char *cmdName, char *hiddenCmdName));
+ char *cmdName, char *hiddenCmdToken));
EXTERN int Tcl_Init _ANSI_ARGS_((Tcl_Interp *interp));
EXTERN void Tcl_InitHashTable _ANSI_ARGS_((Tcl_HashTable *tablePtr,
int keyType));
@@ -1326,6 +1346,8 @@ EXTERN int Tcl_Read _ANSI_ARGS_((Tcl_Channel chan,
EXTERN void Tcl_ReapDetachedProcs _ANSI_ARGS_((void));
EXTERN int Tcl_RecordAndEval _ANSI_ARGS_((Tcl_Interp *interp,
char *cmd, int flags));
+EXTERN int Tcl_RecordAndEvalObj _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *cmdPtr, int flags));
EXTERN Tcl_RegExp Tcl_RegExpCompile _ANSI_ARGS_((Tcl_Interp *interp,
char *string));
EXTERN int Tcl_RegExpExec _ANSI_ARGS_((Tcl_Interp *interp,
@@ -1342,9 +1364,9 @@ EXTERN void Tcl_Release _ANSI_ARGS_((ClientData clientData));
EXTERN void Tcl_RestartIdleTimer _ANSI_ARGS_((void));
EXTERN void Tcl_ResetResult _ANSI_ARGS_((Tcl_Interp *interp));
#define Tcl_Return Tcl_SetResult
-EXTERN int Tcl_ScanCountedElement _ANSI_ARGS_((char *string,
+EXTERN int Tcl_ScanCountedElement _ANSI_ARGS_((CONST char *string,
int length, int *flagPtr));
-EXTERN int Tcl_ScanElement _ANSI_ARGS_((char *string,
+EXTERN int Tcl_ScanElement _ANSI_ARGS_((CONST char *string,
int *flagPtr));
EXTERN int Tcl_Seek _ANSI_ARGS_((Tcl_Channel chan,
int offset, int mode));
diff --git a/contrib/tcl/generic/tclAlloc.c b/contrib/tcl/generic/tclAlloc.c
new file mode 100644
index 000000000000..cf07036cfa30
--- /dev/null
+++ b/contrib/tcl/generic/tclAlloc.c
@@ -0,0 +1,456 @@
+/*
+ * tclAlloc.c --
+ *
+ * This is a very fast storage allocator. It allocates blocks of a
+ * small number of different sizes, and keeps free lists of each size.
+ * Blocks that don't exactly fit are passed up to the next larger size.
+ * Blocks over a certain size are directly allocated from the system.
+ *
+ * Copyright (c) 1983 Regents of the University of California.
+ * Copyright (c) 1996-1997 Sun Microsystems, Inc.
+ *
+ * Portions contributed by Chris Kingsley, Jack Jansen and Ray Johnson.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclAlloc.c 1.4 97/08/11 18:45:38
+ */
+
+#include "tclInt.h"
+#include "tclPort.h"
+
+#ifdef TCL_DEBUG
+# define DEBUG
+/* #define MSTATS */
+# define RCHECK
+#endif
+
+typedef unsigned long caddr_t;
+
+/*
+ * The overhead on a block is at least 4 bytes. When free, this space
+ * contains a pointer to the next free block, and the bottom two bits must
+ * be zero. When in use, the first byte is set to MAGIC, and the second
+ * byte is the size index. The remaining bytes are for alignment.
+ * If range checking is enabled then a second word holds the size of the
+ * requested block, less 1, rounded up to a multiple of sizeof(RMAGIC).
+ * The order of elements is critical: ov_magic must overlay the low order
+ * bits of ov_next, and ov_magic can not be a valid ov_next bit pattern.
+ */
+
+union overhead {
+ union overhead *ov_next; /* when free */
+ struct {
+ unsigned char ovu_magic0; /* magic number */
+ unsigned char ovu_index; /* bucket # */
+ unsigned char ovu_unused; /* unused */
+ unsigned char ovu_magic1; /* other magic number */
+#ifdef RCHECK
+ unsigned short ovu_rmagic; /* range magic number */
+ unsigned long ovu_size; /* actual block size */
+#endif
+ } ovu;
+#define ov_magic0 ovu.ovu_magic0
+#define ov_magic1 ovu.ovu_magic1
+#define ov_index ovu.ovu_index
+#define ov_rmagic ovu.ovu_rmagic
+#define ov_size ovu.ovu_size
+};
+
+
+#define MAGIC 0xef /* magic # on accounting info */
+#define RMAGIC 0x5555 /* magic # on range info */
+
+#ifdef RCHECK
+#define RSLOP sizeof (unsigned short)
+#else
+#define RSLOP 0
+#endif
+
+#define OVERHEAD (sizeof(union overhead) + RSLOP)
+
+/*
+ * nextf[i] is the pointer to the next free block of size 2^(i+3). The
+ * smallest allocatable block is 8 bytes. The overhead information
+ * precedes the data area returned to the user.
+ */
+
+#define NBUCKETS 13
+#define MAXMALLOC (1<<(NBUCKETS+2))
+static union overhead *nextf[NBUCKETS];
+
+#ifdef MSTATS
+
+/*
+ * nmalloc[i] is the difference between the number of mallocs and frees
+ * for a given block size.
+ */
+
+static unsigned int nmalloc[NBUCKETS+1];
+#include <stdio.h>
+#endif
+
+#if defined(DEBUG) || defined(RCHECK)
+#define ASSERT(p) if (!(p)) panic(# p)
+#define RANGE_ASSERT(p) if (!(p)) panic(# p)
+#else
+#define ASSERT(p)
+#define RANGE_ASSERT(p)
+#endif
+
+/*
+ * Prototypes for functions used only in this file.
+ */
+
+static void MoreCore _ANSI_ARGS_((int bucket));
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpAlloc --
+ *
+ * Allocate more memory.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+char *
+TclpAlloc(
+ unsigned int nbytes) /* Number of bytes to allocate. */
+{
+ register union overhead *op;
+ register long bucket;
+ register unsigned amt;
+
+ /*
+ * First the simple case: we simple allocate big blocks directly
+ */
+ if (nbytes + OVERHEAD >= MAXMALLOC) {
+ op = (union overhead *)TclpSysAlloc(nbytes+OVERHEAD, 0);
+ if (op == NULL) {
+ return NULL;
+ }
+ op->ov_magic0 = op->ov_magic1 = MAGIC;
+ op->ov_index = 0xff;
+#ifdef MSTATS
+ nmalloc[NBUCKETS]++;
+#endif
+#ifdef RCHECK
+ /*
+ * Record allocated size of block and
+ * bound space with magic numbers.
+ */
+ op->ov_size = (nbytes + RSLOP - 1) & ~(RSLOP - 1);
+ op->ov_rmagic = RMAGIC;
+ *(unsigned short *)((caddr_t)(op + 1) + op->ov_size) = RMAGIC;
+#endif
+ return (void *)(op+1);
+ }
+ /*
+ * Convert amount of memory requested into closest block size
+ * stored in hash buckets which satisfies request.
+ * Account for space used per block for accounting.
+ */
+#ifndef RCHECK
+ amt = 8; /* size of first bucket */
+ bucket = 0;
+#else
+ amt = 16; /* size of first bucket */
+ bucket = 1;
+#endif
+ while (nbytes + OVERHEAD > amt) {
+ amt <<= 1;
+ if (amt == 0) {
+ return (NULL);
+ }
+ bucket++;
+ }
+ ASSERT( bucket < NBUCKETS );
+
+ /*
+ * If nothing in hash bucket right now,
+ * request more memory from the system.
+ */
+ if ((op = nextf[bucket]) == NULL) {
+ MoreCore(bucket);
+ if ((op = nextf[bucket]) == NULL) {
+ return (NULL);
+ }
+ }
+ /*
+ * Remove from linked list
+ */
+ nextf[bucket] = op->ov_next;
+ op->ov_magic0 = op->ov_magic1 = MAGIC;
+ op->ov_index = (unsigned char) bucket;
+#ifdef MSTATS
+ nmalloc[bucket]++;
+#endif
+#ifdef RCHECK
+ /*
+ * Record allocated size of block and
+ * bound space with magic numbers.
+ */
+ op->ov_size = (nbytes + RSLOP - 1) & ~(RSLOP - 1);
+ op->ov_rmagic = RMAGIC;
+ *(unsigned short *)((caddr_t)(op + 1) + op->ov_size) = RMAGIC;
+#endif
+ return ((char *)(op + 1));
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * MoreCore --
+ *
+ * Allocate more memory to the indicated bucket.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Attempts to get more memory from the system.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+MoreCore(
+ int bucket) /* What bucket to allocat to. */
+{
+ register union overhead *op;
+ register long sz; /* size of desired block */
+ long amt; /* amount to allocate */
+ int nblks; /* how many blocks we get */
+
+ /*
+ * sbrk_size <= 0 only for big, FLUFFY, requests (about
+ * 2^30 bytes on a VAX, I think) or for a negative arg.
+ */
+ sz = 1 << (bucket + 3);
+ ASSERT(sz > 0);
+
+ amt = MAXMALLOC;
+ nblks = amt / sz;
+ ASSERT(nblks*sz == amt);
+
+ op = (union overhead *)TclpSysAlloc(amt, 1);
+ /* no more room! */
+ if (op == NULL) {
+ return;
+ }
+
+ /*
+ * Add new memory allocated to that on
+ * free list for this hash bucket.
+ */
+ nextf[bucket] = op;
+ while (--nblks > 0) {
+ op->ov_next = (union overhead *)((caddr_t)op + sz);
+ op = (union overhead *)((caddr_t)op + sz);
+ }
+ op->ov_next = (union overhead *)NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpFree --
+ *
+ * Free memory.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclpFree(
+ char *cp) /* Pointer to memory to free. */
+{
+ register long size;
+ register union overhead *op;
+
+ if (cp == NULL) {
+ return;
+ }
+
+ op = (union overhead *)((caddr_t)cp - sizeof (union overhead));
+
+ ASSERT(op->ov_magic0 == MAGIC); /* make sure it was in use */
+ ASSERT(op->ov_magic1 == MAGIC);
+ if (op->ov_magic0 != MAGIC || op->ov_magic1 != MAGIC) {
+ return;
+ }
+
+ RANGE_ASSERT(op->ov_rmagic == RMAGIC);
+ RANGE_ASSERT(*(unsigned short *)((caddr_t)(op + 1) + op->ov_size) == RMAGIC);
+ size = op->ov_index;
+ if ( size == 0xff ) {
+#ifdef MSTATS
+ nmalloc[NBUCKETS]--;
+#endif
+ TclpSysFree(op);
+ return;
+ }
+ ASSERT(size < NBUCKETS);
+ op->ov_next = nextf[size]; /* also clobbers ov_magic */
+ nextf[size] = op;
+#ifdef MSTATS
+ nmalloc[size]--;
+#endif
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclpRealloc --
+ *
+ * Reallocate memory.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+char *
+TclpRealloc(
+ char *cp, /* Pointer to alloced block. */
+ unsigned int nbytes) /* New size of memory. */
+{
+ int i;
+ union overhead *op;
+ int expensive;
+ unsigned long maxsize;
+
+ if (cp == NULL) {
+ return (TclpAlloc(nbytes));
+ }
+
+ op = (union overhead *)((caddr_t)cp - sizeof (union overhead));
+
+ ASSERT(op->ov_magic0 == MAGIC); /* make sure it was in use */
+ ASSERT(op->ov_magic1 == MAGIC);
+ if (op->ov_magic0 != MAGIC || op->ov_magic1 != MAGIC) {
+ return NULL;
+ }
+
+ RANGE_ASSERT(op->ov_rmagic == RMAGIC);
+ RANGE_ASSERT(*(unsigned short *)((caddr_t)(op + 1) + op->ov_size) == RMAGIC);
+ i = op->ov_index;
+
+ /*
+ * If the block isn't in a bin, just realloc it.
+ */
+
+ if (i == 0xff) {
+ op = (union overhead *) TclpSysRealloc(op, nbytes+OVERHEAD);
+ if (op == NULL) {
+ return NULL;
+ }
+#ifdef MSTATS
+ nmalloc[NBUCKETS]++;
+#endif
+#ifdef RCHECK
+ /*
+ * Record allocated size of block and update magic number bounds.
+ */
+
+ op->ov_size = (nbytes + RSLOP - 1) & ~(RSLOP - 1);
+ *(unsigned short *)((caddr_t)(op + 1) + op->ov_size) = RMAGIC;
+#endif
+ return (char *)(op+1);
+ }
+ maxsize = 1 << (i+3);
+ expensive = 0;
+ if ( nbytes + OVERHEAD > maxsize ) {
+ expensive = 1;
+ } else if ( i > 0 && nbytes + OVERHEAD < (maxsize/2) ) {
+ expensive = 1;
+ }
+
+ if (expensive) {
+ void *newp;
+
+ newp = TclpAlloc(nbytes);
+ if ( newp == NULL ) {
+ return NULL;
+ }
+ maxsize -= OVERHEAD;
+ if ( maxsize < nbytes )
+ nbytes = maxsize;
+ memcpy((VOID *) newp, (VOID *) cp, (size_t) nbytes);
+ TclpFree(cp);
+ return newp;
+ }
+
+ /*
+ * Ok, we don't have to copy, it fits as-is
+ */
+#ifdef RCHECK
+ op->ov_size = (nbytes + RSLOP - 1) & ~(RSLOP - 1);
+ *(unsigned short *)((caddr_t)(op + 1) + op->ov_size) = RMAGIC;
+#endif
+ return(cp);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * mstats --
+ *
+ * Prints two lines of numbers, one showing the length of the
+ * free list for each size category, the second showing the
+ * number of mallocs - frees for each size category.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+#ifdef MSTATS
+void
+mstats(
+ char *s) /* Where to write info. */
+{
+ register int i, j;
+ register union overhead *p;
+ int totfree = 0,
+ totused = 0;
+
+ fprintf(stderr, "Memory allocation statistics %s\nTclpFree:\t", s);
+ for (i = 0; i < NBUCKETS; i++) {
+ for (j = 0, p = nextf[i]; p; p = p->ov_next, j++)
+ fprintf(stderr, " %d", j);
+ totfree += j * (1 << (i + 3));
+ }
+ fprintf(stderr, "\nused:\t");
+ for (i = 0; i < NBUCKETS; i++) {
+ fprintf(stderr, " %d", nmalloc[i]);
+ totused += nmalloc[i] * (1 << (i + 3));
+ }
+ fprintf(stderr, "\n\tTotal small in use: %d, total free: %d\n",
+ totused, totfree);
+ fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %d\n",
+ MAXMALLOC, nmalloc[NBUCKETS]);
+}
+#endif
diff --git a/contrib/tcl/generic/tclBasic.c b/contrib/tcl/generic/tclBasic.c
index c043dd4389c0..952292f2d101 100644
--- a/contrib/tcl/generic/tclBasic.c
+++ b/contrib/tcl/generic/tclBasic.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclBasic.c 1.280 97/05/20 19:09:26
+ * SCCS: @(#) tclBasic.c 1.305 97/08/13 10:34:43
*/
#include "tclInt.h"
@@ -89,12 +89,10 @@ static CmdInfo builtInCmds[] = {
TclCompileForCmd, 1},
{"foreach", (Tcl_CmdProc *) NULL, Tcl_ForeachObjCmd,
TclCompileForeachCmd, 1},
- {"format", Tcl_FormatCmd, (Tcl_ObjCmdProc *) NULL,
+ {"format", (Tcl_CmdProc *) NULL, Tcl_FormatObjCmd,
(CompileProc *) NULL, 1},
{"global", (Tcl_CmdProc *) NULL, Tcl_GlobalObjCmd,
(CompileProc *) NULL, 1},
- {"history", Tcl_HistoryCmd, (Tcl_ObjCmdProc *) NULL,
- (CompileProc *) NULL, 1},
{"if", Tcl_IfCmd, (Tcl_ObjCmdProc *) NULL,
TclCompileIfCmd, 1},
{"incr", Tcl_IncrCmd, (Tcl_ObjCmdProc *) NULL,
@@ -143,7 +141,7 @@ static CmdInfo builtInCmds[] = {
(CompileProc *) NULL, 1},
{"set", Tcl_SetCmd, (Tcl_ObjCmdProc *) NULL,
TclCompileSetCmd, 1},
- {"split", Tcl_SplitCmd, (Tcl_ObjCmdProc *) NULL,
+ {"split", (Tcl_CmdProc *) NULL, Tcl_SplitObjCmd,
(CompileProc *) NULL, 1},
{"string", (Tcl_CmdProc *) NULL, Tcl_StringObjCmd,
(CompileProc *) NULL, 1},
@@ -169,15 +167,15 @@ static CmdInfo builtInCmds[] = {
*/
#ifndef TCL_GENERIC_ONLY
- {"after", Tcl_AfterCmd, (Tcl_ObjCmdProc *) NULL,
+ {"after", (Tcl_CmdProc *) NULL, Tcl_AfterObjCmd,
(CompileProc *) NULL, 1},
- {"cd", Tcl_CdCmd, (Tcl_ObjCmdProc *) NULL,
+ {"cd", (Tcl_CmdProc *) NULL, Tcl_CdObjCmd,
(CompileProc *) NULL, 0},
- {"close", Tcl_CloseCmd, (Tcl_ObjCmdProc *) NULL,
+ {"close", (Tcl_CmdProc *) NULL, Tcl_CloseObjCmd,
(CompileProc *) NULL, 1},
- {"eof", Tcl_EofCmd, (Tcl_ObjCmdProc *) NULL,
+ {"eof", (Tcl_CmdProc *) NULL, Tcl_EofObjCmd,
(CompileProc *) NULL, 1},
- {"fblocked", Tcl_FblockedCmd, (Tcl_ObjCmdProc *) NULL,
+ {"fblocked", (Tcl_CmdProc *) NULL, Tcl_FblockedObjCmd,
(CompileProc *) NULL, 1},
{"fconfigure", Tcl_FconfigureCmd, (Tcl_ObjCmdProc *) NULL,
(CompileProc *) NULL, 0},
@@ -210,7 +208,7 @@ static CmdInfo builtInCmds[] = {
{"update", Tcl_UpdateCmd, (Tcl_ObjCmdProc *) NULL,
(CompileProc *) NULL, 1},
{"vwait", Tcl_VwaitCmd, (Tcl_ObjCmdProc *) NULL,
- (CompileProc *) NULL, 0},
+ (CompileProc *) NULL, 1},
#ifdef MAC_TCL
{"beep", (Tcl_CmdProc *) NULL, Tcl_BeepObjCmd,
@@ -272,6 +270,7 @@ Tcl_CreateInterp()
*/
if (sizeof(Tcl_CallFrame) != sizeof(CallFrame)) {
+ /*NOTREACHED*/
panic("Tcl_CallFrame and CallFrame are not the same size");
}
@@ -298,14 +297,6 @@ Tcl_CreateInterp()
iPtr->returnCode = TCL_OK;
iPtr->errorInfo = NULL;
iPtr->errorCode = NULL;
- iPtr->numEvents = 0;
- iPtr->events = NULL;
- iPtr->curEvent = 0;
- iPtr->curEventNum = 0;
- iPtr->revPtr = NULL;
- iPtr->historyFirst = NULL;
- iPtr->revDisables = 1;
- iPtr->evalFirst = iPtr->evalLast = NULL;
iPtr->appendResult = NULL;
iPtr->appendAvl = 0;
iPtr->appendUsed = 0;
@@ -399,18 +390,45 @@ Tcl_CreateInterp()
}
}
+ /*
+ * Initialize/Create "errorInfo" and "errorCode" global vars
+ * (because some part of the C code assume they exists
+ * and we can get a seg fault otherwise (in multiple
+ * interps loading of extensions for instance) --dl)
+ */
+ /*
+ * We can't assume that because we initialize
+ * the variables here, they won't be unset later.
+ * so we had 2 choices:
+ * + Check every place where a GetVar of those is used
+ * and the NULL result is not checked (like in tclLoad.c)
+ * + Make SetVar,... NULL friendly
+ * We choosed the second option because :
+ * + It is easy and low cost to check for NULL pointer before
+ * calling strlen()
+ * + It can be helpfull to other people using those API
+ * + Passing a NULL value to those closest 'meaning' is empty string
+ * (specially with the new objects where 0 bytes strings are ok)
+ * So the following init is commented out: -- dl
+ */
+ /*
+ (void)Tcl_SetVar2((Tcl_Interp *)iPtr, "errorInfo", (char *) NULL, "",
+ TCL_GLOBAL_ONLY);
+ (void)Tcl_SetVar2((Tcl_Interp *)iPtr, "errorCode", (char *) NULL, "NONE",
+ TCL_GLOBAL_ONLY);
+ */
+
#ifndef TCL_GENERIC_ONLY
TclSetupEnv((Tcl_Interp *) iPtr);
#endif
/*
- * Do Safe-Tcl init stuff
+ * Do Multiple/Safe Interps Tcl init stuff
*/
-
(void) TclInterpInit((Tcl_Interp *)iPtr);
/*
- * Set up variables such as tcl_library and tcl_precision.
+ * Set up variables such as tcl_version.
*/
TclPlatformInit((Tcl_Interp *)iPtr);
@@ -418,6 +436,9 @@ Tcl_CreateInterp()
TCL_GLOBAL_ONLY);
Tcl_SetVar((Tcl_Interp *) iPtr, "tcl_version", TCL_VERSION,
TCL_GLOBAL_ONLY);
+ Tcl_TraceVar2((Tcl_Interp *) iPtr, "tcl_precision", (char *) NULL,
+ TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
+ TclPrecTraceProc, (ClientData) NULL);
/*
* Compute the byte order of this machine.
@@ -425,7 +446,7 @@ Tcl_CreateInterp()
order.s = 1;
Tcl_SetVar2((Tcl_Interp *) iPtr, "tcl_platform", "byteOrder",
- (order.c[0] == 1) ? "litteEndian" : "bigEndian",
+ (order.c[0] == 1) ? "littleEndian" : "bigEndian",
TCL_GLOBAL_ONLY);
/*
@@ -818,20 +839,6 @@ DeleteInterpProc(interp)
ckfree(iPtr->errorCode);
iPtr->errorCode = NULL;
}
- if (iPtr->events != NULL) {
- for (i = 0; i < iPtr->numEvents; i++) {
- ckfree(iPtr->events[i].command);
- }
- ckfree((char *) iPtr->events);
- iPtr->events = NULL;
- }
- while (iPtr->revPtr != NULL) {
- HistoryRev *nextPtr = iPtr->revPtr->nextPtr;
-
- ckfree(iPtr->revPtr->newBytes);
- ckfree((char *) iPtr->revPtr);
- iPtr->revPtr = nextPtr;
- }
if (iPtr->appendResult != NULL) {
ckfree(iPtr->appendResult);
iPtr->appendResult = NULL;
@@ -964,10 +971,6 @@ HiddenCmdsDeleteProc(clientData, interp)
Command *cmdPtr;
hiddenCmdTblPtr = (Tcl_HashTable *) clientData;
- hPtr = Tcl_FindHashEntry(hiddenCmdTblPtr, "tkerror");
- if (hPtr != NULL) {
- Tcl_DeleteHashEntry(hPtr);
- }
for (hPtr = Tcl_FirstHashEntry(hiddenCmdTblPtr, &hSearch);
hPtr != NULL;
hPtr = Tcl_FirstHashEntry(hiddenCmdTblPtr, &hSearch)) {
@@ -1023,7 +1026,18 @@ HiddenCmdsDeleteProc(clientData, interp)
if (cmdPtr->hPtr != NULL) {
Tcl_DeleteHashEntry(cmdPtr->hPtr);
}
- ckfree((char *) cmdPtr);
+
+ /*
+ * Now free the Command structure, unless there is another reference
+ * to it from a CmdName Tcl object in some ByteCode code
+ * sequence. In that case, delay the cleanup until all references
+ * are either discarded (when a ByteCode is freed) or replaced by a
+ * new reference (when a cached CmdName Command reference is found
+ * to be invalid and TclExecuteByteCode looks up the command in the
+ * command hashtable).
+ */
+
+ TclCleanupCommand(cmdPtr);
}
Tcl_DeleteHashTable(hiddenCmdTblPtr);
ckfree((char *) hiddenCmdTblPtr);
@@ -1042,24 +1056,24 @@ HiddenCmdsDeleteProc(clientData, interp)
* if an error occurs.
*
* Side effects:
- * Moves a command from the command table to the hidden command
- * table.
+ * Removes a command from the command table and create an entry
+ * into the hidden command table under the specified token name.
*
*----------------------------------------------------------------------
*/
int
-Tcl_HideCommand(interp, cmdName, hiddenCmdName)
+Tcl_HideCommand(interp, cmdName, hiddenCmdToken)
Tcl_Interp *interp; /* Interpreter in which to hide command. */
- char *cmdName; /* Name of hidden command. */
- char *hiddenCmdName; /* Name of to-be-hidden command. */
+ char *cmdName; /* Name of command to hide. */
+ char *hiddenCmdToken; /* Token name of the to-be-hidden command. */
{
Interp *iPtr = (Interp *) interp;
Tcl_Command cmd;
Command *cmdPtr;
Tcl_HashTable *hTblPtr;
- Tcl_HashEntry *hPtr, *tkErrorHPtr;
- int isBgerror, new;
+ Tcl_HashEntry *hPtr;
+ int new;
if (iPtr->flags & DELETED) {
@@ -1071,38 +1085,57 @@ Tcl_HideCommand(interp, cmdName, hiddenCmdName)
return TCL_ERROR;
}
- if (strstr(hiddenCmdName, "::") != NULL) {
+ /*
+ * Disallow hiding of commands that are currently in a namespace or
+ * renaming (as part of hiding) into a namespace.
+ *
+ * (because the current implementation with a single global table
+ * and the needed uniqueness of names cause problems with namespaces)
+ *
+ * we don't need to check for "::" in cmdName because the real check is
+ * on the nsPtr below.
+ *
+ * hiddenCmdToken is just a string which is not interpreted in any way.
+ * It may contain :: but the string is not interpreted as a namespace
+ * qualifier command name. Thus, hiding foo::bar to foo::bar and then
+ * trying to expose or invoke ::foo::bar will NOT work; but if the
+ * application always uses the same strings it will get consistent
+ * behaviour.
+ *
+ * But as we currently limit ourselves to the global namespace only
+ * for the source, in order to avoid potential confusion,
+ * lets prevent "::" in the token too. --dl
+ */
+
+ if (strstr(hiddenCmdToken, "::") != NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "hidden command names can't have namespace qualifiers",
- (char *) NULL);
+ "cannot use namespace qualifiers as hidden command",
+ "token (rename)", (char *) NULL);
return TCL_ERROR;
}
/*
* Find the command to hide. An error is returned if cmdName can't
- * be found.
+ * be found. Look up the command only from the global namespace.
+ * Full path of the command must be given if using namespaces.
*/
cmd = Tcl_FindCommand(interp, cmdName, (Tcl_Namespace *) NULL,
- /*flags*/ TCL_LEAVE_ERR_MSG);
+ /*flags*/ TCL_LEAVE_ERR_MSG | TCL_GLOBAL_ONLY);
if (cmd == (Tcl_Command) NULL) {
return TCL_ERROR;
}
cmdPtr = (Command *) cmd;
/*
- * If this command is the "bgerror" command in the global namespace,
- * make note of it now. We'll need to know this later so that we can
- * handle its "tkerror" twin below.
+ * Check that the command is really in global namespace
*/
-
- isBgerror = 0;
- if (cmdPtr->hPtr != NULL) {
- char *tail = Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
- if ((*tail == 'b') && (strcmp(tail, "bgerror") == 0)
- && (cmdPtr->nsPtr == iPtr->globalNsPtr)) {
- isBgerror = 1;
- }
+
+ if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "can only hide global namespace commands",
+ " (use rename then hide)", (char *) NULL);
+ return TCL_ERROR;
}
/*
@@ -1121,19 +1154,26 @@ Tcl_HideCommand(interp, cmdName, hiddenCmdName)
/*
* It is an error to move an exposed command to a hidden command with
- * hiddenCmdName if a hidden command with the name hiddenCmdName already
+ * hiddenCmdToken if a hidden command with the name hiddenCmdToken already
* exists.
*/
- hPtr = Tcl_CreateHashEntry(hTblPtr, hiddenCmdName, &new);
+ hPtr = Tcl_CreateHashEntry(hTblPtr, hiddenCmdToken, &new);
if (!new) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "hidden command named \"", hiddenCmdName, "\" already exists",
+ "hidden command named \"", hiddenCmdToken, "\" already exists",
(char *) NULL);
return TCL_ERROR;
}
/*
+ * Nb : This code is currently 'like' a rename to a specialy set apart
+ * name table. Changes here and in TclRenameCommand must
+ * be kept in synch untill the common parts are actually
+ * factorized out.
+ */
+
+ /*
* Remove the hash entry for the command from the interpreter command
* table. This is like deleting the command, so bump its command epoch;
* this invalidates any cached references that point to the command.
@@ -1146,28 +1186,8 @@ Tcl_HideCommand(interp, cmdName, hiddenCmdName)
}
/*
- * If we are creating a hidden command named "bgerror", share the
- * command data structure with another command named "tkerror". This
- * code should eventually be removed.
- */
-
- if (isBgerror) {
- tkErrorHPtr = Tcl_CreateHashEntry(hTblPtr, "tkerror", &new);
- if (!new) {
- panic("Tcl_HideCommand: hiding bgerror while tkerror is already hidden!");
- }
- Tcl_SetHashValue(tkErrorHPtr, (ClientData) cmdPtr);
- tkErrorHPtr = Tcl_FindHashEntry(&(iPtr->globalNsPtr->cmdTable),
- "tkerror");
- if (tkErrorHPtr != (Tcl_HashEntry *) NULL) {
- Tcl_DeleteHashEntry(tkErrorHPtr);
- }
- }
-
- /*
- * Now link the hash table entry with the command structure. Keep the
- * containing namespace the same. After all, the command really
- * "belongs" to that namespace.
+ * Now link the hash table entry with the command structure.
+ * We ensured above that the nsPtr was right.
*/
cmdPtr->hPtr = hPtr;
@@ -1207,19 +1227,18 @@ Tcl_HideCommand(interp, cmdName, hiddenCmdName)
*/
int
-Tcl_ExposeCommand(interp, hiddenCmdName, cmdName)
+Tcl_ExposeCommand(interp, hiddenCmdToken, cmdName)
Tcl_Interp *interp; /* Interpreter in which to make command
* callable. */
- char *hiddenCmdName; /* Name of hidden command. */
+ char *hiddenCmdToken; /* Name of hidden command. */
char *cmdName; /* Name of to-be-exposed command. */
{
Interp *iPtr = (Interp *) interp;
Command *cmdPtr;
- Namespace *nsPtr, *dummy1, *dummy2;
- Tcl_HashEntry *hPtr, *tkErrorHPtr;
+ Namespace *nsPtr;
+ Tcl_HashEntry *hPtr;
Tcl_HashTable *hTblPtr;
- char *tail;
- int new, result;
+ int new;
if (iPtr->flags & DELETED) {
/*
@@ -1231,6 +1250,20 @@ Tcl_ExposeCommand(interp, hiddenCmdName, cmdName)
}
/*
+ * Check that we have a regular name for the command
+ * (that the user is not trying to do an expose and a rename
+ * (to another namespace) at the same time)
+ */
+
+ if (strstr(cmdName, "::") != NULL) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "can not expose to a namespace ",
+ "(use expose to toplevel, then rename)",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ /*
* Find the hash table for the hidden commands; error out if there
* is none.
*/
@@ -1239,7 +1272,7 @@ Tcl_ExposeCommand(interp, hiddenCmdName, cmdName)
NULL);
if (hTblPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "unknown hidden command \"", hiddenCmdName,
+ "unknown hidden command \"", hiddenCmdToken,
"\"", (char *) NULL);
return TCL_ERROR;
}
@@ -1248,45 +1281,42 @@ Tcl_ExposeCommand(interp, hiddenCmdName, cmdName)
* Get the command from the hidden command table:
*/
- hPtr = Tcl_FindHashEntry(hTblPtr, hiddenCmdName);
+ hPtr = Tcl_FindHashEntry(hTblPtr, hiddenCmdToken);
if (hPtr == (Tcl_HashEntry *) NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "unknown hidden command \"", hiddenCmdName,
+ "unknown hidden command \"", hiddenCmdToken,
"\"", (char *) NULL);
return TCL_ERROR;
}
cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
+
/*
- * Normally, the command will go right back into its containing
- * namespace. But if the exposed command name has "::" namespace
- * qualifiers, it is being moved to another context.
+ * Check that we have a true global namespace
+ * command (enforced by Tcl_HideCommand() but let's double
+ * check. (If it was not, we would not really know how to
+ * handle it).
*/
-
- if (strstr(cmdName, "::") != NULL) {
- result = TclGetNamespaceForQualName(interp, cmdName,
- iPtr->globalNsPtr,
- (CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG),
- &nsPtr, &dummy1, &dummy2, &tail);
- if (result != TCL_OK) {
- return result;
- }
- if ((nsPtr == NULL) || (tail == NULL)) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "bad command name \"", cmdName, "\"", (char *) NULL);
- return TCL_ERROR;
- }
- } else {
- nsPtr = cmdPtr->nsPtr;
- tail = cmdName;
+ if ( cmdPtr->nsPtr != iPtr->globalNsPtr ) {
+ /*
+ * This case is theoritically impossible,
+ * we might rather panic() than 'nicely' erroring out ?
+ */
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "trying to expose a non global command name space command",
+ (char *) NULL);
+ return TCL_ERROR;
}
+
+ /* This is the global table */
+ nsPtr = cmdPtr->nsPtr;
/*
* It is an error to overwrite an existing exposed command as a result
* of exposing a previously hidden command.
*/
- hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
+ hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &new);
if (!new) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"exposed command \"", cmdName,
@@ -1305,35 +1335,22 @@ Tcl_ExposeCommand(interp, hiddenCmdName, cmdName)
}
/*
- * If we are creating a command named "bgerror", share the command
- * data structure with another command named "tkerror". This code
- * should eventually be removed.
- */
-
- if ((*tail == 'b') && (strcmp(tail, "bgerror") == 0)
- && (nsPtr == iPtr->globalNsPtr)) {
- tkErrorHPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable,
- "tkerror", &new);
- if (!new) {
- panic("Tcl_ExposeCommand: exposing bgerror while tkerror is already exposed!");
- }
- Tcl_SetHashValue(tkErrorHPtr, (ClientData) cmdPtr);
- tkErrorHPtr = Tcl_FindHashEntry(hTblPtr, "tkerror");
- if (tkErrorHPtr != NULL) {
- Tcl_DeleteHashEntry(tkErrorHPtr);
- }
- }
-
- /*
* Now link the hash table entry with the command structure.
* This is like creating a new command, so deal with any shadowing
* of commands in the global namespace.
*/
cmdPtr->hPtr = hPtr;
- cmdPtr->nsPtr = nsPtr;
+
Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);
- TclResetShadowedCmdRefs(interp, cmdPtr);
+
+ /*
+ * Not needed as we are only in the global namespace
+ * (but would be needed again if we supported namespace command hiding)
+ *
+ * TclResetShadowedCmdRefs(interp, cmdPtr);
+ */
+
/*
* If the command being exposed has a compile procedure, increment
@@ -1421,18 +1438,6 @@ Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
tail = cmdName;
}
- /*
- * The code below was added in 11/95 to preserve backwards compatibility
- * when "tkerror" was renamed "bgerror": if anyone attempts to define
- * "tkerror" as a command, it is actually created as "bgerror". This
- * code should eventually be removed.
- */
-
- if ((*tail == 't') && (strcmp(tail, "tkerror") == 0)
- && (nsPtr == iPtr->globalNsPtr)) {
- tail = "bgerror";
- }
-
hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
if (!new) {
/*
@@ -1469,23 +1474,6 @@ Tcl_CreateCommand(interp, cmdName, proc, clientData, deleteProc)
cmdPtr->importRefPtr = NULL;
/*
- * The code below provides more backwards compatibility for the
- * renaming of "tkerror" to "bgerror". Like the code above, this
- * code should eventually become unnecessary.
- */
-
- if ((*tail == 'b') && (strcmp(tail, "bgerror") == 0)
- && (nsPtr == iPtr->globalNsPtr)) {
- /*
- * We're currently creating the "bgerror" command; create
- * a "tkerror" command that shares the same Command structure.
- */
-
- hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, "tkerror", &new);
- Tcl_SetHashValue(hPtr, cmdPtr);
- }
-
- /*
* We just created a command, so in its namespace and all of its parent
* namespaces, it may shadow global commands with the same name. If any
* shadowed commands are found, invalidate all cached command references
@@ -1574,18 +1562,6 @@ Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc)
tail = cmdName;
}
- /*
- * The code below was added in 11/95 to preserve backwards compatibility
- * when "tkerror" was renamed "bgerror": if anyone attempts to define
- * "tkerror" as a command, it is actually created as "bgerror". This
- * code should eventually be removed.
- */
-
- if ((*tail == 't') && (strcmp(tail, "tkerror") == 0)
- && (nsPtr == iPtr->globalNsPtr)) {
- tail = "bgerror";
- }
-
hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, tail, &new);
if (!new) {
cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
@@ -1601,7 +1577,7 @@ Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc)
cmdPtr->objClientData = clientData;
cmdPtr->deleteProc = deleteProc;
cmdPtr->deleteData = clientData;
- goto checkForBgerror;
+ return (Tcl_Command) cmdPtr;
}
Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr);
@@ -1632,23 +1608,6 @@ Tcl_CreateObjCommand(interp, cmdName, proc, clientData, deleteProc)
cmdPtr->deleted = 0;
cmdPtr->importRefPtr = NULL;
- /*
- * The code below provides more backwards compatibility for the
- * renaming of "tkerror" to "bgerror". Like the code above, this
- * code should eventually become unnecessary.
- */
-
- checkForBgerror:
- if ((*tail == 'b') && (strcmp(tail, "bgerror") == 0)
- && (nsPtr == iPtr->globalNsPtr)) {
- /*
- * We're currently creating the "bgerror" command; create
- * a "tkerror" command that shares the same Command structure.
- */
-
- hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, "tkerror", &new);
- Tcl_SetHashValue(hPtr, cmdPtr);
- }
return (Tcl_Command) cmdPtr;
}
@@ -1830,7 +1789,8 @@ TclInvokeObjectCommand(clientData, interp, argc, argv)
* Called to give an existing Tcl command a different name. Both the
* old command name and the new command name can have "::" namespace
* qualifiers. If the new command has a different namespace context,
- * the command is automatically moved to that namespace.
+ * the command will be moved to that namespace and will execute in
+ * the context of that new namespace.
*
* If the new command name is NULL or the null string, the command is
* deleted.
@@ -1852,12 +1812,12 @@ TclRenameCommand(interp, oldName, newName)
char *newName; /* New command name. */
{
Interp *iPtr = (Interp *) interp;
- char *cmdTail, *newTail;
+ char *newTail;
Namespace *cmdNsPtr, *newNsPtr, *dummy1, *dummy2;
Tcl_Command cmd;
Command *cmdPtr;
Tcl_HashEntry *hPtr, *oldHPtr;
- int new, isSrcBgerror, isDestBgerror, result;
+ int new, result;
/*
* Find the existing command. An error is returned if cmdName can't
@@ -1869,11 +1829,10 @@ TclRenameCommand(interp, oldName, newName)
cmdPtr = (Command *) cmd;
if (cmdPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't ",
- ((newName == NULL) || (*newName == '\0'))? "delete":"rename",
+ ((newName == NULL)||(*newName == '\0'))? "delete":"rename",
" \"", oldName, "\": command doesn't exist", (char *) NULL);
return TCL_ERROR;
}
- cmdTail = Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
cmdNsPtr = cmdPtr->nsPtr;
/*
@@ -1912,35 +1871,17 @@ TclRenameCommand(interp, oldName, newName)
return TCL_ERROR;
}
+
/*
- * The code below was added in 11/95 to preserve backwards compatibility
- * when "tkerror" was renamed "bgerror": we guarantee that the hash
- * table entries for both commands refer to a single shared Command
- * structure. This code should eventually become unnecessary.
+ * Warning: any changes done in the code here are likely
+ * to be needed in Tcl_HideCommand() code too.
+ * (until the common parts are extracted out) --dl
*/
- if ((*cmdTail == 't') && (strcmp(cmdTail, "tkerror") == 0)
- && (cmdNsPtr == iPtr->globalNsPtr)) {
- cmdTail = "bgerror";
- }
- isSrcBgerror = ((*cmdTail == 'b') && (strcmp(cmdTail, "bgerror") == 0)
- && (cmdNsPtr == iPtr->globalNsPtr));
-
- if ((*newTail == 't') && (strcmp(newTail, "tkerror") == 0)
- && (newNsPtr == iPtr->globalNsPtr)) {
- newTail = "bgerror";
- }
- isDestBgerror = ((*newTail == 'b') && (strcmp(newTail, "bgerror") == 0)
- && (newNsPtr == iPtr->globalNsPtr));
-
/*
- * Put the command in the new namespace, so we can check for an alias
+ * Put the command in the new namespace so we can check for an alias
* loop. Since we are adding a new command to a namespace, we must
* handle any shadowing of the global commands that this might create.
- * Note that the renamed command has a different hashtable pointer than
- * it used to have. This allows the command caching code in tclExecute.c
- * to recognize that a command pointer it has cached for this command is
- * now invalid.
*/
oldHPtr = cmdPtr->hPtr;
@@ -1951,8 +1892,8 @@ TclRenameCommand(interp, oldName, newName)
TclResetShadowedCmdRefs(interp, cmdPtr);
/*
- * Everything is in place so we can check for an alias loop. If we
- * detect one, put everything back the way it was and report the error.
+ * Now check for an alias loop. If we detect one, put everything back
+ * the way it was and report the error.
*/
result = TclPreventAliasLoop(interp, interp, (Tcl_Command) cmdPtr);
@@ -1983,32 +1924,6 @@ TclRenameCommand(interp, oldName, newName)
iPtr->compileEpoch++;
}
- /*
- * The code below provides more backwards compatibility for the
- * "tkerror" => "bgerror" renaming. As with the other compatibility
- * code above, it should eventually be removed.
- */
-
- if (isSrcBgerror) {
- /*
- * The source command is "bgerror": delete the hash table entry for
- * "tkerror" if it exists.
- */
-
- hPtr = Tcl_FindHashEntry(&cmdNsPtr->cmdTable, "tkerror");
- if (hPtr != NULL) {
- Tcl_DeleteHashEntry(hPtr);
- }
- }
- if (isDestBgerror) {
- /*
- * The destination command is "bgerror"; create a "tkerror"
- * command that shares the same Command structure.
- */
-
- hPtr = Tcl_CreateHashEntry(&newNsPtr->cmdTable, "tkerror", &new);
- Tcl_SetHashValue(hPtr, (ClientData) cmdPtr);
- }
return TCL_OK;
}
@@ -2283,15 +2198,8 @@ Tcl_DeleteCommandFromToken(interp, cmd)
{
Interp *iPtr = (Interp *) interp;
Command *cmdPtr = (Command *) cmd;
- char *cmdName;
- int isBgerror;
ImportRef *refPtr, *nextRefPtr;
Tcl_Command importCmd;
- Tcl_HashEntry *tkErrorHPtr;
-
- cmdName = Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr);
- isBgerror = ((*cmdName == 'b') && (strcmp(cmdName, "bgerror") == 0)
- && (cmdPtr->nsPtr == iPtr->globalNsPtr));
/*
* The code here is tricky. We can't delete the hash table entry
@@ -2360,29 +2268,6 @@ Tcl_DeleteCommandFromToken(interp, cmd)
}
/*
- * The code below provides more backwards compatibility for the
- * renaming of "tkerror" to "bgerror". Like the code above, this
- * code should eventually become unnecessary.
- */
-
- if (isBgerror) {
- /*
- * When the "bgerror" command is deleted, delete "tkerror"
- * as well. It shared the same Command structure as "bgerror",
- * so all we have to do is throw away the hash table entry.
- * NOTE: we have to be careful since tkerror may already have
- * been deleted before bgerror.
- */
-
- tkErrorHPtr = Tcl_FindHashEntry(cmdPtr->hPtr->tablePtr,
- "tkerror");
-
- if (tkErrorHPtr != (Tcl_HashEntry *) NULL) {
- Tcl_DeleteHashEntry(tkErrorHPtr);
- }
- }
-
- /*
* Don't use hPtr to delete the hash entry here, because it's
* possible that the deletion callback renamed the command.
* Instead, use cmdPtr->hptr, and make sure that no-one else
@@ -2588,6 +2473,19 @@ Tcl_EvalObj(interp, objPtr)
}
/*
+ * On the Mac, we will never reach the default recursion limit before blowing
+ * the stack. So we need to do a check here.
+ */
+
+ if (TclpCheckStackSpace() == 0) {
+ /*NOTREACHED*/
+ iPtr->numLevels--;
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "too many nested calls to Tcl_EvalObj (infinite loop?)", -1);
+ return TCL_ERROR;
+ }
+
+ /*
* If the interpreter has been deleted, return an error.
*/
@@ -2641,16 +2539,6 @@ Tcl_EvalObj(interp, objPtr)
iPtr->evalFlags = 0;
/*
- * Save information for the history module, if needed.
- * BTL: setting these NULL disables history revisions.
- */
-
- if (flags & TCL_RECORD_BOUNDS) {
- iPtr->evalFirst = NULL;
- iPtr->evalLast = NULL;
- }
-
- /*
* Execute the commands. If the code was compiled from an empty string,
* don't bother executing the code.
*/
@@ -2723,25 +2611,6 @@ Tcl_EvalObj(interp, objPtr)
int length;
/*
- * Compute the line number where the error occurred.
- * BTL: no line # information yet.
- */
-
- iPtr->errorLine = 1;
-#ifdef NOT_YET
- for (p = cmd; p != cmdStart; p++) {
- if (*p == '\n') {
- iPtr->errorLine++;
- }
- }
- for ( ; isspace(UCHAR(*p)) || (*p == ';'); p++) {
- if (*p == '\n') {
- iPtr->errorLine++;
- }
- }
-#endif
-
- /*
* Figure out how much of the command to print in the error
* message (up to a certain number of characters, or up to
* the first new-line).
@@ -2813,7 +2682,6 @@ Tcl_ExprLong(interp, string, ptr)
if (length > 0) {
exprPtr = Tcl_NewStringObj(string, length);
Tcl_IncrRefCount(exprPtr);
-
result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
if (result == TCL_OK) {
/*
@@ -2868,7 +2736,6 @@ Tcl_ExprDouble(interp, string, ptr)
if (length > 0) {
exprPtr = Tcl_NewStringObj(string, length);
Tcl_IncrRefCount(exprPtr);
-
result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
if (result == TCL_OK) {
/*
@@ -2923,7 +2790,6 @@ Tcl_ExprBoolean(interp, string, ptr)
if (length > 0) {
exprPtr = Tcl_NewStringObj(string, length);
Tcl_IncrRefCount(exprPtr);
-
result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
if (result == TCL_OK) {
/*
@@ -3312,7 +3178,7 @@ TclObjInvoke(interp, objc, objv, flags)
hTblPtr = (Tcl_HashTable *)
Tcl_GetAssocData(interp, "tclHiddenCmds", NULL);
if (hTblPtr == (Tcl_HashTable *) NULL) {
- badHiddenCmdName:
+ badhiddenCmdToken:
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"invalid hidden command name \"", cmdName, "\"",
@@ -3326,7 +3192,7 @@ TclObjInvoke(interp, objc, objv, flags)
*/
if (hPtr == NULL) {
- goto badHiddenCmdName;
+ goto badhiddenCmdToken;
}
cmdPtr = (Command *) Tcl_GetHashValue(hPtr);
} else {
@@ -3462,7 +3328,7 @@ Tcl_ExprString(interp, string)
if (length > 0) {
TclNewObj(exprPtr);
TclInitStringRep(exprPtr, string, length);
- Tcl_DecrRefCount(exprPtr);
+ Tcl_IncrRefCount(exprPtr);
result = Tcl_ExprObj(interp, exprPtr, &resultPtr);
if (result == TCL_OK) {
@@ -3554,7 +3420,7 @@ Tcl_ExprObj(interp, objPtr, resultPtrPtr)
Interp dummy;
Tcl_Obj *saveObjPtr;
char *string;
- int result = TCL_OK;
+ int result;
int i;
/*
@@ -3920,12 +3786,14 @@ Tcl_AddObjErrorInfo(interp, message, length)
* Now append "message" to the end of errorInfo.
*/
- messagePtr = Tcl_NewStringObj(message, length);
- Tcl_IncrRefCount(messagePtr);
- Tcl_ObjSetVar2(interp, namePtr, (Tcl_Obj *) NULL, messagePtr,
- (TCL_GLOBAL_ONLY | TCL_APPEND_VALUE));
- Tcl_DecrRefCount(messagePtr); /* free msg object appended above */
-
+ if (length != 0) {
+ messagePtr = Tcl_NewStringObj(message, length);
+ Tcl_IncrRefCount(messagePtr);
+ Tcl_ObjSetVar2(interp, namePtr, (Tcl_Obj *) NULL, messagePtr,
+ (TCL_GLOBAL_ONLY | TCL_APPEND_VALUE));
+ Tcl_DecrRefCount(messagePtr); /* free msg object appended above */
+ }
+
Tcl_DecrRefCount(namePtr); /* free the name object */
}
diff --git a/contrib/tcl/generic/tclBinary.c b/contrib/tcl/generic/tclBinary.c
index 28190cc355ed..c20d03dcd88d 100644
--- a/contrib/tcl/generic/tclBinary.c
+++ b/contrib/tcl/generic/tclBinary.c
@@ -9,9 +9,10 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclBinary.c 1.16 97/05/19 10:29:18
+ * SCCS: @(#) tclBinary.c 1.20 97/08/11 18:43:09
*/
+#include <math.h>
#include "tclInt.h"
#include "tclPort.h"
@@ -275,9 +276,11 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv)
count = 1;
}
if (length >= count) {
- memcpy(cursor, str, (size_t) count);
+ memcpy((VOID *) cursor, (VOID *) str,
+ (size_t) count);
} else {
- memcpy(cursor, str, (size_t) length);
+ memcpy((VOID *) cursor, (VOID *) str,
+ (size_t) length);
memset(cursor+length, pad,
(size_t) (count - length));
}
@@ -877,12 +880,13 @@ FormatNumber(interp, type, src, cursorPtr)
* to the valid range for float.
*/
- if (dvalue > FLT_MAX) {
- *((float *)(*cursorPtr)) = FLT_MAX;
- } else if (dvalue < FLT_MIN) {
- *((float *)(*cursorPtr)) = FLT_MIN;
+ if (fabs(dvalue) > (double)FLT_MAX) {
+ *((float *)(*cursorPtr))
+ = (dvalue >= 0.0) ? FLT_MAX : -FLT_MAX;
+ } else if (fabs(dvalue) < (double)FLT_MIN) {
+ *((float *)(*cursorPtr)) = (float) 0.0;
} else {
- *((float *)(*cursorPtr)) = (float)dvalue;
+ *((float *)(*cursorPtr)) = (float) dvalue;
}
(*cursorPtr) += sizeof(float);
}
diff --git a/contrib/tcl/generic/tclClock.c b/contrib/tcl/generic/tclClock.c
index c6cb924997c6..bf4558351eac 100644
--- a/contrib/tcl/generic/tclClock.c
+++ b/contrib/tcl/generic/tclClock.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclClock.c 1.36 97/06/02 10:14:17
+ * SCCS: @(#) tclClock.c 1.37 97/07/29 10:29:58
*/
#include "tcl.h"
@@ -79,7 +79,7 @@ Tcl_ClockObjCmd (client, interp, objc, objv)
switch (index) {
case 0: /* clicks */
if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "clicks");
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
Tcl_SetLongObj(resultPtr, (long) TclpGetClicks());
@@ -87,8 +87,8 @@ Tcl_ClockObjCmd (client, interp, objc, objv)
case 1: /* format */
if ((objc < 3) || (objc > 7)) {
wrongFmtArgs:
- Tcl_WrongNumArgs(interp, 1, objv,
- "format clockval ?-format string? ?-gmt boolean?");
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "clockval ?-format string? ?-gmt boolean?");
return TCL_ERROR;
}
@@ -126,8 +126,8 @@ Tcl_ClockObjCmd (client, interp, objc, objv)
case 2: /* scan */
if ((objc < 3) || (objc > 7)) {
wrongScanArgs:
- Tcl_WrongNumArgs(interp, 1, objv,
- "scan dateString ?-base clockValue? ?-gmt boolean?");
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "dateString ?-base clockValue? ?-gmt boolean?");
return TCL_ERROR;
}
@@ -184,7 +184,7 @@ Tcl_ClockObjCmd (client, interp, objc, objv)
return TCL_OK;
case 3: /* seconds */
if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "seconds");
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
Tcl_SetLongObj(resultPtr, (long) TclpGetSeconds());
diff --git a/contrib/tcl/generic/tclCmdAH.c b/contrib/tcl/generic/tclCmdAH.c
index 46384c905ba1..79968d343c5a 100644
--- a/contrib/tcl/generic/tclCmdAH.c
+++ b/contrib/tcl/generic/tclCmdAH.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclCmdAH.c 1.146 97/06/26 13:45:20
+ * SCCS: @(#) tclCmdAH.c 1.156 97/08/12 18:10:15
*/
#include "tclInt.h"
@@ -92,6 +92,7 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv)
char *string, *arg;
int argLen, caseObjc;
Tcl_Obj *CONST *caseObjv;
+ Tcl_Obj *armPtr;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv,
@@ -187,11 +188,12 @@ Tcl_CaseObjCmd(dummy, interp, objc, objv)
match:
if (body != -1) {
+ armPtr = caseObjv[body-1];
result = Tcl_EvalObj(interp, caseObjv[body]);
if (result == TCL_ERROR) {
char msg[100];
- arg = Tcl_GetStringFromObj(caseObjv[body-1], &argLen);
+ arg = Tcl_GetStringFromObj(armPtr, &argLen);
sprintf(msg, "\n (\"%.*s\" arm line %d)", argLen, arg,
interp->errorLine);
Tcl_AddObjErrorInfo(interp, msg, -1);
@@ -231,6 +233,7 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
+ Tcl_Obj *varNamePtr = NULL;
int result;
if ((objc != 2) && (objc != 3)) {
@@ -244,10 +247,15 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv)
* stack rendering objv invalid.
*/
+ if (objc == 3) {
+ varNamePtr = objv[2];
+ }
+
result = Tcl_EvalObj(interp, objv[1]);
+
if (objc == 3) {
- if (Tcl_ObjSetVar2(interp, objv[2], NULL, Tcl_GetObjResult(interp),
- TCL_PARSE_PART1) == NULL) {
+ if (Tcl_ObjSetVar2(interp, varNamePtr, NULL,
+ Tcl_GetObjResult(interp), TCL_PARSE_PART1) == NULL) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"couldn't save command result in variable", -1);
@@ -270,7 +278,7 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv)
/*
*----------------------------------------------------------------------
*
- * Tcl_CdCmd --
+ * Tcl_CdObjCmd --
*
* This procedure is invoked to process the "cd" Tcl command.
* See the user documentation for details on what it does.
@@ -286,24 +294,24 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv)
/* ARGSUSED */
int
-Tcl_CdCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+Tcl_CdObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
char *dirName;
+ int dirLength;
Tcl_DString buffer;
int result;
- if (argc > 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " dirName\"", (char *) NULL);
+ if (objc > 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "dirName");
return TCL_ERROR;
}
- if (argc == 2) {
- dirName = argv[1];
+ if (objc == 2) {
+ dirName = Tcl_GetStringFromObj(objv[1], &dirLength);
} else {
dirName = "~";
}
@@ -482,7 +490,7 @@ Tcl_EvalObjCmd(dummy, interp, objc, objv)
objPtr = Tcl_ConcatObj(objc-1, objv+1);
result = Tcl_EvalObj(interp, objPtr);
- TclDecrRefCount(objPtr); /* we're done with the object */
+ Tcl_DecrRefCount(objPtr); /* we're done with the object */
}
if (result == TCL_ERROR) {
char msg[60];
@@ -612,7 +620,7 @@ Tcl_ExprObjCmd(dummy, interp, objc, objv)
* Free allocated resources.
*/
- TclDecrRefCount(objPtr);
+ Tcl_DecrRefCount(objPtr);
return result;
}
@@ -790,8 +798,8 @@ enum {FILE_ATIME, FILE_ATTRIBUTES, FILE_COPY, FILE_DELETE, FILE_DIRNAME,
}
/*
- * Return the last component, unless it is the only component, and it
- * is the root of an absolute path.
+ * Return the last component, unless it is the only component,
+ * and it is the root of an absolute path.
*/
if (pargc > 0) {
@@ -826,10 +834,10 @@ enum {FILE_ATIME, FILE_ATTRIBUTES, FILE_COPY, FILE_DELETE, FILE_DIRNAME,
errorString = "extension name";
goto not3Args;
}
- extension = TclGetExtension(Tcl_GetStringFromObj(objv[2], &length));
+ extension = TclGetExtension(Tcl_GetStringFromObj(objv[2],&length));
if (extension != NULL) {
- Tcl_SetStringObj(resultPtr, extension, (int) strlen(extension));
+ Tcl_SetStringObj(resultPtr, extension, (int)strlen(extension));
}
goto done;
case FILE_PATHTYPE:
@@ -878,7 +886,8 @@ enum {FILE_ATIME, FILE_ATTRIBUTES, FILE_COPY, FILE_DELETE, FILE_DIRNAME,
pargv[i - 2] = Tcl_GetStringFromObj(objv[i], &length);
}
Tcl_JoinPath(objc - 2, pargv, &buffer);
- Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&buffer), buffer.length);
+ Tcl_SetStringObj(resultPtr, Tcl_DStringValue(&buffer),
+ buffer.length);
ckfree((char *) pargv);
Tcl_DStringFree(&buffer);
goto done;
@@ -930,7 +939,11 @@ enum {FILE_ATIME, FILE_ATTRIBUTES, FILE_COPY, FILE_DELETE, FILE_DIRNAME,
case FILE_NATIVENAME:
fileName = Tcl_TranslateFileName(interp,
Tcl_GetStringFromObj(objv[2], &length), &buffer);
- Tcl_SetStringObj(resultPtr, fileName, -1);
+ if (fileName == NULL) {
+ result = TCL_ERROR ;
+ } else {
+ Tcl_SetStringObj(resultPtr, fileName, -1);
+ }
goto done;
}
@@ -950,8 +963,16 @@ enum {FILE_ATIME, FILE_ATTRIBUTES, FILE_COPY, FILE_DELETE, FILE_DIRNAME,
}
mode = R_OK;
checkAccess:
- Tcl_SetBooleanObj(resultPtr, !((fileName == NULL)
- || (access(fileName, mode) == -1)));
+ /*
+ * The result might have been set within Tcl_TranslateFileName
+ * (like no such user "blah" for file exists ~blah)
+ * but we don't want to flag an error in that case.
+ */
+ if (fileName == NULL) {
+ Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0));
+ } else {
+ Tcl_SetBooleanObj(resultPtr, (access(fileName, mode) != -1));
+ }
goto done;
case FILE_WRITABLE:
if (objc != 3) {
@@ -1237,7 +1258,8 @@ StoreStatData(interp, varName, statPtr)
return TCL_ERROR;
}
if (Tcl_SetVar2(interp, varName, "type",
- GetTypeFromMode((int) statPtr->st_mode), TCL_LEAVE_ERR_MSG) == NULL) {
+ GetTypeFromMode((int) statPtr->st_mode), TCL_LEAVE_ERR_MSG)
+ == NULL) {
return TCL_ERROR;
}
return TCL_OK;
@@ -1343,7 +1365,7 @@ Tcl_ForCmd(dummy, interp, argc, argv)
if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
if (result == TCL_ERROR) {
char msg[60];
- sprintf(msg, "\n (\"for\" body line %d)", interp->errorLine);
+ sprintf(msg, "\n (\"for\" body line %d)",interp->errorLine);
Tcl_AddErrorInfo(interp, msg);
}
break;
@@ -1398,13 +1420,24 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv)
int v; /* v selects a loop variable */
int numLists; /* Count of value lists */
Tcl_Obj *bodyPtr;
-
-#define STATIC_SIZE 4
- int indexArray[STATIC_SIZE]; /* Array of value list indices */
- int varcListArray[STATIC_SIZE]; /* # loop variables per list */
- Tcl_Obj **varvListArray[STATIC_SIZE]; /* Array of variable name lists */
- int argcListArray[STATIC_SIZE]; /* Array of value list sizes */
- Tcl_Obj **argvListArray[STATIC_SIZE]; /* Array of value lists */
+
+ /*
+ * We copy the argument object pointers into a local array to avoid
+ * the problem that "objv" might become invalid. It is a pointer into
+ * the evaluation stack and that stack might be grown and reallocated
+ * if the loop body requires a large amount of stack space.
+ */
+
+#define NUM_ARGS 9
+ Tcl_Obj *(argObjStorage[NUM_ARGS]);
+ Tcl_Obj **argObjv = argObjStorage;
+
+#define STATIC_LIST_SIZE 4
+ int indexArray[STATIC_LIST_SIZE]; /* Array of value list indices */
+ int varcListArray[STATIC_LIST_SIZE]; /* # loop variables per list */
+ Tcl_Obj **varvListArray[STATIC_LIST_SIZE]; /* Array of var name lists */
+ int argcListArray[STATIC_LIST_SIZE]; /* Array of value list sizes */
+ Tcl_Obj **argvListArray[STATIC_LIST_SIZE]; /* Array of value lists */
int *index = indexArray;
int *varcList = varcListArray;
@@ -1419,6 +1452,18 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv)
}
/*
+ * Create the object argument array "argObjv". Make sure argObjv is
+ * large enough to hold the objc arguments.
+ */
+
+ if (objc > NUM_ARGS) {
+ argObjv = (Tcl_Obj **) ckalloc(objc * sizeof(Tcl_Obj *));
+ }
+ for (i = 0; i < objc; i++) {
+ argObjv[i] = objv[i];
+ }
+
+ /*
* Manage numList parallel value lists.
* argvList[i] is a value list counted by argcList[i]
* varvList[i] is the list of variables associated with the value list
@@ -1427,7 +1472,7 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv)
*/
numLists = (objc-2)/2;
- if (numLists > STATIC_SIZE) {
+ if (numLists > STATIC_LIST_SIZE) {
index = (int *) ckalloc(numLists * sizeof(int));
varcList = (int *) ckalloc(numLists * sizeof(int));
varvList = (Tcl_Obj ***) ckalloc(numLists * sizeof(Tcl_Obj **));
@@ -1449,7 +1494,7 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv)
maxj = 0;
for (i = 0; i < numLists; i++) {
- result = Tcl_ListObjGetElements(interp, objv[1+i*2],
+ result = Tcl_ListObjGetElements(interp, argObjv[1+i*2],
&varcList[i], &varvList[i]);
if (result != TCL_OK) {
goto done;
@@ -1461,7 +1506,7 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv)
goto done;
}
- result = Tcl_ListObjGetElements(interp, objv[2+i*2],
+ result = Tcl_ListObjGetElements(interp, argObjv[2+i*2],
&argcList[i], &argvList[i]);
if (result != TCL_OK) {
goto done;
@@ -1481,9 +1526,30 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv)
* If some value lists run out of values, set loop vars to ""
*/
- bodyPtr = objv[objc-1];
+ bodyPtr = argObjv[objc-1];
for (j = 0; j < maxj; j++) {
for (i = 0; i < numLists; i++) {
+ /*
+ * If a variable or value list object has been converted to
+ * another kind of Tcl object, convert it back to a list object
+ * and refetch the pointer to its element array.
+ */
+
+ if (argObjv[1+i*2]->typePtr != &tclListType) {
+ result = Tcl_ListObjGetElements(interp, argObjv[1+i*2],
+ &varcList[i], &varvList[i]);
+ if (result != TCL_OK) {
+ panic("Tcl_ForeachObjCmd: could not reconvert variable list %d to a list object\n", i);
+ }
+ }
+ if (argObjv[2+i*2]->typePtr != &tclListType) {
+ result = Tcl_ListObjGetElements(interp, argObjv[2+i*2],
+ &argcList[i], &argvList[i]);
+ if (result != TCL_OK) {
+ panic("Tcl_ForeachObjCmd: could not reconvert value list %d to a list object\n", i);
+ }
+ }
+
for (v = 0; v < varcList[i]; v++) {
int k = index[i]++;
Tcl_Obj *valuePtr, *varValuePtr;
@@ -1536,21 +1602,25 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv)
}
done:
- if (numLists > STATIC_SIZE) {
+ if (numLists > STATIC_LIST_SIZE) {
ckfree((char *) index);
ckfree((char *) varcList);
ckfree((char *) argcList);
ckfree((char *) varvList);
ckfree((char *) argvList);
}
+ if (argObjv != argObjStorage) {
+ ckfree((char *) argObjv);
+ }
return result;
-#undef STATIC_SIZE
+#undef STATIC_LIST_SIZE
+#undef NUM_ARGS
}
/*
*----------------------------------------------------------------------
*
- * Tcl_FormatCmd --
+ * Tcl_FormatObjCmd --
*
* This procedure is invoked to process the "format" Tcl command.
* See the user documentation for details on what it does.
@@ -1566,14 +1636,16 @@ Tcl_ForeachObjCmd(dummy, interp, objc, objv)
/* ARGSUSED */
int
-Tcl_FormatCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+Tcl_FormatObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
register char *format; /* Used to read characters from the format
* string. */
+ int formatLen; /* The length of the format string */
+ char *endPtr; /* Points to the last char in format array */
char newFormat[40]; /* A new format specifier is generated here. */
int width; /* Field width from field specifier, or 0 if
* no width given. */
@@ -1595,17 +1667,19 @@ Tcl_FormatCmd(dummy, interp, argc, argv)
# define INT_VALUE 0
# define PTR_VALUE 1
# define DOUBLE_VALUE 2
- char *dst = interp->result; /* Where result is stored. Starts off at
- * interp->resultSpace, but may get dynamically
- * re-allocated if this isn't enough. */
- int dstSize = 0; /* Number of non-null characters currently
- * stored at dst. */
- int dstSpace = TCL_RESULT_SIZE;
- /* Total amount of storage space available
- * in dst (not including null terminator. */
+# define MAX_FLOAT_SIZE 320
+
+ Tcl_Obj *resultPtr; /* Where result is stored finally. */
+ char staticBuf[MAX_FLOAT_SIZE];
+ /* A static buffer to copy the format results
+ * into */
+ char *dst = staticBuf; /* The buffer that sprintf writes into each
+ * time the format processes a specifier */
+ int dstSize = MAX_FLOAT_SIZE;
+ /* The size of the dst buffer */
int noPercent; /* Special case for speed: indicates there's
- * no field specifier, just a string to copy. */
- int argIndex; /* Index of argument to substitute next. */
+ * no field specifier, just a string to copy.*/
+ int objIndex; /* Index of argument to substitute next. */
int gotXpg = 0; /* Non-zero means that an XPG3 %n$-style
* specifier has been seen. */
int gotSequential = 0; /* Non-zero means that a regular sequential
@@ -1620,20 +1694,25 @@ Tcl_FormatCmd(dummy, interp, argc, argv)
* 1. this procedure can't trust its arguments.
* 2. we must be able to provide a large enough result area to hold
* whatever's generated. This is hard to estimate.
- * 2. there's no way to move the arguments from argv to the call
+ * 2. there's no way to move the arguments from objv to the call
* to sprintf in a reasonable way. This is particularly nasty
* because some of the arguments may be two-word values (doubles).
* So, what happens here is to scan the format string one % group
* at a time, making many individual calls to sprintf.
*/
- if (argc < 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " formatString ?arg arg ...?\"", (char *) NULL);
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "formatString ?arg arg ...?");
return TCL_ERROR;
}
- argIndex = 2;
- for (format = argv[1]; *format != 0; ) {
+
+ format = Tcl_GetStringFromObj(objv[1], &formatLen);
+ endPtr = format + formatLen;
+ resultPtr = Tcl_NewObj();
+ objIndex = 2;
+
+ while (format < endPtr) {
register char *newPtr = newFormat;
width = precision = noPercent = useShort = 0;
@@ -1642,17 +1721,12 @@ Tcl_FormatCmd(dummy, interp, argc, argv)
/*
* Get rid of any characters before the next field specifier.
*/
-
if (*format != '%') {
- register char *p;
-
- ptrValue = p = format;
- while ((*format != '%') && (*format != 0)) {
- *p = *format;
- p++;
+ ptrValue = format;
+ while ((*format != '%') && (format < endPtr)) {
format++;
}
- size = p - ptrValue;
+ size = format - ptrValue;
noPercent = 1;
goto doField;
}
@@ -1670,7 +1744,6 @@ Tcl_FormatCmd(dummy, interp, argc, argv)
* will be needed to store the result, and substitute for
* "*" size specifiers.
*/
-
*newPtr = '%';
newPtr++;
format++;
@@ -1692,8 +1765,8 @@ Tcl_FormatCmd(dummy, interp, argc, argv)
if (gotSequential) {
goto mixedXPG;
}
- argIndex = tmp+1;
- if ((argIndex < 2) || (argIndex >= argc)) {
+ objIndex = tmp+1;
+ if ((objIndex < 2) || (objIndex >= objc)) {
goto badIndex;
}
goto xpgCheckDone;
@@ -1716,13 +1789,14 @@ Tcl_FormatCmd(dummy, interp, argc, argv)
width = strtoul(format, &end, 10);
format = end;
} else if (*format == '*') {
- if (argIndex >= argc) {
+ if (objIndex >= objc) {
goto badIndex;
}
- if (Tcl_GetInt(interp, argv[argIndex], &width) != TCL_OK) {
+ if (Tcl_GetIntFromObj(interp, objv[objIndex],
+ &width) != TCL_OK) {
goto fmtError;
}
- argIndex++;
+ objIndex++;
format++;
}
if (width > 100000) {
@@ -1751,13 +1825,14 @@ Tcl_FormatCmd(dummy, interp, argc, argv)
precision = strtoul(format, &end, 10);
format = end;
} else if (*format == '*') {
- if (argIndex >= argc) {
+ if (objIndex >= objc) {
goto badIndex;
}
- if (Tcl_GetInt(interp, argv[argIndex], &precision) != TCL_OK) {
+ if (Tcl_GetIntFromObj(interp, objv[objIndex],
+ &precision) != TCL_OK) {
goto fmtError;
}
- argIndex++;
+ objIndex++;
format++;
}
if (precision != 0) {
@@ -1777,7 +1852,7 @@ Tcl_FormatCmd(dummy, interp, argc, argv)
*newPtr = *format;
newPtr++;
*newPtr = 0;
- if (argIndex >= argc) {
+ if (objIndex >= objc) {
goto badIndex;
}
switch (*format) {
@@ -1788,20 +1863,19 @@ Tcl_FormatCmd(dummy, interp, argc, argv)
case 'u':
case 'x':
case 'X':
- if (Tcl_GetInt(interp, argv[argIndex], (int *) &intValue)
- != TCL_OK) {
+ if (Tcl_GetIntFromObj(interp, objv[objIndex],
+ (int *) &intValue) != TCL_OK) {
goto fmtError;
}
whichValue = INT_VALUE;
size = 40 + precision;
break;
case 's':
- ptrValue = argv[argIndex];
- size = strlen(argv[argIndex]);
+ ptrValue = Tcl_GetStringFromObj(objv[objIndex], &size);
break;
case 'c':
- if (Tcl_GetInt(interp, argv[argIndex], (int *) &intValue)
- != TCL_OK) {
+ if (Tcl_GetIntFromObj(interp, objv[objIndex],
+ (int *) &intValue) != TCL_OK) {
goto fmtError;
}
whichValue = INT_VALUE;
@@ -1812,12 +1886,12 @@ Tcl_FormatCmd(dummy, interp, argc, argv)
case 'f':
case 'g':
case 'G':
- if (Tcl_GetDouble(interp, argv[argIndex], &doubleValue)
- != TCL_OK) {
+ if (Tcl_GetDoubleFromObj(interp, objv[objIndex],
+ &doubleValue) != TCL_OK) {
goto fmtError;
}
whichValue = DOUBLE_VALUE;
- size = 320;
+ size = MAX_FLOAT_SIZE;
if (precision > 10) {
size += precision;
}
@@ -1829,14 +1903,13 @@ Tcl_FormatCmd(dummy, interp, argc, argv)
goto fmtError;
default:
{
- char buf[80];
-
+ char buf[40];
sprintf(buf, "bad field specifier \"%c\"", *format);
Tcl_SetResult(interp, buf, TCL_VOLATILE);
goto fmtError;
}
}
- argIndex++;
+ objIndex++;
format++;
/*
@@ -1848,62 +1921,56 @@ Tcl_FormatCmd(dummy, interp, argc, argv)
if (width > size) {
size = width;
}
- if ((dstSize + size) > dstSpace) {
- char *newDst;
- int newSpace;
-
- newSpace = 2*(dstSize + size);
- newDst = (char *) ckalloc((unsigned) newSpace+1);
- if (dstSize != 0) {
- memcpy((VOID *) newDst, (VOID *) dst, (size_t) dstSize);
- }
- if (dstSpace != TCL_RESULT_SIZE) {
- ckfree(dst);
- }
- dst = newDst;
- dstSpace = newSpace;
- }
if (noPercent) {
- memcpy((VOID *) (dst+dstSize), (VOID *) ptrValue, (size_t) size);
- dstSize += size;
- dst[dstSize] = 0;
+ Tcl_AppendToObj(resultPtr, ptrValue, size);
} else {
+ if (size > dstSize) {
+ if (dst != staticBuf) {
+ ckfree(dst);
+ }
+ dst = (char *) ckalloc((unsigned) (size + 1));
+ dstSize = size;
+ }
+
if (whichValue == DOUBLE_VALUE) {
- sprintf(dst+dstSize, newFormat, doubleValue);
+ sprintf(dst, newFormat, doubleValue);
} else if (whichValue == INT_VALUE) {
if (useShort) {
- sprintf(dst+dstSize, newFormat, (short) intValue);
+ sprintf(dst, newFormat, (short) intValue);
} else {
- sprintf(dst+dstSize, newFormat, intValue);
+ sprintf(dst, newFormat, intValue);
}
} else {
- sprintf(dst+dstSize, newFormat, ptrValue);
+ sprintf(dst, newFormat, ptrValue);
}
- dstSize += strlen(dst+dstSize);
+ Tcl_AppendToObj(resultPtr, dst, -1);
}
}
- if (dstSpace != TCL_RESULT_SIZE) {
- Tcl_SetResult(interp, dst, TCL_DYNAMIC);
- } else {
- Tcl_SetResult(interp, dst, TCL_STATIC);
+ Tcl_SetObjResult(interp, resultPtr);
+ if(dst != staticBuf) {
+ ckfree(dst);
}
return TCL_OK;
mixedXPG:
- interp->result = "cannot mix \"%\" and \"%n$\" conversion specifiers";
+ Tcl_SetResult(interp,
+ "cannot mix \"%\" and \"%n$\" conversion specifiers", TCL_STATIC);
goto fmtError;
badIndex:
if (gotXpg) {
- interp->result = "\"%n$\" argument index out of range";
+ Tcl_SetResult(interp,
+ "\"%n$\" argument index out of range", TCL_STATIC);
} else {
- interp->result = "not enough arguments for all format specifiers";
+ Tcl_SetResult(interp,
+ "not enough arguments for all format specifiers", TCL_STATIC);
}
fmtError:
- if (dstSpace != TCL_RESULT_SIZE) {
- ckfree(dst);
+ if(dst != staticBuf) {
+ ckfree(dst);
}
+ Tcl_DecrRefCount(resultPtr);
return TCL_ERROR;
}
diff --git a/contrib/tcl/generic/tclCmdIL.c b/contrib/tcl/generic/tclCmdIL.c
index 18342f37ab48..6503d351b5ac 100644
--- a/contrib/tcl/generic/tclCmdIL.c
+++ b/contrib/tcl/generic/tclCmdIL.c
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclCmdIL.c 1.163 97/06/13 18:16:52
+ * SCCS: @(#) tclCmdIL.c 1.168 97/07/29 12:52:40
*/
#include "tclInt.h"
@@ -55,7 +55,7 @@ typedef struct SortInfo {
Tcl_DString compareCmd; /* The Tcl comparison command when sortMode
* is SORTMODE_COMMAND. Pre-initialized to
* hold base of command.*/
- long index; /* If the -index option was specified, this
+ int index; /* If the -index option was specified, this
* holds the index of the list element
* to extract for comparison. If -index
* wasn't specified, this is -1. */
@@ -472,7 +472,7 @@ InfoArgsCmd(dummy, interp, objc, objv)
Tcl_Obj *listObjPtr;
if (objc != 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "args procname");
+ Tcl_WrongNumArgs(interp, 2, objv, "procname");
return TCL_ERROR;
}
@@ -532,7 +532,7 @@ InfoBodyCmd(dummy, interp, objc, objv)
Proc *procPtr;
if (objc != 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "body procname");
+ Tcl_WrongNumArgs(interp, 2, objv, "procname");
return TCL_ERROR;
}
@@ -578,7 +578,7 @@ InfoCmdCountCmd(dummy, interp, objc, objv)
Interp *iPtr = (Interp *) interp;
if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "cmdcount");
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
@@ -659,7 +659,7 @@ InfoCommandsCmd(dummy, interp, objc, objv)
specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
}
} else {
- Tcl_WrongNumArgs(interp, 1, objv, "commands ?pattern?");
+ Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
return TCL_ERROR;
}
@@ -749,7 +749,7 @@ InfoCompleteCmd(dummy, interp, objc, objv)
char *command;
if (objc != 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "complete command");
+ Tcl_WrongNumArgs(interp, 2, objv, "command");
return TCL_ERROR;
}
@@ -797,7 +797,7 @@ InfoDefaultCmd(dummy, interp, objc, objv)
Tcl_Obj *valueObjPtr;
if (objc != 5) {
- Tcl_WrongNumArgs(interp, 1, objv, "default procname arg varname");
+ Tcl_WrongNumArgs(interp, 2, objv, "procname arg varname");
return TCL_ERROR;
}
@@ -877,7 +877,7 @@ InfoExistsCmd(dummy, interp, objc, objv)
Var *varPtr, *arrayPtr;
if (objc != 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "exists varName");
+ Tcl_WrongNumArgs(interp, 2, objv, "varName");
return TCL_ERROR;
}
@@ -933,7 +933,7 @@ InfoGlobalsCmd(dummy, interp, objc, objv)
} else if (objc == 3) {
pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
} else {
- Tcl_WrongNumArgs(interp, 1, objv, "globals ?pattern?");
+ Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
return TCL_ERROR;
}
@@ -988,7 +988,7 @@ InfoHostnameCmd(dummy, interp, objc, objv)
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "hostname");
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
@@ -1065,7 +1065,7 @@ InfoLevelCmd(dummy, interp, objc, objv)
return TCL_OK;
}
- Tcl_WrongNumArgs(interp, 1, objv, "level ?number?");
+ Tcl_WrongNumArgs(interp, 2, objv, "?number?");
return TCL_ERROR;
}
@@ -1100,7 +1100,7 @@ InfoLibraryCmd(dummy, interp, objc, objv)
char *libDirName;
if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "library");
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
@@ -1146,7 +1146,7 @@ InfoLoadedCmd(dummy, interp, objc, objv)
int result;
if ((objc != 2) && (objc != 3)) {
- Tcl_WrongNumArgs(interp, 1, objv, "loaded ?interp?");
+ Tcl_WrongNumArgs(interp, 2, objv, "?interp?");
return TCL_ERROR;
}
@@ -1201,7 +1201,7 @@ InfoLocalsCmd(dummy, interp, objc, objv)
} else if (objc == 3) {
pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
} else {
- Tcl_WrongNumArgs(interp, 1, objv, "locals ?pattern?");
+ Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
return TCL_ERROR;
}
@@ -1280,7 +1280,7 @@ InfoNameOfExecutableCmd(dummy, interp, objc, objv)
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "nameofexecutable");
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
@@ -1321,7 +1321,7 @@ InfoPatchLevelCmd(dummy, interp, objc, objv)
char *patchlevel;
if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "patchlevel");
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
@@ -1374,7 +1374,7 @@ InfoProcsCmd(dummy, interp, objc, objv)
} else if (objc == 3) {
pattern = Tcl_GetStringFromObj(objv[2], (int *) NULL);
} else {
- Tcl_WrongNumArgs(interp, 1, objv, "procs ?pattern?");
+ Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
return TCL_ERROR;
}
@@ -1430,7 +1430,7 @@ InfoScriptCmd(dummy, interp, objc, objv)
{
Interp *iPtr = (Interp *) interp;
if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "script");
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
@@ -1469,7 +1469,7 @@ InfoSharedlibCmd(dummy, interp, objc, objv)
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "sharedlibextension");
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
@@ -1509,7 +1509,7 @@ InfoTclVersionCmd(dummy, interp, objc, objv)
char *version;
if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "tclversion");
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
@@ -1597,7 +1597,7 @@ InfoVarsCmd(dummy, interp, objc, objv)
specificNsInPattern = (strcmp(simplePattern, pattern) != 0);
}
} else {
- Tcl_WrongNumArgs(interp, 1, objv, "vars ?pattern?");
+ Tcl_WrongNumArgs(interp, 2, objv, "?pattern?");
return TCL_ERROR;
}
@@ -1624,7 +1624,8 @@ InfoVarsCmd(dummy, interp, objc, objv)
entryPtr = Tcl_FirstHashEntry(&nsPtr->varTable, &search);
while (entryPtr != NULL) {
varPtr = (Var *) Tcl_GetHashValue(entryPtr);
- if (!TclIsVarUndefined(varPtr)) {
+ if (!TclIsVarUndefined(varPtr)
+ || (varPtr->flags & VAR_NAMESPACE_VAR)) {
varName = Tcl_GetHashKey(&nsPtr->varTable, entryPtr);
if ((simplePattern == NULL)
|| Tcl_StringMatch(varName, simplePattern)) {
@@ -1654,7 +1655,8 @@ InfoVarsCmd(dummy, interp, objc, objv)
entryPtr = Tcl_FirstHashEntry(&globalNsPtr->varTable, &search);
while (entryPtr != NULL) {
varPtr = (Var *) Tcl_GetHashValue(entryPtr);
- if (!TclIsVarUndefined(varPtr)) {
+ if (!TclIsVarUndefined(varPtr)
+ || (varPtr->flags & VAR_NAMESPACE_VAR)) {
varName = Tcl_GetHashKey(&globalNsPtr->varTable,
entryPtr);
if ((simplePattern == NULL)
@@ -2426,14 +2428,9 @@ Tcl_LsortObjCmd(clientData, interp, objc, objv)
-1);
return TCL_ERROR;
}
- if (Tcl_GetLongFromObj(interp, objv[i+1], &sortInfo.index)
+ if (TclGetIntForIndex(interp, objv[i+1], -2, &sortInfo.index)
!= TCL_OK) {
- if (strcmp("end", Tcl_GetStringFromObj(objv[i+1], &dummy))
- == 0) {
- sortInfo.index = -2;
- } else {
- return TCL_ERROR;
- }
+ return TCL_ERROR;
}
cmdPtr = objv[i+1];
i++;
@@ -2675,7 +2672,7 @@ SortCompare(objPtr1, objPtr2, infoPtr)
if (objPtr == NULL) {
objPtr = objPtr1;
missingElement:
- sprintf(buffer, "%ld", infoPtr->index);
+ sprintf(buffer, "%d", infoPtr->index);
Tcl_AppendStringsToObj(Tcl_GetObjResult(infoPtr->interp),
"element ", buffer, " missing from sublist \"",
Tcl_GetStringFromObj(objPtr, (int *) NULL),
diff --git a/contrib/tcl/generic/tclCmdMZ.c b/contrib/tcl/generic/tclCmdMZ.c
index ec1f737dce4a..9ab2c826a656 100644
--- a/contrib/tcl/generic/tclCmdMZ.c
+++ b/contrib/tcl/generic/tclCmdMZ.c
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclCmdMZ.c 1.99 97/05/19 17:37:17
+ * SCCS: @(#) tclCmdMZ.c 1.102 97/08/13 10:06:58
*/
#include "tclInt.h"
@@ -953,7 +953,7 @@ Tcl_SourceObjCmd(dummy, interp, objc, objv)
/*
*----------------------------------------------------------------------
*
- * Tcl_SplitCmd --
+ * Tcl_SplitObjCmd --
*
* This procedure is invoked to process the "split" Tcl command.
* See the user documentation for details on what it does.
@@ -969,60 +969,63 @@ Tcl_SourceObjCmd(dummy, interp, objc, objv)
/* ARGSUSED */
int
-Tcl_SplitCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+Tcl_SplitObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
- char *splitChars;
register char *p, *p2;
- char *elementStart;
+ char *splitChars, *string, *elementStart;
+ int splitCharLen, stringLen, i, j;
+ Tcl_Obj *listPtr;
- if (argc == 2) {
+ if (objc == 2) {
splitChars = " \n\t\r";
- } else if (argc == 3) {
- splitChars = argv[2];
+ splitCharLen = 4;
+ } else if (objc == 3) {
+ splitChars = Tcl_GetStringFromObj(objv[2], &splitCharLen);
} else {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " string ?splitChars?\"", (char *) NULL);
+ Tcl_WrongNumArgs(interp, 1, objv, "string ?splitChars?");
return TCL_ERROR;
}
+ string = Tcl_GetStringFromObj(objv[1], &stringLen);
+ listPtr = Tcl_NewListObj(0, (Tcl_Obj **) NULL);
+
/*
* Handle the special case of splitting on every character.
*/
- if (*splitChars == 0) {
- char string[2];
- string[1] = 0;
- for (p = argv[1]; *p != 0; p++) {
- string[0] = *p;
- Tcl_AppendElement(interp, string);
+ if (splitCharLen == 0) {
+ for (i = 0, p = string; i < stringLen; i++, p++) {
+ Tcl_ListObjAppendElement(interp, listPtr,
+ Tcl_NewStringObj(p, 1));
}
- return TCL_OK;
- }
-
- /*
- * Normal case: split on any of a given set of characters.
- * Discard instances of the split characters.
- */
+ } else {
+ /*
+ * Normal case: split on any of a given set of characters.
+ * Discard instances of the split characters.
+ */
- for (p = elementStart = argv[1]; *p != 0; p++) {
- char c = *p;
- for (p2 = splitChars; *p2 != 0; p2++) {
- if (*p2 == c) {
- *p = 0;
- Tcl_AppendElement(interp, elementStart);
- *p = c;
- elementStart = p+1;
- break;
+ for (i = 0, p = elementStart = string; i < stringLen; i++, p++) {
+ for (j = 0, p2 = splitChars; j < splitCharLen; j++, p2++) {
+ if (*p2 == *p) {
+ Tcl_ListObjAppendElement(interp, listPtr,
+ Tcl_NewStringObj(elementStart, (p-elementStart)));
+ elementStart = p+1;
+ break;
+ }
}
}
+ if (p != string) {
+ int remainingChars = stringLen - (elementStart-string);
+ Tcl_ListObjAppendElement(interp, listPtr,
+ Tcl_NewStringObj(elementStart, remainingChars));
+ }
}
- if (p != argv[1]) {
- Tcl_AppendElement(interp, elementStart);
- }
+
+ Tcl_SetObjResult(interp, listPtr);
return TCL_OK;
}
@@ -1132,15 +1135,17 @@ Tcl_StringObjCmd(dummy, interp, objc, objv)
return TCL_ERROR;
}
+ match = -1;
string1 = Tcl_GetStringFromObj(objv[2], &length1);
string2 = Tcl_GetStringFromObj(objv[3], &length2);
- match = -1;
- end = string2 + length2 - length1 + 1;
- for (p = string2; p < end; p++) {
- if (memcmp(string1, p, (unsigned) length1) == 0) {
- match = p - string2;
- if (first) {
- break;
+ if (length1 > 0) {
+ end = string2 + length2 - length1 + 1;
+ for (p = string2; p < end; p++) {
+ if (memcmp(string1, p, (unsigned) length1) == 0) {
+ match = p - string2;
+ if (first) {
+ break;
+ }
}
}
}
@@ -2066,7 +2071,7 @@ TraceVarProc(clientData, interp, name1, name2, flags)
oldObjResultPtr = iPtr->objResultPtr;
iPtr->objResultPtr = saveObjPtr; /* was incremented above */
- TclDecrRefCount(oldObjResultPtr);
+ Tcl_DecrRefCount(oldObjResultPtr);
Tcl_DecrRefCount(dummy.objResultPtr);
dummy.objResultPtr = NULL;
diff --git a/contrib/tcl/generic/tclCompExpr.c b/contrib/tcl/generic/tclCompExpr.c
index 4113879122a5..74b12c171e6f 100644
--- a/contrib/tcl/generic/tclCompExpr.c
+++ b/contrib/tcl/generic/tclCompExpr.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclCompExpr.c 1.30 97/06/13 18:17:20
+ * SCCS: @(#) tclCompExpr.c 1.31 97/08/07 10:14:07
*/
#include "tclInt.h"
@@ -69,7 +69,14 @@ typedef struct ExprInfo {
* primary to a number if possible. */
int exprIsJustVarRef; /* Set 1 if the expr consists of just a
* variable reference as in the expression
- * of "if $b then...". Otherwise 0. Used
+ * of "if $b then...". Otherwise 0. If 1 the
+ * expr is compiled out-of-line in order to
+ * implement expr's 2 level substitution
+ * semantics properly. */
+ int exprIsComparison; /* Set 1 if the top-level operator in the
+ * expr is a comparison. Otherwise 0. If 1,
+ * because the operands might be strings,
+ * the expr is compiled out-of-line in order
* to implement expr's 2 level substitution
* semantics properly. */
} ExprInfo;
@@ -242,6 +249,11 @@ static int GetToken _ANSI_ARGS_((Tcl_Interp *interp,
* Otherwise it is set 0. This is used to implement Tcl's two level
* expression substitution semantics properly.
*
+ * envPtr->exprIsComparison is set 1 if the top-level operator in the
+ * expr is a comparison. Otherwise it is set 0. If 1, because the
+ * operands might be strings, the expr is compiled out-of-line in order
+ * to implement expr's 2 level substitution semantics properly.
+ *
* Side effects:
* Adds instructions to envPtr to evaluate the expression at runtime.
*
@@ -307,6 +319,7 @@ TclCompileExpr(interp, string, lastChar, flags, envPtr)
info.lastChar = lastChar;
info.hasOperators = 0;
info.exprIsJustVarRef = 1; /* will be set 0 if anything else is seen */
+ info.exprIsComparison = 0; /* set 1 if topmost operator is <,==,etc. */
/*
* Get the first token then compile an expression.
@@ -343,6 +356,7 @@ TclCompileExpr(interp, string, lastChar, flags, envPtr)
envPtr->termOffset = (info.next - string);
envPtr->maxStackDepth = maxDepth;
envPtr->exprIsJustVarRef = info.exprIsJustVarRef;
+ envPtr->exprIsComparison = info.exprIsComparison;
return result;
}
@@ -424,6 +438,7 @@ CompileCondExpr(interp, infoPtr, flags, envPtr)
infoPtr->hasOperators = 0;
infoPtr->exprIsJustVarRef = 0;
+ infoPtr->exprIsComparison = 0;
result = CompileCondExpr(interp, infoPtr, flags, envPtr);
if (result != TCL_OK) {
goto done;
@@ -495,6 +510,12 @@ CompileCondExpr(interp, infoPtr, flags, envPtr)
TclFixupForwardJump(envPtr, &jumpAroundThenFixup, jumpDist, 127);
infoPtr->hasOperators = 1;
+
+ /*
+ * A comparison is not the top-level operator in this expression.
+ */
+
+ infoPtr->exprIsComparison = 0;
}
done:
@@ -658,7 +679,12 @@ CompileLorExpr(interp, infoPtr, flags, envPtr)
TclFixupForwardJump(envPtr, &(jumpFixupArray.fixup[fixupIndex]), jumpDist, 127);
}
+ /*
+ * We get here only if one or more ||'s appear as top-level operators.
+ */
+
done:
+ infoPtr->exprIsComparison = 0;
TclFreeJumpFixupArray(&jumpFixupArray);
envPtr->maxStackDepth = maxDepth;
return result;
@@ -817,10 +843,16 @@ CompileLandExpr(interp, infoPtr, flags, envPtr)
fixupIndex = (j - 1); /* process closest jump first */
currCodeOffset = TclCurrCodeOffset();
jumpDist = (currCodeOffset - jumpFixupArray.fixup[fixupIndex].codeOffset);
- TclFixupForwardJump(envPtr, &(jumpFixupArray.fixup[fixupIndex]), jumpDist, 127);
+ TclFixupForwardJump(envPtr, &(jumpFixupArray.fixup[fixupIndex]),
+ jumpDist, 127);
}
+ /*
+ * We get here only if one or more &&'s appear as top-level operators.
+ */
+
done:
+ infoPtr->exprIsComparison = 0;
TclFreeJumpFixupArray(&jumpFixupArray);
envPtr->maxStackDepth = maxDepth;
return result;
@@ -883,6 +915,12 @@ CompileBitOrExpr(interp, infoPtr, flags, envPtr)
maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
TclEmitOpcode(INST_BITOR, envPtr);
+
+ /*
+ * A comparison is not the top-level operator in this expression.
+ */
+
+ infoPtr->exprIsComparison = 0;
}
done:
@@ -947,6 +985,12 @@ CompileBitXorExpr(interp, infoPtr, flags, envPtr)
maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
TclEmitOpcode(INST_BITXOR, envPtr);
+
+ /*
+ * A comparison is not the top-level operator in this expression.
+ */
+
+ infoPtr->exprIsComparison = 0;
}
done:
@@ -1011,6 +1055,12 @@ CompileBitAndExpr(interp, infoPtr, flags, envPtr)
maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
TclEmitOpcode(INST_BITAND, envPtr);
+
+ /*
+ * A comparison is not the top-level operator in this expression.
+ */
+
+ infoPtr->exprIsComparison = 0;
}
done:
@@ -1082,6 +1132,12 @@ CompileEqualityExpr(interp, infoPtr, flags, envPtr)
}
op = infoPtr->token;
+
+ /*
+ * A comparison _is_ the top-level operator in this expression.
+ */
+
+ infoPtr->exprIsComparison = 1;
}
done:
@@ -1162,6 +1218,12 @@ CompileRelationalExpr(interp, infoPtr, flags, envPtr)
}
op = infoPtr->token;
+
+ /*
+ * A comparison _is_ the top-level operator in this expression.
+ */
+
+ infoPtr->exprIsComparison = 1;
}
done:
@@ -1233,6 +1295,12 @@ CompileShiftExpr(interp, infoPtr, flags, envPtr)
}
op = infoPtr->token;
+
+ /*
+ * A comparison is not the top-level operator in this expression.
+ */
+
+ infoPtr->exprIsComparison = 0;
}
done:
@@ -1304,6 +1372,12 @@ CompileAddExpr(interp, infoPtr, flags, envPtr)
}
op = infoPtr->token;
+
+ /*
+ * A comparison is not the top-level operator in this expression.
+ */
+
+ infoPtr->exprIsComparison = 0;
}
done:
@@ -1377,6 +1451,12 @@ CompileMultiplyExpr(interp, infoPtr, flags, envPtr)
}
op = infoPtr->token;
+
+ /*
+ * A comparison is not the top-level operator in this expression.
+ */
+
+ infoPtr->exprIsComparison = 0;
}
done:
@@ -1449,6 +1529,12 @@ CompileUnaryExpr(interp, infoPtr, flags, envPtr)
TclEmitOpcode(INST_LNOT, envPtr);
break;
}
+
+ /*
+ * A comparison is not the top-level operator in this expression.
+ */
+
+ infoPtr->exprIsComparison = 0;
} else { /* must be a primaryExpr */
result = CompilePrimaryExpr(interp, infoPtr, flags, envPtr);
if (result != TCL_OK) {
@@ -1583,6 +1669,7 @@ CompilePrimaryExpr(interp, infoPtr, flags, envPtr)
if (result != TCL_OK) {
goto done;
}
+ infoPtr->exprIsComparison = 0;
result = CompileCondExpr(interp, infoPtr, flags, envPtr);
if (result != TCL_OK) {
goto done;
@@ -1722,6 +1809,7 @@ CompileMathFuncCall(interp, infoPtr, flags, envPtr)
if (mathFuncPtr->numArgs > 0) {
for (i = 0; ; i++) {
+ infoPtr->exprIsComparison = 0;
result = CompileCondExpr(interp, infoPtr, flags, envPtr);
if (result != TCL_OK) {
goto done;
@@ -1785,7 +1873,12 @@ CompileMathFuncCall(interp, infoPtr, flags, envPtr)
TclEmitInstUInt1(INST_CALL_FUNC1, (mathFuncPtr->numArgs+1), envPtr);
}
+ /*
+ * A comparison is not the top-level operator in this expression.
+ */
+
done:
+ infoPtr->exprIsComparison = 0;
envPtr->maxStackDepth = maxDepth;
return result;
diff --git a/contrib/tcl/generic/tclCompile.c b/contrib/tcl/generic/tclCompile.c
index e8aa99cc747a..d4fad0c74c7d 100644
--- a/contrib/tcl/generic/tclCompile.c
+++ b/contrib/tcl/generic/tclCompile.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclCompile.c 1.61 97/06/23 18:43:46
+ * SCCS: @(#) tclCompile.c 1.76 97/08/12 13:35:43
*/
#include "tclInt.h"
@@ -29,11 +29,26 @@ int tclTraceCompile = 0;
static int traceInitialized = 0;
/*
- * Count of the number of compilations.
+ * Count of the number of compilations and various other compilation-
+ * related statistics.
*/
#ifdef TCL_COMPILE_STATS
long tclNumCompilations = 0;
+double tclTotalSourceBytes = 0.0;
+double tclTotalCodeBytes = 0.0;
+
+double tclTotalInstBytes = 0.0;
+double tclTotalObjBytes = 0.0;
+double tclTotalExceptBytes = 0.0;
+double tclTotalAuxBytes = 0.0;
+double tclTotalCmdMapBytes = 0.0;
+
+double tclCurrentSourceBytes = 0.0;
+double tclCurrentCodeBytes = 0.0;
+
+int tclSourceCount[32];
+int tclByteCodeCount[32];
#endif /* TCL_COMPILE_STATS */
/*
@@ -365,6 +380,9 @@ static int CreateExceptionRange _ANSI_ARGS_((
static void DupByteCodeInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr));
static ClientData DupForeachInfo _ANSI_ARGS_((ClientData clientData));
+static unsigned char * EncodeCmdLocMap _ANSI_ARGS_((
+ CompileEnv *envPtr, ByteCode *codePtr,
+ unsigned char *startPtr));
static void EnterCmdExtentData _ANSI_ARGS_((
CompileEnv *envPtr, int cmdNumber,
int numSrcChars, int numCodeBytes));
@@ -377,6 +395,8 @@ static void FreeForeachInfo _ANSI_ARGS_((
static void FreeByteCodeInternalRep _ANSI_ARGS_((
Tcl_Obj *objPtr));
static void FreeArgInfo _ANSI_ARGS_((ArgInfo *argInfoPtr));
+static int GetCmdLocEncodingSize _ANSI_ARGS_((
+ CompileEnv *envPtr));
static void InitArgInfo _ANSI_ARGS_((ArgInfo *argInfoPtr));
static int LookupCompiledLocal _ANSI_ARGS_((
char *name, int nameChars, int createIfNew,
@@ -421,12 +441,11 @@ TclPrintByteCodeObj(interp, objPtr)
Tcl_Obj *objPtr; /* The bytecode object to disassemble. */
{
ByteCode* codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
- Proc *procPtr;
- CmdLocation *mapPtr;
- ExceptionRange *excRangeArrayPtr;
- unsigned char *codeStart, *codeLimit, *pc, *start;
- int numCmds, numRanges, cmd, maxChars, i;
- char *source;
+ unsigned char *codeStart, *codeLimit, *pc;
+ unsigned char *codeDeltaNext, *codeLengthNext;
+ unsigned char *srcDeltaNext, *srcLengthNext;
+ int codeOffset, codeLen, srcOffset, srcLen;
+ int numCmds, numObjs, delta, objBytes, i;
if (codePtr->refCount <= 0) {
return; /* already freed */
@@ -434,28 +453,60 @@ TclPrintByteCodeObj(interp, objPtr)
codeStart = codePtr->codeStart;
codeLimit = (codeStart + codePtr->numCodeBytes);
- source = codePtr->source;
- procPtr = codePtr->procPtr;
- numCmds = codePtr->numCommands;
- numRanges = codePtr->numExcRanges;
- mapPtr = codePtr->cmdMapPtr;
- excRangeArrayPtr = codePtr->excRangeArrayPtr;
-
- fprintf(stdout, "\nByteCode 0x%x, ref ct %u, epoch %u, interp 0x%x, interp epoch %u\n",
+ numCmds = codePtr->numCommands;
+ numObjs = codePtr->numObjects;
+
+ objBytes = (numObjs * sizeof(Tcl_Obj));
+ for (i = 0; i < numObjs; i++) {
+ Tcl_Obj *litObjPtr = codePtr->objArrayPtr[i];
+ if (litObjPtr->bytes != NULL) {
+ objBytes += litObjPtr->length;
+ }
+ }
+
+ /*
+ * Print header lines describing the ByteCode.
+ */
+
+ fprintf(stdout, "\nByteCode 0x%x, ref ct %u, epoch %u, interp 0x%x(epoch %u)\n",
(unsigned int) codePtr, codePtr->refCount,
codePtr->compileEpoch, (unsigned int) codePtr->iPtr,
codePtr->iPtr->compileEpoch);
- if (procPtr != NULL) {
+ fprintf(stdout, " Source ");
+ TclPrintSource(stdout, codePtr->source,
+ TclMin(codePtr->numSrcChars, 70));
+ fprintf(stdout, "\n Cmds %d, chars %d, inst %d, objs %u, aux %d, stk depth %u, code/src %.2f\n",
+ numCmds, codePtr->numSrcChars, codePtr->numCodeBytes, numObjs,
+ codePtr->numAuxDataItems, codePtr->maxStackDepth,
+ (codePtr->numSrcChars?
+ ((float)codePtr->totalSize)/((float)codePtr->numSrcChars) : 0.0));
+ fprintf(stdout, " Code %d = %d(header)+%d(inst)+%d(objs)+%d(exc)+%d(aux)+%d(cmd map)\n",
+ codePtr->totalSize, sizeof(ByteCode), codePtr->numCodeBytes,
+ objBytes, (codePtr->numExcRanges * sizeof(ExceptionRange)),
+ (codePtr->numAuxDataItems * sizeof(AuxData)),
+ codePtr->numCmdLocBytes);
+
+ /*
+ * If the ByteCode is the compiled body of a Tcl procedure, print
+ * information about that procedure. Note that we don't know the
+ * procedure's name since ByteCode's can be shared among procedures.
+ */
+
+ if (codePtr->procPtr != NULL) {
+ Proc *procPtr = codePtr->procPtr;
int numCompiledLocals = procPtr->numCompiledLocals;
fprintf(stdout,
- " Proc 0x%x, ref ct=%d, %d args, %d compiled locals\n",
+ " Proc 0x%x, ref ct %d, args %d, compiled locals %d\n",
(unsigned int) procPtr, procPtr->refCount, procPtr->numArgs,
numCompiledLocals);
if (numCompiledLocals > 0) {
CompiledLocal *localPtr = procPtr->firstLocalPtr;
for (i = 0; i < numCompiledLocals; i++) {
- fprintf(stdout, " %d: frame index=%d, flags=0x%x%s%s",
- i, localPtr->frameIndex, localPtr->flags,
+ fprintf(stdout, " %d: slot %d%s%s%s%s%s",
+ i, localPtr->frameIndex,
+ ((localPtr->flags & VAR_SCALAR)? ", scalar" : ""),
+ ((localPtr->flags & VAR_ARRAY)? ", array" : ""),
+ ((localPtr->flags & VAR_LINK)? ", link" : ""),
(localPtr->isArg? ", arg" : ""),
(localPtr->isTemp? ", temp" : ""));
if (localPtr->isTemp) {
@@ -467,21 +518,43 @@ TclPrintByteCodeObj(interp, objPtr)
}
}
}
- fprintf(stdout, " Source: ");
- TclPrintSource(stdout, source, TclMin(codePtr->numSrcChars, 70));
- fprintf(stdout, "\n Chars=%d, bytes=%u, objs=%u, stk depth=%u, exc depth=%d, aux items=%d\n",
- codePtr->numSrcChars, codePtr->numCodeBytes,
- codePtr->numObjects, codePtr->maxStackDepth,
- codePtr->maxExcRangeDepth, codePtr->numAuxDataItems);
/*
+ * Print the ExceptionRange array.
+ */
+
+ if (codePtr->numExcRanges > 0) {
+ fprintf(stdout, " Exception ranges %d, depth %d:\n",
+ codePtr->numExcRanges, codePtr->maxExcRangeDepth);
+ for (i = 0; i < codePtr->numExcRanges; i++) {
+ ExceptionRange *rangePtr = &(codePtr->excRangeArrayPtr[i]);
+ fprintf(stdout, " %d: level %d, %s, pc %d-%d, ",
+ i, rangePtr->nestingLevel,
+ ((rangePtr->type == LOOP_EXCEPTION_RANGE)? "loop":"catch"),
+ rangePtr->codeOffset,
+ (rangePtr->codeOffset + rangePtr->numCodeBytes - 1));
+ switch (rangePtr->type) {
+ case LOOP_EXCEPTION_RANGE:
+ fprintf(stdout, "continue %d, break %d\n",
+ rangePtr->continueOffset, rangePtr->breakOffset);
+ break;
+ case CATCH_EXCEPTION_RANGE:
+ fprintf(stdout, "catch %d\n", rangePtr->catchOffset);
+ break;
+ default:
+ panic("TclPrintSource: unrecognized ExceptionRange type %d\n",
+ rangePtr->type);
+ }
+ }
+ }
+
+ /*
* If there were no commands (e.g., an expression or an empty string
- * was compiled), just print all instructions.
+ * was compiled), just print all instructions and return.
*/
if (numCmds == 0) {
- start = codeStart;
- pc = start;
+ pc = codeStart;
while (pc < codeLimit) {
fprintf(stdout, " ");
pc += TclPrintInstruction(codePtr, pc);
@@ -490,68 +563,128 @@ TclPrintByteCodeObj(interp, objPtr)
}
/*
- * Print table giving the source and object locations for each command.
+ * Print table showing the code offset, source offset, and source
+ * length for each command. These are encoded as a sequence of bytes.
*/
- fprintf(stdout, " Commands=%d\n", numCmds);
+ fprintf(stdout, " Commands %d:", numCmds);
+ codeDeltaNext = codePtr->codeDeltaStart;
+ codeLengthNext = codePtr->codeLengthStart;
+ srcDeltaNext = codePtr->srcDeltaStart;
+ srcLengthNext = codePtr->srcLengthStart;
+ codeOffset = srcOffset = 0;
for (i = 0; i < numCmds; i++) {
- fprintf(stdout, " %d: source=%d-%d, code=%d-%d\n",
- (i+1), mapPtr[i].srcOffset,
- (mapPtr[i].srcOffset + mapPtr[i].numSrcChars - 1),
- mapPtr[i].codeOffset,
- (mapPtr[i].codeOffset + mapPtr[i].numCodeBytes - 1));
- }
-
- /*
- * Print the ExceptionRange array.
- */
+ if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {
+ codeDeltaNext++;
+ delta = TclGetInt4AtPtr(codeDeltaNext);
+ codeDeltaNext += 4;
+ } else {
+ delta = TclGetInt1AtPtr(codeDeltaNext);
+ codeDeltaNext++;
+ }
+ codeOffset += delta;
- fprintf(stdout, " Exception ranges=%d\n", numRanges);
- for (i = 0; i < numRanges; i++) {
- ExceptionRange *rangePtr = &(excRangeArrayPtr[i]);
- fprintf(stdout, " %d: level=%d, type=%s, pc range=%d-%d, ",
- i, rangePtr->nestingLevel,
- ((rangePtr->type == LOOP_EXCEPTION_RANGE)? "loop" : "catch"),
- rangePtr->codeOffset,
- (rangePtr->codeOffset + rangePtr->numCodeBytes - 1));
- switch (rangePtr->type) {
- case LOOP_EXCEPTION_RANGE:
- fprintf(stdout, "continue=%d, break=%d\n",
- rangePtr->continueOffset, rangePtr->breakOffset);
- break;
- case CATCH_EXCEPTION_RANGE:
- fprintf(stdout, "catch=%d\n", rangePtr->catchOffset);
- break;
- default:
- fprintf(stdout, "unrecognized ExceptionRange type %d\n",
- rangePtr->type);
+ if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) {
+ codeLengthNext++;
+ codeLen = TclGetInt4AtPtr(codeLengthNext);
+ codeLengthNext += 4;
+ } else {
+ codeLen = TclGetInt1AtPtr(codeLengthNext);
+ codeLengthNext++;
+ }
+
+ if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {
+ srcDeltaNext++;
+ delta = TclGetInt4AtPtr(srcDeltaNext);
+ srcDeltaNext += 4;
+ } else {
+ delta = TclGetInt1AtPtr(srcDeltaNext);
+ srcDeltaNext++;
+ }
+ srcOffset += delta;
+
+ if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {
+ srcLengthNext++;
+ srcLen = TclGetInt4AtPtr(srcLengthNext);
+ srcLengthNext += 4;
+ } else {
+ srcLen = TclGetInt1AtPtr(srcLengthNext);
+ srcLengthNext++;
}
+
+ fprintf(stdout, "%s%4d: pc %d-%d, source %d-%d",
+ ((i % 2)? " " : "\n "),
+ (i+1), codeOffset, (codeOffset + codeLen - 1),
+ srcOffset, (srcOffset + srcLen - 1));
+ }
+ if ((numCmds > 0) && ((numCmds % 2) != 0)) {
+ fprintf(stdout, "\n");
}
/*
* Print each instruction. If the instruction corresponds to the start
- * of a command, print the command's source.
+ * of a command, print the command's source. Note that we don't need
+ * the code length here.
*/
- start = codeStart;
- cmd = 0;
- pc = start;
- while (pc < codeLimit) {
- int pcOffset = (pc - start);
- while ((cmd < numCmds) && (pcOffset >= mapPtr[cmd].codeOffset)) {
- /*
- * The start of the command with index cmd.
- */
-
- maxChars = TclMin(mapPtr[cmd].numSrcChars, 70);
- fprintf(stdout, " Command %d: ", (cmd+1));
- TclPrintSource(stdout, (source + mapPtr[cmd].srcOffset),
- maxChars);
- fprintf(stdout, "\n");
- cmd++;
+ codeDeltaNext = codePtr->codeDeltaStart;
+ srcDeltaNext = codePtr->srcDeltaStart;
+ srcLengthNext = codePtr->srcLengthStart;
+ codeOffset = srcOffset = 0;
+ pc = codeStart;
+ for (i = 0; i < numCmds; i++) {
+ if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {
+ codeDeltaNext++;
+ delta = TclGetInt4AtPtr(codeDeltaNext);
+ codeDeltaNext += 4;
+ } else {
+ delta = TclGetInt1AtPtr(codeDeltaNext);
+ codeDeltaNext++;
+ }
+ codeOffset += delta;
+
+ if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {
+ srcDeltaNext++;
+ delta = TclGetInt4AtPtr(srcDeltaNext);
+ srcDeltaNext += 4;
+ } else {
+ delta = TclGetInt1AtPtr(srcDeltaNext);
+ srcDeltaNext++;
+ }
+ srcOffset += delta;
+
+ if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {
+ srcLengthNext++;
+ srcLen = TclGetInt4AtPtr(srcLengthNext);
+ srcLengthNext += 4;
+ } else {
+ srcLen = TclGetInt1AtPtr(srcLengthNext);
+ srcLengthNext++;
+ }
+
+ /*
+ * Print instructions before command i.
+ */
+
+ while ((pc-codeStart) < codeOffset) {
+ fprintf(stdout, " ");
+ pc += TclPrintInstruction(codePtr, pc);
+ }
+
+ fprintf(stdout, " Command %d: ", (i+1));
+ TclPrintSource(stdout, (codePtr->source + srcOffset),
+ TclMin(srcLen, 70));
+ fprintf(stdout, "\n");
+ }
+ if (pc < codeLimit) {
+ /*
+ * Print instructions after the last command.
+ */
+
+ while (pc < codeLimit) {
+ fprintf(stdout, " ");
+ pc += TclPrintInstruction(codePtr, pc);
}
- fprintf(stdout, " ");
- pc += TclPrintInstruction(codePtr, pc);
}
}
@@ -590,7 +723,7 @@ TclPrintInstruction(codePtr, pc)
for (i = 0; i < instDesc->numOperands; i++) {
switch (instDesc->opTypes[i]) {
case OPERAND_INT1:
- opnd = TclGetInt1AtPc(pc+1+i);
+ opnd = TclGetInt1AtPtr(pc+1+i);
if ((i == 0) && ((opCode == INST_JUMP1)
|| (opCode == INST_JUMP_TRUE1)
|| (opCode == INST_JUMP_FALSE1))) {
@@ -600,7 +733,7 @@ TclPrintInstruction(codePtr, pc)
}
break;
case OPERAND_INT4:
- opnd = TclGetInt4AtPc(pc+1+i);
+ opnd = TclGetInt4AtPtr(pc+1+i);
if ((i == 0) && ((opCode == INST_JUMP4)
|| (opCode == INST_JUMP_TRUE4)
|| (opCode == INST_JUMP_FALSE4))) {
@@ -610,7 +743,7 @@ TclPrintInstruction(codePtr, pc)
}
break;
case OPERAND_UINT1:
- opnd = TclGetUInt1AtPc(pc+1+i);
+ opnd = TclGetUInt1AtPtr(pc+1+i);
if ((i == 0) && (opCode == INST_PUSH1)) {
elemPtr = codePtr->objArrayPtr[opnd];
string = Tcl_GetStringFromObj(elemPtr, &elemLen);
@@ -642,7 +775,7 @@ TclPrintInstruction(codePtr, pc)
}
break;
case OPERAND_UINT4:
- opnd = TclGetUInt4AtPc(pc+1+i);
+ opnd = TclGetUInt4AtPtr(pc+1+i);
if (opCode == INST_PUSH4) {
elemPtr = codePtr->objArrayPtr[opnd];
string = Tcl_GetStringFromObj(elemPtr, &elemLen);
@@ -812,6 +945,11 @@ TclCleanupByteCode(codePtr)
register Tcl_Obj *elemPtr;
register int i;
+#ifdef TCL_COMPILE_STATS
+ tclCurrentSourceBytes -= (double) codePtr->numSrcChars;
+ tclCurrentCodeBytes -= (double) codePtr->totalSize;
+#endif /* TCL_COMPILE_STATS */
+
/*
* A single heap object holds the ByteCode structure and its code,
* object, command location, and auxiliary data arrays. This means we
@@ -864,50 +1002,54 @@ DupByteCodeInternalRep(srcPtr, copyPtr)
{
ByteCode *codePtr = (ByteCode *) srcPtr->internalRep.otherValuePtr;
register ByteCode *dupPtr;
- int codeBytes = codePtr->numCodeBytes;
- int numObjects = codePtr->numObjects;
- int numAuxDataItems = codePtr->numAuxDataItems;
register AuxData *srcAuxDataPtr, *dupAuxDataPtr;
- size_t objArrayBytes, rangeArrayBytes, cmdLocBytes, auxDataBytes;
+ size_t objArrayBytes, exceptArrayBytes, cmdLocBytes, auxDataBytes;
register size_t size;
register char *p;
- int i;
+ int codeBytes, numObjects, i;
/*
* Allocate a single heap object to hold the copied ByteCode structure
* and its code, object, command location, and auxiliary data arrays.
*/
- objArrayBytes = numObjects * sizeof(Tcl_Obj *);
- rangeArrayBytes = (codePtr->numExcRanges * sizeof(ExceptionRange));
- cmdLocBytes = codePtr->numCommands * sizeof(CmdLocation);
- auxDataBytes = numAuxDataItems * sizeof(AuxData);
-
- size = TCL_ALIGN(sizeof(ByteCode));
- size += TCL_ALIGN(codeBytes);
- size += TCL_ALIGN(objArrayBytes);
- size += TCL_ALIGN(rangeArrayBytes);
- size += TCL_ALIGN(cmdLocBytes);
- size += TCL_ALIGN(auxDataBytes);
+ codeBytes = codePtr->numCodeBytes;
+ numObjects = codePtr->numObjects;
+ objArrayBytes = (numObjects * sizeof(Tcl_Obj *));
+ exceptArrayBytes = (codePtr->numExcRanges * sizeof(ExceptionRange));
+ auxDataBytes = (codePtr->numAuxDataItems * sizeof(AuxData));
+ cmdLocBytes = codePtr->numCmdLocBytes;
+
+ size = sizeof(ByteCode);
+ size += TCL_ALIGN(codeBytes); /* align object array */
+ size += TCL_ALIGN(objArrayBytes); /* align exception range array */
+ size += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */
+ size += auxDataBytes;
+ size += cmdLocBytes;
p = (char *) ckalloc(size);
dupPtr = (ByteCode *) p;
memcpy((VOID *) dupPtr, (VOID *) codePtr, size);
- p += TCL_ALIGN(sizeof(ByteCode));
+ p += sizeof(ByteCode);
dupPtr->codeStart = (unsigned char *) p;
- p += TCL_ALIGN(codeBytes);
+ p += TCL_ALIGN(codeBytes); /* object array is aligned */
dupPtr->objArrayPtr = (Tcl_Obj **) p;
- p += TCL_ALIGN(objArrayBytes);
+ p += TCL_ALIGN(objArrayBytes); /* exception range array is aligned */
dupPtr->excRangeArrayPtr = (ExceptionRange *) p;
- p += TCL_ALIGN(rangeArrayBytes);
- dupPtr->cmdMapPtr = (CmdLocation *) p;
-
- p += TCL_ALIGN(cmdLocBytes);
+ p += TCL_ALIGN(exceptArrayBytes); /* AuxData array is aligned */
dupPtr->auxDataArrayPtr = (AuxData *) p;
+
+ p += auxDataBytes;
+ dupPtr->codeDeltaStart = ((unsigned char *) dupPtr) +
+ (codePtr->codeDeltaStart - (unsigned char *) codePtr);
+ dupPtr->srcDeltaStart = ((unsigned char *) dupPtr) +
+ (codePtr->srcDeltaStart - (unsigned char *) codePtr);
+ dupPtr->srcLengthStart = ((unsigned char *) dupPtr) +
+ (codePtr->srcLengthStart - (unsigned char *) codePtr);
/*
* Increment the ref counts for objects in the object array since we are
@@ -924,7 +1066,7 @@ DupByteCodeInternalRep(srcPtr, copyPtr)
srcAuxDataPtr = codePtr->auxDataArrayPtr;
dupAuxDataPtr = dupPtr->auxDataArrayPtr;
- for (i = 0; i < numAuxDataItems; i++) {
+ for (i = 0; i < codePtr->numAuxDataItems; i++) {
if (srcAuxDataPtr->dupProc != NULL) {
dupAuxDataPtr->clientData =
srcAuxDataPtr->dupProc(srcAuxDataPtr->clientData);
@@ -937,6 +1079,11 @@ DupByteCodeInternalRep(srcPtr, copyPtr)
copyPtr->internalRep.otherValuePtr = (VOID *) dupPtr;
copyPtr->typePtr = &tclByteCodeType;
+
+#ifdef TCL_COMPILE_STATS
+ tclCurrentSourceBytes += (double) codePtr->numSrcChars;
+ tclCurrentCodeBytes += (double) codePtr->totalSize;
+#endif /* TCL_COMPILE_STATS */
}
/*
@@ -984,10 +1131,6 @@ SetByteCodeFromAny(interp, objPtr)
traceInitialized = 1;
}
-#ifdef TCL_COMPILE_STATS
- tclNumCompilations++;
-#endif /* TCL_COMPILE_STATS */
-
string = Tcl_GetStringFromObj(objPtr, &length);
TclInitCompileEnv(interp, &compEnv, string);
result = TclCompileString(interp, string, string+length,
@@ -1105,6 +1248,7 @@ TclInitCompileEnv(interp, envPtr, string)
envPtr->wordIsSimple = 0;
envPtr->numSimpleWordChars = 0;
envPtr->exprIsJustVarRef = 0;
+ envPtr->exprIsComparison = 0;
envPtr->termOffset = 0;
envPtr->codeStart = envPtr->staticCodeSpace;
@@ -1204,67 +1348,121 @@ TclFreeCompileEnv(envPtr)
void
TclInitByteCodeObj(objPtr, envPtr)
- Tcl_Obj *objPtr; /* Points object that should be
- * initialized, and whose string rep
- * contains the source code. */
+ Tcl_Obj *objPtr; /* Points object that should be
+ * initialized, and whose string rep
+ * contains the source code. */
register CompileEnv *envPtr; /* Points to the CompileEnv structure from
* which to create a ByteCode structure. */
{
register ByteCode *codePtr;
- size_t codeBytes, objArrayBytes, rangeArrayBytes, cmdLocBytes;
+ size_t codeBytes, objArrayBytes, exceptArrayBytes, cmdLocBytes;
size_t auxDataArrayBytes;
- register size_t size;
- register char *p;
+ register size_t size, objBytes, totalSize;
+ register unsigned char *p;
+ unsigned char *nextPtr;
+ int srcLen = envPtr->termOffset;
+ int numObjects, i;
+#ifdef TCL_COMPILE_STATS
+ int srcLenLog2, sizeLog2;
+#endif /*TCL_COMPILE_STATS*/
+
+ codeBytes = (envPtr->codeNext - envPtr->codeStart);
+ numObjects = envPtr->objArrayNext;
+ objArrayBytes = (envPtr->objArrayNext * sizeof(Tcl_Obj *));
+ exceptArrayBytes = (envPtr->excRangeArrayNext * sizeof(ExceptionRange));
+ auxDataArrayBytes = (envPtr->auxDataArrayNext * sizeof(AuxData));
+ cmdLocBytes = GetCmdLocEncodingSize(envPtr);
+
+ size = sizeof(ByteCode);
+ size += TCL_ALIGN(codeBytes); /* align object array */
+ size += TCL_ALIGN(objArrayBytes); /* align exception range array */
+ size += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */
+ size += auxDataArrayBytes;
+ size += cmdLocBytes;
+
+ /*
+ * Compute the total number of bytes needed for this bytecode
+ * including the storage for the Tcl objects in its object array.
+ */
+
+ objBytes = (numObjects * sizeof(Tcl_Obj));
+ for (i = 0; i < numObjects; i++) {
+ Tcl_Obj *litObjPtr = envPtr->objArrayPtr[i];
+ if (litObjPtr->bytes != NULL) {
+ objBytes += litObjPtr->length;
+ }
+ }
+ totalSize = (size + objBytes);
- codeBytes = envPtr->codeNext - envPtr->codeStart;
- objArrayBytes = envPtr->objArrayNext * sizeof(Tcl_Obj *);
- rangeArrayBytes = (envPtr->excRangeArrayNext * sizeof(ExceptionRange));
- cmdLocBytes = envPtr->numCommands * sizeof(CmdLocation);
- auxDataArrayBytes = envPtr->auxDataArrayNext * sizeof(AuxData);
+#ifdef TCL_COMPILE_STATS
+ tclNumCompilations++;
+ tclTotalSourceBytes += (double) srcLen;
+ tclTotalCodeBytes += (double) totalSize;
- size = TCL_ALIGN(sizeof(ByteCode));
- size += TCL_ALIGN(codeBytes);
- size += TCL_ALIGN(objArrayBytes);
- size += TCL_ALIGN(rangeArrayBytes);
- size += TCL_ALIGN(cmdLocBytes);
- size += TCL_ALIGN(auxDataArrayBytes);
+ tclTotalInstBytes += (double) codeBytes;
+ tclTotalObjBytes += (double) objBytes;
+ tclTotalExceptBytes += exceptArrayBytes;
+ tclTotalAuxBytes += (double) auxDataArrayBytes;
+ tclTotalCmdMapBytes += (double) cmdLocBytes;
+
+ tclCurrentSourceBytes += (double) srcLen;
+ tclCurrentCodeBytes += (double) totalSize;
+
+ srcLenLog2 = TclLog2(srcLen);
+ sizeLog2 = TclLog2((int) totalSize);
+ if ((srcLenLog2 > 31) || (sizeLog2 > 31)) {
+ panic("TclInitByteCodeObj: bad source or code sizes\n");
+ }
+ tclSourceCount[srcLenLog2]++;
+ tclByteCodeCount[sizeLog2]++;
+#endif /* TCL_COMPILE_STATS */
- p = (char *) ckalloc(size);
+ p = (unsigned char *) ckalloc(size);
codePtr = (ByteCode *) p;
codePtr->iPtr = envPtr->iPtr;
codePtr->compileEpoch = envPtr->iPtr->compileEpoch;
codePtr->refCount = 1;
codePtr->source = envPtr->source;
codePtr->procPtr = envPtr->procPtr;
+ codePtr->totalSize = totalSize;
codePtr->numCommands = envPtr->numCommands;
- codePtr->numSrcChars = envPtr->termOffset;
+ codePtr->numSrcChars = srcLen;
codePtr->numCodeBytes = codeBytes;
- codePtr->numObjects = envPtr->objArrayNext;
+ codePtr->numObjects = numObjects;
codePtr->numExcRanges = envPtr->excRangeArrayNext;
codePtr->numAuxDataItems = envPtr->auxDataArrayNext;
+ codePtr->numCmdLocBytes = cmdLocBytes;
codePtr->maxExcRangeDepth = envPtr->maxExcRangeDepth;
codePtr->maxStackDepth = envPtr->maxStackDepth;
- p += TCL_ALIGN(sizeof(ByteCode));
- codePtr->codeStart = (unsigned char *) p;
+ p += sizeof(ByteCode);
+ codePtr->codeStart = p;
memcpy((VOID *) p, (VOID *) envPtr->codeStart, codeBytes);
- p += TCL_ALIGN(codeBytes);
+ p += TCL_ALIGN(codeBytes); /* align object array */
codePtr->objArrayPtr = (Tcl_Obj **) p;
memcpy((VOID *) p, (VOID *) envPtr->objArrayPtr, objArrayBytes);
-
- p += TCL_ALIGN(objArrayBytes);
- codePtr->excRangeArrayPtr = (ExceptionRange *) p;
- memcpy((VOID *) p, (VOID *) envPtr->excRangeArrayPtr, rangeArrayBytes);
-
- p += TCL_ALIGN(rangeArrayBytes);
- codePtr->cmdMapPtr = (CmdLocation *) p;
- memcpy((VOID *) p, (VOID *) envPtr->cmdMapPtr, cmdLocBytes);
- p += TCL_ALIGN(cmdLocBytes);
- codePtr->auxDataArrayPtr = (AuxData *) p;
- memcpy((VOID *) p, (VOID *) envPtr->auxDataArrayPtr, auxDataArrayBytes);
+ p += TCL_ALIGN(objArrayBytes); /* align exception range array */
+ if (exceptArrayBytes > 0) {
+ codePtr->excRangeArrayPtr = (ExceptionRange *) p;
+ memcpy((VOID *) p, (VOID *) envPtr->excRangeArrayPtr,
+ exceptArrayBytes);
+ }
+
+ p += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */
+ if (auxDataArrayBytes > 0) {
+ codePtr->auxDataArrayPtr = (AuxData *) p;
+ memcpy((VOID *) p, (VOID *) envPtr->auxDataArrayPtr,
+ auxDataArrayBytes);
+ }
+ p += auxDataArrayBytes;
+ nextPtr = EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p);
+ if (((size_t)(nextPtr - p)) != cmdLocBytes) {
+ panic("TclInitByteCodeObj: encoded cmd location bytes %d != expected size %d\n", (nextPtr - p), cmdLocBytes);
+ }
+
/*
* Free the old internal rep then convert the object to a
* bytecode object by making its internal rep point to the just
@@ -1282,6 +1480,204 @@ TclInitByteCodeObj(objPtr, envPtr)
/*
*----------------------------------------------------------------------
*
+ * GetCmdLocEncodingSize --
+ *
+ * Computes the total number of bytes needed to encode the command
+ * location information for some compiled code.
+ *
+ * Results:
+ * The byte count needed to encode the compiled location information.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+GetCmdLocEncodingSize(envPtr)
+ CompileEnv *envPtr; /* Points to compilation environment
+ * structure containing the CmdLocation
+ * structure to encode. */
+{
+ register CmdLocation *mapPtr = envPtr->cmdMapPtr;
+ int numCmds = envPtr->numCommands;
+ int codeDelta, codeLen, srcDelta, srcLen;
+ int codeDeltaNext, codeLengthNext, srcDeltaNext, srcLengthNext;
+ /* The offsets in their respective byte
+ * sequences where the next encoded offset
+ * or length should go. */
+ int prevCodeOffset, prevSrcOffset, i;
+
+ codeDeltaNext = codeLengthNext = srcDeltaNext = srcLengthNext = 0;
+ prevCodeOffset = prevSrcOffset = 0;
+ for (i = 0; i < numCmds; i++) {
+ codeDelta = (mapPtr[i].codeOffset - prevCodeOffset);
+ if (codeDelta < 0) {
+ panic("GetCmdLocEncodingSize: bad code offset");
+ } else if (codeDelta <= 127) {
+ codeDeltaNext++;
+ } else {
+ codeDeltaNext += 5; /* 1 byte for 0xFF, 4 for positive delta */
+ }
+ prevCodeOffset = mapPtr[i].codeOffset;
+
+ codeLen = mapPtr[i].numCodeBytes;
+ if (codeLen < 0) {
+ panic("GetCmdLocEncodingSize: bad code length");
+ } else if (codeLen <= 127) {
+ codeLengthNext++;
+ } else {
+ codeLengthNext += 5; /* 1 byte for 0xFF, 4 for length */
+ }
+
+ srcDelta = (mapPtr[i].srcOffset - prevSrcOffset);
+ if ((-127 <= srcDelta) && (srcDelta <= 127)) {
+ srcDeltaNext++;
+ } else {
+ srcDeltaNext += 5; /* 1 byte for 0xFF, 4 for delta */
+ }
+ prevSrcOffset = mapPtr[i].srcOffset;
+
+ srcLen = mapPtr[i].numSrcChars;
+ if (srcLen < 0) {
+ panic("GetCmdLocEncodingSize: bad source length");
+ } else if (srcLen <= 127) {
+ srcLengthNext++;
+ } else {
+ srcLengthNext += 5; /* 1 byte for 0xFF, 4 for length */
+ }
+ }
+
+ return (codeDeltaNext + codeLengthNext + srcDeltaNext + srcLengthNext);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * EncodeCmdLocMap --
+ *
+ * Encode the command location information for some compiled code into
+ * a ByteCode structure. The encoded command location map is stored as
+ * three adjacent byte sequences.
+ *
+ * Results:
+ * Pointer to the first byte after the encoded command location
+ * information.
+ *
+ * Side effects:
+ * The encoded information is stored into the block of memory headed
+ * by codePtr. Also records pointers to the start of the four byte
+ * sequences in fields in codePtr's ByteCode header structure.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static unsigned char *
+EncodeCmdLocMap(envPtr, codePtr, startPtr)
+ CompileEnv *envPtr; /* Points to compilation environment
+ * structure containing the CmdLocation
+ * structure to encode. */
+ ByteCode *codePtr; /* ByteCode in which to encode envPtr's
+ * command location information. */
+ unsigned char *startPtr; /* Points to the first byte in codePtr's
+ * memory block where the location
+ * information is to be stored. */
+{
+ register CmdLocation *mapPtr = envPtr->cmdMapPtr;
+ int numCmds = envPtr->numCommands;
+ register unsigned char *p = startPtr;
+ int codeDelta, codeLen, srcDelta, srcLen, prevOffset;
+ register int i;
+
+ /*
+ * Encode the code offset for each command as a sequence of deltas.
+ */
+
+ codePtr->codeDeltaStart = p;
+ prevOffset = 0;
+ for (i = 0; i < numCmds; i++) {
+ codeDelta = (mapPtr[i].codeOffset - prevOffset);
+ if (codeDelta < 0) {
+ panic("EncodeCmdLocMap: bad code offset");
+ } else if (codeDelta <= 127) {
+ TclStoreInt1AtPtr(codeDelta, p);
+ p++;
+ } else {
+ TclStoreInt1AtPtr(0xFF, p);
+ p++;
+ TclStoreInt4AtPtr(codeDelta, p);
+ p += 4;
+ }
+ prevOffset = mapPtr[i].codeOffset;
+ }
+
+ /*
+ * Encode the code length for each command.
+ */
+
+ codePtr->codeLengthStart = p;
+ for (i = 0; i < numCmds; i++) {
+ codeLen = mapPtr[i].numCodeBytes;
+ if (codeLen < 0) {
+ panic("EncodeCmdLocMap: bad code length");
+ } else if (codeLen <= 127) {
+ TclStoreInt1AtPtr(codeLen, p);
+ p++;
+ } else {
+ TclStoreInt1AtPtr(0xFF, p);
+ p++;
+ TclStoreInt4AtPtr(codeLen, p);
+ p += 4;
+ }
+ }
+
+ /*
+ * Encode the source offset for each command as a sequence of deltas.
+ */
+
+ codePtr->srcDeltaStart = p;
+ prevOffset = 0;
+ for (i = 0; i < numCmds; i++) {
+ srcDelta = (mapPtr[i].srcOffset - prevOffset);
+ if ((-127 <= srcDelta) && (srcDelta <= 127)) {
+ TclStoreInt1AtPtr(srcDelta, p);
+ p++;
+ } else {
+ TclStoreInt1AtPtr(0xFF, p);
+ p++;
+ TclStoreInt4AtPtr(srcDelta, p);
+ p += 4;
+ }
+ prevOffset = mapPtr[i].srcOffset;
+ }
+
+ /*
+ * Encode the source length for each command.
+ */
+
+ codePtr->srcLengthStart = p;
+ for (i = 0; i < numCmds; i++) {
+ srcLen = mapPtr[i].numSrcChars;
+ if (srcLen < 0) {
+ panic("EncodeCmdLocMap: bad source length");
+ } else if (srcLen <= 127) {
+ TclStoreInt1AtPtr(srcLen, p);
+ p++;
+ } else {
+ TclStoreInt1AtPtr(0xFF, p);
+ p++;
+ TclStoreInt4AtPtr(srcLen, p);
+ p += 4;
+ }
+ }
+
+ return p;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclCompileString --
*
* Compile a Tcl script in a null-terminated binary string.
@@ -1308,8 +1704,8 @@ int
TclCompileString(interp, string, lastChar, flags, envPtr)
Tcl_Interp *interp; /* Used for error reporting. */
char *string; /* The source string to compile. */
- char *lastChar; /* Pointer to terminating character of
- * string. */
+ char *lastChar; /* Pointer to terminating character of
+ * string. */
int flags; /* Flags to control compilation (same as
* passed to Tcl_Eval). */
CompileEnv *envPtr; /* Holds resulting instructions. */
@@ -1326,7 +1722,7 @@ TclCompileString(interp, string, lastChar, flags, envPtr)
char *cmdSrcStart = NULL; /* Points to first non-blank char in each
* command. Initialized to avoid compiler
* warning. */
- int cmdIndex = -1; /* The index of the current command in the
+ int cmdIndex; /* The index of the current command in the
* compilation environment's command
* location table. Initialized to avoid
* compiler warning. */
@@ -1379,7 +1775,7 @@ TclCompileString(interp, string, lastChar, flags, envPtr)
if (src[1] == '\n') {
src += 2;
} else {
- break; /* no longer white space */
+ break;
}
} else {
src++;
@@ -1418,7 +1814,7 @@ TclCompileString(interp, string, lastChar, flags, envPtr)
type = CHAR_TYPE(src, lastChar);
if ((type == TCL_COMMAND_END)
&& ((c != ']') || (flags & TCL_BRACKET_TERM))) {
- continue; /* ignore empty command; restart outer cmd loop */
+ continue; /* empty command; restart outer cmd loop */
}
/*
@@ -1449,45 +1845,42 @@ TclCompileString(interp, string, lastChar, flags, envPtr)
* of compilation procedures. If a word other than the first is
* simple and represents an integer whose formatted representation
* is the same as the word, just push an integer object. Also record
- * starting source and object information for the command if we are
- * at the top level (i.e. we were called directly from
- * SetByteCodeFromAny and are not compiling a substring enclosed in
- * square brackets).
+ * starting source and object information for the command.
*/
cmdSrcStart = src;
cmdCodeOffset = (envPtr->codeNext - envPtr->codeStart);
cmdWords = 0;
- if (!(flags & TCL_BRACKET_TERM)) {
- envPtr->numCommands++;
- cmdIndex = (envPtr->numCommands - 1);
- EnterCmdStartData(envPtr, cmdIndex,
- (cmdSrcStart - envPtr->source), cmdCodeOffset);
+
+ envPtr->numCommands++;
+ cmdIndex = (envPtr->numCommands - 1);
+ EnterCmdStartData(envPtr, cmdIndex,
+ (cmdSrcStart - envPtr->source), cmdCodeOffset);
- if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) {
- /*
- * Display a line summarizing the top level command we
- * are about to compile.
- */
-
- char *p = cmdSrcStart;
- int numChars;
- char *ellipsis = "";
-
- while ((CHAR_TYPE(p, lastChar) != TCL_COMMAND_END)
- || ((*p == ']') && !(flags & TCL_BRACKET_TERM))) {
- p++;
- }
- numChars = (p - cmdSrcStart);
- if (numChars > 60) {
- numChars = 60;
- ellipsis = " ...";
- } else if ((numChars >= 2) && (*p == '\n') && (*(p-1) == '{')) {
- ellipsis = " ...";
- }
- fprintf(stdout, "Compiling: %.*s%s\n",
- numChars, cmdSrcStart, ellipsis);
+ if ((!(flags & TCL_BRACKET_TERM))
+ && (tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) {
+ /*
+ * Display a line summarizing the top level command we are about
+ * to compile.
+ */
+
+ char *p = cmdSrcStart;
+ int numChars, complete;
+
+ while ((CHAR_TYPE(p, lastChar) != TCL_COMMAND_END)
+ || ((*p == ']') && !(flags & TCL_BRACKET_TERM))) {
+ p++;
+ }
+ numChars = (p - cmdSrcStart);
+ complete = 1;
+ if (numChars > 60) {
+ numChars = 60;
+ complete = 0;
+ } else if ((numChars >= 2) && (*p == '\n') && (*(p-1) == '{')) {
+ complete = 0;
}
+ fprintf(stdout, "Compiling: %.*s%s\n",
+ numChars, cmdSrcStart, (complete? "" : " ..."));
}
while ((type != TCL_COMMAND_END)
@@ -1502,7 +1895,7 @@ TclCompileString(interp, string, lastChar, flags, envPtr)
if (src[1] == '\n') {
src += 2;
} else {
- break; /* no longer white space */
+ break;
}
} else {
src++;
@@ -1520,9 +1913,9 @@ TclCompileString(interp, string, lastChar, flags, envPtr)
* avoid an extra procedure call.
*/
- envPtr->pushSimpleWords = 0; /* we will handle simple words */
+ envPtr->pushSimpleWords = 0;
if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) {
- src++; /* advance over the " or { */
+ src++;
if (type == TCL_QUOTE) {
result = TclCompileQuotes(interp, src, lastChar,
'"', flags, envPtr);
@@ -1590,18 +1983,29 @@ TclCompileString(interp, string, lastChar, flags, envPtr)
* traces). Look up the first word in the interpreter's
* hashtable of commands. If a compilation procedure is
* found, let it compile the command after resetting
- * error logging information.
+ * error logging information. Note that if we are
+ * compiling a procedure, we must look up the command
+ * in the procedure's namespace and not the current
+ * namespace.
*/
+ Namespace *cmdNsPtr;
+
+ if (envPtr->procPtr != NULL) {
+ cmdNsPtr = envPtr->procPtr->cmdPtr->nsPtr;
+ } else {
+ cmdNsPtr = NULL;
+ }
+
cmdPtr = NULL;
cmd = Tcl_FindCommand(interp, src,
- (Tcl_Namespace *) NULL, /*flags*/ 0);
+ (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0);
if (cmd != (Tcl_Command) NULL) {
cmdPtr = (Command *) cmd;
}
if ((cmdPtr != NULL) && (cmdPtr->compileProc != NULL)) {
char *firstArg = termPtr;
- src[numChars] = savedChar; /* restore chr */
+ src[numChars] = savedChar;
iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS
| ERROR_CODE_SET);
result = (*(cmdPtr->compileProc))(interp,
@@ -1609,9 +2013,9 @@ TclCompileString(interp, string, lastChar, flags, envPtr)
if (result == TCL_OK) {
src = (firstArg + envPtr->termOffset);
maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
- goto finishCommand; /* done with command */
+ goto finishCommand;
} else if (result == TCL_OUT_LINE_COMPILE) {
- result = TCL_OK; /* reset result */
+ result = TCL_OK;
src[numChars] = '\0';
} else {
src = firstArg;
@@ -1652,8 +2056,9 @@ TclCompileString(interp, string, lastChar, flags, envPtr)
resPtr->refNsCmdEpoch = nsPtr->cmdRefEpoch;
resPtr->cmdEpoch = cmdPtr->cmdEpoch;
resPtr->refCount = 1;
- objPtr->internalRep.otherValuePtr =
- (VOID *) resPtr;
+ objPtr->internalRep.twoPtrValue.ptr1 =
+ (VOID *) resPtr;
+ objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = &tclCmdNameType;
cmdPtr->refCount++;
}
@@ -1671,7 +2076,8 @@ TclCompileString(interp, string, lastChar, flags, envPtr)
char buf[40];
if (TclLooksLikeInt(src)) {
- if (TclGetLong(interp, src, &n) == TCL_OK) {
+ int code = TclGetLong(interp, src, &n);
+ if (code == TCL_OK) {
TclFormatInt(buf, n);
if (strcmp(src, buf) == 0) {
isCompilableInt = 1;
@@ -1684,6 +2090,8 @@ TclCompileString(interp, string, lastChar, flags, envPtr)
objPtr->internalRep.longValue = n;
objPtr->typePtr = &tclIntType;
}
+ } else {
+ Tcl_ResetResult(interp);
}
}
if (!isCompilableInt) {
@@ -1691,7 +2099,7 @@ TclCompileString(interp, string, lastChar, flags, envPtr)
/*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
}
}
- src[numChars] = savedChar; /* restore the saved char */
+ src[numChars] = savedChar;
TclEmitPush(objIndex, envPtr);
maxDepth = TclMax((cmdWords + 1), maxDepth);
} else { /* not a simple word */
@@ -1709,13 +2117,6 @@ TclCompileString(interp, string, lastChar, flags, envPtr)
* was found for the command we called it and skipped this.
*/
-#ifdef TCL_COMPILE_DEBUG
- if ((cmdWords < 0) || (cmdWords > 10000)) {
- fprintf(stderr, "\nTclCompileString: bad cmdWords value %d\n",
- cmdWords);
- panic("TclCompileString: bad cmdWords value %d");
- }
-#endif /*TCL_COMPILE_DEBUG*/
if (cmdWords > 0) {
if (cmdWords <= 255) {
TclEmitInstUInt1(INST_INVOKE_STK1, cmdWords, envPtr);
@@ -1726,18 +2127,13 @@ TclCompileString(interp, string, lastChar, flags, envPtr)
/*
* Update the compilation environment structure. Record
- * source/object information for the command if we are at the top
- * level (i.e. we we called directly from SetByteCodeFromAny and are
- * not compiling a substring enclosed in square brackets).
+ * source/object information for the command.
*/
finishCommand:
- if (!(flags & TCL_BRACKET_TERM)) {
- int cmdSrcChars = (src - cmdSrcStart);
- cmdCodeBytes =
- (envPtr->codeNext - envPtr->codeStart - cmdCodeOffset);
- EnterCmdExtentData(envPtr, cmdIndex, cmdSrcChars, cmdCodeBytes);
- }
+ cmdCodeBytes = envPtr->codeNext - envPtr->codeStart - cmdCodeOffset;
+ EnterCmdExtentData(envPtr, cmdIndex, src-cmdSrcStart, cmdCodeBytes);
+
isFirstCmd = 0;
envPtr->termOffset = (src - string);
c = *src;
@@ -1754,7 +2150,7 @@ TclCompileString(interp, string, lastChar, flags, envPtr)
int objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0,
/*inHeap*/ 0, envPtr);
TclEmitPush(objIndex, envPtr);
- maxDepth = 1; /* we pushed 1 word for the empty string */
+ maxDepth = 1;
}
} else {
/*
@@ -1762,8 +2158,8 @@ TclCompileString(interp, string, lastChar, flags, envPtr)
* where the error occurred.
*/
- int numChars;
register char *p;
+ int numChars;
char buf[200];
iPtr->errorLine = 1;
@@ -1780,14 +2176,22 @@ TclCompileString(interp, string, lastChar, flags, envPtr)
/*
* Figure out how much of the command to print (up to a certain
- * number of characters, or up to the first newline).
+ * number of characters, or up to the end of the command).
*/
- numChars = (src - cmdSrcStart);
+ p = cmdSrcStart;
+ while ((CHAR_TYPE(p, lastChar) != TCL_COMMAND_END)
+ || ((*p == ']') && !(flags & TCL_BRACKET_TERM))) {
+ p++;
+ }
+ numChars = (p - cmdSrcStart);
if (numChars > 150) {
numChars = 150;
ellipsis = " ...";
+ } else if ((numChars >= 2) && (*p == '\n') && (*(p-1) == '{')) {
+ ellipsis = " ...";
}
+
sprintf(buf, "\n while compiling\n\"%.*s%s\"",
numChars, cmdSrcStart, ellipsis);
Tcl_AddObjErrorInfo(interp, buf, -1);
@@ -1902,7 +2306,7 @@ CompileWord(interp, string, lastChar, flags, envPtr)
*/
if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) {
- src++; /* advance over the " or { */
+ src++;
if (type == TCL_QUOTE) {
result = TclCompileQuotes(interp, src, lastChar, '"', flags,
envPtr);
@@ -2080,7 +2484,7 @@ CompileMultipartWord(interp, string, lastChar, flags, envPtr)
if (src[1] == '\n') {
src += numRead;
type = TCL_SPACE; /* force word end */
- break; /* exit loop: \newline is word separator */
+ break;
}
src += numRead;
} else {
@@ -2131,7 +2535,7 @@ CompileMultipartWord(interp, string, lastChar, flags, envPtr)
if (*p == '\\') {
*dst = Tcl_Backslash(p, &numRead);
if (p[1] == '\n') {
- break; /* end of word */
+ break;
}
p += numRead;
dst++;
@@ -2146,7 +2550,7 @@ CompileMultipartWord(interp, string, lastChar, flags, envPtr)
objIndex = TclObjIndexForString(start, numChars,
/*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
}
- start[numChars] = savedChar; /* restore the saved char */
+ start[numChars] = savedChar;
TclEmitPush(objIndex, envPtr);
maxDepth = TclMax((numParts + 1), maxDepth);
} else if (type == TCL_DOLLAR) {
@@ -2167,7 +2571,7 @@ CompileMultipartWord(interp, string, lastChar, flags, envPtr)
(flags | TCL_BRACKET_TERM), envPtr);
termPtr = (src + envPtr->termOffset);
if (*termPtr == ']') {
- termPtr++; /* advance over the ']'. */
+ termPtr++;
} else if (*termPtr == '\0') {
/*
* Missing ] at end of nested command.
@@ -2327,7 +2731,7 @@ TclCompileQuotes(interp, string, lastChar, termChar, flags, envPtr)
(flags | TCL_BRACKET_TERM), envPtr);
termPtr = (src + envPtr->termOffset);
if (*termPtr == ']') {
- termPtr++; /* advance over the ']'. */
+ termPtr++;
}
src = termPtr;
if (result != TCL_OK) {
@@ -2384,7 +2788,7 @@ TclCompileQuotes(interp, string, lastChar, termChar, flags, envPtr)
Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
result = TCL_ERROR;
} else {
- src++; /* advance over termChar */
+ src++;
}
envPtr->wordIsSimple = 1;
envPtr->numSimpleWordChars = (src - string - 1);
@@ -2425,7 +2829,7 @@ TclCompileQuotes(interp, string, lastChar, termChar, flags, envPtr)
objIndex = TclObjIndexForString(start, numChars,
/*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
}
- start[numChars] = savedChar; /* restore the saved char */
+ start[numChars] = savedChar;
TclEmitPush(objIndex, envPtr);
maxDepth = TclMax((numParts + 1), maxDepth);
}
@@ -2445,7 +2849,7 @@ TclCompileQuotes(interp, string, lastChar, termChar, flags, envPtr)
result = TCL_ERROR;
goto done;
} else {
- src++; /* advance over termChar */
+ src++;
}
if (numParts == 0) {
@@ -2577,8 +2981,7 @@ CompileBraces(interp, string, lastChar, flags, envPtr)
--level;
if (level == 0) {
src++;
- last = (src - 2); /* i.e. point just before
- * terminating } */
+ last = (src - 2); /* point just before terminating } */
break;
}
} else if (c == '\\') {
@@ -2645,7 +3048,7 @@ CompileBraces(interp, string, lastChar, flags, envPtr)
objIndex = TclObjIndexForString(string, numChars, /*allocStrRep*/ 1,
/*inHeap*/ 0, envPtr);
}
- string[numChars] = savedChar; /* restore the saved char */
+ string[numChars] = savedChar;
TclEmitPush(objIndex, envPtr);
done:
@@ -2755,7 +3158,7 @@ TclCompileDollarVar(interp, string, lastChar, flags, envPtr)
char *p;
- src++; /* advance over the '{'. */
+ src++;
name = src;
c = *src;
while (c != '}') {
@@ -2788,9 +3191,9 @@ TclCompileDollarVar(interp, string, lastChar, flags, envPtr)
if (c == ':') {
if (*(src+1) == ':') {
nameHasNsSeparators = 1;
- src += 2; /* skip over the initial :: */
+ src += 2;
while (*src == ':') {
- src++; /* skip over a subsequent : */
+ src++;
}
c = *src;
} else {
@@ -2826,11 +3229,11 @@ TclCompileDollarVar(interp, string, lastChar, flags, envPtr)
if (!isArrayRef) { /* scalar reference */
if ((envPtr->procPtr == NULL) || nameHasNsSeparators) {
- savedChar = name[nameChars]; /* save char just after name */
+ savedChar = name[nameChars];
name[nameChars] = '\0';
objIndex = TclObjIndexForString(name, nameChars,
/*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- name[nameChars] = savedChar; /* restore the saved char */
+ name[nameChars] = savedChar;
TclEmitPush(objIndex, envPtr);
TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr);
maxDepth = 1;
@@ -2846,11 +3249,11 @@ TclCompileDollarVar(interp, string, lastChar, flags, envPtr)
}
maxDepth = 0;
} else {
- savedChar = name[nameChars]; /* save char after name */
+ savedChar = name[nameChars];
name[nameChars] = '\0';
objIndex = TclObjIndexForString(name, nameChars,
/*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- name[nameChars] = savedChar; /* restore the saved char */
+ name[nameChars] = savedChar;
TclEmitPush(objIndex, envPtr);
TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr);
maxDepth = 1;
@@ -2858,11 +3261,11 @@ TclCompileDollarVar(interp, string, lastChar, flags, envPtr)
}
} else { /* array reference */
if ((envPtr->procPtr == NULL) || nameHasNsSeparators) {
- savedChar = name[nameChars]; /* save char after name */
+ savedChar = name[nameChars];
name[nameChars] = '\0';
objIndex = TclObjIndexForString(name, nameChars,
/*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- name[nameChars] = savedChar; /* restore the saved char */
+ name[nameChars] = savedChar;
TclEmitPush(objIndex, envPtr);
maxDepth = 1;
} else {
@@ -2870,11 +3273,11 @@ TclCompileDollarVar(interp, string, lastChar, flags, envPtr)
/*createIfNew*/ 0, /*flagsIfCreated*/ 0,
envPtr->procPtr);
if (localIndex < 0) {
- savedChar = name[nameChars]; /* save char after name */
+ savedChar = name[nameChars];
name[nameChars] = '\0';
objIndex = TclObjIndexForString(name, nameChars,
/*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- name[nameChars] = savedChar; /* restore the saved char */
+ name[nameChars] = savedChar;
TclEmitPush(objIndex, envPtr);
maxDepth = 1;
}
@@ -2885,11 +3288,11 @@ TclCompileDollarVar(interp, string, lastChar, flags, envPtr)
* just as is done for quoted strings.
*/
- src++; /* advance over the '(' */
+ src++;
envPtr->pushSimpleWords = 1;
result = TclCompileQuotes(interp, src, lastChar, ')', flags,
envPtr);
- src += envPtr->termOffset; /* advance beyond the terminating ) */
+ src += envPtr->termOffset;
if (result != TCL_OK) {
char msg[200];
sprintf(msg, "\n (parsing index for array \"%.*s\")",
@@ -3122,7 +3525,7 @@ TclCompileCatchCmd(interp, string, lastChar, flags, envPtr)
if (*p == '(') {
if (*lastChar == ')') { /* we have an array element */
result = TCL_OUT_LINE_COMPILE;
- goto done; /* only scalar loop vars for now */
+ goto done;
}
}
p++;
@@ -3165,11 +3568,11 @@ TclCompileCatchCmd(interp, string, lastChar, flags, envPtr)
bodyStart = argInfo.startArray[0];
bodyEnd = argInfo.endArray[0];
- savedChar = *(bodyEnd+1); /* save char after body */
+ savedChar = *(bodyEnd+1);
*(bodyEnd+1) = '\0';
result = CompileCmdWordInline(interp, bodyStart, (bodyEnd+1),
flags, envPtr);
- *(bodyEnd+1) = savedChar; /* restore the saved char */
+ *(bodyEnd+1) = savedChar;
if (result != TCL_OK) {
if (result == TCL_ERROR) {
@@ -3199,7 +3602,7 @@ TclCompileCatchCmd(interp, string, lastChar, flags, envPtr)
TclEmitInstUInt4(INST_STORE_SCALAR4, localIndex, envPtr);
}
}
- TclEmitOpcode(INST_POP, envPtr); /* pop the result */
+ TclEmitOpcode(INST_POP, envPtr);
objIndex = TclObjIndexForString("0", 1, /*allocStrRep*/ 0, /*inHeap*/ 0,
envPtr);
@@ -3224,14 +3627,7 @@ TclCompileCatchCmd(interp, string, lastChar, flags, envPtr)
* catch's error target.
*/
-#ifdef TCL_COMPILE_DEBUG
- if (envPtr->excRangeArrayPtr[range].type != CATCH_EXCEPTION_RANGE) {
- panic("TclCompileCatchCmd: bad body ExceptionRange type %d\n",
- envPtr->excRangeArrayPtr[range].type);
- }
-#endif /*TCL_COMPILE_DEBUG*/
envPtr->excRangeArrayPtr[range].catchOffset = TclCurrCodeOffset();
-
if (localIndex != -1) {
TclEmitOpcode(INST_PUSH_RESULT, envPtr);
if (localIndex <= 255) {
@@ -3239,7 +3635,7 @@ TclCompileCatchCmd(interp, string, lastChar, flags, envPtr)
} else {
TclEmitInstUInt4(INST_STORE_SCALAR4, localIndex, envPtr);
}
- TclEmitOpcode(INST_POP, envPtr); /* pop the result */
+ TclEmitOpcode(INST_POP, envPtr);
}
TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr);
@@ -3405,6 +3801,7 @@ TclCompileExprCmd(interp, string, lastChar, flags, envPtr)
char c;
int savePushSimpleWords = envPtr->pushSimpleWords;
int saveExprIsJustVarRef = envPtr->exprIsJustVarRef;
+ int saveExprIsComparison = envPtr->exprIsComparison;
/*
* Scan the words of the command and record the start and finish of
@@ -3458,10 +3855,10 @@ TclCompileExprCmd(interp, string, lastChar, flags, envPtr)
* Simple case: a single argument word in {}'s.
*/
- *wordEnd = '\0'; /* temporarily replace the '}' by a null */
+ *wordEnd = '\0';
result = TclCompileExpr(interp, (wordStart + 1), wordEnd,
flags, envPtr);
- *wordEnd = '}'; /* restore the '}' */
+ *wordEnd = '}';
envPtr->termOffset = (wordEnd + 1) - string;
envPtr->pushSimpleWords = savePushSimpleWords;
@@ -3529,7 +3926,7 @@ TclCompileExprCmd(interp, string, lastChar, flags, envPtr)
envPtr->excRangeDepth++;
envPtr->maxExcRangeDepth =
- TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth);
+ TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth);
range = CreateExceptionRange(CATCH_EXCEPTION_RANGE, envPtr);
TclEmitInstUInt4(INST_BEGIN_CATCH4, range, envPtr);
@@ -3539,23 +3936,36 @@ TclCompileExprCmd(interp, string, lastChar, flags, envPtr)
envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset();
savedChar = *(last + 1);
- *(last + 1) = '\0'; /* replace term. char with null */
+ *(last + 1) = '\0';
result = TclCompileExpr(interp, first, last + 1, flags, envPtr);
- *(last + 1) = savedChar; /* restore the saved char */
+ *(last + 1) = savedChar;
maxDepth = envPtr->maxStackDepth;
envPtr->excRangeArrayPtr[range].numCodeBytes =
- TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset;
+ TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset;
- if ((envPtr->exprIsJustVarRef) || (result != TCL_OK)) {
+ if ((result != TCL_OK) || (envPtr->exprIsJustVarRef)
+ || (envPtr->exprIsComparison)) {
/*
- * We must call the expr command at runtime since the expression
- * consisted of just a single variable reference (and a second
- * round of substitutions might be needed) or there was a
- * compilation error. Delete the inline code by backing up the
- * code pc and catch index. Note that if there was a compilation
- * error, we can't report the error yet since the expression
- * might be valid after the second round of substitutions.
+ * We must call the expr command at runtime. Either there was a
+ * compilation error or the inline code might fail to give the
+ * correct 2 level substitution semantics.
+ *
+ * The latter can happen if the expression consisted of just a
+ * single variable reference or if the top-level operator in the
+ * expr is a comparison (which might operate on strings). In the
+ * latter case, the expression's code might execute (apparently)
+ * successfully but produce the wrong result. We depend on its
+ * execution failing if a second level of substitutions is
+ * required. This causes the "catch" code we generate around the
+ * inline code to back off to a call on the expr command at
+ * runtime, and this always gives the right 2 level substitution
+ * semantics.
+ *
+ * We delete the inline code by backing up the code pc and catch
+ * index. Note that if there was a compilation error, we can't
+ * report the error yet since the expression might be valid
+ * after the second round of substitutions.
*/
envPtr->codeNext = (envPtr->codeStart + startCodeOffset);
@@ -3579,10 +3989,10 @@ TclCompileExprCmd(interp, string, lastChar, flags, envPtr)
wordStart = argInfo.startArray[i];
wordEnd = argInfo.endArray[i];
savedChar = *(wordEnd + 1);
- *(wordEnd + 1) = '\0'; /* replace term. char with null */
+ *(wordEnd + 1) = '\0';
envPtr->pushSimpleWords = 1;
result = CompileWord(interp, wordStart, wordEnd+1, flags, envPtr);
- *(wordEnd + 1) = savedChar; /* restore the saved char */
+ *(wordEnd + 1) = savedChar;
if (result != TCL_OK) {
break;
}
@@ -3620,13 +4030,6 @@ TclCompileExprCmd(interp, string, lastChar, flags, envPtr)
* target since it, being after the jump, also moved down.
*/
-#ifdef TCL_COMPILE_DEBUG
- if (envPtr->excRangeArrayPtr[range].type != CATCH_EXCEPTION_RANGE) {
- panic("TclCompileExprCmd: bad body ExceptionRange type %d\n",
- envPtr->excRangeArrayPtr[range].type);
- }
-#endif /* TCL_COMPILE_DEBUG */
-
envPtr->excRangeArrayPtr[range].catchOffset += 3;
}
}
@@ -3643,6 +4046,7 @@ TclCompileExprCmd(interp, string, lastChar, flags, envPtr)
}
envPtr->pushSimpleWords = savePushSimpleWords;
envPtr->exprIsJustVarRef = saveExprIsJustVarRef;
+ envPtr->exprIsComparison = saveExprIsComparison;
envPtr->maxStackDepth = maxDepth;
FreeArgInfo(&argInfo);
return result;
@@ -3849,13 +4253,6 @@ TclCompileForCmd(interp, string, lastChar, flags, envPtr)
jumpBackOffset = TclCurrCodeOffset();
jumpBackDist = (jumpBackOffset - testCodeOffset);
-#ifdef TCL_COMPILE_DEBUG
- if (jumpBackDist > MAX_JUMP_DIST) {
- fprintf(stderr, "\nTclCompileForCmd: bad distance %u for unconditional jump\n",
- jumpBackDist);
- panic("TclCompileForCmd: bad distance for unconditional jump");
- }
-#endif /*TCL_COMPILE_DEBUG*/
if (jumpBackDist > 120) {
TclEmitInstInt4(INST_JUMP4, /*offset*/ -jumpBackDist, envPtr);
} else {
@@ -3878,12 +4275,6 @@ TclCompileForCmd(interp, string, lastChar, flags, envPtr)
* record since it also moved down.
*/
-#ifdef TCL_COMPILE_DEBUG
- if (envPtr->excRangeArrayPtr[range1].type != LOOP_EXCEPTION_RANGE) {
- panic("TclCompileForCmd: bad body ExceptionRange type %d\n",
- envPtr->excRangeArrayPtr[range1].type);
- }
-#endif /* TCL_COMPILE_DEBUG */
envPtr->excRangeArrayPtr[range1].codeOffset += 3;
envPtr->excRangeArrayPtr[range1].continueOffset += 3;
envPtr->excRangeArrayPtr[range2].codeOffset += 3;
@@ -3911,12 +4302,6 @@ TclCompileForCmd(interp, string, lastChar, flags, envPtr)
* is the loop's break target.
*/
-#ifdef TCL_COMPILE_DEBUG
- if (envPtr->excRangeArrayPtr[range1].type != LOOP_EXCEPTION_RANGE) {
- panic("TclCompileForCmd: bad body ExceptionRange type %d\n",
- envPtr->excRangeArrayPtr[range1].type);
- }
-#endif /* TCL_COMPILE_DEBUG */
envPtr->excRangeArrayPtr[range1].breakOffset =
envPtr->excRangeArrayPtr[range2].breakOffset = TclCurrCodeOffset();
@@ -3928,7 +4313,7 @@ TclCompileForCmd(interp, string, lastChar, flags, envPtr)
envPtr);
TclEmitPush(objIndex, envPtr);
if (maxDepth == 0) {
- maxDepth = 1; /* since we just pushed one object */
+ maxDepth = 1;
}
done:
@@ -4104,11 +4489,11 @@ TclCompileForeachCmd(interp, string, lastChar, flags, envPtr)
* NOTE: THIS NEEDS TO BE CONVERTED TO AN OBJECT LIST.
*/
- savedChar = *(varListEnd+1); /* save char after var list */
+ savedChar = *(varListEnd+1);
*(varListEnd+1) = '\0';
result = Tcl_SplitList(interp, varListStart,
&varcList[i], &varvList[i]);
- *(varListEnd+1) = savedChar; /* restore the saved char */
+ *(varListEnd+1) = savedChar;
if (result != TCL_OK) {
goto done;
}
@@ -4135,7 +4520,7 @@ TclCompileForeachCmd(interp, string, lastChar, flags, envPtr)
q--;
if (*q == ')') { /* we have an array element */
result = TCL_OUT_LINE_COMPILE;
- goto done; /* only scalar loop vars for now */
+ goto done;
}
}
p++;
@@ -4224,7 +4609,7 @@ TclCompileForeachCmd(interp, string, lastChar, flags, envPtr)
} else {
TclEmitInstUInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
}
- TclEmitOpcode(INST_POP, envPtr); /* no longer need list on the stk */
+ TclEmitOpcode(INST_POP, envPtr);
}
/*
@@ -4257,12 +4642,12 @@ TclCompileForeachCmd(interp, string, lastChar, flags, envPtr)
bodyStart = argInfo.startArray[numWords - 1];
bodyEnd = argInfo.endArray[numWords - 1];
- savedChar = *(bodyEnd+1); /* save char after body */
+ savedChar = *(bodyEnd+1);
*(bodyEnd+1) = '\0';
envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset();
result = CompileCmdWordInline(interp, bodyStart, bodyEnd+1, flags,
envPtr);
- *(bodyEnd+1) = savedChar; /* restore the saved char */
+ *(bodyEnd+1) = savedChar;
if (result != TCL_OK) {
if (result == TCL_ERROR) {
char msg[60];
@@ -4293,12 +4678,6 @@ TclCompileForeachCmd(interp, string, lastChar, flags, envPtr)
jumpBackOffset = TclCurrCodeOffset();
jumpBackDist =
(jumpBackOffset - envPtr->excRangeArrayPtr[range].continueOffset);
-#ifdef TCL_COMPILE_DEBUG
- if (jumpBackDist > MAX_JUMP_DIST) {
- fprintf(stderr, "\nTclCompileForeachCmd: bad distance %u for unconditional jump\n", jumpBackDist);
- panic("TclCompileForeachCmd: bad distance for unconditional jump");
- }
-#endif /*TCL_COMPILE_DEBUG*/
if (jumpBackDist > 120) {
TclEmitInstInt4(INST_JUMP4, /*offset*/ -jumpBackDist, envPtr);
} else {
@@ -4318,12 +4697,6 @@ TclCompileForeachCmd(interp, string, lastChar, flags, envPtr)
* Update the loop body's starting PC offset since it moved down.
*/
-#ifdef TCL_COMPILE_DEBUG
- if (envPtr->excRangeArrayPtr[range].type != LOOP_EXCEPTION_RANGE) {
- panic("TclCompileForeachCmd: bad body ExceptionRange type %d\n",
- envPtr->excRangeArrayPtr[range].type);
- }
-#endif /*TCL_COMPILE_DEBUG*/
envPtr->excRangeArrayPtr[range].codeOffset += 3;
/*
@@ -4349,12 +4722,6 @@ TclCompileForeachCmd(interp, string, lastChar, flags, envPtr)
* break target.
*/
-#ifdef TCL_COMPILE_DEBUG
- if (envPtr->excRangeArrayPtr[range].type != LOOP_EXCEPTION_RANGE) {
- panic("TclCompileForeachCmd: bad body ExceptionRange type %d\n",
- envPtr->excRangeArrayPtr[range].type);
- }
-#endif /*TCL_COMPILE_DEBUG*/
envPtr->excRangeArrayPtr[range].breakOffset = TclCurrCodeOffset();
/*
@@ -4365,7 +4732,7 @@ TclCompileForeachCmd(interp, string, lastChar, flags, envPtr)
envPtr);
TclEmitPush(objIndex, envPtr);
if (maxDepth == 0) {
- maxDepth = 1; /* since we just pushed one object */
+ maxDepth = 1;
}
done:
@@ -4541,7 +4908,7 @@ TclCompileIfCmd(interp, string, lastChar, flags, envPtr)
* a script to execute if the expression is true.
*/
- AdvanceToNextWord(src, envPtr); /* make sure there is a next word */
+ AdvanceToNextWord(src, envPtr);
src += envPtr->termOffset;
type = CHAR_TYPE(src, lastChar);
if (type == TCL_COMMAND_END) {
@@ -4557,7 +4924,7 @@ TclCompileIfCmd(interp, string, lastChar, flags, envPtr)
*/
testSrcStart = src;
- envPtr->pushSimpleWords = 1; /* process words normally */
+ envPtr->pushSimpleWords = 1;
result = CompileExprWord(interp, src, lastChar, flags, envPtr);
if (result != TCL_OK) {
if (result == TCL_ERROR) {
@@ -4602,7 +4969,7 @@ TclCompileIfCmd(interp, string, lastChar, flags, envPtr)
if ((*src == 't') && (strncmp(src, "then", 4) == 0)) {
type = CHAR_TYPE(src+4, lastChar);
if ((type == TCL_SPACE) || (type == TCL_COMMAND_END)) {
- src += 4; /* skip over the "then" */
+ src += 4;
AdvanceToNextWord(src, envPtr);
src += envPtr->termOffset;
type = CHAR_TYPE(src, lastChar);
@@ -4623,7 +4990,10 @@ TclCompileIfCmd(interp, string, lastChar, flags, envPtr)
result = CompileCmdWordInline(interp, src, lastChar, flags, envPtr);
if (result != TCL_OK) {
if (result == TCL_ERROR) {
- Tcl_AddObjErrorInfo(interp, "\n (\"if\" body script)", -1);
+ char msg[60];
+ sprintf(msg, "\n (\"if\" then script line %d)",
+ interp->errorLine);
+ Tcl_AddObjErrorInfo(interp, msg, -1);
}
goto done;
}
@@ -4676,7 +5046,7 @@ TclCompileIfCmd(interp, string, lastChar, flags, envPtr)
&& ((*src == 'e') && (strncmp(src, "elseif", 6) == 0))) {
type = CHAR_TYPE(src+6, lastChar);
if ((type == TCL_SPACE) || (type == TCL_COMMAND_END)) {
- src += 6; /* skip over the "elseif" */
+ src += 6;
AdvanceToNextWord(src, envPtr);
src += envPtr->termOffset;
type = CHAR_TYPE(src, lastChar);
@@ -4690,7 +5060,7 @@ TclCompileIfCmd(interp, string, lastChar, flags, envPtr)
continue; /* continue the "expr then body" loop */
}
}
- break; /* exit the loop */
+ break;
} /* end of the "expr then body" loop */
/*
@@ -4702,7 +5072,7 @@ TclCompileIfCmd(interp, string, lastChar, flags, envPtr)
if ((*src == 'e') && (strncmp(src, "else", 4) == 0)) {
type = CHAR_TYPE(src+4, lastChar);
if ((type == TCL_SPACE) || (type == TCL_COMMAND_END)) {
- src += 4; /* skip over the "else" */
+ src += 4;
AdvanceToNextWord(src, envPtr);
src += envPtr->termOffset;
type = CHAR_TYPE(src, lastChar);
@@ -4723,7 +5093,10 @@ TclCompileIfCmd(interp, string, lastChar, flags, envPtr)
result = CompileCmdWordInline(interp, src, lastChar, flags, envPtr);
if (result != TCL_OK) {
if (result == TCL_ERROR) {
- Tcl_AddObjErrorInfo(interp, "\n (\"if\" else script)", -1);
+ char msg[60];
+ sprintf(msg, "\n (\"if\" else script line %d)",
+ interp->errorLine);
+ Tcl_AddObjErrorInfo(interp, msg, -1);
}
goto done;
}
@@ -4780,13 +5153,13 @@ TclCompileIfCmd(interp, string, lastChar, flags, envPtr)
ifFalsePc = (envPtr->codeStart + jumpFalseFixupArray.fixup[jumpIndex].codeOffset);
opCode = *ifFalsePc;
if (opCode == INST_JUMP_FALSE1) {
- jumpFalseDist = TclGetInt1AtPc(ifFalsePc + 1);
+ jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1);
jumpFalseDist += 3;
- TclUpdateInt1AtPc(jumpFalseDist, (ifFalsePc + 1));
+ TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1));
} else if (opCode == INST_JUMP_FALSE4) {
- jumpFalseDist = TclGetInt4AtPc(ifFalsePc + 1);
+ jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1);
jumpFalseDist += 3;
- TclUpdateInt4AtPc(jumpFalseDist, (ifFalsePc + 1));
+ TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1));
} else {
panic("TclCompileIfCmd: unexpected opcode updating ifFalse jump");
}
@@ -4886,7 +5259,7 @@ TclCompileIncrCmd(interp, string, lastChar, flags, envPtr)
* an optional "elName". Otherwise, if not simple, just push the name.
*/
- AdvanceToNextWord(src, envPtr); /* make sure there is a next word */
+ AdvanceToNextWord(src, envPtr);
src += envPtr->termOffset;
type = CHAR_TYPE(src, lastChar);
if (type == TCL_COMMAND_END) {
@@ -4898,7 +5271,7 @@ TclCompileIncrCmd(interp, string, lastChar, flags, envPtr)
goto done;
}
- envPtr->pushSimpleWords = 0; /* we will process the varName */
+ envPtr->pushSimpleWords = 0;
result = CompileWord(interp, src, lastChar, flags, envPtr);
if (result != TCL_OK) {
goto done;
@@ -4908,7 +5281,7 @@ TclCompileIncrCmd(interp, string, lastChar, flags, envPtr)
name = src;
nameChars = envPtr->numSimpleWordChars;
if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) {
- name++; /* advance over the " or { */
+ name++;
}
elName = NULL;
elNameChars = 0;
@@ -4955,11 +5328,11 @@ TclCompileIncrCmd(interp, string, lastChar, flags, envPtr)
if (simpleVarName) {
if (procPtr == NULL) {
- savedChar = name[nameChars]; /* save char after name */
+ savedChar = name[nameChars];
name[nameChars] = '\0';
objIndex = TclObjIndexForString(name, nameChars,
/*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- name[nameChars] = savedChar; /* restore the saved char */
+ name[nameChars] = savedChar;
TclEmitPush(objIndex, envPtr);
maxDepth = 1;
} else {
@@ -4970,11 +5343,11 @@ TclCompileIncrCmd(interp, string, lastChar, flags, envPtr)
if (localIndex > 255) { /* we'll push the name */
localIndex = -1;
}
- savedChar = name[nameChars]; /* save char after name */
+ savedChar = name[nameChars];
name[nameChars] = '\0';
objIndex = TclObjIndexForString(name, nameChars,
/*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- name[nameChars] = savedChar; /* restore the saved char */
+ name[nameChars] = savedChar;
TclEmitPush(objIndex, envPtr);
maxDepth = 1;
} else {
@@ -4988,12 +5361,12 @@ TclCompileIncrCmd(interp, string, lastChar, flags, envPtr)
* substitutions on it, just as is done for quoted strings.
*/
- savedChar = elName[elNameChars]; /* save char after elName */
+ savedChar = elName[elNameChars];
elName[elNameChars] = '\0';
envPtr->pushSimpleWords = 1;
result = TclCompileQuotes(interp, elName, elName+elNameChars,
0, flags, envPtr);
- elName[elNameChars] = savedChar; /* restore the saved char */
+ elName[elNameChars] = savedChar;
if (result != TCL_OK) {
char msg[200];
sprintf(msg, "\n (parsing index for array \"%.*s\")",
@@ -5011,17 +5384,17 @@ TclCompileIncrCmd(interp, string, lastChar, flags, envPtr)
if (incrementGiven) {
type = CHAR_TYPE(src, lastChar);
- envPtr->pushSimpleWords = 0; /* we will handle simple words */
+ envPtr->pushSimpleWords = 0;
result = CompileWord(interp, src, lastChar, flags, envPtr);
if (result != TCL_OK) {
if (result == TCL_ERROR) {
Tcl_AddObjErrorInfo(interp,
- "\n (reading increment)", -1);
+ "\n (increment expression)", -1);
}
goto done;
}
if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) {
- src++; /* advance over the " or { */
+ src++;
}
if (envPtr->wordIsSimple) {
/*
@@ -5040,7 +5413,8 @@ TclCompileIncrCmd(interp, string, lastChar, flags, envPtr)
src[numChars] = '\0';
if (TclLooksLikeInt(src)) {
- if (TclGetLong(interp, src, &n) == TCL_OK) {
+ int code = TclGetLong(interp, src, &n);
+ if (code == TCL_OK) {
if ((-127 <= n) && (n <= 127)) {
isCompilableInt = 1;
isImmIncrValue = 1;
@@ -5062,6 +5436,8 @@ TclCompileIncrCmd(interp, string, lastChar, flags, envPtr)
maxDepth += 1;
}
}
+ } else {
+ Tcl_ResetResult(interp);
}
}
if (!isCompilableInt) {
@@ -5070,7 +5446,7 @@ TclCompileIncrCmd(interp, string, lastChar, flags, envPtr)
TclEmitPush(objIndex, envPtr);
maxDepth += 1;
}
- src[numChars] = savedChar; /* restore the saved char */
+ src[numChars] = savedChar;
} else {
maxDepth += envPtr->maxStackDepth;
}
@@ -5088,10 +5464,6 @@ TclCompileIncrCmd(interp, string, lastChar, flags, envPtr)
* Now emit instructions to increment the variable.
*/
- if ((localIndex >= 0) && (localIndex > 255)) {
- panic("TclCompileIncrCmd: bad localIndex %d\n", localIndex);
- return TCL_ERROR;
- }
if (simpleVarName) {
if (elName == NULL) { /* scalar */
if (localIndex >= 0) {
@@ -5146,7 +5518,7 @@ TclCompileIncrCmd(interp, string, lastChar, flags, envPtr)
src += envPtr->termOffset;
type = CHAR_TYPE(src, lastChar);
if (type != TCL_COMMAND_END) {
- goto badArgs; /* too many arguments */
+ goto badArgs;
}
}
@@ -5263,7 +5635,7 @@ TclCompileSetCmd(interp, string, lastChar, flags, envPtr)
* runtime.
*/
- envPtr->pushSimpleWords = 0; /* we will process the varName */
+ envPtr->pushSimpleWords = 0;
result = CompileWord(interp, wordStart, argInfo.endArray[0] + 1,
flags, envPtr);
if (result != TCL_OK) {
@@ -5344,11 +5716,11 @@ TclCompileSetCmd(interp, string, lastChar, flags, envPtr)
*/
if ((procPtr == NULL) || nameHasNsSeparators) {
- savedChar = name[nameChars]; /* save char after name */
+ savedChar = name[nameChars];
name[nameChars] = '\0';
objIndex = TclObjIndexForString(name, nameChars,
/*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- name[nameChars] = savedChar; /* restore the saved char */
+ name[nameChars] = savedChar;
TclEmitPush(objIndex, envPtr);
maxDepth = 1;
} else {
@@ -5360,11 +5732,11 @@ TclCompileSetCmd(interp, string, lastChar, flags, envPtr)
if (localIndex >= 0) {
maxDepth = 0;
} else {
- savedChar = name[nameChars]; /* save char after name */
+ savedChar = name[nameChars];
name[nameChars] = '\0';
objIndex = TclObjIndexForString(name, nameChars,
/*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- name[nameChars] = savedChar; /* restore the saved char */
+ name[nameChars] = savedChar;
TclEmitPush(objIndex, envPtr);
maxDepth = 1;
}
@@ -5377,12 +5749,12 @@ TclCompileSetCmd(interp, string, lastChar, flags, envPtr)
*/
if (elName != NULL) {
- savedChar = elName[elNameChars]; /* save char after elName */
+ savedChar = elName[elNameChars];
elName[elNameChars] = '\0';
envPtr->pushSimpleWords = 1;
result = TclCompileQuotes(interp, elName, elName+elNameChars,
0, flags, envPtr);
- elName[elNameChars] = savedChar; /* restore the saved char */
+ elName[elNameChars] = savedChar;
if (result != TCL_OK) {
char msg[200];
sprintf(msg, "\n (parsing index for array \"%.*s\")",
@@ -5425,13 +5797,14 @@ TclCompileSetCmd(interp, string, lastChar, flags, envPtr)
p = wordStart;
if ((*wordStart == '"') || (*wordStart == '{')) {
- p++; /* advance over the " or { */
+ p++;
}
savedChar = p[envPtr->numSimpleWordChars];
p[envPtr->numSimpleWordChars] = '\0';
isCompilableInt = 0;
if (TclLooksLikeInt(p)) {
- if (TclGetLong(interp, p, &n) == TCL_OK) {
+ int code = TclGetLong(interp, p, &n);
+ if (code == TCL_OK) {
TclFormatInt(buf, n);
if (strcmp(p, buf) == 0) {
isCompilableInt = 1;
@@ -5444,6 +5817,8 @@ TclCompileSetCmd(interp, string, lastChar, flags, envPtr)
objPtr->internalRep.longValue = n;
objPtr->typePtr = &tclIntType;
}
+ } else {
+ Tcl_ResetResult(interp);
}
}
if (!isCompilableInt) {
@@ -5451,7 +5826,7 @@ TclCompileSetCmd(interp, string, lastChar, flags, envPtr)
envPtr->numSimpleWordChars, /*allocStrRep*/ 1,
/*inHeap*/ 0, envPtr);
}
- p[envPtr->numSimpleWordChars] = savedChar; /* restore char */
+ p[envPtr->numSimpleWordChars] = savedChar;
TclEmitPush(objIndex, envPtr);
maxDepth += 1;
}
@@ -5575,7 +5950,7 @@ TclCompileWhileCmd(interp, string, lastChar, flags, envPtr)
range = CreateExceptionRange(LOOP_EXCEPTION_RANGE, envPtr);
envPtr->excRangeArrayPtr[range].continueOffset = TclCurrCodeOffset();
- AdvanceToNextWord(src, envPtr); /* make sure there is a next word */
+ AdvanceToNextWord(src, envPtr);
src += envPtr->termOffset;
type = CHAR_TYPE(src, lastChar);
if (type == TCL_COMMAND_END) {
@@ -5605,7 +5980,7 @@ TclCompileWhileCmd(interp, string, lastChar, flags, envPtr)
* Compile the next word: the test expression.
*/
- envPtr->pushSimpleWords = 1; /* process words normally */
+ envPtr->pushSimpleWords = 1;
result = CompileExprWord(interp, src, lastChar, flags, envPtr);
if (result != TCL_OK) {
if (result == TCL_ERROR) {
@@ -5630,7 +6005,7 @@ TclCompileWhileCmd(interp, string, lastChar, flags, envPtr)
* starting PC offset and byte length in the its ExceptionRange record.
*/
- AdvanceToNextWord(src, envPtr); /* make sure there is a next word */
+ AdvanceToNextWord(src, envPtr);
src += envPtr->termOffset;
type = CHAR_TYPE(src, lastChar);
if (type == TCL_COMMAND_END) {
@@ -5670,12 +6045,6 @@ TclCompileWhileCmd(interp, string, lastChar, flags, envPtr)
jumpBackOffset = TclCurrCodeOffset();
jumpBackDist =
(jumpBackOffset - envPtr->excRangeArrayPtr[range].continueOffset);
-#ifdef TCL_COMPILE_DEBUG
- if (jumpBackDist > MAX_JUMP_DIST) {
- fprintf(stderr, "\nTclCompileWhileCmd: bad distance %u for unconditional jump\n", jumpBackDist);
- panic("TclCompileWhileCmd: bad distance for unconditional jump");
- }
-#endif /*TCL_COMPILE_DEBUG*/
if (jumpBackDist > 120) {
TclEmitInstInt4(INST_JUMP4, /*offset*/ -jumpBackDist, envPtr);
} else {
@@ -5695,12 +6064,6 @@ TclCompileWhileCmd(interp, string, lastChar, flags, envPtr)
* Update the loop body's starting PC offset since it moved down.
*/
-#ifdef TCL_COMPILE_DEBUG
- if (envPtr->excRangeArrayPtr[range].type != LOOP_EXCEPTION_RANGE) {
- panic("TclCompileWhileCmd: bad body ExceptionRange type %d\n",
- envPtr->excRangeArrayPtr[range].type);
- }
-#endif /* TCL_COMPILE_DEBUG */
envPtr->excRangeArrayPtr[range].codeOffset += 3;
/*
@@ -5726,12 +6089,6 @@ TclCompileWhileCmd(interp, string, lastChar, flags, envPtr)
* break target.
*/
-#ifdef TCL_COMPILE_DEBUG
- if (envPtr->excRangeArrayPtr[range].type != LOOP_EXCEPTION_RANGE) {
- panic("TclCompileWhileCmd: bad body ExceptionRange type %d\n",
- envPtr->excRangeArrayPtr[range].type);
- }
-#endif /* TCL_COMPILE_DEBUG */
envPtr->excRangeArrayPtr[range].breakOffset = TclCurrCodeOffset();
/*
@@ -5742,7 +6099,7 @@ TclCompileWhileCmd(interp, string, lastChar, flags, envPtr)
envPtr);
TclEmitPush(objIndex, envPtr);
if (maxDepth == 0) {
- maxDepth = 1; /* since we just pushed one object */
+ maxDepth = 1;
}
/*
@@ -5755,7 +6112,7 @@ TclCompileWhileCmd(interp, string, lastChar, flags, envPtr)
src += envPtr->termOffset;
type = CHAR_TYPE(src, lastChar);
if (type != TCL_COMMAND_END) {
- goto badArgs; /* too many arguments */
+ goto badArgs;
}
}
@@ -5827,6 +6184,7 @@ CompileExprWord(interp, string, lastChar, flags, envPtr)
char c;
int savePushSimpleWords = envPtr->pushSimpleWords;
int saveExprIsJustVarRef = envPtr->exprIsJustVarRef;
+ int saveExprIsComparison = envPtr->exprIsComparison;
int numChars, result;
/*
@@ -5872,7 +6230,7 @@ CompileExprWord(interp, string, lastChar, flags, envPtr)
first = src+1;
src = TclWordEnd(src, lastChar, nestedCmd, NULL);
- if (*src == 0) { /* word doesn't end properly. */
+ if (*src == 0) {
goto badArgs;
}
if (*src != '}') {
@@ -5882,12 +6240,12 @@ CompileExprWord(interp, string, lastChar, flags, envPtr)
numChars = (last - first + 1);
savedChar = first[numChars];
- first[numChars] = '\0'; /* replace term. char with null */
+ first[numChars] = '\0';
result = TclCompileExpr(interp, first, first+numChars,
flags, envPtr);
- first[numChars] = savedChar; /* restore the saved char */
+ first[numChars] = savedChar;
- src++; /* advance src after terminating '}' */
+ src++;
maxDepth = envPtr->maxStackDepth;
} else {
/*
@@ -5945,24 +6303,36 @@ CompileExprWord(interp, string, lastChar, flags, envPtr)
envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset();
numChars = (last - first + 1);
savedChar = first[numChars];
- first[numChars] = '\0'; /* replace term. char with null */
+ first[numChars] = '\0';
result = TclCompileExpr(interp, first, first + numChars,
flags, envPtr);
- first[numChars] = savedChar; /* restore the saved char */
+ first[numChars] = savedChar;
envPtr->excRangeArrayPtr[range].numCodeBytes =
TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset;
- if ((envPtr->exprIsJustVarRef) || (result != TCL_OK)) {
+ if ((result != TCL_OK) || (envPtr->exprIsJustVarRef)
+ || (envPtr->exprIsComparison)) {
/*
- * We must call the expr command at runtime since the
- * expression consisted of just a single variable reference
- * (and a second round of substitutions might be needed) or
- * there was a compilation error. Delete the inline code by
- * backing up the code pc and catch index. Note that if
- * there was a compilation error, we can't report the error
- * yet since the expression might be valid after the second
- * round of substitutions.
+ * We must call the expr command at runtime. Either there
+ * was a compilation error or the inline code might fail to
+ * give the correct 2 level substitution semantics.
+ *
+ * The latter can happen if the expression consisted of just
+ * a single variable reference or if the top-level operator
+ * in the expr is a comparison (which might operate on
+ * strings). In the latter case, the expression's code might
+ * execute (apparently) successfully but produce the wrong
+ * result. We depend on its execution failing if a second
+ * level of substitutions is required. This causes the
+ * "catch" code we generate around the inline code to back
+ * off to a call on the expr command at runtime, and this
+ * always gives the right 2 level substitution semantics.
+ *
+ * We delete the inline code by backing up the code pc and
+ * catch index. Note that if there was a compilation error,
+ * we can't report the error yet since the expression might
+ * be valid after the second round of substitutions.
*/
envPtr->codeNext = (envPtr->codeStart + startCodeOffset);
@@ -6001,13 +6371,6 @@ CompileExprWord(interp, string, lastChar, flags, envPtr)
* target since it, being after the jump, also moved down.
*/
-#ifdef TCL_COMPILE_DEBUG
- if (envPtr->excRangeArrayPtr[range].type != CATCH_EXCEPTION_RANGE) {
- panic("CompileExprWord: bad body ExceptionRange type %d\n",
- envPtr->excRangeArrayPtr[range].type);
- }
-#endif /* TCL_COMPILE_DEBUG */
-
envPtr->excRangeArrayPtr[range].catchOffset += 3;
}
}
@@ -6018,6 +6381,7 @@ CompileExprWord(interp, string, lastChar, flags, envPtr)
envPtr->maxStackDepth = maxDepth;
envPtr->pushSimpleWords = savePushSimpleWords;
envPtr->exprIsJustVarRef = saveExprIsJustVarRef;
+ envPtr->exprIsComparison = saveExprIsComparison;
return result;
}
@@ -6079,8 +6443,8 @@ CompileCmdWordInline(interp, string, lastChar, flags, envPtr)
type = CHAR_TYPE(src, lastChar);
if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) {
- src++; /* advance over the " or { */
- envPtr->pushSimpleWords = 0; /* we process a simple word below */
+ src++;
+ envPtr->pushSimpleWords = 0;
if (type == TCL_QUOTE) {
result = TclCompileQuotes(interp, src, lastChar,
'"', flags, envPtr);
@@ -6132,7 +6496,7 @@ CompileCmdWordInline(interp, string, lastChar, flags, envPtr)
*closeCharPos = '\0';
result = TclCompileString(interp, src, closeCharPos,
(flags & ~TCL_BRACKET_TERM), envPtr);
- *closeCharPos = savedChar; /* restore the saved char */
+ *closeCharPos = savedChar;
if (result != TCL_OK) {
goto done;
}
@@ -6168,7 +6532,7 @@ CompileCmdWordInline(interp, string, lastChar, flags, envPtr)
Tcl_Command cmd;
Command *cmdPtr = NULL;
- int wasCompiled = 0; /* set 1 if word has compile proc. */
+ int wasCompiled = 0;
savedChar = *p;
*p = '\0';
@@ -6179,7 +6543,7 @@ CompileCmdWordInline(interp, string, lastChar, flags, envPtr)
cmdPtr = (Command *) cmd;
}
if (cmdPtr != NULL && cmdPtr->compileProc != NULL) {
- *p = savedChar; /* restore the saved char */
+ *p = savedChar;
src = p;
iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS
| ERROR_CODE_SET);
@@ -6194,7 +6558,7 @@ CompileCmdWordInline(interp, string, lastChar, flags, envPtr)
if (!wasCompiled) {
objIndex = TclObjIndexForString(src, p-src,
/*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
- *p = savedChar; /* restore the saved char */
+ *p = savedChar;
TclEmitPush(objIndex, envPtr);
TclEmitInstUInt1(INST_INVOKE_STK1, 1, envPtr);
src = p;
@@ -6205,7 +6569,7 @@ CompileCmdWordInline(interp, string, lastChar, flags, envPtr)
* Push the word and call eval at runtime.
*/
- envPtr->pushSimpleWords = 1; /* process words normally */
+ envPtr->pushSimpleWords = 1;
result = CompileWord(interp, src, lastChar, flags, envPtr);
if (result != TCL_OK) {
goto done;
@@ -6312,7 +6676,7 @@ LookupCompiledLocal(name, nameChars, createIfNew, flagsIfCreated, procPtr)
localPtr->flags = flagsIfCreated;
localPtr->defValuePtr = NULL;
if (name != NULL) {
- strncpy(localPtr->name, name, (unsigned) nameChars);
+ memcpy((VOID *) localPtr->name, (VOID *) name, (size_t) nameChars);
}
localPtr->name[nameChars] = '\0';
procPtr->numCompiledLocals++;
@@ -6387,12 +6751,12 @@ AdvanceToNextWord(string, envPtr)
char
Tcl_Backslash(src, readPtr)
- char *src; /* Points to the backslash character of
+ CONST char *src; /* Points to the backslash character of
* a backslash sequence. */
int *readPtr; /* Fill in with number of characters read
* from src, unless NULL. */
{
- register char *p = src+1;
+ CONST char *p = src + 1;
char result;
int count;
@@ -6547,7 +6911,7 @@ TclObjIndexForString(string, length, allocStrRep, inHeap, envPtr)
if (!new) { /* already in object table and array */
objIndex = (int) Tcl_GetHashValue(hPtr);
if (inHeap) {
- ckfree(string); /* since we own the string */
+ ckfree(string);
}
return objIndex;
}
@@ -6562,17 +6926,18 @@ TclObjIndexForString(string, length, allocStrRep, inHeap, envPtr)
if (allocStrRep) {
if (inHeap) { /* use input string for obj's string rep */
objPtr->bytes = string;
- } else { /* must allocate string rep */
+ } else {
if (length > 0) {
objPtr->bytes = ckalloc((unsigned) length + 1);
- memcpy(objPtr->bytes, string, (size_t) length);
+ memcpy((VOID *) objPtr->bytes, (VOID *) string,
+ (size_t) length);
objPtr->bytes[length] = '\0';
}
}
objPtr->length = length;
} else { /* leave the string rep NULL */
if (inHeap) {
- ckfree(string); /* since we own the string */
+ ckfree(string);
}
}
@@ -6581,7 +6946,7 @@ TclObjIndexForString(string, length, allocStrRep, inHeap, envPtr)
}
objIndex = envPtr->objArrayNext;
envPtr->objArrayPtr[objIndex] = objPtr;
- Tcl_IncrRefCount(objPtr); /* since obj array now has a reference */
+ Tcl_IncrRefCount(objPtr);
envPtr->objArrayNext++;
if (hPtr) {
@@ -6754,10 +7119,16 @@ EnterCmdStartData(envPtr, cmdIndex, srcOffset, codeOffset)
envPtr->mallocedCmdMap = 1;
}
+ if (cmdIndex > 0) {
+ if (codeOffset < envPtr->cmdMapPtr[cmdIndex-1].codeOffset) {
+ panic("EnterCmdStartData: cmd map table not sorted by code offset");
+ }
+ }
+
cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]);
+ cmdLocPtr->codeOffset = codeOffset;
cmdLocPtr->srcOffset = srcOffset;
cmdLocPtr->numSrcChars = -1;
- cmdLocPtr->codeOffset = codeOffset;
cmdLocPtr->numCodeBytes = -1;
}
@@ -6766,7 +7137,7 @@ EnterCmdStartData(envPtr, cmdIndex, srcOffset, codeOffset)
*
* EnterCmdExtentData --
*
- * Registers the source and bytecode length of a command. This
+ * Registers the source and bytecode length for a command. This
* information is used at runtime to map between instruction pc and
* source locations.
*
@@ -6895,7 +7266,7 @@ CollectArgInfo(interp, string, lastChar, flags, argInfoPtr)
} else if (*src == '"') {
wordStart = src;
src = TclWordEnd(src, lastChar, nestedCmd, NULL);
- if (src == lastChar) { /* word doesn't end properly. */
+ if (src == lastChar) {
badStringTermination:
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
@@ -6905,9 +7276,9 @@ CollectArgInfo(interp, string, lastChar, flags, argInfoPtr)
prev = (src-1);
if (*src == '"') {
wordEnd = src;
- src++; /* skip over terminating '"' */
+ src++;
} else if ((*src == ';') && (*prev == '"')) {
- scanningArgs = 0; /* found a terminating ';' */
+ scanningArgs = 0;
wordEnd = prev;
} else {
goto badStringTermination;
@@ -6915,7 +7286,7 @@ CollectArgInfo(interp, string, lastChar, flags, argInfoPtr)
} else if (*src == '{') {
wordStart = src;
src = TclWordEnd(src, lastChar, nestedCmd, NULL);
- if (src == lastChar) { /* word doesn't end properly. */
+ if (src == lastChar) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"missing close-brace", -1);
@@ -6924,9 +7295,9 @@ CollectArgInfo(interp, string, lastChar, flags, argInfoPtr)
prev = (src-1);
if (*src == '}') {
wordEnd = src;
- src++; /* skip over terminating '}' */
+ src++;
} else if ((*src == ';') && (*prev == '}')) {
- scanningArgs = 0; /* found a terminating ';' */
+ scanningArgs = 0;
wordEnd = prev;
} else {
Tcl_ResetResult(interp);
@@ -6938,17 +7309,17 @@ CollectArgInfo(interp, string, lastChar, flags, argInfoPtr)
wordStart = src;
src = TclWordEnd(src, lastChar, nestedCmd, NULL);
prev = (src-1);
- if (src == lastChar) { /* word doesn't end properly. */
+ if (src == lastChar) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"missing close-bracket or close-brace", -1);
return TCL_ERROR;
} else if (*src == ';') {
- scanningArgs = 0; /* found a terminating ';' */
+ scanningArgs = 0;
wordEnd = prev;
} else {
wordEnd = src;
- src++; /* advance to char after word */
+ src++;
if ((src == lastChar) || (*src == '\n')
|| ((*src == ']') && nestedCmd)) {
scanningArgs = 0;
@@ -7378,13 +7749,6 @@ TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold)
int firstCmd, lastCmd, firstRange, lastRange, k;
unsigned int numBytes;
-#ifdef TCL_COMPILE_DEBUG
- if (jumpDist > MAX_JUMP_DIST) {
- fprintf(stderr, "\nTclFixupForwardJump: bad jump distance %u\n", jumpDist);
- panic("TclFixupForwardJump: bad jump distance");
- }
-#endif /*TCL_COMPILE_DEBUG*/
-
if (jumpDist <= distThreshold) {
jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset);
switch (jumpFixupPtr->jumpType) {
@@ -7398,7 +7762,7 @@ TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold)
TclUpdateInstInt1AtPc(INST_JUMP_FALSE1, jumpDist, jumpPc);
break;
}
- return 0; /* no need to grow the jump */
+ return 0;
}
/*
diff --git a/contrib/tcl/generic/tclCompile.h b/contrib/tcl/generic/tclCompile.h
index 65bbe42d46e9..6dc3f0348695 100644
--- a/contrib/tcl/generic/tclCompile.h
+++ b/contrib/tcl/generic/tclCompile.h
@@ -6,7 +6,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclCompile.h 1.33 97/05/02 13:12:43
+ * SCCS: @(#) tclCompile.h 1.37 97/08/07 19:11:50
*/
#ifndef _TCLCOMPILATION
@@ -55,11 +55,29 @@ extern int tclTraceCompile;
extern int tclTraceExec;
/*
- * The number of bytecode compilations.
+ * The number of bytecode compilations and various other compilation-related
+ * statistics. The tclByteCodeCount and tclSourceCount arrays are used to
+ * hold the count of ByteCodes and sources whose sizes fall into various
+ * binary decades; e.g., tclByteCodeCount[5] is a count of the ByteCodes
+ * with size larger than 2**4 and less than or equal to 2**5.
*/
#ifdef TCL_COMPILE_STATS
extern long tclNumCompilations;
+extern double tclTotalSourceBytes;
+extern double tclTotalCodeBytes;
+
+extern double tclTotalInstBytes;
+extern double tclTotalObjBytes;
+extern double tclTotalExceptBytes;
+extern double tclTotalAuxBytes;
+extern double tclTotalCmdMapBytes;
+
+extern double tclCurrentSourceBytes;
+extern double tclCurrentCodeBytes;
+
+extern int tclSourceCount[32];
+extern int tclByteCodeCount[32];
#endif /* TCL_COMPILE_STATS */
/*
@@ -115,15 +133,17 @@ typedef struct ExceptionRange {
/*
* Structure used to map between instruction pc and source locations. It
- * defines for each compiled Tcl command the starting and ending offsets for
- * its source and code.
+ * defines for each compiled Tcl command its code's starting offset and
+ * its source's starting offset and length. Note that the code offset
+ * increases monotonically: that is, the table is sorted in code offset
+ * order. The source offset is not monotonic.
*/
typedef struct CmdLocation {
+ int codeOffset; /* Offset of first byte of command code. */
+ int numCodeBytes; /* Number of bytes for command's code. */
int srcOffset; /* Offset of first char of the command. */
int numSrcChars; /* Number of command source chars. */
- int codeOffset; /* Offset of first byte of command code. */
- int numCodeBytes; /* Number of code bytes for command code. */
} CmdLocation;
/*
@@ -222,6 +242,12 @@ typedef struct CompileEnv {
* of "if $b then...". Otherwise 0. Used
* to implement expr's 2 level substitution
* semantics properly. */
+ int exprIsComparison; /* Set 1 if the top-level operator in the
+ * expression last compiled is a comparison.
+ * Otherwise 0. If 1, since the operands
+ * might be strings, the expr is compiled
+ * out-of-line to implement expr's 2 level
+ * substitution semantics properly. */
int termOffset; /* Offset of character just after the last
* one compiled. Set by compilation
* procedures before returning. */
@@ -307,12 +333,17 @@ typedef struct ByteCode {
* pointer is also not owned by the ByteCode
* and must not be freed by it. Used for
* debugging. */
+ size_t totalSize; /* Total number of bytes required for this
+ * ByteCode structure including the storage
+ * for Tcl objects in its object array. */
int numCommands; /* Number of commands compiled. */
int numSrcChars; /* Number of source chars compiled. */
int numCodeBytes; /* Number of code bytes. */
int numObjects; /* Number of Tcl objects in object array. */
int numExcRanges; /* Number of ExceptionRange array elems. */
int numAuxDataItems; /* Number of AuxData items. */
+ int numCmdLocBytes; /* Number of bytes needed for encoded
+ * command location information. */
int maxExcRangeDepth; /* Maximum nesting level of ExceptionRanges;
* -1 if no ranges were compiled. */
int maxStackDepth; /* Maximum number of stack elements needed
@@ -326,13 +357,43 @@ typedef struct ByteCode {
/* Points to the start of the ExceptionRange
* array. This is just after the last
* object in the object array. */
- CmdLocation *cmdMapPtr; /* Points to pc <-> source map: an array of
- * numCommands CmdLocation structures. This
- * is just after the last entry in the
- * ExceptionRange array. */
AuxData *auxDataArrayPtr; /* Points to the start of the auxiliary data
* array. This is just after the last entry
- * in the CmdLocation array. */
+ * in the ExceptionRange array. */
+ unsigned char *codeDeltaStart;
+ /* Points to the first of a sequence of
+ * bytes that encode the change in the
+ * starting offset of each command's code.
+ * If -127<=delta<=127, it is encoded as 1
+ * byte, otherwise 0xFF (128) appears and
+ * the delta is encoded by the next 4 bytes.
+ * Code deltas are always positive. This
+ * sequence is just after the last entry in
+ * the AuxData array. */
+ unsigned char *codeLengthStart;
+ /* Points to the first of a sequence of
+ * bytes that encode the length of each
+ * command's code. The encoding is the same
+ * as for code deltas. Code lengths are
+ * always positive. This sequence is just
+ * after the last entry in the code delta
+ * sequence. */
+ unsigned char *srcDeltaStart;
+ /* Points to the first of a sequence of
+ * bytes that encode the change in the
+ * starting offset of each command's source.
+ * The encoding is the same as for code
+ * deltas. Source deltas can be negative.
+ * This sequence is just after the last byte
+ * in the code length sequence. */
+ unsigned char *srcLengthStart;
+ /* Points to the first of a sequence of
+ * bytes that encode the length of each
+ * command's source. The encoding is the
+ * same as for code deltas. Source lengths
+ * are always positive. This sequence is
+ * just after the last byte in the source
+ * delta sequence. */
} ByteCode;
/*
@@ -709,14 +770,15 @@ EXTERN int TclFixupForwardJump _ANSI_ARGS_((
EXTERN void TclFreeCompileEnv _ANSI_ARGS_((CompileEnv *envPtr));
EXTERN void TclFreeJumpFixupArray _ANSI_ARGS_((
JumpFixupArray *fixupArrayPtr));
-EXTERN int TclGetSrcInfoForPc _ANSI_ARGS_((unsigned char *pc,
- ByteCode* codePtr));
EXTERN void TclInitByteCodeObj _ANSI_ARGS_((Tcl_Obj *objPtr,
CompileEnv *envPtr));
EXTERN void TclInitCompileEnv _ANSI_ARGS_((Tcl_Interp *interp,
CompileEnv *envPtr, char *string));
EXTERN void TclInitJumpFixupArray _ANSI_ARGS_((
JumpFixupArray *fixupArrayPtr));
+#ifdef TCL_COMPILE_STATS
+EXTERN int TclLog2 _ANSI_ARGS_((int value));
+#endif /*TCL_COMPILE_STATS*/
EXTERN int TclObjIndexForString _ANSI_ARGS_((char *start,
int length, int allocStrRep, int inHeap,
CompileEnv *envPtr));
@@ -826,7 +888,7 @@ EXTERN void TclPrintSource _ANSI_ARGS_((FILE *outFile,
/*
* Macro to push a Tcl object onto the Tcl evaluation stack. It emits the
* object's one or four byte array index into the CompileEnv's code
- * array. These support, respectively, a maximum of 256 (2^8) and 2^32
+ * array. These support, respectively, a maximum of 256 (2**8) and 2**32
* objects in a CompileEnv. The ANSI C "prototype" for this macro is:
*
* EXTERN void TclEmitPush _ANSI_ARGS_((int objIndex, CompileEnv *envPtr));
@@ -840,22 +902,22 @@ EXTERN void TclPrintSource _ANSI_ARGS_((FILE *outFile,
}
/*
- * Macros to update a (signed or unsigned) integer starting at a bytecode
- * pc. The two variants depend on the number of bytes. The ANSI C
- * "prototypes" for these macros are:
+ * Macros to update a (signed or unsigned) integer starting at a pointer.
+ * The two variants depend on the number of bytes. The ANSI C "prototypes"
+ * for these macros are:
*
- * EXTERN void TclUpdateInt1AtPc _ANSI_ARGS_((int i, unsigned char *pc));
- * EXTERN void TclUpdateInt4AtPc _ANSI_ARGS_((int i, unsigned char *pc));
+ * EXTERN void TclStoreInt1AtPtr _ANSI_ARGS_((int i, unsigned char *p));
+ * EXTERN void TclStoreInt4AtPtr _ANSI_ARGS_((int i, unsigned char *p));
*/
-#define TclUpdateInt1AtPc(i, pc) \
- *(pc) = (unsigned char) ((unsigned int) (i))
+#define TclStoreInt1AtPtr(i, p) \
+ *(p) = (unsigned char) ((unsigned int) (i))
-#define TclUpdateInt4AtPc(i, pc) \
- *(pc) = (unsigned char) ((unsigned int) (i) >> 24); \
- *(pc+1) = (unsigned char) ((unsigned int) (i) >> 16); \
- *(pc+2) = (unsigned char) ((unsigned int) (i) >> 8); \
- *(pc+3) = (unsigned char) ((unsigned int) (i) )
+#define TclStoreInt4AtPtr(i, p) \
+ *(p) = (unsigned char) ((unsigned int) (i) >> 24); \
+ *(p+1) = (unsigned char) ((unsigned int) (i) >> 16); \
+ *(p+2) = (unsigned char) ((unsigned int) (i) >> 8); \
+ *(p+3) = (unsigned char) ((unsigned int) (i) )
/*
* Macros to update instructions at a particular pc with a new op code
@@ -870,54 +932,54 @@ EXTERN void TclPrintSource _ANSI_ARGS_((FILE *outFile,
#define TclUpdateInstInt1AtPc(op, i, pc) \
*(pc) = (unsigned char) (op); \
- TclUpdateInt1AtPc((i), ((pc)+1))
+ TclStoreInt1AtPtr((i), ((pc)+1))
#define TclUpdateInstInt4AtPc(op, i, pc) \
*(pc) = (unsigned char) (op); \
- TclUpdateInt4AtPc((i), ((pc)+1))
+ TclStoreInt4AtPtr((i), ((pc)+1))
/*
* Macros to get a signed integer (GET_INT{1,2}) or an unsigned int
- * (GET_UINT{1,2}) from a code pc pointer. There are two variants for each
- * return type that depend on the number of bytes fetched from the code
- * sequence. The ANSI C "prototypes" for these macros are:
+ * (GET_UINT{1,2}) from a pointer. There are two variants for each
+ * return type that depend on the number of bytes fetched.
+ * The ANSI C "prototypes" for these macros are:
*
- * EXTERN int TclGetInt1AtPc _ANSI_ARGS_((unsigned char *pc));
- * EXTERN int TclGetInt4AtPc _ANSI_ARGS_((unsigned char *pc));
- * EXTERN unsigned int TclGetUInt1AtPc _ANSI_ARGS_((unsigned char *pc));
- * EXTERN unsigned int TclGetUInt4AtPc _ANSI_ARGS_((unsigned char *pc));
+ * EXTERN int TclGetInt1AtPtr _ANSI_ARGS_((unsigned char *p));
+ * EXTERN int TclGetInt4AtPtr _ANSI_ARGS_((unsigned char *p));
+ * EXTERN unsigned int TclGetUInt1AtPtr _ANSI_ARGS_((unsigned char *p));
+ * EXTERN unsigned int TclGetUInt4AtPtr _ANSI_ARGS_((unsigned char *p));
*/
/*
- * The TclGetInt1AtPc macro is tricky because we want to do sign
+ * The TclGetInt1AtPtr macro is tricky because we want to do sign
* extension on the 1-byte value. Unfortunately the "char" type isn't
* signed on all platforms so sign-extension doesn't always happen
- * automatically. Sometimes we can explicitly declare the pointer to be
+ * automatically. Sometimes we can explicitly declare the pointer to be
* signed, but other times we have to explicitly sign-extend the value
* in software.
*/
#ifndef __CHAR_UNSIGNED__
-# define TclGetInt1AtPc(pc) ((int) *((char *) pc))
+# define TclGetInt1AtPtr(p) ((int) *((char *) p))
#else
# ifdef HAVE_SIGNED_CHAR
-# define TclGetInt1AtPc(pc) ((int) *((signed char *) pc))
+# define TclGetInt1AtPtr(p) ((int) *((signed char *) p))
# else
-# define TclGetInt1AtPc(pc) (((int) *((char *) pc)) \
- | ((*(pc) & 0200) ? (-256) : 0))
+# define TclGetInt1AtPtr(p) (((int) *((char *) p)) \
+ | ((*(p) & 0200) ? (-256) : 0))
# endif
#endif
-#define TclGetInt4AtPc(pc) (((int) TclGetInt1AtPc(pc) << 24) | \
- (*((pc)+1) << 16) | \
- (*((pc)+2) << 8) | \
- (*((pc)+3)))
+#define TclGetInt4AtPtr(p) (((int) TclGetInt1AtPtr(p) << 24) | \
+ (*((p)+1) << 16) | \
+ (*((p)+2) << 8) | \
+ (*((p)+3)))
-#define TclGetUInt1AtPc(pc) ((unsigned int) *(pc))
-#define TclGetUInt4AtPc(pc) ((unsigned int) (*(pc) << 24) | \
- (*((pc)+1) << 16) | \
- (*((pc)+2) << 8) | \
- (*((pc)+3)))
+#define TclGetUInt1AtPtr(p) ((unsigned int) *(p))
+#define TclGetUInt4AtPtr(p) ((unsigned int) (*(p) << 24) | \
+ (*((p)+1) << 16) | \
+ (*((p)+2) << 8) | \
+ (*((p)+3)))
/*
* Macros used to compute the minimum and maximum of two integers.
diff --git a/contrib/tcl/generic/tclEnv.c b/contrib/tcl/generic/tclEnv.c
index f619769d1cb8..8027f5ed76d2 100644
--- a/contrib/tcl/generic/tclEnv.c
+++ b/contrib/tcl/generic/tclEnv.c
@@ -2,7 +2,9 @@
* tclEnv.c --
*
* Tcl support for environment variables, including a setenv
- * procedure.
+ * procedure. This file contains the generic portion of the
+ * environment module. It is primarily responsible for keeping
+ * the "env" arrays in sync with the system environment variables.
*
* Copyright (c) 1991-1994 The Regents of the University of California.
* Copyright (c) 1994-1996 Sun Microsystems, Inc.
@@ -10,21 +12,11 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclEnv.c 1.43 97/05/21 17:10:56
+ * SCCS: @(#) tclEnv.c 1.49 97/08/11 20:22:40
*/
-/*
- * The putenv and setenv definitions below cause any system prototypes for
- * those procedures to be ignored so that there won't be a clash when the
- * versions in this file are compiled.
- */
-
-#define putenv ignore_putenv
-#define setenv ignore_setenv
#include "tclInt.h"
#include "tclPort.h"
-#undef putenv
-#undef setenv
/*
* The structure below is used to keep track of all of the interpereters
@@ -44,25 +36,30 @@ static EnvInterp *firstInterpPtr = NULL;
/* First in list of all managed interpreters,
* or NULL if none. */
-static int environSize = 0; /* Non-zero means that the all of the
- * environ-related information is malloc-ed
- * and the environ array itself has this
- * many total entries allocated to it (not
- * all may be in use at once). Zero means
- * that the environment array is in its
- * original static state. */
+static int cacheSize = 0; /* Number of env strings in environCache. */
+static char **environCache = NULL;
+ /* Array containing all of the environment
+ * strings that Tcl has allocated. */
+
+#ifndef USE_PUTENV
+static int environSize = 0; /* Non-zero means that the environ array was
+ * malloced and has this many total entries
+ * allocated to it (not all may be in use at
+ * once). Zero means that the environment
+ * array is in its original static state. */
+#endif
/*
* Declarations for local procedures defined in this file:
*/
-static void EnvExitProc _ANSI_ARGS_((ClientData clientData));
-static void EnvInit _ANSI_ARGS_((void));
static char * EnvTraceProc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, char *name1, char *name2,
int flags));
static int FindVariable _ANSI_ARGS_((CONST char *name,
int *lengthPtr));
+static void ReplaceString _ANSI_ARGS_((CONST char *oldStr,
+ char *newStr));
void TclSetEnv _ANSI_ARGS_((CONST char *name,
CONST char *value));
void TclUnsetEnv _ANSI_ARGS_((CONST char *name));
@@ -100,14 +97,11 @@ TclSetupEnv(interp)
Tcl_DString ds;
int i, sz;
- /*
- * First, initialize our environment-related information, if
- * necessary.
- */
-
- if (environSize == 0) {
- EnvInit();
+#ifdef MAC_TCL
+ if (environ == NULL) {
+ environSize = TclMacCreateEnv();
}
+#endif
/*
* Next, initialize the DString we are going to use for copying
@@ -170,97 +164,6 @@ TclSetupEnv(interp)
/*
*----------------------------------------------------------------------
*
- * FindVariable --
- *
- * Locate the entry in environ for a given name.
- *
- * Results:
- * The return value is the index in environ of an entry with the
- * name "name", or -1 if there is no such entry. The integer at
- * *lengthPtr is filled in with the length of name (if a matching
- * entry is found) or the length of the environ array (if no matching
- * entry is found).
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-FindVariable(name, lengthPtr)
- CONST char *name; /* Name of desired environment variable. */
- int *lengthPtr; /* Used to return length of name (for
- * successful searches) or number of non-NULL
- * entries in environ (for unsuccessful
- * searches). */
-{
- int i;
- register CONST char *p1, *p2;
-
- for (i = 0, p1 = environ[i]; p1 != NULL; i++, p1 = environ[i]) {
- for (p2 = name; *p2 == *p1; p1++, p2++) {
- /* NULL loop body. */
- }
- if ((*p1 == '=') && (*p2 == '\0')) {
- *lengthPtr = p2-name;
- return i;
- }
- }
- *lengthPtr = i;
- return -1;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclGetEnv --
- *
- * Get an environment variable or return NULL if the variable
- * doesn't exist. This procedure is intended to be a
- * stand-in for the UNIX "getenv" procedure so that applications
- * using that procedure will interface properly to Tcl. To make
- * it a stand-in, the Makefile must define "TclGetEnv" to "getenv".
- *
- * Results:
- * ptr to value on success, NULL if error.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-char *
-TclGetEnv(name)
- char *name; /* Name of desired environment variable. */
-{
- int i;
- size_t len, nameLen;
- char *equal;
-
- nameLen = strlen(name);
- for (i = 0; environ[i] != NULL; i++) {
- equal = strchr(environ[i], '=');
- if (equal == NULL) {
- continue;
- }
- len = (size_t) (equal - environ[i]);
- if ((len == nameLen) && (strncmp(name, environ[i], len) == 0)) {
- /*
- * The caller of this function should regard this
- * as static memory.
- */
- return &environ[i][len+1];
- }
- }
-
- return NULL;
-}
-
-/*
- *----------------------------------------------------------------------
- *
* TclSetEnv --
*
* Set an environment variable, replacing an existing value
@@ -287,12 +190,14 @@ TclSetEnv(name, value)
CONST char *value; /* New value for variable. */
{
int index, length, nameLength;
- char *p;
+ char *p, *oldValue;
EnvInterp *eiPtr;
- if (environSize == 0) {
- EnvInit();
+#ifdef MAC_TCL
+ if (environ == NULL) {
+ environSize = TclMacCreateEnv();
}
+#endif
/*
* Figure out where the entry is going to go. If the name doesn't
@@ -302,6 +207,7 @@ TclSetEnv(name, value)
index = FindVariable(name, &length);
if (index == -1) {
+#ifndef USE_PUTENV
if ((length+2) > environSize) {
char **newEnviron;
@@ -309,12 +215,16 @@ TclSetEnv(name, value)
((length+5) * sizeof(char *)));
memcpy((VOID *) newEnviron, (VOID *) environ,
length*sizeof(char *));
- ckfree((char *) environ);
+ if (environSize != 0) {
+ ckfree((char *) environ);
+ }
environ = newEnviron;
environSize = length+5;
}
index = length;
environ[index+1] = NULL;
+#endif
+ oldValue = NULL;
nameLength = strlen(name);
} else {
/*
@@ -328,35 +238,44 @@ TclSetEnv(name, value)
if (strcmp(value, environ[index]+length+1) == 0) {
return;
}
- ckfree(environ[index]);
+ oldValue = environ[index];
nameLength = length;
}
+
+
+ /*
+ * Update all of the interpreters.
+ */
+
+ for (eiPtr= firstInterpPtr; eiPtr != NULL; eiPtr = eiPtr->nextPtr) {
+ (void) Tcl_SetVar2(eiPtr->interp, "env", (char *) name,
+ (char *) value, TCL_GLOBAL_ONLY);
+ }
/*
- * Create a new entry and enter it into the table.
+ * Create a new entry.
*/
p = (char *) ckalloc((unsigned) (nameLength + strlen(value) + 2));
- environ[index] = p;
strcpy(p, name);
- p += nameLength;
- *p = '=';
- strcpy(p+1, value);
+ p[nameLength] = '=';
+ strcpy(p+nameLength+1, value);
/*
- * Update all of the interpreters.
+ * Update the system environment.
*/
- for (eiPtr= firstInterpPtr; eiPtr != NULL; eiPtr = eiPtr->nextPtr) {
- (void) Tcl_SetVar2(eiPtr->interp, "env", (char *) name,
- p+1, TCL_GLOBAL_ONLY);
- }
+#ifdef USE_PUTENV
+ putenv(p);
+#else
+ environ[index] = p;
+#endif
/*
- * Update the system environment.
+ * Replace the old value with the new value in the cache.
*/
- TclSetSystemEnv(name, value);
+ ReplaceString(oldValue, p);
}
/*
@@ -408,7 +327,7 @@ Tcl_PutEnv(string)
return 0;
}
name = (char *) ckalloc((unsigned) nameLength+1);
- memcpy(name, string, (size_t) nameLength);
+ memcpy((VOID *) name, (VOID *) string, (size_t) nameLength);
name[nameLength] = 0;
TclSetEnv(name, value+1);
ckfree(name);
@@ -439,29 +358,63 @@ void
TclUnsetEnv(name)
CONST char *name; /* Name of variable to remove. */
{
- int index, dummy;
- char **envPtr;
EnvInterp *eiPtr;
+ char *oldValue;
+ int length, index;
+#ifdef USE_PUTENV
+ char *string;
+#else
+ char **envPtr;
+#endif
- if (environSize == 0) {
- EnvInit();
+#ifdef MAC_TCL
+ if (environ == NULL) {
+ environSize = TclMacCreateEnv();
}
+#endif
+
+ index = FindVariable(name, &length);
/*
- * Update the environ array.
+ * First make sure that the environment variable exists to avoid
+ * doing needless work and to avoid recursion on the unset.
*/
-
- index = FindVariable(name, &dummy);
+
if (index == -1) {
return;
}
- ckfree(environ[index]);
+ /*
+ * Remember the old value so we can free it if Tcl created the string.
+ */
+
+ oldValue = environ[index];
+
+ /*
+ * Update the system environment. This must be done before we
+ * update the interpreters or we will recurse.
+ */
+
+#ifdef USE_PUTENV
+ string = ckalloc(length+2);
+ memcpy((VOID *) string, (VOID *) name, (size_t) length);
+ string[length] = '=';
+ string[length+1] = '\0';
+ putenv(string);
+ ckfree(string);
+#else
for (envPtr = environ+index+1; ; envPtr++) {
envPtr[-1] = *envPtr;
if (*envPtr == NULL) {
break;
- }
+ }
}
+#endif
+
+ /*
+ * Replace the old value in the cache.
+ */
+
+ ReplaceString(oldValue, NULL);
/*
* Update all of the interpreters.
@@ -471,12 +424,43 @@ TclUnsetEnv(name)
(void) Tcl_UnsetVar2(eiPtr->interp, "env", (char *) name,
TCL_GLOBAL_ONLY);
}
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclGetEnv --
+ *
+ * Retrieve the value of an environment variable.
+ *
+ * Results:
+ * Returns a pointer to a static string in the environment,
+ * or NULL if the value was not found.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
- /*
- * Update the system environment.
- */
+char *
+TclGetEnv(name)
+ CONST char *name; /* Name of variable to find. */
+{
+ int length, index;
+
+#ifdef MAC_TCL
+ if (environ == NULL) {
+ environSize = TclMacCreateEnv();
+ }
+#endif
- TclSetSystemEnv(name, NULL);
+ index = FindVariable(name, &length);
+ if ((index != -1) && (*(environ[index]+length) == '=')) {
+ return environ[index]+length+1;
+ } else {
+ return NULL;
+ }
}
/*
@@ -560,91 +544,151 @@ EnvTraceProc(clientData, interp, name1, name2, flags)
/*
*----------------------------------------------------------------------
*
- * EnvInit --
+ * ReplaceString --
*
- * This procedure is called to initialize our management
- * of the environ array.
+ * Replace one string with another in the environment variable
+ * cache. The cache keeps track of all of the environment
+ * variables that Tcl has modified so they can be freed later.
*
* Results:
* None.
*
* Side effects:
- * Environ gets copied to malloc-ed storage, so that in
- * the future we don't have to worry about which entries
- * are malloc-ed and which are static.
+ * May free the old string.
*
*----------------------------------------------------------------------
*/
static void
-EnvInit()
+ReplaceString(oldStr, newStr)
+ CONST char *oldStr; /* Old environment string. */
+ char *newStr; /* New environment string. */
{
-#ifdef MAC_TCL
- environSize = TclMacCreateEnv();
-#else
- char **newEnviron, **oldEnviron;
- int i, length;
+ int i;
+ char **newCache;
- oldEnviron = environ;
- if (environSize != 0) {
- return;
- }
- for (length = 0; environ[length] != NULL; length++) {
- /* Empty loop body. */
+ /*
+ * Check to see if the old value was allocated by Tcl. If so,
+ * it needs to be deallocated to avoid memory leaks. Note that this
+ * algorithm is O(n), not O(1). This will result in n-squared behavior
+ * if lots of environment changes are being made.
+ */
+
+ for (i = 0; i < cacheSize; i++) {
+ if ((environCache[i] == oldStr) || (environCache[i] == NULL)) {
+ break;
+ }
}
- environSize = length+5;
- newEnviron = (char **) ckalloc((unsigned)
- (environSize * sizeof(char *)));
- for (i = 0; i < length; i++) {
- newEnviron[i] = (char *) ckalloc((unsigned) (strlen(environ[i]) + 1));
- strcpy(newEnviron[i], environ[i]);
+ if (i < cacheSize) {
+ /*
+ * Replace or delete the old value.
+ */
+
+ if (environCache[i]) {
+ ckfree(environCache[i]);
+ }
+
+ if (newStr) {
+ environCache[i] = newStr;
+ } else {
+ for (; i < cacheSize-1; i++) {
+ environCache[i] = environCache[i+1];
+ }
+ environCache[cacheSize-1] = NULL;
+ }
+ } else {
+ /*
+ * We need to grow the cache in order to hold the new string.
+ */
+
+ newCache = (char **) ckalloc((cacheSize + 5) * sizeof(char *));
+ if (environCache) {
+ memcpy((VOID *) newCache, (VOID *) environCache,
+ (size_t) (cacheSize * sizeof(char*)));
+ ckfree((char *) environCache);
+ }
+ environCache = newCache;
+ environCache[cacheSize] = (char *) newStr;
+ environCache[cacheSize+1] = NULL;
+ cacheSize += 5;
}
- newEnviron[length] = NULL;
- environ = newEnviron;
- Tcl_CreateExitHandler(EnvExitProc, (ClientData) oldEnviron);
-#endif
}
/*
*----------------------------------------------------------------------
*
- * EnvExitProc --
+ * FindVariable --
*
- * This procedure is called just before the process exits. It
- * frees the memory associated with environment variables.
+ * Locate the entry in environ for a given name.
*
* Results:
- * None.
+ * The return value is the index in environ of an entry with the
+ * name "name", or -1 if there is no such entry. The integer at
+ * *lengthPtr is filled in with the length of name (if a matching
+ * entry is found) or the length of the environ array (if no matching
+ * entry is found).
*
* Side effects:
- * Memory is freed.
+ * None.
*
*----------------------------------------------------------------------
*/
-static void
-EnvExitProc(clientData)
- ClientData clientData; /* Old environment pointer -- restore this. */
+static int
+FindVariable(name, lengthPtr)
+ CONST char *name; /* Name of desired environment variable. */
+ int *lengthPtr; /* Used to return length of name (for
+ * successful searches) or number of non-NULL
+ * entries in environ (for unsuccessful
+ * searches). */
{
- char **p;
- EnvInterp *eiPtr, *nextPtr;
+ int i;
+ register CONST char *p1, *p2;
- for (p = environ; *p != NULL; p++) {
- ckfree(*p);
+ for (i = 0, p1 = environ[i]; p1 != NULL; i++, p1 = environ[i]) {
+ for (p2 = name; *p2 == *p1; p1++, p2++) {
+ /* NULL loop body. */
+ }
+ if ((*p1 == '=') && (*p2 == '\0')) {
+ *lengthPtr = p2-name;
+ return i;
+ }
}
- ckfree((char *) environ);
+ *lengthPtr = i;
+ return -1;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclFinalizeEnvironment --
+ *
+ * This function releases any storage allocated by this module
+ * that isn't still in use by the global environment. Any
+ * strings that are still in the environment will be leaked.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * May deallocate storage.
+ *
+ *----------------------------------------------------------------------
+ */
+void
+TclFinalizeEnvironment()
+{
/*
- * Note that we need to reset the environ global so the Borland C run-time
- * doesn't choke on exit.
+ * For now we just deallocate the cache array and none of the environment
+ * strings. This may leak more memory that strictly necessary, since some
+ * of the strings may no longer be in the environment. However,
+ * determining which ones are ok to delete is n-squared, and is pretty
+ * unlikely, so we don't bother.
*/
- environ = (char **) clientData;
- environSize = 0;
-
- for (eiPtr = firstInterpPtr; eiPtr != NULL; eiPtr = nextPtr) {
- nextPtr = eiPtr->nextPtr;
- ckfree((char *) eiPtr);
+ if (environCache) {
+ ckfree((char *) environCache);
+ environCache = NULL;
}
- firstInterpPtr = NULL;
}
diff --git a/contrib/tcl/generic/tclEvent.c b/contrib/tcl/generic/tclEvent.c
index a503df7f841b..46729826dc7f 100644
--- a/contrib/tcl/generic/tclEvent.c
+++ b/contrib/tcl/generic/tclEvent.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclEvent.c 1.152 97/05/21 07:06:19
+ * SCCS: @(#) tclEvent.c 1.153 97/08/11 20:22:31
*/
#include "tclInt.h"
@@ -516,6 +516,10 @@ Tcl_Finalize()
{
ExitHandler *exitPtr;
+ /*
+ * Invoke exit handler first.
+ */
+
tclInExit = 1;
for (exitPtr = firstExitPtr; exitPtr != NULL; exitPtr = firstExitPtr) {
/*
@@ -530,11 +534,12 @@ Tcl_Finalize()
}
/*
- * Uninitialize everything associated with the compile and execute
- * environment. This *must* be done at the latest possible time.
+ * Now finalize the Tcl execution environment. Note that this must be done
+ * after the exit handlers, because there are order dependencies.
*/
TclFinalizeCompExecEnv();
+ TclFinalizeEnvironment();
firstExitPtr = NULL;
tclInExit = 0;
}
diff --git a/contrib/tcl/generic/tclExecute.c b/contrib/tcl/generic/tclExecute.c
index 111cf4bbdc37..4c1243793093 100644
--- a/contrib/tcl/generic/tclExecute.c
+++ b/contrib/tcl/generic/tclExecute.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclExecute.c 1.81 97/06/26 13:50:03
+ * SCCS: @(#) tclExecute.c 1.95 97/08/12 17:06:49
*/
#include "tclInt.h"
@@ -21,7 +21,7 @@
# include <float.h>
#endif
#ifndef TCL_NO_MATH
-#include <math.h>
+#include "tclMath.h"
#endif
/*
@@ -119,8 +119,8 @@ static char *resultStrings[] = {
*/
#ifdef TCL_COMPILE_STATS
-static int instructionCount[256];
static long numExecutions = 0;
+static int instructionCount[256];
#endif /* TCL_COMPILE_STATS */
/*
@@ -283,18 +283,27 @@ static int EvalStatsCmd _ANSI_ARGS_((ClientData clientData,
#endif /* TCL_COMPILE_STATS */
static void FreeCmdNameInternalRep _ANSI_ARGS_((
Tcl_Obj *objPtr));
+static char * GetSrcInfoForPc _ANSI_ARGS_((unsigned char *pc,
+ ByteCode* codePtr, int *lengthPtr));
static void GrowEvaluationStack _ANSI_ARGS_((ExecEnv *eePtr));
static void IllegalExprOperandType _ANSI_ARGS_((
Tcl_Interp *interp, unsigned int opCode,
Tcl_Obj *opndPtr));
static void InitByteCodeExecution _ANSI_ARGS_((
Tcl_Interp *interp));
+static void PrintByteCodeInfo _ANSI_ARGS_((ByteCode *codePtr));
static int SetCmdNameFromAny _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
#ifdef TCL_COMPILE_DEBUG
static char * StringForResultCode _ANSI_ARGS_((int result));
#endif /* TCL_COMPILE_DEBUG */
static void UpdateStringOfCmdName _ANSI_ARGS_((Tcl_Obj *objPtr));
+#ifdef TCL_COMPILE_DEBUG
+static void ValidatePcAndStackTop _ANSI_ARGS_((
+ ByteCode *codePtr, unsigned char *pc,
+ int stackTop, int stackLowerBound,
+ int stackUpperBound));
+#endif /* TCL_COMPILE_DEBUG */
/*
* Table describing the built-in math functions. Entries in this table are
@@ -388,6 +397,9 @@ InitByteCodeExecution(interp)
#ifdef TCL_COMPILE_STATS
(VOID *) memset(instructionCount, 0, sizeof(instructionCount));
+ (VOID *) memset(tclByteCodeCount, 0, sizeof(tclByteCodeCount));
+ (VOID *) memset(tclSourceCount, 0, sizeof(tclSourceCount));
+
Tcl_CreateCommand(interp, "evalstats", EvalStatsCmd,
(ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
#endif /* TCL_COMPILE_STATS */
@@ -607,24 +619,7 @@ TclExecuteByteCode(interp, codePtr)
*/
if (tclTraceExec >= 2) {
- Proc *procPtr = codePtr->procPtr;
- fprintf(stdout, "\nExecuting ByteCode 0x%x, ref ct %u, epoch %u, cmds %u, interp 0x%x, interp epoch %u\n",
- (unsigned int) codePtr, codePtr->refCount,
- codePtr->compileEpoch, codePtr->numCommands,
- (unsigned int) codePtr->iPtr, codePtr->iPtr->compileEpoch);
- if (procPtr != NULL) {
- fprintf(stdout,
- " Proc 0x%x, ref ct=%d, %d args, %d compiled locals\n",
- (unsigned int) procPtr, procPtr->refCount,
- procPtr->numArgs, procPtr->numCompiledLocals);
- }
- fprintf(stdout, " Source: ");
- TclPrintSource(stdout, codePtr->source, 70);
- fprintf(stdout, "\n");
- fprintf(stdout, " Chars=%d, bytes=%u, objs=%u, stk depth=%u, exc depth=%d, aux items=%d\n",
- codePtr->numSrcChars, codePtr->numCodeBytes,
- codePtr->numObjects, codePtr->maxStackDepth,
- codePtr->maxExcRangeDepth, codePtr->numAuxDataItems);
+ PrintByteCodeInfo(codePtr);
#ifdef TCL_COMPILE_STATS
fprintf(stdout, " Starting stack top=%d, system objects=%ld\n",
eePtr->stackTop, (tclObjsAlloced - tclObjsFreed));
@@ -671,44 +666,10 @@ TclExecuteByteCode(interp, codePtr)
*/
for (;;) {
- opCode = *pc;
-
#ifdef TCL_COMPILE_DEBUG
- if (((unsigned int) pc < (unsigned int) codePtr->codeStart)
- || ((unsigned int) pc > (unsigned int) (codePtr->codeStart + codePtr->numCodeBytes))) {
- fprintf(stderr,
- "\nTclExecuteByteCode: bad instruction pc 0x%x\n",
- (unsigned int) pc);
- panic("TclExecuteByteCode execution failure: bad pc");
- }
- if ((unsigned int) opCode > LAST_INST_OPCODE) {
- fprintf(stderr,
- "\nTclExecuteByteCode: bad opcode %d at pc %u\n",
- (unsigned int) opCode,
- (unsigned int)(pc - codePtr->codeStart));
- panic("TclExecuteByteCode execution failure: bad opcode");
- }
- if ((stackTop < initStackTop) || (stackTop > eePtr->stackEnd)) {
- int cmdIndex = TclGetSrcInfoForPc(pc, codePtr);
- fprintf(stderr,
- "\nTclExecuteByteCode: bad stack top %d at pc %u",
- stackTop, (unsigned int)(pc - codePtr->codeStart));
- if (cmdIndex != -1) {
- CmdLocation *locPtr = &(codePtr->cmdMapPtr[cmdIndex]);
- char *ellipsis = "";
- int numChars = locPtr->numSrcChars;
- if (numChars > 100) {
- numChars = 100;
- ellipsis = "...";
- }
- fprintf(stderr, "\n executing %.*s%s\n", numChars,
- (codePtr->source + locPtr->srcOffset), ellipsis);
- } else {
- fprintf(stderr, "\n");
- }
- panic("TclExecuteByteCode execution failure: bad stack top");
- }
-#else /* not TCL_COMPILE_DEBUG - print generic trace if so requested */
+ ValidatePcAndStackTop(codePtr, pc, stackTop, initStackTop,
+ eePtr->stackEnd);
+#else /* not TCL_COMPILE_DEBUG */
if (traceInstructions) {
#ifdef TCL_COMPILE_STATS
fprintf(stdout, "%d: %d,%ld ", iPtr->numLevels, stackTop,
@@ -721,10 +682,11 @@ TclExecuteByteCode(interp, codePtr)
}
#endif /* TCL_COMPILE_DEBUG */
+ opCode = *pc;
#ifdef TCL_COMPILE_STATS
instructionCount[opCode]++;
#endif /* TCL_COMPILE_STATS */
-
+
switch (opCode) {
case INST_DONE:
/*
@@ -733,7 +695,7 @@ TclExecuteByteCode(interp, codePtr)
*/
valuePtr = POP_OBJECT();
Tcl_SetObjResult(interp, valuePtr);
- TclDecrRefCount(valuePtr); /* done with valuePtr */
+ TclDecrRefCount(valuePtr);
if (stackTop != initStackTop) {
fprintf(stderr, "\nTclExecuteByteCode: done instruction at pc %u: stack top %d != entry stack top %d\n",
(unsigned int)(pc - codePtr->codeStart),
@@ -748,16 +710,16 @@ TclExecuteByteCode(interp, codePtr)
goto done;
case INST_PUSH1:
- valuePtr = objArrayPtr[TclGetUInt1AtPc(pc+1)];
+ valuePtr = objArrayPtr[TclGetUInt1AtPtr(pc+1)];
PUSH_OBJECT(valuePtr);
- TRACE_WITH_OBJ(("push1 %u => ", TclGetUInt1AtPc(pc+1)),
+ TRACE_WITH_OBJ(("push1 %u => ", TclGetUInt1AtPtr(pc+1)),
valuePtr);
ADJUST_PC(2);
case INST_PUSH4:
- valuePtr = objArrayPtr[TclGetUInt4AtPc(pc+1)];
+ valuePtr = objArrayPtr[TclGetUInt4AtPtr(pc+1)];
PUSH_OBJECT(valuePtr);
- TRACE_WITH_OBJ(("push4 %u => ", TclGetUInt4AtPc(pc+1)),
+ TRACE_WITH_OBJ(("push4 %u => ", TclGetUInt4AtPtr(pc+1)),
valuePtr);
ADJUST_PC(5);
@@ -774,7 +736,7 @@ TclExecuteByteCode(interp, codePtr)
ADJUST_PC(1);
case INST_CONCAT1:
- opnd = TclGetUInt1AtPc(pc+1);
+ opnd = TclGetUInt1AtPtr(pc+1);
{
Tcl_Obj *concatObjPtr;
int totalLen = 0;
@@ -828,12 +790,12 @@ TclExecuteByteCode(interp, codePtr)
}
case INST_INVOKE_STK4:
- opnd = TclGetUInt4AtPc(pc+1);
+ opnd = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
goto doInvocation;
case INST_INVOKE_STK1:
- opnd = TclGetUInt1AtPc(pc+1);
+ opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
doInvocation:
@@ -926,16 +888,12 @@ TclExecuteByteCode(interp, codePtr)
for (tracePtr = iPtr->tracePtr; tracePtr != NULL;
tracePtr = tracePtr->nextPtr) {
if (iPtr->numLevels <= tracePtr->level) {
- int cmdIndex = TclGetSrcInfoForPc(pc, codePtr);
- if (cmdIndex != -1) {
- CmdLocation *locPtr =
- &(codePtr->cmdMapPtr[cmdIndex]);
- char *command =
- (codePtr->source + locPtr->srcOffset);
- int numChars = locPtr->numSrcChars;
+ int numChars;
+ char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars);
+ if (cmd != NULL) {
DECACHE_STACK_INFO();
CallTraceProcedure(interp, tracePtr, cmdPtr,
- command, numChars, objc, objv);
+ cmd, numChars, objc, objv);
CACHE_STACK_INFO();
}
}
@@ -1083,41 +1041,12 @@ TclExecuteByteCode(interp, codePtr)
case TCL_ERROR:
/*
- * The invoked command returned an error. Record
- * information about what was being executed when the
- * error occurred, then look for an enclosing catch
- * exception range, if any.
+ * The invoked command returned an error. Look for an
+ * enclosing catch exception range, if any.
*/
TRACE_WITH_OBJ(("%s %u => ... after \"%.20s\", TCL_ERROR ",
opName[opCode], objc, cmdNameBuf),
Tcl_GetObjResult(interp));
- if (!(iPtr->flags & ERR_ALREADY_LOGGED)) {
- char buf[200];
- int cmdIndex = TclGetSrcInfoForPc(pc, codePtr);
- if (cmdIndex != -1) {
- CmdLocation *locPtr =
- &(codePtr->cmdMapPtr[cmdIndex]);
- char *ellipsis = "";
- int numChars = locPtr->numSrcChars;
- if (numChars > 150) {
- numChars = 150;
- ellipsis = "...";
- }
- if (!(iPtr->flags & ERR_IN_PROGRESS)) {
- sprintf(buf, "\n while executing\n\"%.*s%s\"",
- numChars,
- (codePtr->source + locPtr->srcOffset),
- ellipsis);
- } else {
- sprintf(buf, "\n invoked from within\n\"%.*s%s\"",
- numChars,
- (codePtr->source + locPtr->srcOffset),
- ellipsis);
- }
- Tcl_AddObjErrorInfo(interp, buf, -1);
- iPtr->flags |= ERR_ALREADY_LOGGED;
- }
- }
goto checkForCatch;
case TCL_RETURN:
@@ -1151,7 +1080,7 @@ TclExecuteByteCode(interp, codePtr)
PUSH_OBJECT(Tcl_GetObjResult(interp));
TRACE_WITH_OBJ(("evalStk \"%.30s\" => ", O2S(objPtr)),
Tcl_GetObjResult(interp));
- TclDecrRefCount(objPtr); /* done with popped object */
+ TclDecrRefCount(objPtr);
ADJUST_PC(1);
} else if ((result == TCL_BREAK) || (result == TCL_CONTINUE)) {
/*
@@ -1172,7 +1101,7 @@ TclExecuteByteCode(interp, codePtr)
if (rangePtr == NULL) {
TRACE(("evalStk \"%.30s\" => no encl. loop or catch, returning %s\n",
O2S(objPtr), StringForResultCode(result)));
- Tcl_DecrRefCount(objPtr); /* done with popped obj */
+ Tcl_DecrRefCount(objPtr);
goto abnormalReturn; /* no catch exists to check */
}
switch (rangePtr->type) {
@@ -1182,7 +1111,7 @@ TclExecuteByteCode(interp, codePtr)
} else if (rangePtr->continueOffset == -1) {
TRACE(("evalStk \"%.30s\" => %s, loop w/o continue, checking for catch\n",
O2S(objPtr), StringForResultCode(result)));
- Tcl_DecrRefCount(objPtr); /* done with popped obj */
+ Tcl_DecrRefCount(objPtr);
goto checkForCatch;
} else {
newPcOffset = rangePtr->continueOffset;
@@ -1196,18 +1125,18 @@ TclExecuteByteCode(interp, codePtr)
TRACE_WITH_OBJ(("evalStk \"%.30s\" => %s ",
O2S(objPtr), StringForResultCode(result)),
valuePtr);
- Tcl_DecrRefCount(objPtr); /* done with popped obj */
+ Tcl_DecrRefCount(objPtr);
goto processCatch; /* it will use rangePtr */
default:
panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type);
}
- Tcl_DecrRefCount(objPtr); /* done with popped obj */
+ Tcl_DecrRefCount(objPtr);
pc = (codePtr->codeStart + newPcOffset);
continue; /* restart outer instruction loop at pc */
} else { /* eval returned TCL_ERROR, TCL_RETURN, unknown code */
TRACE_WITH_OBJ(("evalStk \"%.30s\" => ERROR: ", O2S(objPtr)),
Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(objPtr); /* done with popped obj */
+ Tcl_DecrRefCount(objPtr);
goto checkForCatch;
}
@@ -1220,21 +1149,21 @@ TclExecuteByteCode(interp, codePtr)
if (result != TCL_OK) {
TRACE_WITH_OBJ(("exprStk \"%.30s\" => ERROR: ",
O2S(objPtr)), Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(objPtr); /* done with popped object */
+ Tcl_DecrRefCount(objPtr);
goto checkForCatch;
}
stackPtr[++stackTop].o = valuePtr; /* already has right refct */
TRACE_WITH_OBJ(("exprStk \"%.30s\" => ", O2S(objPtr)), valuePtr);
- TclDecrRefCount(objPtr); /* done with popped object */
+ TclDecrRefCount(objPtr);
ADJUST_PC(1);
case INST_LOAD_SCALAR4:
- opnd = TclGetInt4AtPc(pc+1);
+ opnd = TclGetInt4AtPtr(pc+1);
pcAdjustment = 5;
goto doLoadScalar;
case INST_LOAD_SCALAR1:
- opnd = TclGetUInt1AtPc(pc+1);
+ opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
doLoadScalar:
@@ -1261,23 +1190,23 @@ TclExecuteByteCode(interp, codePtr)
if (valuePtr == NULL) {
TRACE_WITH_OBJ(("loadScalarStk \"%.30s\" => ERROR: ",
O2S(namePtr)), Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(namePtr); /* done with popped name. */
+ Tcl_DecrRefCount(namePtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(valuePtr);
TRACE_WITH_OBJ(("loadScalarStk \"%.30s\" => ",
O2S(namePtr)), valuePtr);
- TclDecrRefCount(namePtr); /* done with popped name. */
+ TclDecrRefCount(namePtr);
ADJUST_PC(1);
case INST_LOAD_ARRAY4:
- opnd = TclGetUInt4AtPc(pc+1);
+ opnd = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
goto doLoadArray;
case INST_LOAD_ARRAY1:
- opnd = TclGetUInt1AtPc(pc+1);
+ opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
doLoadArray:
@@ -1292,14 +1221,14 @@ TclExecuteByteCode(interp, codePtr)
TRACE_WITH_OBJ(("%s %u \"%.30s\" => ERROR: ",
opName[opCode], opnd, O2S(elemPtr)),
Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(elemPtr); /* done with element name. */
+ Tcl_DecrRefCount(elemPtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(valuePtr);
TRACE_WITH_OBJ(("%s %u \"%.30s\" => ",
opName[opCode], opnd, O2S(elemPtr)), valuePtr);
- TclDecrRefCount(elemPtr); /* done with element name. */
+ TclDecrRefCount(elemPtr);
}
ADJUST_PC(pcAdjustment);
@@ -1316,16 +1245,16 @@ TclExecuteByteCode(interp, codePtr)
TRACE_WITH_OBJ(("loadArrayStk \"%.30s(%.30s)\" => ERROR: ",
O2S(namePtr), O2S(elemPtr)),
Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(namePtr); /* done with array name */
- Tcl_DecrRefCount(elemPtr); /* and element name. */
+ Tcl_DecrRefCount(namePtr);
+ Tcl_DecrRefCount(elemPtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(valuePtr);
TRACE_WITH_OBJ(("loadArrayStk \"%.30s(%.30s)\" => ",
O2S(namePtr), O2S(elemPtr)), valuePtr);
- TclDecrRefCount(namePtr); /* done with array name */
- TclDecrRefCount(elemPtr); /* and element name. */
+ TclDecrRefCount(namePtr);
+ TclDecrRefCount(elemPtr);
}
ADJUST_PC(1);
@@ -1338,23 +1267,23 @@ TclExecuteByteCode(interp, codePtr)
if (valuePtr == NULL) {
TRACE_WITH_OBJ(("loadStk \"%.30s\" => ERROR: ",
O2S(namePtr)), Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(namePtr); /* done with popped name. */
+ Tcl_DecrRefCount(namePtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(valuePtr);
TRACE_WITH_OBJ(("loadStk \"%.30s\" => ", O2S(namePtr)),
valuePtr);
- TclDecrRefCount(namePtr); /* done with popped name. */
+ TclDecrRefCount(namePtr);
ADJUST_PC(1);
case INST_STORE_SCALAR4:
- opnd = TclGetUInt4AtPc(pc+1);
+ opnd = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
goto doStoreScalar;
case INST_STORE_SCALAR1:
- opnd = TclGetUInt1AtPc(pc+1);
+ opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
doStoreScalar:
@@ -1367,14 +1296,14 @@ TclExecuteByteCode(interp, codePtr)
TRACE_WITH_OBJ(("%s %u <- \"%.30s\" => ERROR: ",
opName[opCode], opnd, O2S(valuePtr)),
Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(valuePtr); /* done with popped value. */
+ Tcl_DecrRefCount(valuePtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
TRACE_WITH_OBJ(("%s %u <- \"%.30s\" => ",
opName[opCode], opnd, O2S(valuePtr)), value2Ptr);
- TclDecrRefCount(valuePtr); /* done with popped value. */
+ TclDecrRefCount(valuePtr);
ADJUST_PC(pcAdjustment);
case INST_STORE_SCALAR_STK:
@@ -1389,8 +1318,8 @@ TclExecuteByteCode(interp, codePtr)
("storeScalarStk \"%.30s\" <- \"%.30s\" => ERROR: ",
O2S(namePtr), O2S(valuePtr)),
Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(namePtr); /* done with popped name. */
- Tcl_DecrRefCount(valuePtr); /* done with popped value. */
+ Tcl_DecrRefCount(namePtr);
+ Tcl_DecrRefCount(valuePtr);
result = TCL_ERROR;
goto checkForCatch;
}
@@ -1400,17 +1329,17 @@ TclExecuteByteCode(interp, codePtr)
O2S(namePtr),
O2S(valuePtr)),
value2Ptr);
- TclDecrRefCount(namePtr); /* done with popped name. */
- TclDecrRefCount(valuePtr); /* done with popped value. */
+ TclDecrRefCount(namePtr);
+ TclDecrRefCount(valuePtr);
ADJUST_PC(1);
case INST_STORE_ARRAY4:
- opnd = TclGetUInt4AtPc(pc+1);
+ opnd = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
goto doStoreArray;
case INST_STORE_ARRAY1:
- opnd = TclGetUInt1AtPc(pc+1);
+ opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
doStoreArray:
@@ -1428,8 +1357,8 @@ TclExecuteByteCode(interp, codePtr)
("%s %u \"%.30s\" <- \"%.30s\" => ERROR: ",
opName[opCode], opnd, O2S(elemPtr),
O2S(valuePtr)), Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(elemPtr); /* done with element name */
- Tcl_DecrRefCount(valuePtr); /* done with popped value */
+ Tcl_DecrRefCount(elemPtr);
+ Tcl_DecrRefCount(valuePtr);
result = TCL_ERROR;
goto checkForCatch;
}
@@ -1437,8 +1366,8 @@ TclExecuteByteCode(interp, codePtr)
TRACE_WITH_OBJ(("%s %u \"%.30s\" <- \"%.30s\" => ",
opName[opCode], opnd, O2S(elemPtr), O2S(valuePtr)),
value2Ptr);
- TclDecrRefCount(elemPtr); /* done with element name */
- TclDecrRefCount(valuePtr); /* done with popped value */
+ TclDecrRefCount(elemPtr);
+ TclDecrRefCount(valuePtr);
}
ADJUST_PC(pcAdjustment);
@@ -1457,9 +1386,9 @@ TclExecuteByteCode(interp, codePtr)
TRACE_WITH_OBJ(("storeArrayStk \"%.30s(%.30s)\" <- \"%.30s\" => ERROR: ",
O2S(namePtr), O2S(elemPtr), O2S(valuePtr)),
Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(namePtr); /* done with array name, */
- Tcl_DecrRefCount(elemPtr); /* the element name, */
- Tcl_DecrRefCount(valuePtr); /* and the popped value. */
+ Tcl_DecrRefCount(namePtr);
+ Tcl_DecrRefCount(elemPtr);
+ Tcl_DecrRefCount(valuePtr);
result = TCL_ERROR;
goto checkForCatch;
}
@@ -1467,9 +1396,9 @@ TclExecuteByteCode(interp, codePtr)
TRACE_WITH_OBJ(("storeArrayStk \"%.30s(%.30s)\" <- \"%.30s\" => ",
O2S(namePtr), O2S(elemPtr), O2S(valuePtr)),
value2Ptr);
- TclDecrRefCount(namePtr); /* done with array name, */
- TclDecrRefCount(elemPtr); /* the element name, */
- TclDecrRefCount(valuePtr); /* and popped value. */
+ TclDecrRefCount(namePtr);
+ TclDecrRefCount(elemPtr);
+ TclDecrRefCount(valuePtr);
}
ADJUST_PC(1);
@@ -1484,27 +1413,27 @@ TclExecuteByteCode(interp, codePtr)
TRACE_WITH_OBJ(("storeStk \"%.30s\" <- \"%.30s\" => ERROR: ",
O2S(namePtr), O2S(valuePtr)),
Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(namePtr); /* done with popped name. */
- Tcl_DecrRefCount(valuePtr); /* and popped value. */
+ Tcl_DecrRefCount(namePtr);
+ Tcl_DecrRefCount(valuePtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
TRACE_WITH_OBJ(("storeStk \"%.30s\" <- \"%.30s\" => ",
O2S(namePtr), O2S(valuePtr)), value2Ptr);
- TclDecrRefCount(namePtr); /* done with popped name */
- TclDecrRefCount(valuePtr); /* and popped value. */
+ TclDecrRefCount(namePtr);
+ TclDecrRefCount(valuePtr);
ADJUST_PC(1);
case INST_INCR_SCALAR1:
- opnd = TclGetUInt1AtPc(pc+1);
+ opnd = TclGetUInt1AtPtr(pc+1);
valuePtr = POP_OBJECT();
if (valuePtr->typePtr != &tclIntType) {
result = tclIntType.setFromAnyProc(interp, valuePtr);
if (result != TCL_OK) {
TRACE_WITH_OBJ(("incrScalar1 %u (by %s) => ERROR converting increment amount to int: ",
opnd, O2S(valuePtr)), Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(valuePtr); /* done with incr amount */
+ Tcl_DecrRefCount(valuePtr);
goto checkForCatch;
}
}
@@ -1515,14 +1444,14 @@ TclExecuteByteCode(interp, codePtr)
if (value2Ptr == NULL) {
TRACE_WITH_OBJ(("incrScalar1 %u (by %ld) => ERROR: ",
opnd, i), Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(valuePtr); /* done with incr amount */
+ Tcl_DecrRefCount(valuePtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
TRACE_WITH_OBJ(("incrScalar1 %u (by %ld) => ", opnd, i),
value2Ptr);
- TclDecrRefCount(valuePtr); /* done with incr amount */
+ TclDecrRefCount(valuePtr);
ADJUST_PC(2);
case INST_INCR_SCALAR_STK:
@@ -1535,8 +1464,8 @@ TclExecuteByteCode(interp, codePtr)
TRACE_WITH_OBJ(("%s \"%.30s\" (by %s) => ERROR converting increment amount to int: ",
opName[opCode], O2S(namePtr), O2S(valuePtr)),
Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(namePtr); /* done with var name */
- Tcl_DecrRefCount(valuePtr); /* done with incr amount */
+ Tcl_DecrRefCount(namePtr);
+ Tcl_DecrRefCount(valuePtr);
goto checkForCatch;
}
}
@@ -1549,23 +1478,23 @@ TclExecuteByteCode(interp, codePtr)
TRACE_WITH_OBJ(("%s \"%.30s\" (by %ld) => ERROR: ",
opName[opCode], O2S(namePtr), i),
Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(namePtr); /* done with var name */
- Tcl_DecrRefCount(valuePtr); /* done with incr amount */
+ Tcl_DecrRefCount(namePtr);
+ Tcl_DecrRefCount(valuePtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
TRACE_WITH_OBJ(("%s \"%.30s\" (by %ld) => ",
opName[opCode], O2S(namePtr), i), value2Ptr);
- Tcl_DecrRefCount(namePtr); /* done with var name */
- Tcl_DecrRefCount(valuePtr); /* done with incr amount */
+ Tcl_DecrRefCount(namePtr);
+ Tcl_DecrRefCount(valuePtr);
ADJUST_PC(1);
case INST_INCR_ARRAY1:
{
Tcl_Obj *elemPtr;
- opnd = TclGetUInt1AtPc(pc+1);
+ opnd = TclGetUInt1AtPtr(pc+1);
valuePtr = POP_OBJECT();
elemPtr = POP_OBJECT();
if (valuePtr->typePtr != &tclIntType) {
@@ -1574,8 +1503,8 @@ TclExecuteByteCode(interp, codePtr)
TRACE_WITH_OBJ(("incrArray1 %u \"%.30s\" (by %s) => ERROR converting increment amount to int: ",
opnd, O2S(elemPtr), O2S(valuePtr)),
Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(elemPtr); /* done w elem name */
- Tcl_DecrRefCount(valuePtr); /* done w incr amount */
+ Tcl_DecrRefCount(elemPtr);
+ Tcl_DecrRefCount(valuePtr);
goto checkForCatch;
}
}
@@ -1588,16 +1517,16 @@ TclExecuteByteCode(interp, codePtr)
TRACE_WITH_OBJ(("incrArray1 %u \"%.30s\" (by %ld) => ERROR: ",
opnd, O2S(elemPtr), i),
Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(elemPtr); /* done w element name */
- Tcl_DecrRefCount(valuePtr); /* done w incr amount */
+ Tcl_DecrRefCount(elemPtr);
+ Tcl_DecrRefCount(valuePtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
TRACE_WITH_OBJ(("incrArray1 %u \"%.30s\" (by %ld) => ",
opnd, O2S(elemPtr), i), value2Ptr);
- Tcl_DecrRefCount(elemPtr); /* done w element name */
- Tcl_DecrRefCount(valuePtr); /* done w incr amount */
+ Tcl_DecrRefCount(elemPtr);
+ Tcl_DecrRefCount(valuePtr);
}
ADJUST_PC(2);
@@ -1614,9 +1543,9 @@ TclExecuteByteCode(interp, codePtr)
TRACE_WITH_OBJ(("incrArrayStk \"%.30s(%.30s)\" (by %s) => ERROR converting increment amount to int: ",
O2S(namePtr), O2S(elemPtr), O2S(valuePtr)),
Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(namePtr); /* done w array name */
- Tcl_DecrRefCount(elemPtr); /* done w elem name */
- Tcl_DecrRefCount(valuePtr); /* done w incr amount */
+ Tcl_DecrRefCount(namePtr);
+ Tcl_DecrRefCount(elemPtr);
+ Tcl_DecrRefCount(valuePtr);
goto checkForCatch;
}
}
@@ -1629,24 +1558,24 @@ TclExecuteByteCode(interp, codePtr)
TRACE_WITH_OBJ(("incrArrayStk \"%.30s(%.30s)\" (by %ld) => ERROR: ",
O2S(namePtr), O2S(elemPtr), i),
Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(namePtr); /* done w array name */
- Tcl_DecrRefCount(elemPtr); /* done w elem name */
- Tcl_DecrRefCount(valuePtr); /* done w incr amount */
+ Tcl_DecrRefCount(namePtr);
+ Tcl_DecrRefCount(elemPtr);
+ Tcl_DecrRefCount(valuePtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
TRACE_WITH_OBJ(("incrArrayStk \"%.30s(%.30s)\" (by %ld) => ",
O2S(namePtr), O2S(elemPtr), i), value2Ptr);
- Tcl_DecrRefCount(namePtr); /* done w array name */
- Tcl_DecrRefCount(elemPtr); /* done w elem name */
- Tcl_DecrRefCount(valuePtr); /* done w incr amount */
+ Tcl_DecrRefCount(namePtr);
+ Tcl_DecrRefCount(elemPtr);
+ Tcl_DecrRefCount(valuePtr);
}
ADJUST_PC(1);
case INST_INCR_SCALAR1_IMM:
- opnd = TclGetUInt1AtPc(pc+1);
- i = TclGetInt1AtPc(pc+2);
+ opnd = TclGetUInt1AtPtr(pc+1);
+ i = TclGetInt1AtPtr(pc+2);
DECACHE_STACK_INFO();
value2Ptr = TclIncrIndexedScalar(interp, opnd, i);
CACHE_STACK_INFO();
@@ -1664,7 +1593,7 @@ TclExecuteByteCode(interp, codePtr)
case INST_INCR_SCALAR_STK_IMM:
case INST_INCR_STK_IMM:
namePtr = POP_OBJECT();
- i = TclGetInt1AtPc(pc+1);
+ i = TclGetInt1AtPtr(pc+1);
DECACHE_STACK_INFO();
value2Ptr = TclIncrVar2(interp, namePtr, (Tcl_Obj *) NULL, i,
/*part1NotParsed*/ (opCode == INST_INCR_STK_IMM));
@@ -1674,21 +1603,21 @@ TclExecuteByteCode(interp, codePtr)
opName[opCode], O2S(namePtr), i),
Tcl_GetObjResult(interp));
result = TCL_ERROR;
- Tcl_DecrRefCount(namePtr); /* done with var name */
+ Tcl_DecrRefCount(namePtr);
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
TRACE_WITH_OBJ(("%s \"%.30s\" %ld => ",
opName[opCode], O2S(namePtr), i), value2Ptr);
- TclDecrRefCount(namePtr); /* done with var name */
+ TclDecrRefCount(namePtr);
ADJUST_PC(2);
case INST_INCR_ARRAY1_IMM:
{
Tcl_Obj *elemPtr;
- opnd = TclGetUInt1AtPc(pc+1);
- i = TclGetInt1AtPc(pc+2);
+ opnd = TclGetUInt1AtPtr(pc+1);
+ i = TclGetInt1AtPtr(pc+2);
elemPtr = POP_OBJECT();
DECACHE_STACK_INFO();
value2Ptr = TclIncrElementOfIndexedArray(interp, opnd,
@@ -1698,14 +1627,14 @@ TclExecuteByteCode(interp, codePtr)
TRACE_WITH_OBJ(("incrArray1Imm %u \"%.30s\" (by %ld) => ERROR: ",
opnd, O2S(elemPtr), i),
Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(elemPtr); /* done with element name */
+ Tcl_DecrRefCount(elemPtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
TRACE_WITH_OBJ(("incrArray1Imm %u \"%.30s\" (by %ld) => ",
opnd, O2S(elemPtr), i), value2Ptr);
- Tcl_DecrRefCount(elemPtr); /* done with element name */
+ Tcl_DecrRefCount(elemPtr);
}
ADJUST_PC(3);
@@ -1713,7 +1642,7 @@ TclExecuteByteCode(interp, codePtr)
{
Tcl_Obj *elemPtr;
- i = TclGetInt1AtPc(pc+1);
+ i = TclGetInt1AtPtr(pc+1);
elemPtr = POP_OBJECT();
namePtr = POP_OBJECT();
DECACHE_STACK_INFO();
@@ -1724,38 +1653,38 @@ TclExecuteByteCode(interp, codePtr)
TRACE_WITH_OBJ(("incrArrayStkImm \"%.30s(%.30s)\" (by %ld) => ERROR: ",
O2S(namePtr), O2S(elemPtr), i),
Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(namePtr); /* done with array name */
- Tcl_DecrRefCount(elemPtr); /* done with element name */
+ Tcl_DecrRefCount(namePtr);
+ Tcl_DecrRefCount(elemPtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
TRACE_WITH_OBJ(("incrArrayStkImm \"%.30s(%.30s)\" (by %ld) => ",
O2S(namePtr), O2S(elemPtr), i), value2Ptr);
- Tcl_DecrRefCount(namePtr); /* done with array name */
- Tcl_DecrRefCount(elemPtr); /* done with element name */
+ Tcl_DecrRefCount(namePtr);
+ Tcl_DecrRefCount(elemPtr);
}
ADJUST_PC(2);
case INST_JUMP1:
- opnd = TclGetInt1AtPc(pc+1);
+ opnd = TclGetInt1AtPtr(pc+1);
TRACE(("jump1 %d => new pc %u\n", opnd,
(unsigned int)(pc + opnd - codePtr->codeStart)));
ADJUST_PC(opnd);
case INST_JUMP4:
- opnd = TclGetInt4AtPc(pc+1);
+ opnd = TclGetInt4AtPtr(pc+1);
TRACE(("jump4 %d => new pc %u\n", opnd,
(unsigned int)(pc + opnd - codePtr->codeStart)));
ADJUST_PC(opnd);
case INST_JUMP_TRUE4:
- opnd = TclGetInt4AtPc(pc+1);
+ opnd = TclGetInt4AtPtr(pc+1);
pcAdjustment = 5;
goto doJumpTrue;
case INST_JUMP_TRUE1:
- opnd = TclGetInt1AtPc(pc+1);
+ opnd = TclGetInt1AtPtr(pc+1);
pcAdjustment = 2;
doJumpTrue:
@@ -1772,7 +1701,7 @@ TclExecuteByteCode(interp, codePtr)
if (result != TCL_OK) {
TRACE_WITH_OBJ(("%s %d => ERROR: ", opName[opCode],
opnd), Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(valuePtr); /* done w popped obj */
+ Tcl_DecrRefCount(valuePtr);
goto checkForCatch;
}
}
@@ -1780,23 +1709,23 @@ TclExecuteByteCode(interp, codePtr)
TRACE(("%s %d => %.20s true, new pc %u\n",
opName[opCode], opnd, O2S(valuePtr),
(unsigned int)(pc+opnd - codePtr->codeStart)));
- TclDecrRefCount(valuePtr); /* done with popped obj */
+ TclDecrRefCount(valuePtr);
ADJUST_PC(opnd);
} else {
TRACE(("%s %d => %.20s false\n", opName[opCode], opnd,
O2S(valuePtr)));
- TclDecrRefCount(valuePtr); /* done with popped obj */
+ TclDecrRefCount(valuePtr);
ADJUST_PC(pcAdjustment);
}
}
case INST_JUMP_FALSE4:
- opnd = TclGetInt4AtPc(pc+1);
+ opnd = TclGetInt4AtPtr(pc+1);
pcAdjustment = 5;
goto doJumpFalse;
case INST_JUMP_FALSE1:
- opnd = TclGetInt1AtPc(pc+1);
+ opnd = TclGetInt1AtPtr(pc+1);
pcAdjustment = 2;
doJumpFalse:
@@ -1813,20 +1742,20 @@ TclExecuteByteCode(interp, codePtr)
if (result != TCL_OK) {
TRACE_WITH_OBJ(("%s %d => ERROR: ", opName[opCode],
opnd), Tcl_GetObjResult(interp));
- Tcl_DecrRefCount(valuePtr); /* done w popped obj */
+ Tcl_DecrRefCount(valuePtr);
goto checkForCatch;
}
}
if (b) {
TRACE(("%s %d => %.20s true\n", opName[opCode], opnd,
O2S(valuePtr)));
- TclDecrRefCount(valuePtr); /* done with popped obj */
+ TclDecrRefCount(valuePtr);
ADJUST_PC(pcAdjustment);
} else {
TRACE(("%s %d => %.20s false, new pc %u\n",
opName[opCode], opnd, O2S(valuePtr),
(unsigned int)(pc + opnd - codePtr->codeStart)));
- TclDecrRefCount(valuePtr); /* done with popped obj */
+ TclDecrRefCount(valuePtr);
ADJUST_PC(opnd);
}
}
@@ -1858,19 +1787,19 @@ TclExecuteByteCode(interp, codePtr)
if (TclLooksLikeInt(s)) {
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
valuePtr, &i);
- i = (valuePtr->internalRep.longValue != 0);
+ i = (i != 0);
} else {
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
valuePtr, &d1);
- i = (valuePtr->internalRep.doubleValue != 0.0);
+ i = (d1 != 0.0);
}
if (result != TCL_OK) {
TRACE(("%s \"%.20s\" => ILLEGAL TYPE %s \n",
opName[opCode], O2S(valuePtr),
(t1Ptr? t1Ptr->name : "null")));
IllegalExprOperandType(interp, opCode, valuePtr);
- Tcl_DecrRefCount(valuePtr); /* done with object */
- Tcl_DecrRefCount(value2Ptr); /* done with object */
+ Tcl_DecrRefCount(valuePtr);
+ Tcl_DecrRefCount(value2Ptr);
goto checkForCatch;
}
}
@@ -1884,19 +1813,19 @@ TclExecuteByteCode(interp, codePtr)
if (TclLooksLikeInt(s)) {
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
value2Ptr, &i2);
- i2 = (value2Ptr->internalRep.longValue != 0);
+ i2 = (i2 != 0);
} else {
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
value2Ptr, &d1);
- i2 = (value2Ptr->internalRep.doubleValue != 0.0);
+ i2 = (d1 != 0.0);
}
if (result != TCL_OK) {
TRACE(("%s \"%.20s\" => ILLEGAL TYPE %s \n",
opName[opCode], O2S(value2Ptr),
(t2Ptr? t2Ptr->name : "null")));
IllegalExprOperandType(interp, opCode, value2Ptr);
- Tcl_DecrRefCount(valuePtr); /* done with object */
- Tcl_DecrRefCount(value2Ptr); /* done with object */
+ Tcl_DecrRefCount(valuePtr);
+ Tcl_DecrRefCount(value2Ptr);
goto checkForCatch;
}
}
@@ -1914,7 +1843,7 @@ TclExecuteByteCode(interp, codePtr)
PUSH_OBJECT(Tcl_NewLongObj(iResult));
TRACE(("%s %.20s %.20s => %ld\n", opName[opCode],
O2S(valuePtr), O2S(value2Ptr), iResult));
- TclDecrRefCount(valuePtr); /* done with object */
+ TclDecrRefCount(valuePtr);
} else { /* reuse the valuePtr object */
TRACE(("%s %.20s %.20s => %ld\n",
opName[opCode], /* NB: stack top is off by 1 */
@@ -1922,7 +1851,7 @@ TclExecuteByteCode(interp, codePtr)
Tcl_SetLongObj(valuePtr, iResult);
++stackTop; /* valuePtr now on stk top has right r.c. */
}
- TclDecrRefCount(value2Ptr); /* done with object */
+ TclDecrRefCount(value2Ptr);
}
ADJUST_PC(1);
@@ -1945,7 +1874,7 @@ TclExecuteByteCode(interp, codePtr)
double d1 = 0.0; /* Init. avoids compiler warning. */
double d2 = 0.0; /* Init. avoids compiler warning. */
long iResult = 0; /* Init. avoids compiler warning. */
-
+
value2Ptr = POP_OBJECT();
valuePtr = POP_OBJECT();
t1Ptr = valuePtr->typePtr;
@@ -2076,7 +2005,7 @@ TclExecuteByteCode(interp, codePtr)
PUSH_OBJECT(Tcl_NewLongObj(iResult));
TRACE(("%s %.20s %.20s => %ld\n", opName[opCode],
O2S(valuePtr), O2S(value2Ptr), iResult));
- TclDecrRefCount(valuePtr); /* done with object */
+ TclDecrRefCount(valuePtr);
} else { /* reuse the valuePtr object */
TRACE(("%s %.20s %.20s => %ld\n",
opName[opCode], /* NB: stack top is off by 1 */
@@ -2084,7 +2013,7 @@ TclExecuteByteCode(interp, codePtr)
Tcl_SetLongObj(valuePtr, iResult);
++stackTop; /* valuePtr now on stk top has right r.c. */
}
- TclDecrRefCount(value2Ptr); /* done with object */
+ TclDecrRefCount(value2Ptr);
}
ADJUST_PC(1);
@@ -2115,8 +2044,8 @@ TclExecuteByteCode(interp, codePtr)
(valuePtr->typePtr?
valuePtr->typePtr->name : "null")));
IllegalExprOperandType(interp, opCode, valuePtr);
- Tcl_DecrRefCount(valuePtr); /* done with object */
- Tcl_DecrRefCount(value2Ptr); /* done with object */
+ Tcl_DecrRefCount(valuePtr);
+ Tcl_DecrRefCount(value2Ptr);
goto checkForCatch;
}
}
@@ -2131,8 +2060,8 @@ TclExecuteByteCode(interp, codePtr)
(value2Ptr->typePtr?
value2Ptr->typePtr->name : "null")));
IllegalExprOperandType(interp, opCode, value2Ptr);
- Tcl_DecrRefCount(valuePtr); /* done with object */
- Tcl_DecrRefCount(value2Ptr); /* done with object */
+ Tcl_DecrRefCount(valuePtr);
+ Tcl_DecrRefCount(value2Ptr);
goto checkForCatch;
}
}
@@ -2147,8 +2076,8 @@ TclExecuteByteCode(interp, codePtr)
*/
if (i2 == 0) {
TRACE(("mod %ld %ld => DIVIDE BY ZERO\n", i, i2));
- Tcl_DecrRefCount(valuePtr); /* done with object */
- Tcl_DecrRefCount(value2Ptr); /* done with object */
+ Tcl_DecrRefCount(valuePtr);
+ Tcl_DecrRefCount(value2Ptr);
goto divideByZero;
}
negative = 0;
@@ -2200,14 +2129,14 @@ TclExecuteByteCode(interp, codePtr)
PUSH_OBJECT(Tcl_NewLongObj(iResult));
TRACE(("%s %ld %ld => %ld\n", opName[opCode], i, i2,
iResult));
- TclDecrRefCount(valuePtr); /* done with object */
+ TclDecrRefCount(valuePtr);
} else { /* reuse the valuePtr object */
TRACE(("%s %ld %ld => %ld\n", opName[opCode], i, i2,
iResult)); /* NB: stack top is off by 1 */
Tcl_SetLongObj(valuePtr, iResult);
++stackTop; /* valuePtr now on stk top has right r.c. */
}
- TclDecrRefCount(value2Ptr); /* done with object */
+ TclDecrRefCount(value2Ptr);
}
ADJUST_PC(1);
@@ -2252,8 +2181,8 @@ TclExecuteByteCode(interp, codePtr)
(valuePtr->typePtr?
valuePtr->typePtr->name : "null")));
IllegalExprOperandType(interp, opCode, valuePtr);
- Tcl_DecrRefCount(valuePtr); /* done with object */
- Tcl_DecrRefCount(value2Ptr); /* done with object */
+ Tcl_DecrRefCount(valuePtr);
+ Tcl_DecrRefCount(value2Ptr);
goto checkForCatch;
}
t1Ptr = valuePtr->typePtr;
@@ -2278,8 +2207,8 @@ TclExecuteByteCode(interp, codePtr)
(value2Ptr->typePtr?
value2Ptr->typePtr->name : "null")));
IllegalExprOperandType(interp, opCode, value2Ptr);
- Tcl_DecrRefCount(valuePtr); /* done with object */
- Tcl_DecrRefCount(value2Ptr); /* done with object */
+ Tcl_DecrRefCount(valuePtr);
+ Tcl_DecrRefCount(value2Ptr);
goto checkForCatch;
}
t2Ptr = value2Ptr->typePtr;
@@ -2309,8 +2238,8 @@ TclExecuteByteCode(interp, codePtr)
if (d2 == 0.0) {
TRACE(("div %.6g %.6g => DIVIDE BY ZERO\n",
d1, d2));
- Tcl_DecrRefCount(valuePtr); /* done with obj */
- Tcl_DecrRefCount(value2Ptr); /* done with obj */
+ Tcl_DecrRefCount(valuePtr);
+ Tcl_DecrRefCount(value2Ptr);
goto divideByZero;
}
dResult = d1 / d2;
@@ -2326,8 +2255,8 @@ TclExecuteByteCode(interp, codePtr)
opName[opCode], O2S(valuePtr), O2S(value2Ptr)));
TclExprFloatError(interp, dResult);
result = TCL_ERROR;
- Tcl_DecrRefCount(valuePtr); /* done with object */
- Tcl_DecrRefCount(value2Ptr); /* done with object */
+ Tcl_DecrRefCount(valuePtr);
+ Tcl_DecrRefCount(value2Ptr);
goto checkForCatch;
}
} else {
@@ -2354,8 +2283,8 @@ TclExecuteByteCode(interp, codePtr)
if (i2 == 0) {
TRACE(("div %ld %ld => DIVIDE BY ZERO\n",
i, i2));
- Tcl_DecrRefCount(valuePtr); /* done with obj */
- Tcl_DecrRefCount(value2Ptr); /* done with obj */
+ Tcl_DecrRefCount(valuePtr);
+ Tcl_DecrRefCount(value2Ptr);
goto divideByZero;
}
if (i2 < 0) {
@@ -2386,7 +2315,7 @@ TclExecuteByteCode(interp, codePtr)
TRACE(("%s %ld %ld => %ld\n", opName[opCode],
i, i2, iResult));
}
- TclDecrRefCount(valuePtr); /* done with object */
+ TclDecrRefCount(valuePtr);
} else { /* reuse the valuePtr object */
if (doDouble) { /* NB: stack top is off by 1 */
TRACE(("%s %.6g %.6g => %.6g\n", opName[opCode],
@@ -2399,7 +2328,7 @@ TclExecuteByteCode(interp, codePtr)
}
++stackTop; /* valuePtr now on stk top has right r.c. */
}
- TclDecrRefCount(value2Ptr); /* done with object */
+ TclDecrRefCount(value2Ptr);
}
ADJUST_PC(1);
@@ -2464,7 +2393,7 @@ TclExecuteByteCode(interp, codePtr)
opName[opCode], s,
(tPtr? tPtr->name : "null")));
IllegalExprOperandType(interp, opCode, valuePtr);
- Tcl_DecrRefCount(valuePtr); /* done with object */
+ Tcl_DecrRefCount(valuePtr);
goto checkForCatch;
}
tPtr = valuePtr->typePtr;
@@ -2495,7 +2424,7 @@ TclExecuteByteCode(interp, codePtr)
objPtr); /* NB: stack top is off by 1 */
}
PUSH_OBJECT(objPtr);
- TclDecrRefCount(valuePtr); /* done with popped obj */
+ TclDecrRefCount(valuePtr);
} else {
/*
* valuePtr is unshared. Modify it directly.
@@ -2545,7 +2474,7 @@ TclExecuteByteCode(interp, codePtr)
TRACE(("bitnot \"%.20s\" => ILLEGAL TYPE %s\n",
O2S(valuePtr), (tPtr? tPtr->name : "null")));
IllegalExprOperandType(interp, opCode, valuePtr);
- Tcl_DecrRefCount(valuePtr); /* done with object */
+ Tcl_DecrRefCount(valuePtr);
goto checkForCatch;
}
}
@@ -2554,7 +2483,7 @@ TclExecuteByteCode(interp, codePtr)
if (Tcl_IsShared(valuePtr)) {
PUSH_OBJECT(Tcl_NewLongObj(~i));
TRACE(("bitnot 0x%lx => (%lu)\n", i, ~i));
- TclDecrRefCount(valuePtr); /* done with popped obj */
+ TclDecrRefCount(valuePtr);
} else {
/*
* valuePtr is unshared. Modify it directly.
@@ -2567,7 +2496,7 @@ TclExecuteByteCode(interp, codePtr)
ADJUST_PC(1);
case INST_CALL_BUILTIN_FUNC1:
- opnd = TclGetUInt1AtPc(pc+1);
+ opnd = TclGetUInt1AtPtr(pc+1);
{
/*
* Call one of the built-in Tcl math functions.
@@ -2595,7 +2524,7 @@ TclExecuteByteCode(interp, codePtr)
ADJUST_PC(2);
case INST_CALL_FUNC1:
- opnd = TclGetUInt1AtPc(pc+1);
+ opnd = TclGetUInt1AtPtr(pc+1);
{
/*
* Call a non-builtin Tcl math function previously
@@ -2677,7 +2606,7 @@ TclExecuteByteCode(interp, codePtr)
objPtr = Tcl_NewDoubleObj(d);
}
Tcl_IncrRefCount(objPtr);
- TclDecrRefCount(valuePtr); /* done with object */
+ TclDecrRefCount(valuePtr);
valuePtr = objPtr;
tPtr = valuePtr->typePtr;
} else {
@@ -2695,6 +2624,8 @@ TclExecuteByteCode(interp, codePtr)
goto checkForCatch;
}
}
+ shared = shared; /* lint, shared not used. */
+ converted = converted; /* lint, converted not used. */
TRACE(("tryCvtToNumeric \"%.20s\" => numeric, %s, %s\n",
O2S(valuePtr),
(converted? "converted" : "not converted"),
@@ -2754,7 +2685,7 @@ TclExecuteByteCode(interp, codePtr)
if (rangePtr == NULL) {
TRACE(("continue => no encl. loop or catch, returning TCL_CONTINUE\n"));
result = TCL_CONTINUE;
- goto abnormalReturn; /* no catch exists to check */
+ goto abnormalReturn;
}
switch (rangePtr->type) {
case LOOP_EXCEPTION_RANGE:
@@ -2778,7 +2709,7 @@ TclExecuteByteCode(interp, codePtr)
continue; /* restart outer instruction loop at pc */
case INST_FOREACH_START4:
- opnd = TclGetUInt4AtPc(pc+1);
+ opnd = TclGetUInt4AtPtr(pc+1);
{
/*
* Initialize the temporary local var that holds the count
@@ -2795,22 +2726,13 @@ TclExecuteByteCode(interp, codePtr)
iterVarPtr = &(compiledLocals[iterTmpIndex]);
oldValuePtr = iterVarPtr->value.objPtr;
-#ifdef TCL_COMPILE_DEBUG
- if (TclIsVarLink(iterVarPtr)) {
- panic("TclExecuteByteCode execution failure: foreach loop iter temp %d is link\n", iterTmpIndex);
- }
- if ((oldValuePtr != NULL) && Tcl_IsShared(oldValuePtr)) {
- panic("TclExecuteByteCode execution failure: foreach loop iter temp %d has shared object\n", iterTmpIndex);
- }
-#endif /* TCL_COMPILE_DEBUG */
-
if (oldValuePtr == NULL) {
iterVarPtr->value.objPtr = Tcl_NewLongObj(-1);
Tcl_IncrRefCount(iterVarPtr->value.objPtr);
if (oldValuePtr != NULL) {
- Tcl_DecrRefCount(oldValuePtr); /* free old value */
+ Tcl_DecrRefCount(oldValuePtr);
}
- } else { /* update object in place */
+ } else {
Tcl_SetLongObj(oldValuePtr, -1);
}
TclSetVarScalar(iterVarPtr);
@@ -2821,7 +2743,7 @@ TclExecuteByteCode(interp, codePtr)
ADJUST_PC(5);
case INST_FOREACH_STEP4:
- opnd = TclGetUInt4AtPc(pc+1);
+ opnd = TclGetUInt4AtPtr(pc+1);
{
/*
* "Step" a foreach loop (i.e., begin its next iteration) by
@@ -2848,18 +2770,6 @@ TclExecuteByteCode(interp, codePtr)
iterVarPtr = &(compiledLocals[iterTmpIndex]);
oldValuePtr = iterVarPtr->value.objPtr;
-#ifdef TCL_COMPILE_DEBUG
- if (TclIsVarLink(iterVarPtr) || TclIsVarUndefined(iterVarPtr)
- || !TclIsVarScalar(iterVarPtr)) {
- panic("TclExecuteByteCode execution failure: foreach loop iter temp %d is link, undefined, or array\n", iterTmpIndex);
- }
- if ((oldValuePtr == NULL)
- || (oldValuePtr->typePtr != &tclIntType)
- || (oldValuePtr->bytes != NULL)
- || Tcl_IsShared(oldValuePtr)) {
- panic("TclExecuteByteCode execution failure: foreach loop iter count object is bad\n");
- }
-#endif /* TCL_COMPILE_DEBUG */
iterNum = (oldValuePtr->internalRep.longValue + 1);
Tcl_SetLongObj(oldValuePtr, iterNum);
@@ -2875,17 +2785,6 @@ TclExecuteByteCode(interp, codePtr)
listVarPtr = &(compiledLocals[listTmpIndex]);
listPtr = listVarPtr->value.objPtr;
-#ifdef TCL_COMPILE_DEBUG
- if (TclIsVarLink(listVarPtr) || TclIsVarUndefined(listVarPtr)
- || !TclIsVarScalar(listVarPtr)) {
- panic("TclExecuteByteCode execution failure: foreach loop list temp %d is link, undefined, or array\n", listTmpIndex);
- }
- if (listPtr == NULL) {
- panic("TclExecuteByteCode execution failure: NULL foreach list temp %d: \"%s\"\n",
- listTmpIndex,
- Tcl_GetStringFromObj(Tcl_GetObjResult(interp), &length));
- }
-#endif /* TCL_COMPILE_DEBUG */
result = Tcl_ListObjLength(interp, listPtr, &listLen);
if (result != TCL_OK) {
TRACE_WITH_OBJ(("foreach_step4 %u => ERROR converting list %ld, \"%s\": ",
@@ -2923,7 +2822,7 @@ TclExecuteByteCode(interp, codePtr)
int setEmptyStr = 0;
if (valIndex >= listLen) {
setEmptyStr = 1;
- elemPtr = Tcl_NewObj(); /* set to "" */
+ elemPtr = Tcl_NewObj();
} else {
elemPtr = listRepPtr->elements[valIndex];
}
@@ -2970,7 +2869,7 @@ TclExecuteByteCode(interp, codePtr)
*/
catchStackPtr[++catchTop] = stackTop;
TRACE(("beginCatch4 %u => catchTop=%d, stackTop=%d\n",
- TclGetUInt4AtPc(pc+1), catchTop, stackTop));
+ TclGetUInt4AtPtr(pc+1), catchTop, stackTop));
ADJUST_PC(5);
case INST_END_CATCH:
@@ -2985,7 +2884,7 @@ TclExecuteByteCode(interp, codePtr)
ADJUST_PC(1);
case INST_PUSH_RETURN_CODE:
- PUSH_OBJECT(Tcl_NewLongObj(result)); /* i.e., the return code */
+ PUSH_OBJECT(Tcl_NewLongObj(result));
TRACE(("pushReturnCode => %u\n", result));
ADJUST_PC(1);
@@ -3007,68 +2906,71 @@ TclExecuteByteCode(interp, codePtr)
result = TCL_ERROR;
/*
- * Execution has generated an "exceptional return" (or "exception")
- * such as TCL_ERROR. Look for the closest enclosing catch exception
- * range, if any. If no enclosing catch range is found, stop
- * execution and return the "exceptional return" code.
+ * Execution has generated an "exception" such as TCL_ERROR. If the
+ * exception is an error, record information about what was being
+ * executed when the error occurred. Find the closest enclosing
+ * catch range, if any. If no enclosing catch range is found, stop
+ * execution and return the "exception" code.
*/
checkForCatch:
- rangePtr = TclGetExceptionRangeForPc(pc, /*catchOnly*/ 1, codePtr);
- if (rangePtr == NULL) {
- TRACE((" ... no enclosing catch, returning %s\n",
- StringForResultCode(result)));
- goto abnormalReturn; /* no catch exists to check */
- }
-
- /*
- * A catch exception range (rangePtr) has been to handle an
- * "exception". It was found either by checkForCatch just above or
- * by an instruction during break, continue, or error processing.
- * Jump to its catchOffset after unwinding the operand stack to
- * the depth it had when starting to execute the range's catch
- * command. Also, if the exception is an error, record information
- * about what was being executed when the error occurred.
- */
-
- processCatch:
if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
+ int numChars;
+ char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars);
char buf[200];
- int cmdIndex = TclGetSrcInfoForPc(pc, codePtr);
-
- /*
- * Compute the line number where the error occurred.
- */
+ register char *p;
+ char *ellipsis = "";
- iPtr->errorLine = 1; /* no correct line # information yet */
-
/*
* Print the command in the error message (up to a certain
- * number of characters, or up to the first new-line).
+ * number of characters, or up to the first newline).
*/
-
- if (cmdIndex != -1) {
- CmdLocation *locPtr = &(codePtr->cmdMapPtr[cmdIndex]);
- char *ellipsis = "";
- int numChars = locPtr->numSrcChars;
+
+ iPtr->errorLine = 1;
+ if (cmd != NULL) {
+ for (p = codePtr->source; p != cmd; p++) {
+ if (*p == '\n') {
+ iPtr->errorLine++;
+ }
+ }
+ for ( ; (isspace(UCHAR(*p)) || (*p == ';')); p++) {
+ if (*p == '\n') {
+ iPtr->errorLine++;
+ }
+ }
+
if (numChars > 150) {
numChars = 150;
ellipsis = "...";
}
if (!(iPtr->flags & ERR_IN_PROGRESS)) {
sprintf(buf, "\n while executing\n\"%.*s%s\"",
- numChars, (codePtr->source + locPtr->srcOffset),
- ellipsis);
+ numChars, cmd, ellipsis);
} else {
sprintf(buf, "\n invoked from within\n\"%.*s%s\"",
- numChars, (codePtr->source + locPtr->srcOffset),
- ellipsis);
+ numChars, cmd, ellipsis);
}
Tcl_AddObjErrorInfo(interp, buf, -1);
iPtr->flags |= ERR_ALREADY_LOGGED;
}
}
-
+ rangePtr = TclGetExceptionRangeForPc(pc, /*catchOnly*/ 1, codePtr);
+ if (rangePtr == NULL) {
+ TRACE((" ... no enclosing catch, returning %s\n",
+ StringForResultCode(result)));
+ goto abnormalReturn;
+ }
+
+ /*
+ * A catch exception range (rangePtr) was found to handle an
+ * "exception". It was found either by checkForCatch just above or
+ * by an instruction during break, continue, or error processing.
+ * Jump to its catchOffset after unwinding the operand stack to
+ * the depth it had when starting to execute the range's catch
+ * command.
+ */
+
+ processCatch:
while (stackTop > catchStackPtr[catchTop]) {
valuePtr = POP_OBJECT();
TclDecrRefCount(valuePtr);
@@ -3107,6 +3009,140 @@ TclExecuteByteCode(interp, codePtr)
/*
*----------------------------------------------------------------------
*
+ * PrintByteCodeInfo --
+ *
+ * This procedure prints a summary about a bytecode object to stdout.
+ * It is called by TclExecuteByteCode when starting to execute the
+ * bytecode object if tclTraceExec has the value 2 or more.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+PrintByteCodeInfo(codePtr)
+ register ByteCode *codePtr; /* The bytecode whose summary is printed
+ * to stdout. */
+{
+ Proc *procPtr = codePtr->procPtr;
+ int numCmds = codePtr->numCommands;
+ int numObjs = codePtr->numObjects;
+ int objBytes, i;
+
+ objBytes = (numObjs * sizeof(Tcl_Obj));
+ for (i = 0; i < numObjs; i++) {
+ Tcl_Obj *litObjPtr = codePtr->objArrayPtr[i];
+ if (litObjPtr->bytes != NULL) {
+ objBytes += litObjPtr->length;
+ }
+ }
+
+ fprintf(stdout, "\nExecuting ByteCode 0x%x, ref ct %u, epoch %u, interp 0x%x(epoch %u)\n",
+ (unsigned int) codePtr, codePtr->refCount,
+ codePtr->compileEpoch, (unsigned int) codePtr->iPtr,
+ codePtr->iPtr->compileEpoch);
+
+ fprintf(stdout, " Source: ");
+ TclPrintSource(stdout, codePtr->source, 70);
+
+ fprintf(stdout, "\n Cmds %d, chars %d, inst %u, objs %u, aux %d, stk depth %u, code/src %.2fn",
+ numCmds, codePtr->numSrcChars, codePtr->numCodeBytes, numObjs,
+ codePtr->numAuxDataItems, codePtr->maxStackDepth,
+ (codePtr->numSrcChars?
+ ((float)codePtr->totalSize)/((float)codePtr->numSrcChars) : 0.0));
+
+ fprintf(stdout, " Code %d = %d(header)+%d(inst)+%d(objs)+%d(exc)+%d(aux)+%d(cmd map)\n",
+ codePtr->totalSize, sizeof(ByteCode), codePtr->numCodeBytes,
+ objBytes, (codePtr->numExcRanges * sizeof(ExceptionRange)),
+ (codePtr->numAuxDataItems * sizeof(AuxData)),
+ codePtr->numCmdLocBytes);
+
+ if (procPtr != NULL) {
+ fprintf(stdout,
+ " Proc 0x%x, ref ct %d, args %d, compiled locals %d\n",
+ (unsigned int) procPtr, procPtr->refCount,
+ procPtr->numArgs, procPtr->numCompiledLocals);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ValidatePcAndStackTop --
+ *
+ * This procedure is called by TclExecuteByteCode when debugging to
+ * verify that the program counter and stack top are valid during
+ * execution.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Prints a message to stderr and panics if either the pc or stack
+ * top are invalid.
+ *
+ *----------------------------------------------------------------------
+ */
+
+#ifdef TCL_COMPILE_DEBUG
+static void
+ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound, stackUpperBound)
+ register ByteCode *codePtr; /* The bytecode whose summary is printed
+ * to stdout. */
+ unsigned char *pc; /* Points to first byte of a bytecode
+ * instruction. The program counter. */
+ int stackTop; /* Current stack top. Must be between
+ * stackLowerBound and stackUpperBound
+ * (inclusive). */
+ int stackLowerBound; /* Smallest legal value for stackTop. */
+ int stackUpperBound; /* Greatest legal value for stackTop. */
+{
+ unsigned int relativePc = (unsigned int) (pc - codePtr->codeStart);
+ unsigned int codeStart = (unsigned int) codePtr->codeStart;
+ unsigned int codeEnd = (unsigned int)
+ (codePtr->codeStart + codePtr->numCodeBytes);
+ unsigned char opCode = *pc;
+
+ if (((unsigned int) pc < codeStart) || ((unsigned int) pc > codeEnd)) {
+ fprintf(stderr, "\nBad instruction pc 0x%x in TclExecuteByteCode\n",
+ (unsigned int) pc);
+ panic("TclExecuteByteCode execution failure: bad pc");
+ }
+ if ((unsigned int) opCode > LAST_INST_OPCODE) {
+ fprintf(stderr, "\nBad opcode %d at pc %u in TclExecuteByteCode\n",
+ (unsigned int) opCode, relativePc);
+ panic("TclExecuteByteCode execution failure: bad opcode");
+ }
+ if ((stackTop < stackLowerBound) || (stackTop > stackUpperBound)) {
+ int numChars;
+ char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars);
+ char *ellipsis = "";
+
+ fprintf(stderr, "\nBad stack top %d at pc %u in TclExecuteByteCode",
+ stackTop, relativePc);
+ if (cmd != NULL) {
+ if (numChars > 100) {
+ numChars = 100;
+ ellipsis = "...";
+ }
+ fprintf(stderr, "\n executing %.*s%s\n", numChars, cmd,
+ ellipsis);
+ } else {
+ fprintf(stderr, "\n");
+ }
+ panic("TclExecuteByteCode execution failure: bad stack top");
+ }
+}
+#endif /* TCL_COMPILE_DEBUG */
+
+/*
+ *----------------------------------------------------------------------
+ *
* IllegalExprOperandType --
*
* Used by TclExecuteByteCode to add an error message to errorInfo
@@ -3201,7 +3237,7 @@ CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv)
*/
p = (char *) ckalloc((unsigned) (numChars + 1));
- strncpy(p, command, (size_t) numChars);
+ memcpy((VOID *) p, (VOID *) command, (size_t) numChars);
p[numChars] = '\0';
/*
@@ -3218,21 +3254,20 @@ CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv)
/*
*----------------------------------------------------------------------
*
- * TclGetSrcInfoForPc --
+ * GetSrcInfoForPc --
*
- * Procedure that given a program counter value, returns an index
- * of the closest command's element in the bytecode code unit's
- * CmdLocation array. This element provides information about that
- * command's source: a pointer to its first byte and the number
- * of its characters.
+ * Given a program counter value, finds the closest command in the
+ * bytecode code unit's CmdLocation array and returns information about
+ * that command's source: a pointer to its first byte and the number of
+ * characters.
*
* Results:
- * If a command in the bytecode code unit is found that encloses
- * the program counter value, the index of the command's element
- * in the CmdLocation array is returned. If multiple commands
- * resulted in code at pc, the index for the command with code that
- * starts closest to pc is returned. If no matching command is
- * found, -1 is returned.
+ * If a command is found that encloses the program counter value, a
+ * pointer to the command's source is returned and the length of the
+ * source is stored at *lengthPtr. If multiple commands resulted in
+ * code at pc, information about the closest enclosing command is
+ * returned. If no matching command is found, NULL is returned and
+ * *lengthPtr is unchanged.
*
* Side effects:
* None.
@@ -3240,38 +3275,102 @@ CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv)
*----------------------------------------------------------------------
*/
-int
-TclGetSrcInfoForPc(pc, codePtr)
+static char *
+GetSrcInfoForPc(pc, codePtr, lengthPtr)
unsigned char *pc; /* The program counter value for which to
* return the closest command's source info.
* This points to a bytecode instruction
* in codePtr's code. */
ByteCode* codePtr; /* The bytecode sequence in which to look
* up the command source for the pc. */
+ int *lengthPtr; /* If non-NULL, the location where the
+ * length of the command's source should be
+ * stored. If NULL, no length is stored. */
{
- int codeOffset = (pc - codePtr->codeStart);
- int numCommands = codePtr->numCommands;
- CmdLocation *cmdMapPtr = codePtr->cmdMapPtr;
- register CmdLocation *locPtr;
- int bestCmd = -1; /* Index of current candidate for closest
- * command. */
- int bestDist = INT_MAX; /* Distance of pc to bestCmd's start pc. */
- int startOffset, endOffset, dist;
- register int i;
+ register int pcOffset = (pc - codePtr->codeStart);
+ int numCmds = codePtr->numCommands;
+ unsigned char *codeDeltaNext, *codeLengthNext;
+ unsigned char *srcDeltaNext, *srcLengthNext;
+ int codeOffset, codeLen, codeEnd, srcOffset, srcLen, delta, i;
+ int bestDist = INT_MAX; /* Distance of pc to best cmd's start pc. */
+ int bestSrcOffset = -1; /* Initialized to avoid compiler warning. */
+ int bestSrcLength = -1; /* Initialized to avoid compiler warning. */
+
+ if ((pcOffset < 0) || (pcOffset >= codePtr->numCodeBytes)) {
+ return NULL;
+ }
+
+ /*
+ * Decode the code and source offset and length for each command. The
+ * closest enclosing command is the last one whose code started before
+ * pcOffset.
+ */
+
+ codeDeltaNext = codePtr->codeDeltaStart;
+ codeLengthNext = codePtr->codeLengthStart;
+ srcDeltaNext = codePtr->srcDeltaStart;
+ srcLengthNext = codePtr->srcLengthStart;
+ codeOffset = srcOffset = 0;
+ for (i = 0; i < numCmds; i++) {
+ if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {
+ codeDeltaNext++;
+ delta = TclGetInt4AtPtr(codeDeltaNext);
+ codeDeltaNext += 4;
+ } else {
+ delta = TclGetInt1AtPtr(codeDeltaNext);
+ codeDeltaNext++;
+ }
+ codeOffset += delta;
- for (i = 0; i < numCommands; i++) {
- locPtr = &(cmdMapPtr[i]);
- startOffset = locPtr->codeOffset;
- endOffset = (startOffset + locPtr->numCodeBytes - 1);
- if ((startOffset <= codeOffset) && (codeOffset <= endOffset)) {
- dist = (codeOffset - startOffset);
+ if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) {
+ codeLengthNext++;
+ codeLen = TclGetInt4AtPtr(codeLengthNext);
+ codeLengthNext += 4;
+ } else {
+ codeLen = TclGetInt1AtPtr(codeLengthNext);
+ codeLengthNext++;
+ }
+ codeEnd = (codeOffset + codeLen - 1);
+
+ if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {
+ srcDeltaNext++;
+ delta = TclGetInt4AtPtr(srcDeltaNext);
+ srcDeltaNext += 4;
+ } else {
+ delta = TclGetInt1AtPtr(srcDeltaNext);
+ srcDeltaNext++;
+ }
+ srcOffset += delta;
+
+ if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {
+ srcLengthNext++;
+ srcLen = TclGetInt4AtPtr(srcLengthNext);
+ srcLengthNext += 4;
+ } else {
+ srcLen = TclGetInt1AtPtr(srcLengthNext);
+ srcLengthNext++;
+ }
+
+ if (codeOffset > pcOffset) { /* best cmd already found */
+ break;
+ } else if (pcOffset <= codeEnd) { /* this cmd's code encloses pc */
+ int dist = (pcOffset - codeOffset);
if (dist <= bestDist) {
- bestCmd = i;
bestDist = dist;
+ bestSrcOffset = srcOffset;
+ bestSrcLength = srcLen;
}
}
}
- return bestCmd;
+
+ if (bestDist == INT_MAX) {
+ return NULL;
+ }
+
+ if (lengthPtr != NULL) {
+ *lengthPtr = bestSrcLength;
+ }
+ return (codePtr->source + bestSrcOffset);
}
/*
@@ -3430,7 +3529,7 @@ ExprUnaryFunc(interp, eePtr, clientData)
*/
done:
- Tcl_DecrRefCount(valuePtr); /* done with popped obj */
+ Tcl_DecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return result;
}
@@ -3530,8 +3629,8 @@ ExprBinaryFunc(interp, eePtr, clientData)
*/
done:
- Tcl_DecrRefCount(valuePtr); /* done with popped obj */
- Tcl_DecrRefCount(value2Ptr); /* done with popped obj */
+ Tcl_DecrRefCount(valuePtr);
+ Tcl_DecrRefCount(value2Ptr);
DECACHE_STACK_INFO();
return result;
}
@@ -3625,7 +3724,7 @@ ExprAbsFunc(interp, eePtr, clientData)
*/
done:
- Tcl_DecrRefCount(valuePtr); /* done with popped obj */
+ Tcl_DecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return result;
}
@@ -3689,7 +3788,7 @@ ExprDoubleFunc(interp, eePtr, clientData)
*/
done:
- Tcl_DecrRefCount(valuePtr); /* done with popped obj */
+ Tcl_DecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return result;
}
@@ -3782,7 +3881,7 @@ ExprIntFunc(interp, eePtr, clientData)
*/
done:
- Tcl_DecrRefCount(valuePtr); /* done with popped obj */
+ Tcl_DecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return result;
}
@@ -3956,7 +4055,7 @@ ExprRoundFunc(interp, eePtr, clientData)
*/
done:
- Tcl_DecrRefCount(valuePtr); /* done with popped obj */
+ Tcl_DecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return result;
}
@@ -3975,7 +4074,7 @@ ExprSrandFunc(interp, eePtr, clientData)
Tcl_Obj *valuePtr;
Tcl_ObjType *tPtr;
long i = 0; /* Initialized to avoid compiler warning. */
- int result = TCL_OK;
+ int result;
/*
* Set stackPtr and stackTop from eePtr.
@@ -4000,7 +4099,7 @@ ExprSrandFunc(interp, eePtr, clientData)
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use ",
((tPtr == &tclDoubleType)? "floating-point value" : "non-numeric string"),
" as argument to srand", (char *) NULL);
- Tcl_DecrRefCount(valuePtr); /* done with popped obj */
+ Tcl_DecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return result;
}
@@ -4264,6 +4363,39 @@ TclExprFloatError(interp, value)
/*
*----------------------------------------------------------------------
*
+ * TclLog2 --
+ *
+ * Procedure used while collecting compilation statistics to determine
+ * the log base 2 of an integer.
+ *
+ * Results:
+ * Returns the log base 2 of the operand. If the argument is less
+ * than or equal to zero, a zero is returned.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclLog2(value)
+ register int value; /* The integer for which to compute the
+ * log base 2. */
+{
+ register int n = value;
+ register int result = 0;
+
+ while (n > 1) {
+ n = n >> 1;
+ result++;
+ }
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* EvalStatsCmd --
*
* Implements the "evalstats" command that prints instruction execution
@@ -4287,23 +4419,108 @@ EvalStatsCmd(unused, interp, argc, argv)
{
register double total = 0.0;
register int i;
+ int maxSizeDecade = 0;
+ double totalHeaderBytes = (tclNumCompilations * sizeof(ByteCode));
for (i = 0; i < 256; i++) {
- if (instructionCount[i]) {
+ if (instructionCount[i] != 0) {
total += instructionCount[i];
}
- }
+ }
+
+ for (i = 31; i >= 0; i--) {
+ if ((tclSourceCount[i] > 0) && (tclByteCodeCount[i] > 0)) {
+ maxSizeDecade = i;
+ break;
+ }
+ }
- fprintf(stdout, "\nNumber of ByteCode compilations: %ld\n",
+ fprintf(stdout, "\nNumber of compilations %ld\n",
tclNumCompilations);
- fprintf(stdout, "Number of ByteCode executions: %ld\n",
+ fprintf(stdout, "Number of executions %ld\n",
numExecutions);
- fprintf(stdout, "Number of Tcl objects in use: %ld, allocated %ld, freed %ld\n",
- (tclObjsAlloced - tclObjsFreed), tclObjsAlloced, tclObjsFreed);
- fprintf(stdout, "Number of instructions executed: %.0f\n\n", total);
+ fprintf(stdout, "Average executions/compilation %.0f\n",
+ ((float) numExecutions/tclNumCompilations));
+
+ fprintf(stdout, "\nInstructions executed %.0f\n",
+ total);
+ fprintf(stdout, "Average instructions/compile %.0f\n",
+ total/tclNumCompilations);
+ fprintf(stdout, "Average instructions/execution %.0f\n",
+ total/numExecutions);
+
+ fprintf(stdout, "\nTotal source bytes %.6g\n",
+ tclTotalSourceBytes);
+ fprintf(stdout, "Total code bytes %.6g\n",
+ tclTotalCodeBytes);
+ fprintf(stdout, "Average code/compilation %.0f\n",
+ tclTotalCodeBytes/tclNumCompilations);
+ fprintf(stdout, "Average code/source %.2f\n",
+ tclTotalCodeBytes/tclTotalSourceBytes);
+ fprintf(stdout, "Current source bytes %.6g\n",
+ tclCurrentSourceBytes);
+ fprintf(stdout, "Current code bytes %.6g\n",
+ tclCurrentCodeBytes);
+ fprintf(stdout, "Current code/source %.2f\n",
+ tclCurrentCodeBytes/tclCurrentSourceBytes);
+
+ fprintf(stdout, "\nTotal objects allocated %ld\n",
+ tclObjsAlloced);
+ fprintf(stdout, "Total objects freed %ld\n",
+ tclObjsFreed);
+ fprintf(stdout, "Current objects: %ld\n",
+ (tclObjsAlloced - tclObjsFreed));
+
+ fprintf(stdout, "\nBreakdown of code byte requirements:\n");
+ fprintf(stdout, " Total bytes Pct of Avg per\n");
+ fprintf(stdout, " all code compile\n");
+ fprintf(stdout, "Total code %12.6g 100%% %8.2f\n",
+ tclTotalCodeBytes, tclTotalCodeBytes/tclNumCompilations);
+ fprintf(stdout, "Header %12.6g %8.2f%% %8.2f\n",
+ totalHeaderBytes,
+ ((totalHeaderBytes * 100.0) / tclTotalCodeBytes),
+ totalHeaderBytes/tclNumCompilations);
+ fprintf(stdout, "Instructions %12.6g %8.2f%% %8.2f\n",
+ tclTotalInstBytes,
+ ((tclTotalInstBytes * 100.0) / tclTotalCodeBytes),
+ tclTotalInstBytes/tclNumCompilations);
+ fprintf(stdout, "Objects %12.6g %8.2f%% %8.2f\n",
+ tclTotalObjBytes,
+ ((tclTotalObjBytes * 100.0) / tclTotalCodeBytes),
+ tclTotalObjBytes/tclNumCompilations);
+ fprintf(stdout, "Exception table %12.6g %8.2f%% %8.2f\n",
+ tclTotalExceptBytes,
+ ((tclTotalExceptBytes * 100.0) / tclTotalCodeBytes),
+ tclTotalExceptBytes/tclNumCompilations);
+ fprintf(stdout, "Auxiliary data %12.6g %8.2f%% %8.2f\n",
+ tclTotalAuxBytes,
+ ((tclTotalAuxBytes * 100.0) / tclTotalCodeBytes),
+ tclTotalAuxBytes/tclNumCompilations);
+ fprintf(stdout, "Command map %12.6g %8.2f%% %8.2f\n",
+ tclTotalCmdMapBytes,
+ ((tclTotalCmdMapBytes * 100.0) / tclTotalCodeBytes),
+ tclTotalCmdMapBytes/tclNumCompilations);
+
+ fprintf(stdout, "\nSource and ByteCode size distributions:\n");
+ fprintf(stdout, " binary decade source code\n");
+ for (i = 0; i <= maxSizeDecade; i++) {
+ int decadeLow, decadeHigh;
+
+ if (i == 0) {
+ decadeLow = 0;
+ } else {
+ decadeLow = 1 << i;
+ }
+ decadeHigh = (1 << (i+1)) - 1;
+ fprintf(stdout, " %6d -%6d %6d %6d\n",
+ decadeLow, decadeHigh,
+ tclSourceCount[i], tclByteCodeCount[i]);
+ }
+
+ fprintf(stdout, "\nInstruction counts:\n");
for (i = 0; i < 256; i++) {
if (instructionCount[i]) {
- fprintf(stdout, "%30s %8d %6.2f%%\n",
+ fprintf(stdout, "%20s %8d %6.2f%%\n",
opName[i], instructionCount[i],
(instructionCount[i] * 100.0)/total);
}
@@ -4494,7 +4711,8 @@ DupCmdNameInternalRep(srcPtr, copyPtr)
register ResolvedCmdName *resPtr =
(ResolvedCmdName *) srcPtr->internalRep.otherValuePtr;
- copyPtr->internalRep.otherValuePtr = (VOID *) resPtr;
+ copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
+ copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
if (resPtr != NULL) {
resPtr->refCount++;
}
@@ -4590,6 +4808,7 @@ SetCmdNameFromAny(interp, objPtr)
}
objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
+ objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = &tclCmdNameType;
return TCL_OK;
}
diff --git a/contrib/tcl/generic/tclFileName.c b/contrib/tcl/generic/tclFileName.c
index 74643048769a..69d825cdac41 100644
--- a/contrib/tcl/generic/tclFileName.c
+++ b/contrib/tcl/generic/tclFileName.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclFileName.c 1.28 97/05/14 13:23:48
+ * SCCS: @(#) tclFileName.c 1.31 97/08/05 15:23:04
*/
#include "tclInt.h"
@@ -1088,7 +1088,9 @@ DoTildeSubst(interp, user, resultPtr)
}
Tcl_JoinPath(1, &dir, resultPtr);
} else {
- if (TclGetUserHome(user, resultPtr) == NULL) {
+
+ /* lint, TclGetuserHome() always NULL under windows. */
+ if (TclGetUserHome(user, resultPtr) == NULL) {
if (interp) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "user \"", user, "\" doesn't exist",
diff --git a/contrib/tcl/generic/tclHistory.c b/contrib/tcl/generic/tclHistory.c
index f6572c7a2031..0419c3d4b4af 100644
--- a/contrib/tcl/generic/tclHistory.c
+++ b/contrib/tcl/generic/tclHistory.c
@@ -1,139 +1,23 @@
/*
* tclHistory.c --
*
- * This module implements history as an optional addition to Tcl.
- * It can be called to record commands ("events") before they are
- * executed, and it provides a command that may be used to perform
- * history substitutions.
+ * This module and the Tcl library file history.tcl together implement
+ * Tcl command history. Tcl_RecordAndEval(Obj) can be called to record
+ * commands ("events") before they are executed. Commands defined in
+ * history.tcl may be used to perform history substitutions.
*
* Copyright (c) 1990-1993 The Regents of the University of California.
- * Copyright (c) 1994-1996 Sun Microsystems, Inc.
+ * Copyright (c) 1994-1997 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclHistory.c 1.43 97/05/14 13:23:18
+ * SCCS: @(#) tclHistory.c 1.47 97/08/04 16:08:17
*/
#include "tclInt.h"
#include "tclPort.h"
-/*
- * This history stuff is mostly straightforward, except for one thing
- * that makes everything very complicated. Suppose that the following
- * commands get executed:
- * echo foo
- * history redo
- * It's important that the history event recorded for the second command
- * be "echo foo", not "history redo". Otherwise, if another "history redo"
- * command is typed, it will result in infinite recursions on the
- * "history redo" command. Thus, the actual recorded history must be
- * echo foo
- * echo foo
- * To do this, the history command revises recorded history as part of
- * its execution. In the example above, when "history redo" starts
- * execution, the current event is "history redo", but the history
- * command arranges for the current event to be changed to "echo foo".
- *
- * There are three additional complications. The first is that history
- * substitution may only be part of a command, as in the following
- * command sequence:
- * echo foo bar
- * echo [history word 3]
- * In this case, the second event should be recorded as "echo bar". Only
- * part of the recorded event is to be modified. Fortunately, Tcl_Eval
- * helps with this by recording (in the evalFirst and evalLast fields of
- * the intepreter) the location of the command being executed, so the
- * history module can replace exactly the range of bytes corresponding
- * to the history substitution command.
- *
- * The second complication is that there are two ways to revise history:
- * replace a command, and replace the result of a command. Consider the
- * two examples below:
- * format {result is %d} $num | format {result is %d} $num
- * print [history redo] | print [history word 3]
- * Recorded history for these two cases should be as follows:
- * format {result is %d} $num | format {result is %d} $num
- * print [format {result is %d} $num] | print $num
- * In the left case, the history command was replaced with another command
- * to be executed (the brackets were retained), but in the case on the
- * right the result of executing the history command was replaced (i.e.
- * brackets were replaced too).
- *
- * The third complication is that there could potentially be many
- * history substitutions within a single command, as in:
- * echo [history word 3] [history word 2]
- * There could even be nested history substitutions, as in:
- * history subs abc [history word 2]
- * If history revisions were made immediately during each "history" command
- * invocations, it would be very difficult to produce the correct cumulative
- * effect from several substitutions in the same command. To get around
- * this problem, the actual history revision isn't made during the execution
- * of the "history" command. Information about the changes is just recorded,
- * in xxx records, and the actual changes are made during the next call to
- * Tcl_RecordHistory (when we know that execution of the previous command
- * has finished).
- */
-
-/*
- * Default space allocation for command strings:
- */
-
-#define INITIAL_CMD_SIZE 40
-
-/*
- * Forward declarations for procedures defined later in this file:
- */
-
-static void DoRevs _ANSI_ARGS_((Interp *iPtr));
-static HistoryEvent * GetEvent _ANSI_ARGS_((Interp *iPtr, char *string));
-static char * GetWords _ANSI_ARGS_((Interp *iPtr, char *command,
- char *words));
-static void InitHistory _ANSI_ARGS_((Interp *iPtr));
-static void InsertRev _ANSI_ARGS_((Interp *iPtr,
- HistoryRev *revPtr));
-static void MakeSpace _ANSI_ARGS_((HistoryEvent *hPtr, int size));
-static void RevCommand _ANSI_ARGS_((Interp *iPtr, char *string));
-static void RevResult _ANSI_ARGS_((Interp *iPtr, char *string));
-static int SubsAndEval _ANSI_ARGS_((Interp *iPtr, char *cmd,
- char *old, char *new));
-
-/*
- *----------------------------------------------------------------------
- *
- * InitHistory --
- *
- * Initialize history-related state in an interpreter.
- *
- * Results:
- * None.
- *
- * Side effects:
- * History info is initialized in iPtr.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-InitHistory(iPtr)
- register Interp *iPtr; /* Interpreter to initialize. */
-{
- int i;
-
- if (iPtr->numEvents != 0) {
- return;
- }
- iPtr->numEvents = 20;
- iPtr->events = (HistoryEvent *)
- ckalloc((unsigned) (iPtr->numEvents * sizeof(HistoryEvent)));
- for (i = 0; i < iPtr->numEvents; i++) {
- iPtr->events[i].command = (char *) ckalloc(INITIAL_CMD_SIZE);
- *iPtr->events[i].command = 0;
- iPtr->events[i].bytesAvl = INITIAL_CMD_SIZE;
- }
- iPtr->curEvent = 0;
- iPtr->curEventNum = 0;
-}
/*
*----------------------------------------------------------------------
@@ -149,11 +33,7 @@ InitHistory(iPtr)
* executing cmd.
*
* Side effects:
- * The command is recorded and executed. In addition, pending history
- * revisions are carried out, and information is set up to enable
- * Tcl_Eval to identify history command ranges. This procedure also
- * initializes history information for the interpreter, if it hasn't
- * already been initialized.
+ * The command is recorded and executed.
*
*----------------------------------------------------------------------
*/
@@ -168,931 +48,108 @@ Tcl_RecordAndEval(interp, cmd, flags)
* TCL_EVAL_GLOBAL means use Tcl_GlobalEval
* instead of Tcl_Eval. */
{
- register Interp *iPtr = (Interp *) interp;
- register HistoryEvent *eventPtr;
- int length, result;
-
- if (iPtr->numEvents == 0) {
- InitHistory(iPtr);
- }
- DoRevs(iPtr);
-
- /*
- * Don't record empty commands.
- */
-
- while (isspace(UCHAR(*cmd))) {
- cmd++;
- }
- if (*cmd == '\0') {
- Tcl_ResetResult(interp);
- return TCL_OK;
- }
-
- iPtr->curEventNum++;
- iPtr->curEvent++;
- if (iPtr->curEvent >= iPtr->numEvents) {
- iPtr->curEvent = 0;
- }
- eventPtr = &iPtr->events[iPtr->curEvent];
-
- /*
- * Chop off trailing newlines before recording the command.
- */
-
- length = strlen(cmd);
- while (cmd[length-1] == '\n') {
- length--;
- }
- MakeSpace(eventPtr, length + 1);
- strncpy(eventPtr->command, cmd, (size_t) length);
- eventPtr->command[length] = 0;
-
- /*
- * Execute the command. Note: history revision isn't possible after
- * a nested call to this procedure, because the event at the top of
- * the history list no longer corresponds to what's going on when
- * a nested call here returns. Thus, must leave history revision
- * disabled when we return.
- */
-
- result = TCL_OK;
- if (!(flags & TCL_NO_EVAL)) {
- iPtr->historyFirst = cmd;
- iPtr->revDisables = 0;
- iPtr->evalFlags = (flags & ~TCL_EVAL_GLOBAL) | TCL_RECORD_BOUNDS;
- if (flags & TCL_EVAL_GLOBAL) {
- result = Tcl_GlobalEval(interp, cmd);
- } else {
- result = Tcl_Eval(interp, cmd);
- }
- }
- iPtr->revDisables = 1;
- return result;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_HistoryCmd --
- *
- * This procedure is invoked to process the "history" Tcl command.
- * See the user documentation for details on what it does.
- *
- * Results:
- * A standard Tcl result.
- *
- * Side effects:
- * See the user documentation.
- *
- *----------------------------------------------------------------------
- */
-
- /* ARGSUSED */
-int
-Tcl_HistoryCmd(dummy, interp, argc, argv)
- ClientData dummy; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
-{
- register Interp *iPtr = (Interp *) interp;
- register HistoryEvent *eventPtr;
- size_t length;
- int c;
-
- if (iPtr->numEvents == 0) {
- InitHistory(iPtr);
- }
-
- /*
- * If no arguments, treat the same as "history info".
- */
-
- if (argc == 1) {
- goto infoCmd;
- }
-
- c = argv[1][0];
- length = strlen(argv[1]);
+ register Tcl_Obj *cmdPtr;
+ int length = strlen(cmd);
+ int result;
- if ((c == 'a') && (strncmp(argv[1], "add", length)) == 0) {
- if ((argc != 3) && (argc != 4)) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " add event ?exec?\"", (char *) NULL);
- return TCL_ERROR;
- }
- if (argc == 4) {
- if (strncmp(argv[3], "exec", strlen(argv[3])) != 0) {
- Tcl_AppendResult(interp, "bad argument \"", argv[3],
- "\": should be \"exec\"", (char *) NULL);
- return TCL_ERROR;
- }
- return Tcl_RecordAndEval(interp, argv[2], 0);
- }
- return Tcl_RecordAndEval(interp, argv[2], TCL_NO_EVAL);
- } else if ((c == 'c') && (strncmp(argv[1], "change", length)) == 0) {
- if ((argc != 3) && (argc != 4)) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " change newValue ?event?\"", (char *) NULL);
- return TCL_ERROR;
- }
- if (argc == 3) {
- eventPtr = &iPtr->events[iPtr->curEvent];
- iPtr->revDisables += 1;
- while (iPtr->revPtr != NULL) {
- HistoryRev *nextPtr;
-
- ckfree(iPtr->revPtr->newBytes);
- nextPtr = iPtr->revPtr->nextPtr;
- ckfree((char *) iPtr->revPtr);
- iPtr->revPtr = nextPtr;
- }
- } else {
- eventPtr = GetEvent(iPtr, argv[3]);
- if (eventPtr == NULL) {
- return TCL_ERROR;
- }
- }
- MakeSpace(eventPtr, (int) strlen(argv[2]) + 1);
- strcpy(eventPtr->command, argv[2]);
- return TCL_OK;
- } else if ((c == 'e') && (strncmp(argv[1], "event", length)) == 0) {
- if (argc > 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " event ?event?\"", (char *) NULL);
- return TCL_ERROR;
- }
- eventPtr = GetEvent(iPtr, argc==2 ? "-1" : argv[2]);
- if (eventPtr == NULL) {
- return TCL_ERROR;
- }
- RevResult(iPtr, eventPtr->command);
- Tcl_SetResult(interp, eventPtr->command, TCL_VOLATILE);
- return TCL_OK;
- } else if ((c == 'i') && (strncmp(argv[1], "info", length)) == 0) {
- int count, indx, i;
- char *newline;
-
- if ((argc != 2) && (argc != 3)) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " info ?count?\"", (char *) NULL);
- return TCL_ERROR;
- }
- infoCmd:
- if (argc == 3) {
- if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) {
- return TCL_ERROR;
- }
- if (count > iPtr->numEvents) {
- count = iPtr->numEvents;
- }
- } else {
- count = iPtr->numEvents;
- }
- newline = "";
- for (i = 0, indx = iPtr->curEvent + 1 + iPtr->numEvents - count;
- i < count; i++, indx++) {
- char *cur, *next, savedChar;
- char serial[20];
-
- if (indx >= iPtr->numEvents) {
- indx -= iPtr->numEvents;
- }
- cur = iPtr->events[indx].command;
- if (*cur == '\0') {
- continue; /* No command recorded here. */
- }
- sprintf(serial, "%6d ", iPtr->curEventNum + 1 - (count - i));
- Tcl_AppendResult(interp, newline, serial, (char *) NULL);
- newline = "\n";
-
- /*
- * Tricky formatting here: for multi-line commands, indent
- * the continuation lines.
- */
+ if (length > 0) {
+ /*
+ * Call Tcl_RecordAndEvalObj to do the actual work.
+ */
- while (1) {
- next = strchr(cur, '\n');
- if (next == NULL) {
- break;
- }
- next++;
- savedChar = *next;
- *next = 0;
- Tcl_AppendResult(interp, cur, "\t", (char *) NULL);
- *next = savedChar;
- cur = next;
- }
- Tcl_AppendResult(interp, cur, (char *) NULL);
- }
- return TCL_OK;
- } else if ((c == 'k') && (strncmp(argv[1], "keep", length)) == 0) {
- int count, i, src;
- HistoryEvent *events;
+ TclNewObj(cmdPtr);
+ TclInitStringRep(cmdPtr, cmd, length);
+ Tcl_IncrRefCount(cmdPtr);
- if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " keep number\"", (char *) NULL);
- return TCL_ERROR;
- }
- if (Tcl_GetInt(interp, argv[2], &count) != TCL_OK) {
- return TCL_ERROR;
- }
- if ((count <= 0) || (count > 1000)) {
- Tcl_AppendResult(interp, "illegal keep count \"", argv[2],
- "\"", (char *) NULL);
- return TCL_ERROR;
- }
+ result = Tcl_RecordAndEvalObj(interp, cmdPtr, flags);
/*
- * Create a new history array and copy as much existing history
- * as possible from the old array.
+ * Move the interpreter's object result to the string result,
+ * then reset the object result.
+ * FAILS IF OBJECT RESULT'S STRING REPRESENTATION CONTAINS NULLS.
*/
- events = (HistoryEvent *)
- ckalloc((unsigned) (count * sizeof(HistoryEvent)));
- if (count < iPtr->numEvents) {
- src = iPtr->curEvent + 1 - count;
- if (src < 0) {
- src += iPtr->numEvents;
- }
- } else {
- src = iPtr->curEvent + 1;
- }
- for (i = 0; i < count; i++, src++) {
- if (src >= iPtr->numEvents) {
- src = 0;
- }
- if (i < iPtr->numEvents) {
- events[i] = iPtr->events[src];
- iPtr->events[src].command = NULL;
- } else {
- events[i].command = (char *) ckalloc(INITIAL_CMD_SIZE);
- events[i].command[0] = 0;
- events[i].bytesAvl = INITIAL_CMD_SIZE;
- }
- }
+ Tcl_SetResult(interp,
+ TclGetStringFromObj(Tcl_GetObjResult(interp), (int *) NULL),
+ TCL_VOLATILE);
/*
- * Throw away everything left in the old history array, and
- * substitute the new one for the old one.
+ * Discard the Tcl object created to hold the command.
*/
-
- for (i = 0; i < iPtr->numEvents; i++) {
- if (iPtr->events[i].command != NULL) {
- ckfree(iPtr->events[i].command);
- }
- }
- ckfree((char *) iPtr->events);
- iPtr->events = events;
- if (count < iPtr->numEvents) {
- iPtr->curEvent = count-1;
- } else {
- iPtr->curEvent = iPtr->numEvents-1;
- }
- iPtr->numEvents = count;
- return TCL_OK;
- } else if ((c == 'n') && (strncmp(argv[1], "nextid", length)) == 0) {
- char buf[40];
- if (argc != 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " nextid\"", (char *) NULL);
- return TCL_ERROR;
- }
- TclFormatInt(buf, iPtr->curEventNum+1);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
- return TCL_OK;
- } else if ((c == 'r') && (strncmp(argv[1], "redo", length)) == 0) {
- if (argc > 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " redo ?event?\"", (char *) NULL);
- return TCL_ERROR;
- }
- eventPtr = GetEvent(iPtr, argc==2 ? "-1" : argv[2]);
- if (eventPtr == NULL) {
- return TCL_ERROR;
- }
- RevCommand(iPtr, eventPtr->command);
- return Tcl_Eval(interp, eventPtr->command);
- } else if ((c == 's') && (strncmp(argv[1], "substitute", length)) == 0) {
- if ((argc > 5) || (argc < 4)) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " substitute old new ?event?\"", (char *) NULL);
- return TCL_ERROR;
- }
- eventPtr = GetEvent(iPtr, argc==4 ? "-1" : argv[4]);
- if (eventPtr == NULL) {
- return TCL_ERROR;
- }
- return SubsAndEval(iPtr, eventPtr->command, argv[2], argv[3]);
- } else if ((c == 'w') && (strncmp(argv[1], "words", length)) == 0) {
- char *words;
-
- if ((argc != 3) && (argc != 4)) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " words num-num/pat ?event?\"", (char *) NULL);
- return TCL_ERROR;
- }
- eventPtr = GetEvent(iPtr, argc==3 ? "-1" : argv[3]);
- if (eventPtr == NULL) {
- return TCL_ERROR;
- }
- words = GetWords(iPtr, eventPtr->command, argv[2]);
- if (words == NULL) {
- return TCL_ERROR;
- }
- RevResult(iPtr, words);
- Tcl_SetResult(interp, words, TCL_DYNAMIC);
- return TCL_OK;
- }
-
- Tcl_AppendResult(interp, "bad option \"", argv[1],
- "\": must be add, change, event, info, keep, nextid, ",
- "redo, substitute, or words", (char *) NULL);
- return TCL_ERROR;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * MakeSpace --
- *
- * Given a history event, make sure it has enough space for
- * a string of a given length (enlarge the string area if
- * necessary).
- *
- * Results:
- * None.
- *
- * Side effects:
- * More memory may get allocated.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-MakeSpace(hPtr, size)
- HistoryEvent *hPtr;
- int size; /* # of bytes needed in hPtr. */
-{
- if (hPtr->bytesAvl < size) {
- ckfree(hPtr->command);
- hPtr->command = (char *) ckalloc((unsigned) size);
- hPtr->bytesAvl = size;
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * InsertRev --
- *
- * Add a new revision to the list of those pending for iPtr.
- * Do it in a way that keeps the revision list sorted in
- * increasing order of firstIndex. Also, eliminate revisions
- * that are subsets of other revisions.
- *
- * Results:
- * None.
- *
- * Side effects:
- * RevPtr is added to iPtr's revision list.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-InsertRev(iPtr, revPtr)
- Interp *iPtr; /* Interpreter to use. */
- register HistoryRev *revPtr; /* Revision to add to iPtr's list. */
-{
- register HistoryRev *curPtr;
- register HistoryRev *prevPtr;
-
- for (curPtr = iPtr->revPtr, prevPtr = NULL; curPtr != NULL;
- prevPtr = curPtr, curPtr = curPtr->nextPtr) {
+ Tcl_DecrRefCount(cmdPtr);
+ } else {
/*
- * If this revision includes the new one (or vice versa) then
- * just eliminate the one that is a subset of the other.
+ * An empty string. Just reset the interpreter's result.
*/
- if ((revPtr->firstIndex <= curPtr->firstIndex)
- && (revPtr->lastIndex >= curPtr->firstIndex)) {
- curPtr->firstIndex = revPtr->firstIndex;
- curPtr->lastIndex = revPtr->lastIndex;
- curPtr->newSize = revPtr->newSize;
- ckfree(curPtr->newBytes);
- curPtr->newBytes = revPtr->newBytes;
- ckfree((char *) revPtr);
- return;
- }
- if ((revPtr->firstIndex >= curPtr->firstIndex)
- && (revPtr->lastIndex <= curPtr->lastIndex)) {
- ckfree(revPtr->newBytes);
- ckfree((char *) revPtr);
- return;
- }
-
- if (revPtr->firstIndex < curPtr->firstIndex) {
- break;
- }
- }
-
- /*
- * Insert revPtr just after prevPtr.
- */
-
- if (prevPtr == NULL) {
- revPtr->nextPtr = iPtr->revPtr;
- iPtr->revPtr = revPtr;
- } else {
- revPtr->nextPtr = prevPtr->nextPtr;
- prevPtr->nextPtr = revPtr;
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * RevCommand --
- *
- * This procedure is invoked by the "history" command to record
- * a command revision. See the comments at the beginning of the
- * file for more information about revisions.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Revision information is recorded.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-RevCommand(iPtr, string)
- register Interp *iPtr; /* Interpreter in which to perform the
- * substitution. */
- char *string; /* String to substitute. */
-{
- register HistoryRev *revPtr;
-
- if ((iPtr->evalFirst == NULL) || (iPtr->revDisables > 0)) {
- return;
- }
- revPtr = (HistoryRev *) ckalloc(sizeof(HistoryRev));
- revPtr->firstIndex = iPtr->evalFirst - iPtr->historyFirst;
- revPtr->lastIndex = iPtr->evalLast - iPtr->historyFirst;
- revPtr->newSize = strlen(string);
- revPtr->newBytes = (char *) ckalloc((unsigned) (revPtr->newSize+1));
- strcpy(revPtr->newBytes, string);
- InsertRev(iPtr, revPtr);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * RevResult --
- *
- * This procedure is invoked by the "history" command to record
- * a result revision. See the comments at the beginning of the
- * file for more information about revisions.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Revision information is recorded.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-RevResult(iPtr, string)
- register Interp *iPtr; /* Interpreter in which to perform the
- * substitution. */
- char *string; /* String to substitute. */
-{
- register HistoryRev *revPtr;
- char *evalFirst, *evalLast;
- char *argv[2];
-
- if ((iPtr->evalFirst == NULL) || (iPtr->revDisables > 0)) {
- return;
- }
-
- /*
- * Expand the replacement range to include the brackets that surround
- * the command. If there aren't any brackets (i.e. this command was
- * invoked at top-level) then don't do any revision. Also, if there
- * are several commands in brackets, of which this is just one,
- * then don't do any revision.
- */
-
- evalFirst = iPtr->evalFirst;
- evalLast = iPtr->evalLast + 1;
- while (1) {
- if (evalFirst == iPtr->historyFirst) {
- return;
- }
- evalFirst--;
- if (*evalFirst == '[') {
- break;
- }
- if (!isspace(UCHAR(*evalFirst))) {
- return;
- }
- }
- if (*evalLast != ']') {
- return;
- }
-
- revPtr = (HistoryRev *) ckalloc(sizeof(HistoryRev));
- revPtr->firstIndex = evalFirst - iPtr->historyFirst;
- revPtr->lastIndex = evalLast - iPtr->historyFirst;
- argv[0] = string;
- revPtr->newBytes = Tcl_Merge(1, argv);
- revPtr->newSize = strlen(revPtr->newBytes);
- InsertRev(iPtr, revPtr);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * DoRevs --
- *
- * This procedure is called to apply the history revisions that
- * have been recorded in iPtr.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The most recent entry in the history for iPtr may be modified.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-DoRevs(iPtr)
- register Interp *iPtr; /* Interpreter whose history is to
- * be modified. */
-{
- register HistoryRev *revPtr;
- register HistoryEvent *eventPtr;
- char *newCommand, *p;
- unsigned int size;
- int bytesSeen, count;
-
- if (iPtr->revPtr == NULL) {
- return;
- }
-
- /*
- * The revision is done in two passes. The first pass computes the
- * amount of space needed for the revised event, and the second pass
- * pieces together the new event and frees up the revisions.
- */
-
- eventPtr = &iPtr->events[iPtr->curEvent];
- size = strlen(eventPtr->command) + 1;
- for (revPtr = iPtr->revPtr; revPtr != NULL; revPtr = revPtr->nextPtr) {
- size -= revPtr->lastIndex + 1 - revPtr->firstIndex;
- size += revPtr->newSize;
- }
-
- newCommand = (char *) ckalloc(size);
- p = newCommand;
- bytesSeen = 0;
- for (revPtr = iPtr->revPtr; revPtr != NULL; ) {
- HistoryRev *nextPtr = revPtr->nextPtr;
-
- count = revPtr->firstIndex - bytesSeen;
- if (count > 0) {
- strncpy(p, eventPtr->command + bytesSeen, (size_t) count);
- p += count;
- }
- strncpy(p, revPtr->newBytes, (size_t) revPtr->newSize);
- p += revPtr->newSize;
- bytesSeen = revPtr->lastIndex+1;
- ckfree(revPtr->newBytes);
- ckfree((char *) revPtr);
- revPtr = nextPtr;
- }
- strcpy(p, eventPtr->command + bytesSeen);
-
- /*
- * Replace the command in the event.
- */
-
- ckfree(eventPtr->command);
- eventPtr->command = newCommand;
- eventPtr->bytesAvl = size;
- iPtr->revPtr = NULL;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * GetEvent --
- *
- * Given a textual description of an event (see the manual page
- * for legal values) find the corresponding event and return its
- * command string.
- *
- * Results:
- * The return value is a pointer to the event named by "string".
- * If no such event exists, then NULL is returned and an error
- * message is left in iPtr.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-static HistoryEvent *
-GetEvent(iPtr, string)
- register Interp *iPtr; /* Interpreter in which to look. */
- char *string; /* Description of event. */
-{
- int eventNum, index;
- register HistoryEvent *eventPtr;
- int length;
-
- /*
- * First check for a numeric specification of an event.
- */
-
- if (isdigit(UCHAR(*string)) || (*string == '-')) {
- if (Tcl_GetInt((Tcl_Interp *) iPtr, string, &eventNum) != TCL_OK) {
- return NULL;
- }
- if (eventNum < 0) {
- eventNum += iPtr->curEventNum;
- }
- if (eventNum > iPtr->curEventNum) {
- Tcl_AppendResult((Tcl_Interp *) iPtr, "event \"", string,
- "\" hasn't occurred yet", (char *) NULL);
- return NULL;
- }
- if ((eventNum <= iPtr->curEventNum-iPtr->numEvents)
- || (eventNum <= 0)) {
- Tcl_AppendResult((Tcl_Interp *) iPtr, "event \"", string,
- "\" is too far in the past", (char *) NULL);
- return NULL;
- }
- index = iPtr->curEvent + (eventNum - iPtr->curEventNum);
- if (index < 0) {
- index += iPtr->numEvents;
- }
- return &iPtr->events[index];
- }
-
- /*
- * Next, check for an event that contains the string as a prefix or
- * that matches the string in the sense of Tcl_StringMatch.
- */
-
- length = strlen(string);
- for (index = iPtr->curEvent - 1; ; index--) {
- if (index < 0) {
- index += iPtr->numEvents;
- }
- if (index == iPtr->curEvent) {
- break;
- }
- eventPtr = &iPtr->events[index];
- if ((strncmp(eventPtr->command, string, (size_t) length) == 0)
- || Tcl_StringMatch(eventPtr->command, string)) {
- return eventPtr;
- }
- }
-
- Tcl_AppendResult((Tcl_Interp *) iPtr, "no event matches \"", string,
- "\"", (char *) NULL);
- return NULL;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * SubsAndEval --
- *
- * Generate a new command by making a textual substitution in
- * the "cmd" argument. Then execute the new command.
- *
- * Results:
- * The return value is a standard Tcl error.
- *
- * Side effects:
- * History gets revised if the substitution is occurring on
- * a recorded command line. Also, the re-executed command
- * may produce side-effects.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-SubsAndEval(iPtr, cmd, old, new)
- register Interp *iPtr; /* Interpreter in which to execute
- * new command. */
- char *cmd; /* Command in which to substitute. */
- char *old; /* String to search for in command. */
- char *new; /* Replacement string for "old". */
-{
- char *src, *dst, *newCmd;
- int count, oldLength, newLength, length, result;
-
- /*
- * Figure out how much space it will take to hold the
- * substituted command (and complain if the old string
- * doesn't appear in the original command).
- */
-
- oldLength = strlen(old);
- newLength = strlen(new);
- src = cmd;
- count = 0;
- while (1) {
- src = strstr(src, old);
- if (src == NULL) {
- break;
- }
- src += oldLength;
- count++;
- }
- if (count == 0) {
- Tcl_AppendResult((Tcl_Interp *) iPtr, "\"", old,
- "\" doesn't appear in event", (char *) NULL);
- return TCL_ERROR;
- }
- length = strlen(cmd) + count*(newLength - oldLength);
-
- /*
- * Generate a substituted command.
- */
-
- newCmd = (char *) ckalloc((unsigned) (length + 1));
- dst = newCmd;
- while (1) {
- src = strstr(cmd, old);
- if (src == NULL) {
- strcpy(dst, cmd);
- break;
- }
- strncpy(dst, cmd, (size_t) (src-cmd));
- dst += src-cmd;
- strcpy(dst, new);
- dst += newLength;
- cmd = src + oldLength;
+ Tcl_ResetResult(interp);
+ result = TCL_OK;
}
-
- RevCommand(iPtr, newCmd);
- result = Tcl_Eval((Tcl_Interp *) iPtr, newCmd);
- ckfree(newCmd);
return result;
}
/*
*----------------------------------------------------------------------
*
- * GetWords --
+ * Tcl_RecordAndEvalObj --
*
- * Given a command string, return one or more words from the
- * command string.
+ * This procedure adds the command held in its argument object to the
+ * current list of recorded events and then executes the command by
+ * calling Tcl_EvalObj.
*
* Results:
- * The return value is a pointer to a dynamically-allocated
- * string containing the words of command specified by "words".
- * If the word specifier has improper syntax then an error
- * message is placed in iPtr->result and NULL is returned.
+ * The return value is a standard Tcl return value, the result of
+ * executing the command.
*
* Side effects:
- * Memory is allocated. It is the caller's responsibilty to
- * free the returned string..
+ * The command is recorded and executed.
*
*----------------------------------------------------------------------
*/
-static char *
-GetWords(iPtr, command, words)
- register Interp *iPtr; /* Tcl interpreter in which to place
- * an error message if needed. */
- char *command; /* Command string. */
- char *words; /* Description of which words to extract
- * from the command. Either num[-num] or
- * a pattern. */
+int
+Tcl_RecordAndEvalObj(interp, cmdPtr, flags)
+ Tcl_Interp *interp; /* Token for interpreter in which command
+ * will be executed. */
+ Tcl_Obj *cmdPtr; /* Points to object holding the command to
+ * record and execute. */
+ int flags; /* Additional flags. TCL_NO_EVAL means
+ * record only: don't execute the command.
+ * TCL_EVAL_GLOBAL means use
+ * Tcl_GlobalEvalObj instead of
+ * Tcl_EvalObj. */
{
- char *result;
- char *start, *end, *dst;
- register char *next;
- int first; /* First word desired. -1 means last word
- * only. */
- int last; /* Last word desired. -1 means use everything
- * up to the end. */
- int index; /* Index of current word. */
- char *pattern;
+ Interp *iPtr = (Interp *) interp;
+ int result;
+ Tcl_Obj *list[3];
+ register Tcl_Obj *objPtr;
/*
- * Figure out whether we're looking for a numerical range or for
- * a pattern.
+ * Do recording by eval'ing a tcl history command: history add $cmd.
*/
- pattern = NULL;
- first = 0;
- last = -1;
- if (*words == '$') {
- if (words[1] != '\0') {
- goto error;
- }
- first = -1;
- } else if (isdigit(UCHAR(*words))) {
- first = strtoul(words, &start, 0);
- if (*start == 0) {
- last = first;
- } else if (*start == '-') {
- start++;
- if (*start == '$') {
- start++;
- } else if (isdigit(UCHAR(*start))) {
- last = strtoul(start, &start, 0);
- } else {
- goto error;
- }
- if (*start != 0) {
- goto error;
- }
- }
- if ((first > last) && (last != -1)) {
- goto error;
- }
- } else {
- pattern = words;
- }
+ list[0] = Tcl_NewStringObj("history", -1);
+ list[1] = Tcl_NewStringObj("add", -1);
+ list[2] = cmdPtr;
+
+ objPtr = Tcl_NewListObj(3, list);
+ Tcl_IncrRefCount(objPtr);
+ (void) Tcl_GlobalEvalObj(interp, objPtr);
+ Tcl_DecrRefCount(objPtr);
/*
- * Scan through the words one at a time, copying those that are
- * relevant into the result string. Allocate a result area large
- * enough to hold all the words if necessary.
+ * Execute the command.
*/
- result = (char *) ckalloc((unsigned) (strlen(command) + 1));
- dst = result;
- for (next = command; isspace(UCHAR(*next)); next++) {
- /* Empty loop body: just find start of first word. */
- }
- for (index = 0; *next != 0; index++) {
- start = next;
- end = TclWordEnd(next, next + strlen(next), 0, (int *) NULL);
- if (*end != 0) {
- end++;
- for (next = end; isspace(UCHAR(*next)); next++) {
- /* Empty loop body: just find start of next word. */
- }
- }
- if ((first > index) || ((first == -1) && (*next != 0))) {
- continue;
- }
- if ((last != -1) && (last < index)) {
- continue;
- }
- if (pattern != NULL) {
- int match;
- char savedChar = *end;
-
- *end = 0;
- match = Tcl_StringMatch(start, pattern);
- *end = savedChar;
- if (!match) {
- continue;
- }
- }
- if (dst != result) {
- *dst = ' ';
- dst++;
+ result = TCL_OK;
+ if (!(flags & TCL_NO_EVAL)) {
+ iPtr->evalFlags = (flags & ~TCL_EVAL_GLOBAL);
+ if (flags & TCL_EVAL_GLOBAL) {
+ result = Tcl_GlobalEvalObj(interp, cmdPtr);
+ } else {
+ result = Tcl_EvalObj(interp, cmdPtr);
}
- strncpy(dst, start, (size_t) (end-start));
- dst += end-start;
- }
- *dst = 0;
-
- /*
- * Check for an out-of-range argument index.
- */
-
- if ((last >= index) || (first >= index)) {
- ckfree(result);
- Tcl_AppendResult((Tcl_Interp *) iPtr, "word selector \"", words,
- "\" specified non-existent words", (char *) NULL);
- return NULL;
}
return result;
-
- error:
- Tcl_AppendResult((Tcl_Interp *) iPtr, "bad word selector \"", words,
- "\": should be num-num or pattern", (char *) NULL);
- return NULL;
}
diff --git a/contrib/tcl/generic/tclIO.c b/contrib/tcl/generic/tclIO.c
index b562b7b54615..2b13e2d60ad3 100644
--- a/contrib/tcl/generic/tclIO.c
+++ b/contrib/tcl/generic/tclIO.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclIO.c 1.265 97/06/20 13:24:48
+ * SCCS: @(#) tclIO.c 1.268 97/07/28 14:20:36
*/
#include "tclInt.h"
@@ -1682,6 +1682,10 @@ FlushChannel(interp, chanPtr, calledFromAsyncFlush)
}
} else {
Tcl_SetErrno(errorCode);
+ if (interp != NULL) {
+ Tcl_SetResult(interp,
+ Tcl_PosixError(interp), TCL_VOLATILE);
+ }
}
/*
@@ -4969,7 +4973,9 @@ ChannelEventScriptInvoker(clientData, mask)
*/
if (result != TCL_OK) {
- DeleteScriptRecord(interp, chanPtr, mask);
+ if (chanPtr->typePtr != NULL) {
+ DeleteScriptRecord(interp, chanPtr, mask);
+ }
Tcl_BackgroundError(interp);
}
Tcl_Release((ClientData) interp);
@@ -5662,14 +5668,6 @@ TclCopyChannel(interp, inChan, outChan, toRead, cmdPtr)
csPtr->total = 0;
csPtr->interp = interp;
if (cmdPtr) {
- /*
- * We save this command object and mutate it later with
- * extra arguments, so we need a private copy.
- */
-
- if (Tcl_IsShared(cmdPtr)) {
- cmdPtr = Tcl_DuplicateObj(cmdPtr);
- }
Tcl_IncrRefCount(cmdPtr);
}
csPtr->cmdPtr = cmdPtr;
@@ -5838,18 +5836,22 @@ CopyData(csPtr, mask)
/*
* Make the callback or return the number of bytes transferred.
- * The local total is used because StopCopoy frees csPtr.
+ * The local total is used because StopCopy frees csPtr.
*/
total = csPtr->total;
if (cmdPtr) {
+ /*
+ * Get a private copy of the command so we can mutate it
+ * by adding arguments. Note that StopCopy frees our saved
+ * reference to the original command obj.
+ */
+
+ cmdPtr = Tcl_DuplicateObj(cmdPtr);
Tcl_IncrRefCount(cmdPtr);
StopCopy(csPtr);
Tcl_Preserve((ClientData) interp);
- /*
- * This is already a private object, so we mutate it to add args.
- */
Tcl_ListObjAppendElement(interp, cmdPtr, Tcl_NewIntObj(total));
if (errObj) {
Tcl_ListObjAppendElement(interp, cmdPtr, errObj);
diff --git a/contrib/tcl/generic/tclIOCmd.c b/contrib/tcl/generic/tclIOCmd.c
index ae09c8f95e7b..5640b47615de 100644
--- a/contrib/tcl/generic/tclIOCmd.c
+++ b/contrib/tcl/generic/tclIOCmd.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclIOCmd.c 1.117 97/06/23 18:57:17
+ * SCCS: @(#) tclIOCmd.c 1.119 97/07/25 20:49:23
*/
#include "tclInt.h"
@@ -579,7 +579,7 @@ Tcl_TellCmd(clientData, interp, argc, argv)
/*
*----------------------------------------------------------------------
*
- * Tcl_CloseCmd --
+ * Tcl_CloseObjCmd --
*
* This procedure is invoked to process the Tcl "close" command.
* See the user documentation for details on what it does.
@@ -595,26 +595,28 @@ Tcl_TellCmd(clientData, interp, argc, argv)
/* ARGSUSED */
int
-Tcl_CloseCmd(clientData, interp, argc, argv)
- ClientData clientData; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+Tcl_CloseObjCmd(clientData, interp, objc, objv)
+ ClientData clientData; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Channel chan; /* The channel to close. */
int len; /* Length of error output. */
+ char *arg;
- if (argc != 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " channelId\"", (char *) NULL);
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "channelId");
return TCL_ERROR;
}
- chan = Tcl_GetChannel(interp, argv[1], NULL);
+
+ arg = Tcl_GetStringFromObj(objv[1], NULL);
+ chan = Tcl_GetChannel(interp, arg, NULL);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
- if (Tcl_UnregisterChannel(interp, chan) != TCL_OK) {
+ if (Tcl_UnregisterChannel(interp, chan) != TCL_OK) {
/*
* If there is an error message and it ends with a newline, remove
* the newline. This is done for command pipeline channels where the
@@ -633,6 +635,7 @@ Tcl_CloseCmd(clientData, interp, argc, argv)
return TCL_ERROR;
}
+
return TCL_OK;
}
@@ -705,7 +708,7 @@ Tcl_FconfigureCmd(clientData, interp, argc, argv)
/*
*----------------------------------------------------------------------
*
- * Tcl_EofCmd --
+ * Tcl_EofObjCmd --
*
* This procedure is invoked to process the Tcl "eof" command.
* See the user documentation for details on what it does.
@@ -722,22 +725,24 @@ Tcl_FconfigureCmd(clientData, interp, argc, argv)
/* ARGSUSED */
int
-Tcl_EofCmd(unused, interp, argc, argv)
- ClientData unused; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+Tcl_EofObjCmd(unused, interp, objc, objv)
+ ClientData unused; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Channel chan; /* The channel to query for EOF. */
int mode; /* Mode in which channel is opened. */
char buf[40];
+ char *arg;
- if (argc != 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " channelId\"", (char *) NULL);
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "channelId");
return TCL_ERROR;
}
- chan = Tcl_GetChannel(interp, argv[1], &mode);
+
+ arg = Tcl_GetStringFromObj(objv[1], NULL);
+ chan = Tcl_GetChannel(interp, arg, &mode);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
@@ -891,7 +896,7 @@ Tcl_ExecCmd(dummy, interp, argc, argv)
/*
*----------------------------------------------------------------------
*
- * Tcl_FblockedCmd --
+ * Tcl_FblockedObjCmd --
*
* This procedure is invoked to process the Tcl "fblocked" command.
* See the user documentation for details on what it does.
@@ -908,27 +913,30 @@ Tcl_ExecCmd(dummy, interp, argc, argv)
/* ARGSUSED */
int
-Tcl_FblockedCmd(unused, interp, argc, argv)
- ClientData unused; /* Not used. */
- Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+Tcl_FblockedObjCmd(unused, interp, objc, objv)
+ ClientData unused; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
Tcl_Channel chan; /* The channel to query for blocked. */
int mode; /* Mode in which channel was opened. */
char buf[40];
+ char *arg;
- if (argc != 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
- " channelId\"", (char *) NULL);
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "channelId");
return TCL_ERROR;
}
- chan = Tcl_GetChannel(interp, argv[1], &mode);
+
+ arg = Tcl_GetStringFromObj(objv[1], NULL);
+ chan = Tcl_GetChannel(interp, arg, &mode);
if (chan == (Tcl_Channel) NULL) {
return TCL_ERROR;
}
if ((mode & TCL_READABLE) == 0) {
- Tcl_AppendResult(interp, "channel \"", argv[1],
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "channel \"",
+ Tcl_GetStringFromObj(objv[1], NULL),
"\" wasn't opened for reading", (char *) NULL);
return TCL_ERROR;
}
@@ -1491,7 +1499,8 @@ Tcl_FcopyObjCmd(dummy, interp, objc, objv)
enum { FcopySize, FcopyCommand } index;
if ((objc < 3) || (objc > 7) || (objc == 4) || (objc == 6)) {
- Tcl_WrongNumArgs(interp, 1, objv, "input output ?-size size? ?-command callback?");
+ Tcl_WrongNumArgs(interp, 1, objv,
+ "input output ?-size size? ?-command callback?");
return TCL_ERROR;
}
@@ -1541,5 +1550,6 @@ Tcl_FcopyObjCmd(dummy, interp, objc, objv)
break;
}
}
+
return TclCopyChannel(interp, inChan, outChan, toRead, cmdPtr);
}
diff --git a/contrib/tcl/generic/tclIndexObj.c b/contrib/tcl/generic/tclIndexObj.c
index 86a394fbb703..824270a0751e 100644
--- a/contrib/tcl/generic/tclIndexObj.c
+++ b/contrib/tcl/generic/tclIndexObj.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclIndexObj.c 1.4 97/02/11 13:30:01
+ * SCCS: @(#) tclIndexObj.c 1.8 97/07/29 10:16:54
*/
#include "tclInt.h"
@@ -237,3 +237,72 @@ UpdateStringOfIndex(objPtr)
{
panic("UpdateStringOfIndex should never be invoked");
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_WrongNumArgs --
+ *
+ * This procedure generates a "wrong # args" error message in an
+ * interpreter. It is used as a utility function by many command
+ * procedures.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * An error message is generated in interp's result object to
+ * indicate that a command was invoked with the wrong number of
+ * arguments. The message has the form
+ * wrong # args: should be "foo bar additional stuff"
+ * where "foo" and "bar" are the initial objects in objv (objc
+ * determines how many of these are printed) and "additional stuff"
+ * is the contents of the message argument.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_WrongNumArgs(interp, objc, objv, message)
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments to print
+ * from objv. */
+ Tcl_Obj *CONST objv[]; /* Initial argument objects, which
+ * should be included in the error
+ * message. */
+ char *message; /* Error message to print after the
+ * leading objects in objv. The
+ * message may be NULL. */
+{
+ Tcl_Obj *objPtr;
+ char **tablePtr;
+ int i;
+
+ objPtr = Tcl_GetObjResult(interp);
+ Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1);
+ for (i = 0; i < objc; i++) {
+ /*
+ * If the object is an index type use the index table which allows
+ * for the correct error message even if the subcommand was
+ * abbreviated. Otherwise, just use the string rep.
+ */
+
+ if (objv[i]->typePtr == &tclIndexType) {
+ tablePtr = ((char **) objv[i]->internalRep.twoPtrValue.ptr1);
+ Tcl_AppendStringsToObj(objPtr,
+ tablePtr[(int) objv[i]->internalRep.twoPtrValue.ptr2],
+ (char *) NULL);
+ } else {
+ Tcl_AppendStringsToObj(objPtr,
+ Tcl_GetStringFromObj(objv[i], (int *) NULL),
+ (char *) NULL);
+ }
+ if (i < (objc - 1)) {
+ Tcl_AppendStringsToObj(objPtr, " ", (char *) NULL);
+ }
+ }
+ if (message) {
+ Tcl_AppendStringsToObj(objPtr, " ", message, (char *) NULL);
+ }
+ Tcl_AppendStringsToObj(objPtr, "\"", (char *) NULL);
+}
diff --git a/contrib/tcl/generic/tclInt.h b/contrib/tcl/generic/tclInt.h
index 1e889927ad45..32ef58ab5c2e 100644
--- a/contrib/tcl/generic/tclInt.h
+++ b/contrib/tcl/generic/tclInt.h
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclInt.h 1.277 97/06/20 15:19:00
+ *SCCS: @(#) tclInt.h 1.293 97/08/12 17:07:02
*/
#ifndef _TCLINT
@@ -281,8 +281,9 @@ typedef struct Var {
* call frame or the hash table: 1 for each
* additional variable whose linkPtr points
* here, 1 for each nested trace active on
- * variable. This record can't be deleted
- * until refCount becomes 0. */
+ * variable, and 1 if the variable is a
+ * namespace variable. This record can't be
+ * deleted until refCount becomes 0. */
VarTrace *tracePtr; /* First in list of all traces set for this
* variable. */
ArraySearch *searchPtr; /* First in list of all searches active
@@ -330,6 +331,14 @@ typedef struct Var {
* element, so it is not legal for it to be
* an array itself (the VAR_ARRAY flag had
* better not be set).
+ * VAR_NAMESPACE_VAR - 1 means that this variable was declared
+ * as a namespace variable. This flag ensures
+ * it persists until its namespace is
+ * destroyed or until the variable is unset;
+ * it will persist even if it has not been
+ * initialized and is marked undefined.
+ * The variable's refCount is incremented to
+ * reflect the "reference" from its namespace.
*/
#define VAR_SCALAR 0x1
@@ -339,6 +348,7 @@ typedef struct Var {
#define VAR_IN_HASHTABLE 0x10
#define VAR_TRACE_ACTIVE 0x20
#define VAR_ARRAY_ELEMENT 0x40
+#define VAR_NAMESPACE_VAR 0x80
/*
* Macros to ensure that various flag bits are set properly for variables.
@@ -404,6 +414,13 @@ typedef struct Var {
*/
/*
+ * Forward declaration to prevent an error when the forward reference to
+ * Command is encountered in the Proc and ImportRef types declared below.
+ */
+
+struct Command;
+
+/*
* The variable-length structure below describes a local variable of a
* procedure that was recognized by the compiler. These variables have a
* name, an element in the array of compiler-assigned local variables in the
@@ -459,8 +476,10 @@ typedef struct Proc {
* to the procedure that is currently
* active. This structure can be freed
* when refCount becomes zero. */
- Namespace *nsPtr; /* Points to the namespace that contains
- * this procedure. */
+ struct Command *cmdPtr; /* Points to the Command structure for
+ * this procedure. This is used to get
+ * the namespace in which to execute
+ * the procedure. */
Tcl_Obj *bodyPtr; /* Points to the ByteCode object for
* procedure's body command. */
int numArgs; /* Number of formal parameters. */
@@ -700,13 +719,6 @@ typedef struct ExecEnv {
*/
/*
- * Forward declaration to prevent an error when the forward reference to
- * Command is encountered in the ImportRef type declared below.
- */
-
-struct Command;
-
-/*
* An imported command is created in an namespace when it imports a "real"
* command from another namespace. An imported command has a Command
* structure that points (via its ClientData value) to the "real" Command
@@ -859,32 +871,6 @@ typedef struct Interp {
* is TCL_ERROR. Malloc'ed, may be NULL */
/*
- * Information related to history:
- */
-
- int numEvents; /* Number of previously-executed commands
- * to retain. */
- HistoryEvent *events; /* Array containing numEvents entries
- * (dynamically allocated). */
- int curEvent; /* Index into events of place where current
- * (or most recent) command is recorded. */
- int curEventNum; /* Event number associated with the slot
- * given by curEvent. */
- HistoryRev *revPtr; /* First in list of pending revisions. */
- char *historyFirst; /* First char. of current command executed
- * from history module or NULL if none. */
- int revDisables; /* 0 means history revision OK; > 0 gives
- * a count of number of times revision has
- * been disabled. */
- char *evalFirst; /* If TCL_RECORD_BOUNDS Tcl_Eval and
- * Tcl_EvalObj set this field to point to
- * the first char. of text from which the
- * current command came. Otherwise set to
- * NULL. */
- char *evalLast; /* Similar to evalFirst, except points to
- * last character of current command. */
-
- /*
* Information used by Tcl_AppendResult to keep track of partial
* results. See Tcl_AppendResult code for details.
*/
@@ -976,17 +962,12 @@ typedef struct Interp {
*
* TCL_BRACKET_TERM 1 means that the current script is terminated by
* a close bracket rather than the end of the string.
- * TCL_RECORD_BOUNDS Tells Tcl_Eval to record information in the
- * evalFirst and evalLast fields for each command
- * executed directly from the string (top-level
- * commands and those from command substitution).
* TCL_ALLOW_EXCEPTIONS 1 means it's OK for the script to terminate with
* a code other than TCL_OK or TCL_ERROR; 0 means
* codes other than these should be turned into errors.
*/
#define TCL_BRACKET_TERM 1
-#define TCL_RECORD_BOUNDS 2
#define TCL_ALLOW_EXCEPTIONS 4
/*
@@ -1016,6 +997,9 @@ typedef struct Interp {
* RAND_SEED_INITIALIZED: Non-zero means that the randSeed value of the
* interp has not be initialized. This is set 1
* when we first use the rand() or srand() functions.
+ * SAFE_INTERP: Non zero means that the current interp is a
+ * safe interp (ie it has only the safe commands
+ * installed, less priviledge than a regular interp).
*/
#define DELETED 1
@@ -1025,6 +1009,7 @@ typedef struct Interp {
#define EXPR_INITIALIZED 0x10
#define DONT_COMPILE_CMDS_INLINE 0x20
#define RAND_SEED_INITIALIZED 0x40
+#define SAFE_INTERP 0x80
/*
*----------------------------------------------------------------
@@ -1300,6 +1285,7 @@ EXTERN int TclFileMakeDirsCmd _ANSI_ARGS_((Tcl_Interp *interp,
EXTERN int TclFileRenameCmd _ANSI_ARGS_((Tcl_Interp *interp,
int argc, char **argv)) ;
EXTERN void TclFinalizeCompExecEnv _ANSI_ARGS_((void));
+EXTERN void TclFinalizeEnvironment _ANSI_ARGS_((void));
EXTERN void TclFinalizeExecEnv _ANSI_ARGS_((void));
EXTERN int TclFindElement _ANSI_ARGS_((Tcl_Interp *interp,
char *list, int listLength, char **elementPtr,
@@ -1318,7 +1304,7 @@ EXTERN Tcl_Channel TclGetDefaultStdChannel _ANSI_ARGS_((int type));
EXTERN Tcl_Obj * TclGetElementOfIndexedArray _ANSI_ARGS_((
Tcl_Interp *interp, int localIndex,
Tcl_Obj *elemPtr, int leaveErrorMsg));
-EXTERN char * TclGetEnv _ANSI_ARGS_((char *name));
+EXTERN char * TclGetEnv _ANSI_ARGS_((CONST char *name));
EXTERN char * TclGetExtension _ANSI_ARGS_((char *name));
EXTERN int TclGetFrame _ANSI_ARGS_((Tcl_Interp *interp,
char *string, CallFrame **framePtrPtr));
@@ -1388,6 +1374,7 @@ EXTERN int TclMatchFiles _ANSI_ARGS_((Tcl_Interp *interp,
char *separators, Tcl_DString *dirPtr,
char *pattern, char *tail));
EXTERN int TclNeedSpace _ANSI_ARGS_((char *start, char *end));
+EXTERN int TclObjCommandComplete _ANSI_ARGS_((Tcl_Obj *cmdPtr));
EXTERN int TclObjInterpProc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
@@ -1396,6 +1383,17 @@ EXTERN int TclObjInvoke _ANSI_ARGS_((Tcl_Interp *interp,
EXTERN int TclObjInvokeGlobal _ANSI_ARGS_((Tcl_Interp *interp,
int objc, Tcl_Obj *CONST objv[], int flags));
EXTERN char * TclpAlloc _ANSI_ARGS_((unsigned int size));
+
+/*
+ * On a Mac, we can exit gracefully if the stack gets too small.
+ */
+
+#ifdef MAC_TCL
+EXTERN int TclpCheckStackSpace _ANSI_ARGS_((void));
+#else
+#define TclpCheckStackSpace() (1)
+#endif
+
EXTERN int TclpCloseFile _ANSI_ARGS_((TclFile file));
EXTERN int TclpCopyFile _ANSI_ARGS_((char *source, char *dest));
EXTERN int TclpCopyDirectory _ANSI_ARGS_((char *source,
@@ -1419,15 +1417,27 @@ EXTERN unsigned long TclpGetSeconds _ANSI_ARGS_((void));
EXTERN void TclpGetTime _ANSI_ARGS_((Tcl_Time *time));
EXTERN int TclpGetTimeZone _ANSI_ARGS_((unsigned long time));
EXTERN char * TclpGetTZName _ANSI_ARGS_((void));
+EXTERN int TclpListVolumes _ANSI_ARGS_((Tcl_Interp *interp));
EXTERN TclFile TclpMakeFile _ANSI_ARGS_((Tcl_Channel channel,
int direction));
EXTERN TclFile TclpOpenFile _ANSI_ARGS_((char *fname, int mode));
-EXTERN int TclpListVolumes _ANSI_ARGS_((Tcl_Interp *interp));
EXTERN char * TclpRealloc _ANSI_ARGS_((char *ptr,
unsigned int size));
EXTERN int TclpRemoveDirectory _ANSI_ARGS_((char *path,
int recursive, Tcl_DString *errorPtr));
EXTERN int TclpRenameFile _ANSI_ARGS_((char *source, char *dest));
+EXTERN char * TclpSetEnv _ANSI_ARGS_((CONST char *name,
+ CONST char *value));
+#ifndef TclpSysAlloc
+EXTERN VOID * TclpSysAlloc _ANSI_ARGS_((long size, int isBin));
+#endif
+#ifndef TclpSysFree
+EXTERN void TclpSysFree _ANSI_ARGS_((VOID *ptr));
+#endif
+#ifndef TclpSysRealloc
+EXTERN VOID * TclpSysRealloc _ANSI_ARGS_((VOID *cp,
+ unsigned int size));
+#endif
EXTERN int TclParseBraces _ANSI_ARGS_((Tcl_Interp *interp,
char *string, char **termPtr, ParseValue *pvPtr));
EXTERN int TclParseNestedCmd _ANSI_ARGS_((Tcl_Interp *interp,
@@ -1438,6 +1448,9 @@ EXTERN int TclParseQuotes _ANSI_ARGS_((Tcl_Interp *interp,
char **termPtr, ParseValue *pvPtr));
EXTERN void TclPlatformExit _ANSI_ARGS_((int status));
EXTERN void TclPlatformInit _ANSI_ARGS_((Tcl_Interp *interp));
+EXTERN char * TclPrecTraceProc _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, char *name1, char *name2,
+ int flags));
EXTERN int TclPreventAliasLoop _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Interp *cmdInterp, Tcl_Command cmd));
EXTERN void TclPrintByteCodeObj _ANSI_ARGS_((Tcl_Interp *interp,
@@ -1475,8 +1488,8 @@ EXTERN char * TclWordEnd _ANSI_ARGS_((char *start, char *lastChar,
*----------------------------------------------------------------
*/
-EXTERN int Tcl_AfterCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+EXTERN int Tcl_AfterObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_AppendObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_ArrayObjCmd _ANSI_ARGS_((ClientData clientData,
@@ -1489,18 +1502,18 @@ EXTERN int Tcl_CaseObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_CatchObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
-EXTERN int Tcl_CdCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+EXTERN int Tcl_CdObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_ClockObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
-EXTERN int Tcl_CloseCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+EXTERN int Tcl_CloseObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_ConcatObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_ContinueCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, char **argv));
-EXTERN int Tcl_EofCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+EXTERN int Tcl_EofObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_ErrorObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_EvalObjCmd _ANSI_ARGS_((ClientData clientData,
@@ -1511,8 +1524,8 @@ EXTERN int Tcl_ExitObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_ExprObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
-EXTERN int Tcl_FblockedCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+EXTERN int Tcl_FblockedObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_FconfigureCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, char **argv));
EXTERN int Tcl_FcopyObjCmd _ANSI_ARGS_((ClientData dummy,
@@ -1527,8 +1540,8 @@ EXTERN int Tcl_ForCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, char **argv));
EXTERN int Tcl_ForeachObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
-EXTERN int Tcl_FormatCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+EXTERN int Tcl_FormatObjCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_GetsObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_GlobalObjCmd _ANSI_ARGS_((ClientData clientData,
@@ -1597,8 +1610,8 @@ EXTERN int Tcl_SeekCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, char **argv));
EXTERN int Tcl_SetCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, char **argv));
-EXTERN int Tcl_SplitCmd _ANSI_ARGS_((ClientData clientData,
- Tcl_Interp *interp, int argc, char **argv));
+EXTERN int Tcl_SplitObjCmd _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]));
EXTERN int Tcl_SocketCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, char **argv));
EXTERN int Tcl_SourceObjCmd _ANSI_ARGS_((ClientData clientData,
diff --git a/contrib/tcl/generic/tclInterp.c b/contrib/tcl/generic/tclInterp.c
index e9ad76a294f3..ae5171a0a388 100644
--- a/contrib/tcl/generic/tclInterp.c
+++ b/contrib/tcl/generic/tclInterp.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclInterp.c 1.115 97/06/19 18:06:39
+ * SCCS: @(#) tclInterp.c 1.125 97/08/05 15:22:51
*/
#include <stdio.h>
@@ -17,20 +17,6 @@
#include "tclPort.h"
/*
- * Tcl script to make an interpreter safe.
- */
-
-static char makeSafeScript[] =
-"if {[info exists env(DISPLAY)]} {\n\
- set ___x___ $env(DISPLAY)\n\
-}\n\
-unset env\n\
-if {[info exists ___x___]} {\n\
- set env(DISPLAY) $___x___\n\
- unset ___x___\n\
-}";
-
-/*
* Counter for how many aliases were created (global)
*/
@@ -108,13 +94,15 @@ typedef struct {
/*
* struct Master:
*
- * This record is used for three purposes: First, slaveTable (a hashtable)
+ * This record is used for two purposes: First, slaveTable (a hashtable)
* maps from names of commands to slave interpreters. This hashtable is
* used to store information about slave interpreters of this interpreter,
* to map over all slaves, etc. The second purpose is to store information
* about all aliases in slaves (or siblings) which direct to target commands
- * in this interpreter (using the targetTable hashtable). The third field in
- * the record, isSafe, denotes whether the interpreter is safe or not. Safe
+ * in this interpreter (using the targetTable hashtable).
+ *
+ * NB: the flags field in the interp structure, used with SAFE_INTERP
+ * mask denotes whether the interpreter is safe or not. Safe
* interpreters have restricted functionality, can only create safe slave
* interpreters and can only load safe extensions.
*/
@@ -122,7 +110,6 @@ typedef struct {
typedef struct {
Tcl_HashTable slaveTable; /* Hash table for slave interpreters.
* Maps from command names to Slave records. */
- int isSafe; /* Am I a "safe" interpreter? */
Tcl_HashTable targetTable; /* Hash table for Target Records. Contains
* all Target records which denote aliases
* from slaves or sibling interpreters that
@@ -204,6 +191,9 @@ static int InterpShareHelper _ANSI_ARGS_((Tcl_Interp *interp,
static int InterpTargetHelper _ANSI_ARGS_((Tcl_Interp *interp,
Master *masterPtr, int objc,
Tcl_Obj *CONST objv[]));
+static int InterpTransferHelper _ANSI_ARGS_((Tcl_Interp *interp,
+ Master *masterPtr, int objc,
+ Tcl_Obj *CONST objv[]));
static int MarkTrusted _ANSI_ARGS_((Tcl_Interp *interp));
static void MasterRecordDeleteProc _ANSI_ARGS_((
ClientData clientData, Tcl_Interp *interp));
@@ -351,15 +341,9 @@ static int
MarkTrusted(interp)
Tcl_Interp *interp; /* Interpreter to be marked unsafe. */
{
- Master *masterPtr; /* Master record for interpreter to
- * be marked unsafe. */
+ Interp *iPtr = (Interp *) interp;
- masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord",
- NULL);
- if (masterPtr == (Master *) NULL) {
- panic("MarkTrusted: could not find master record");
- }
- masterPtr->isSafe = 0;
+ iPtr->flags &= ~SAFE_INTERP;
return TCL_OK;
}
@@ -386,28 +370,40 @@ int
Tcl_MakeSafe(interp)
Tcl_Interp *interp; /* Interpreter to be made safe. */
{
- Master *masterPtr; /* Master record of interp
- * to be made safe. */
Tcl_Channel chan; /* Channel to remove from
* safe interpreter. */
- Tcl_Obj *objPtr;
+ Interp *iPtr = (Interp *) interp;
TclHideUnsafeCommands(interp);
- masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord",
- NULL);
- if (masterPtr == (Master *) NULL) {
- panic("MakeSafe: could not find master record");
- }
- masterPtr->isSafe = 1;
- objPtr = Tcl_NewStringObj(makeSafeScript, -1);
- Tcl_IncrRefCount(objPtr);
+
+ iPtr->flags |= SAFE_INTERP;
- if (Tcl_EvalObj(interp, objPtr) == TCL_ERROR) {
- Tcl_DecrRefCount(objPtr);
- return TCL_ERROR;
- }
+ /*
+ * Unsetting variables : (which should not have been set
+ * in the first place, but...)
+ */
- Tcl_DecrRefCount(objPtr);
+ /*
+ * No env array in a safe slave.
+ */
+
+ Tcl_UnsetVar(interp, "env", TCL_GLOBAL_ONLY);
+
+ /*
+ * Remove unsafe parts of tcl_platform
+ */
+
+ Tcl_UnsetVar2(interp, "tcl_platform", "os", TCL_GLOBAL_ONLY);
+ Tcl_UnsetVar2(interp, "tcl_platform", "osVersion", TCL_GLOBAL_ONLY);
+ Tcl_UnsetVar2(interp, "tcl_platform", "machine", TCL_GLOBAL_ONLY);
+
+ /*
+ * Unset path informations variables
+ * (the only one remaining is [info nameofexecutable])
+ */
+
+ Tcl_UnsetVar(interp, "tcl_library", TCL_GLOBAL_ONLY);
+ Tcl_UnsetVar(interp, "tcl_pkgPath", TCL_GLOBAL_ONLY);
/*
* Remove the standard channels from the interpreter; safe interpreters
@@ -557,7 +553,7 @@ CreateSlave(interp, masterPtr, slavePath, safe)
ckfree((char *) masterPath);
slavePath = argv[argc-1];
if (!safe) {
- safe = masterPtr->isSafe;
+ safe = Tcl_IsSafe(masterInterp);
}
}
hPtr = Tcl_CreateHashEntry(&(masterPtr->slaveTable), slavePath, &new);
@@ -572,7 +568,7 @@ CreateSlave(interp, masterPtr, slavePath, safe)
if (slaveInterp == (Tcl_Interp *) NULL) {
panic("CreateSlave: out of memory while creating a new interpreter");
}
- slavePtr = (Slave *) ckalloc((unsigned) sizeof(Slave));
+ slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", NULL);
slavePtr->masterInterp = masterInterp;
slavePtr->slaveEntry = hPtr;
slavePtr->slaveInterp = slaveInterp;
@@ -648,10 +644,10 @@ CreateInterpObject(interp, masterPtr, objc, objv)
moreFlags = 1;
slavePath = NULL;
- safe = masterPtr->isSafe;
+ safe = Tcl_IsSafe(interp);
if ((objc < 2) || (objc > 5)) {
- Tcl_WrongNumArgs(interp, 1, objv, "create ?-safe? ?--? ?path?");
+ Tcl_WrongNumArgs(interp, 2, objv, "?-safe? ?--? ?path?");
return TCL_ERROR;
}
for (i = 2; i < objc; i++) {
@@ -675,8 +671,23 @@ CreateInterpObject(interp, masterPtr, objc, objv)
}
}
if (slavePath == (char *) NULL) {
- sprintf(localSlaveName, "interp%d", interpCounter);
- interpCounter++;
+
+ /*
+ * Create an anonymous interpreter -- we choose its name and
+ * the name of the command. We check that the command name that
+ * we use for the interpreter does not collide with an existing
+ * command in the master interpreter.
+ */
+
+ while (1) {
+ Tcl_CmdInfo cmdInfo;
+
+ sprintf(localSlaveName, "interp%d", interpCounter);
+ interpCounter++;
+ if (!(Tcl_GetCommandInfo(interp, localSlaveName, &cmdInfo))) {
+ break;
+ }
+ }
slavePath = localSlaveName;
}
if (CreateSlave(interp, masterPtr, slavePath, safe) != NULL) {
@@ -850,19 +861,12 @@ AliasCreationHelper(curInterp, slaveInterp, masterInterp, masterPtr,
slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord", NULL);
/*
- * Fix it up if there is no slave record. This can happen if someone
- * uses "" as the source for an alias.
+ * Slave record should be always present because it is created when
+ * the interpreter is created.
*/
if (slavePtr == (Slave *) NULL) {
- slavePtr = (Slave *) ckalloc((unsigned) sizeof(Slave));
- slavePtr->masterInterp = (Tcl_Interp *) NULL;
- slavePtr->slaveEntry = (Tcl_HashEntry *) NULL;
- slavePtr->slaveInterp = slaveInterp;
- slavePtr->interpCmd = (Tcl_Command) NULL;
- Tcl_InitHashTable(&(slavePtr->aliasTable), TCL_STRING_KEYS);
- (void) Tcl_SetAssocData(slaveInterp, "tclSlaveRecord",
- SlaveRecordDeleteProc, (ClientData) slavePtr);
+ panic("AliasCreationHelper: could not find slave record");
}
if ((targetName == (char *) NULL) || (targetName[0] == '\0')) {
@@ -1018,7 +1022,7 @@ InterpAliasesHelper(interp, masterPtr, objc, objv)
Tcl_Obj *listObjPtr, *elemObjPtr; /* Local object pointers. */
if ((objc != 2) && (objc != 3)) {
- Tcl_WrongNumArgs(interp, 1, objv, " aliases ?path?");
+ Tcl_WrongNumArgs(interp, 2, objv, "?path?");
return TCL_ERROR;
}
if (objc == 3) {
@@ -1092,8 +1096,8 @@ InterpAliasHelper(interp, masterPtr, objc, objv)
int len;
if (objc < 4) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "alias slavePath slaveCmd masterPath masterCmd ?args ..?");
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "slavePath slaveCmd masterPath masterCmd ?args ..?");
return TCL_ERROR;
}
slaveInterp = GetInterp(interp, masterPtr,
@@ -1114,8 +1118,8 @@ InterpAliasHelper(interp, masterPtr, objc, objv)
Tcl_GetStringFromObj(objv[3], &len));
}
if (objc < 6) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "alias slavePath slaveCmd masterPath masterCmd ?args ..?");
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "slavePath slaveCmd masterPath masterCmd ?args ..?");
return TCL_ERROR;
}
masterInterp = GetInterp(interp, masterPtr,
@@ -1159,19 +1163,19 @@ InterpExistsHelper(interp, masterPtr, objc, objv)
int len;
if (objc > 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "exists ?path?");
+ Tcl_WrongNumArgs(interp, 2, objv, "?path?");
return TCL_ERROR;
}
if (objc == 3) {
if (GetInterp(interp, masterPtr,
Tcl_GetStringFromObj(objv[2], &len), NULL) ==
(Tcl_Interp *) NULL) {
- objPtr = Tcl_NewStringObj("0", 1);
+ objPtr = Tcl_NewIntObj(0);
} else {
- objPtr = Tcl_NewStringObj("1", 1);
+ objPtr = Tcl_NewIntObj(1);
}
} else {
- objPtr = Tcl_NewStringObj("1", 1);
+ objPtr = Tcl_NewIntObj(1);
}
Tcl_SetObjResult(interp, objPtr);
@@ -1210,7 +1214,7 @@ InterpEvalHelper(interp, masterPtr, objc, objv)
char *string;
if (objc < 4) {
- Tcl_WrongNumArgs(interp, 1, objv, " eval path arg ?arg ...?");
+ Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?");
return TCL_ERROR;
}
slaveInterp = GetInterp(interp, masterPtr,
@@ -1306,8 +1310,8 @@ InterpExposeHelper(interp, masterPtr, objc, objv)
int len; /* Dummy length variable. */
if ((objc != 4) && (objc != 5)) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "expose path hiddenCmdName ?cmdName?");
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "path hiddenCmdName ?cmdName?");
return TCL_ERROR;
}
if (Tcl_IsSafe(interp)) {
@@ -1368,8 +1372,8 @@ InterpHideHelper(interp, masterPtr, objc, objv)
int len; /* Dummy length variable. */
if ((objc != 4) && (objc != 5)) {
- Tcl_WrongNumArgs(interp, 1, objv,
- " hide path cmdName ?hiddenCmdName?");
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "path cmdName ?hiddenCmdName?");
return TCL_ERROR;
}
if (Tcl_IsSafe(interp)) {
@@ -1431,7 +1435,7 @@ InterpHiddenHelper(interp, masterPtr, objc, objv)
Tcl_Obj *listObjPtr; /* Local object pointer. */
if (objc > 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "hidden ?path?");
+ Tcl_WrongNumArgs(interp, 2, objv, "?path?");
return TCL_ERROR;
}
if (objc == 3) {
@@ -1498,8 +1502,8 @@ InterpInvokeHiddenHelper(interp, masterPtr, objc, objv)
char *string;
if (objc < 4) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "invokehidden path ?-global? cmd ?arg ..?");
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "path ?-global? cmd ?arg ..?");
return TCL_ERROR;
}
if (Tcl_IsSafe(interp)) {
@@ -1511,8 +1515,8 @@ InterpInvokeHiddenHelper(interp, masterPtr, objc, objv)
if (strcmp(Tcl_GetStringFromObj(objv[3], &len), "-global") == 0) {
doGlobal = 1;
if (objc < 5) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "invokehidden path ?-global? cmd ?arg ..?");
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "path ?-global? cmd ?arg ..?");
return TCL_ERROR;
}
}
@@ -1607,7 +1611,7 @@ InterpMarkTrustedHelper(interp, masterPtr, objc, objv)
int len; /* Dummy length variable. */
if (objc != 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "marktrusted path");
+ Tcl_WrongNumArgs(interp, 2, objv, "path");
return TCL_ERROR;
}
if (Tcl_IsSafe(interp)) {
@@ -1658,7 +1662,7 @@ InterpIsSafeHelper(interp, masterPtr, objc, objv)
Tcl_Obj *objPtr; /* Local object pointer. */
if (objc > 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "issafe ?path?");
+ Tcl_WrongNumArgs(interp, 2, objv, "?path?");
return TCL_ERROR;
}
if (objc == 3) {
@@ -1671,11 +1675,9 @@ InterpIsSafeHelper(interp, masterPtr, objc, objv)
(char *) NULL);
return TCL_ERROR;
}
- }
- if (masterPtr->isSafe == 0) {
- objPtr = Tcl_NewStringObj("0", 1);
+ objPtr = Tcl_NewIntObj(Tcl_IsSafe(slaveInterp));
} else {
- objPtr = Tcl_NewStringObj("1", 1);
+ objPtr = Tcl_NewIntObj(Tcl_IsSafe(interp));
}
Tcl_SetObjResult(interp, objPtr);
return TCL_OK;
@@ -1710,7 +1712,7 @@ InterpSlavesHelper(interp, masterPtr, objc, objv)
Tcl_Obj *listObjPtr; /* Local object pointers. */
if ((objc != 2) && (objc != 3)) {
- Tcl_WrongNumArgs(interp, 1, objv, "slaves ?path?");
+ Tcl_WrongNumArgs(interp, 2, objv, "?path?");
return TCL_ERROR;
}
if (objc == 3) {
@@ -1768,7 +1770,7 @@ InterpShareHelper(interp, masterPtr, objc, objv)
Tcl_Channel chan;
if (objc != 5) {
- Tcl_WrongNumArgs(interp, 1, objv, "share srcPath channelId destPath");
+ Tcl_WrongNumArgs(interp, 2, objv, "srcPath channelId destPath");
return TCL_ERROR;
}
masterInterp = GetInterp(interp, masterPtr,
@@ -1826,7 +1828,7 @@ InterpTargetHelper(interp, masterPtr, objc, objv)
int len;
if (objc != 4) {
- Tcl_WrongNumArgs(interp, 1, objv, "target path alias");
+ Tcl_WrongNumArgs(interp, 2, objv, "path alias");
return TCL_ERROR;
}
return GetTarget(interp,
@@ -1865,8 +1867,8 @@ InterpTransferHelper(interp, masterPtr, objc, objv)
Tcl_Channel chan;
if (objc != 5) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "transfer srcPath channelId destPath");
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "srcPath channelId destPath");
return TCL_ERROR;
}
masterInterp = GetInterp(interp, masterPtr,
@@ -1944,24 +1946,14 @@ DescribeAlias(interp, slaveInterp, aliasName)
slavePtr = (Slave *) Tcl_GetAssocData(slaveInterp, "tclSlaveRecord",
NULL);
- if (slavePtr == (Slave *) NULL) {
- /*
- * It's possible that the interpreter still does not have a slave
- * record. If so, create such a record now. This is only possible
- * for interpreters that were created with Tcl_CreateInterp, not
- * those created with Tcl_CreateSlave, so this interpreter does
- * not have a master.
- */
-
- slavePtr = (Slave *) ckalloc((unsigned) sizeof(Slave));
- slavePtr->masterInterp = (Tcl_Interp *) NULL;
- slavePtr->slaveEntry = (Tcl_HashEntry *) NULL;
- slavePtr->slaveInterp = slaveInterp;
- slavePtr->interpCmd = (Tcl_Command) NULL;
- Tcl_InitHashTable(&(slavePtr->aliasTable), TCL_STRING_KEYS);
- (void) Tcl_SetAssocData(slaveInterp, "tclSlaveRecord",
- SlaveRecordDeleteProc, (ClientData) slavePtr);
+ /*
+ * The slave record should always be present because it is created
+ * by Tcl_CreateInterp.
+ */
+
+ if (slavePtr == (Slave *) NULL) {
+ panic("DescribeAlias: could not find slave record");
}
hPtr = Tcl_FindHashEntry(&(slavePtr->aliasTable), aliasName);
if (hPtr == (Tcl_HashEntry *) NULL) {
@@ -2322,8 +2314,8 @@ SlaveAliasHelper(interp, slaveInterp, slavePtr, objc, objv)
switch (objc-2) {
case 0:
- Tcl_WrongNumArgs(interp, 1, objv,
- "alias aliasName ?targetName? ?args..?");
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "aliasName ?targetName? ?args..?");
return TCL_ERROR;
case 1:
@@ -2430,7 +2422,7 @@ SlaveEvalHelper(interp, slaveInterp, slavePtr, objc, objv)
int result;
if (objc < 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "eval arg ?arg ...?");
+ Tcl_WrongNumArgs(interp, 2, objv, "arg ?arg ...?");
return TCL_ERROR;
}
@@ -2517,7 +2509,7 @@ SlaveExposeHelper(interp, slaveInterp, slavePtr, objc, objv)
int len;
if ((objc != 3) && (objc != 4)) {
- Tcl_WrongNumArgs(interp, 1, objv, "expose hiddenCmdName ?cmdName?");
+ Tcl_WrongNumArgs(interp, 2, objv, "hiddenCmdName ?cmdName?");
return TCL_ERROR;
}
if (Tcl_IsSafe(interp)) {
@@ -2566,7 +2558,7 @@ SlaveHideHelper(interp, slaveInterp, slavePtr, objc, objv)
int len;
if ((objc != 3) && (objc != 4)) {
- Tcl_WrongNumArgs(interp, 1, objv, "hide cmdName ?hiddenCmdName?");
+ Tcl_WrongNumArgs(interp, 2, objv, "cmdName ?hiddenCmdName?");
return TCL_ERROR;
}
if (Tcl_IsSafe(interp)) {
@@ -2618,7 +2610,7 @@ SlaveHiddenHelper(interp, slaveInterp, slavePtr, objc, objv)
Tcl_HashSearch hSearch; /* For local searches. */
if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "hidden");
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
@@ -2661,24 +2653,15 @@ SlaveIsSafeHelper(interp, slaveInterp, slavePtr, objc, objv)
int objc; /* Count of arguments. */
Tcl_Obj *CONST objv[]; /* Vector of arguments. */
{
- Master *masterPtr; /* Master record for slave interp. */
- Tcl_Obj *namePtr; /* Local object pointer. */
+ Tcl_Obj *resultPtr; /* Local object pointer. */
if (objc > 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "issafe");
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
- masterPtr = (Master *) Tcl_GetAssocData(slaveInterp,
- "tclMasterRecord", NULL);
- if (masterPtr == (Master *) NULL) {
- panic("SlaveObjectCmd: could not find master record");
- }
- if (masterPtr->isSafe == 1) {
- namePtr = Tcl_NewStringObj("1", 1);
- } else {
- namePtr = Tcl_NewStringObj("0", 1);
- }
- Tcl_SetObjResult(interp, namePtr);
+ resultPtr = Tcl_NewIntObj(Tcl_IsSafe(slaveInterp));
+
+ Tcl_SetObjResult(interp, resultPtr);
return TCL_OK;
}
@@ -2715,8 +2698,8 @@ SlaveInvokeHiddenHelper(interp, slaveInterp, slavePtr, objc, objv)
Tcl_Obj *namePtr, *objPtr;
if (objc < 3) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "invokehidden ?-global? cmd ?arg ..?");
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "?-global? cmd ?arg ..?");
return TCL_ERROR;
}
if (Tcl_IsSafe(interp)) {
@@ -2728,8 +2711,8 @@ SlaveInvokeHiddenHelper(interp, slaveInterp, slavePtr, objc, objv)
if (strcmp(Tcl_GetStringFromObj(objv[2], &len), "-global") == 0) {
doGlobal = 1;
if (objc < 4) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "invokehidden path ?-global? cmd ?arg ..?");
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "path ?-global? cmd ?arg ..?");
return TCL_ERROR;
}
}
@@ -2821,7 +2804,7 @@ SlaveMarkTrustedHelper(interp, slaveInterp, slavePtr, objc, objv)
int len;
if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "marktrusted");
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
if (Tcl_IsSafe(interp)) {
@@ -3459,14 +3442,26 @@ TclInterpInit(interp)
Tcl_Interp *interp; /* Interpreter to initialize. */
{
Master *masterPtr; /* Its Master record. */
+ Slave *slavePtr; /* And its slave record. */
masterPtr = (Master *) ckalloc((unsigned) sizeof(Master));
- masterPtr->isSafe = 0;
+
Tcl_InitHashTable(&(masterPtr->slaveTable), TCL_STRING_KEYS);
Tcl_InitHashTable(&(masterPtr->targetTable), TCL_ONE_WORD_KEYS);
(void) Tcl_SetAssocData(interp, "tclMasterRecord", MasterRecordDeleteProc,
(ClientData) masterPtr);
+
+ slavePtr = (Slave *) ckalloc((unsigned) sizeof(Slave));
+
+ slavePtr->masterInterp = (Tcl_Interp *) NULL;
+ slavePtr->slaveEntry = (Tcl_HashEntry *) NULL;
+ slavePtr->slaveInterp = interp;
+ slavePtr->interpCmd = (Tcl_Command) NULL;
+ Tcl_InitHashTable(&(slavePtr->aliasTable), TCL_STRING_KEYS);
+
+ (void) Tcl_SetAssocData(interp, "tclSlaveRecord", SlaveRecordDeleteProc,
+ (ClientData) slavePtr);
return TCL_OK;
}
@@ -3491,16 +3486,14 @@ int
Tcl_IsSafe(interp)
Tcl_Interp *interp; /* Is this interpreter "safe" ? */
{
- Master *masterPtr; /* Its master record. */
+ Interp *iPtr;
if (interp == (Tcl_Interp *) NULL) {
return 0;
}
- masterPtr = (Master *) Tcl_GetAssocData(interp, "tclMasterRecord", NULL);
- if (masterPtr == (Master *) NULL) {
- panic("Tcl_IsSafe: could not find master record");
- }
- return masterPtr->isSafe;
+ iPtr = (Interp *) interp;
+
+ return ( (iPtr->flags) & SAFE_INTERP ) ? 1 : 0 ;
}
/*
diff --git a/contrib/tcl/generic/tclListObj.c b/contrib/tcl/generic/tclListObj.c
index 04b263302711..0f76f6ff213b 100644
--- a/contrib/tcl/generic/tclListObj.c
+++ b/contrib/tcl/generic/tclListObj.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclListObj.c 1.44 97/06/13 18:25:32
+ * SCCS: @(#) tclListObj.c 1.47 97/08/12 19:02:02
*/
#include "tclInt.h"
@@ -413,7 +413,7 @@ Tcl_ListObjAppendElement(interp, listPtr, objPtr)
{
register List *listRepPtr;
register Tcl_Obj **elemPtrs;
- int numElems;
+ int numElems, numRequired;
if (Tcl_IsShared(listPtr)) {
panic("Tcl_ListObjAppendElement called with shared object");
@@ -428,14 +428,14 @@ Tcl_ListObjAppendElement(interp, listPtr, objPtr)
listRepPtr = (List *) listPtr->internalRep.otherValuePtr;
elemPtrs = listRepPtr->elements;
numElems = listRepPtr->elemCount;
+ numRequired = numElems + 1 ;
/*
* If there is no room in the current array of element pointers,
* allocate a new, larger array and copy the pointers to it.
*/
- if (numElems >= listRepPtr->maxElemCount) {
- int numRequired = (numElems + 1);
+ if (numRequired > listRepPtr->maxElemCount) {
int newMax = (2 * numRequired);
Tcl_Obj **newElemPtrs = (Tcl_Obj **)
ckalloc((unsigned) (newMax * sizeof(Tcl_Obj *)));
@@ -639,7 +639,7 @@ Tcl_ListObjReplace(interp, listPtr, first, count, objc, objv)
}
numRequired = (numElems - count + objc);
- if (numRequired < listRepPtr->maxElemCount) {
+ if (numRequired <= listRepPtr->maxElemCount) {
/*
* Enough room in the current array. First "delete" count
* elements starting at first.
@@ -941,7 +941,7 @@ SetListFromAny(interp, objPtr)
s = ckalloc((unsigned) elemSize + 1);
if (hasBrace) {
- strncpy(s, elemStart, (size_t) elemSize);
+ memcpy((VOID *) s, (VOID *) elemStart, (size_t) elemSize);
s[elemSize] = 0;
} else {
elemSize = TclCopyAndCollapse(elemSize, elemStart, s);
diff --git a/contrib/tcl/generic/tclLoad.c b/contrib/tcl/generic/tclLoad.c
index 2e4e615ee24b..a1deee014da9 100644
--- a/contrib/tcl/generic/tclLoad.c
+++ b/contrib/tcl/generic/tclLoad.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclLoad.c 1.16 97/05/14 13:23:37
+ * SCCS: @(#) tclLoad.c 1.17 97/07/24 20:05:04
*/
#include "tclInt.h"
@@ -370,6 +370,10 @@ Tcl_LoadCmd(dummy, interp, argc, argv)
* everything we need in target's $errorInfo.
*/
+ /*
+ * It is (abusively) assumed that errorInfo and errorCode vars exists.
+ * we changed SetVar2 to accept NULL values to avoid crashes. --dl
+ */
Tcl_ResetResult(interp);
Tcl_AddErrorInfo(interp, Tcl_GetVar2(target,
"errorInfo", (char *) NULL, TCL_GLOBAL_ONLY));
diff --git a/contrib/tcl/generic/tclMain.c b/contrib/tcl/generic/tclMain.c
index 6ed86e5a5a58..ce87636b9668 100644
--- a/contrib/tcl/generic/tclMain.c
+++ b/contrib/tcl/generic/tclMain.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclMain.c 1.52 96/10/22 11:23:51
+ * SCCS: @(#) tclMain.c 1.54 97/08/07 19:04:43
*/
#include "tcl.h"
@@ -38,14 +38,13 @@ extern int isatty _ANSI_ARGS_((int fd));
extern char * strcpy _ANSI_ARGS_((char *dst, CONST char *src));
static Tcl_Interp *interp; /* Interpreter for application. */
-static Tcl_DString command; /* Used to buffer incomplete commands being
- * read from stdin. */
+
#ifdef TCL_MEM_DEBUG
static char dumpFile[100]; /* Records where to dump memory allocation
* information. */
-static int quitFlag = 0; /* 1 means the "checkmem" command was
- * invoked, so the application should quit
- * and dump memory allocation information. */
+static int quitFlag = 0; /* 1 means "checkmem" command was called,
+ * so the application should quit and dump
+ * memory allocation information. */
#endif
/*
@@ -78,14 +77,19 @@ static int CheckmemCmd _ANSI_ARGS_((ClientData clientData,
void
Tcl_Main(argc, argv, appInitProc)
- int argc; /* Number of arguments. */
- char **argv; /* Array of argument strings. */
- Tcl_AppInitProc *appInitProc; /* Application-specific initialization
- * procedure to call after most
- * initialization but before starting
- * to execute commands. */
+ int argc; /* Number of arguments. */
+ char **argv; /* Array of argument strings. */
+ Tcl_AppInitProc *appInitProc;
+ /* Application-specific initialization
+ * procedure to call after most
+ * initialization but before starting to
+ * execute commands. */
{
- char buffer[1000], *cmd, *args, *fileName;
+ Tcl_Obj *prompt1NamePtr = NULL;
+ Tcl_Obj *prompt2NamePtr = NULL;
+ Tcl_Obj *resultPtr;
+ Tcl_Obj *commandPtr = NULL;
+ char buffer[1000], *args, *fileName, *bytes;
int code, gotPartial, tty, length;
int exitCode = 0;
Tcl_Channel inChannel, outChannel, errChannel;
@@ -178,29 +182,38 @@ Tcl_Main(argc, argv, appInitProc)
* eval, since they may have been changed.
*/
- gotPartial = 0;
- Tcl_DStringInit(&command);
+ commandPtr = Tcl_NewObj();
+ Tcl_IncrRefCount(commandPtr);
+ prompt1NamePtr = Tcl_NewStringObj("tcl_prompt1", -1);
+ Tcl_IncrRefCount(prompt1NamePtr);
+ prompt2NamePtr = Tcl_NewStringObj("tcl_prompt2", -1);
+ Tcl_IncrRefCount(prompt2NamePtr);
+
inChannel = Tcl_GetStdChannel(TCL_STDIN);
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
+ gotPartial = 0;
while (1) {
if (tty) {
- char *promptCmd;
+ Tcl_Obj *promptCmdPtr;
- promptCmd = Tcl_GetVar(interp,
- gotPartial ? "tcl_prompt2" : "tcl_prompt1", TCL_GLOBAL_ONLY);
- if (promptCmd == NULL) {
-defaultPrompt:
+ promptCmdPtr = Tcl_ObjGetVar2(interp,
+ (gotPartial? prompt2NamePtr : prompt1NamePtr),
+ (Tcl_Obj *) NULL, TCL_GLOBAL_ONLY);
+ if (promptCmdPtr == NULL) {
+ defaultPrompt:
if (!gotPartial && outChannel) {
Tcl_Write(outChannel, "% ", 2);
}
} else {
- code = Tcl_Eval(interp, promptCmd);
+ code = Tcl_EvalObj(interp, promptCmdPtr);
inChannel = Tcl_GetStdChannel(TCL_STDIN);
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
errChannel = Tcl_GetStdChannel(TCL_STDERR);
if (code != TCL_OK) {
if (errChannel) {
- Tcl_Write(errChannel, interp->result, -1);
+ resultPtr = Tcl_GetObjResult(interp);
+ bytes = Tcl_GetStringFromObj(resultPtr, &length);
+ Tcl_Write(errChannel, bytes, length);
Tcl_Write(errChannel, "\n", 1);
}
Tcl_AddErrorInfo(interp,
@@ -215,7 +228,7 @@ defaultPrompt:
if (!inChannel) {
goto done;
}
- length = Tcl_Gets(inChannel, &command);
+ length = Tcl_GetsObj(inChannel, commandPtr);
if (length < 0) {
goto done;
}
@@ -224,36 +237,41 @@ defaultPrompt:
}
/*
- * Add the newline removed by Tcl_Gets back to the string.
+ * Add the newline removed by Tcl_GetsObj back to the string.
*/
-
- (void) Tcl_DStringAppend(&command, "\n", -1);
- cmd = Tcl_DStringValue(&command);
- if (!Tcl_CommandComplete(cmd)) {
+ Tcl_AppendToObj(commandPtr, "\n", 1);
+ if (!TclObjCommandComplete(commandPtr)) {
gotPartial = 1;
continue;
}
gotPartial = 0;
- code = Tcl_RecordAndEval(interp, cmd, 0);
+ code = Tcl_RecordAndEvalObj(interp, commandPtr, 0);
inChannel = Tcl_GetStdChannel(TCL_STDIN);
outChannel = Tcl_GetStdChannel(TCL_STDOUT);
errChannel = Tcl_GetStdChannel(TCL_STDERR);
- Tcl_DStringFree(&command);
+ Tcl_SetObjLength(commandPtr, 0);
if (code != TCL_OK) {
if (errChannel) {
- Tcl_Write(errChannel, interp->result, -1);
+ resultPtr = Tcl_GetObjResult(interp);
+ bytes = Tcl_GetStringFromObj(resultPtr, &length);
+ Tcl_Write(errChannel, bytes, length);
Tcl_Write(errChannel, "\n", 1);
}
- } else if (tty && (*interp->result != 0)) {
- if (outChannel) {
- Tcl_Write(outChannel, interp->result, -1);
+ } else if (tty) {
+ resultPtr = Tcl_GetObjResult(interp);
+ bytes = Tcl_GetStringFromObj(resultPtr, &length);
+ if ((length > 0) && outChannel) {
+ Tcl_Write(outChannel, bytes, length);
Tcl_Write(outChannel, "\n", 1);
}
}
#ifdef TCL_MEM_DEBUG
if (quitFlag) {
+ Tcl_DecrRefCount(commandPtr);
+ Tcl_DecrRefCount(prompt1NamePtr);
+ Tcl_DecrRefCount(prompt2NamePtr);
Tcl_DeleteInterp(interp);
Tcl_Exit(0);
}
@@ -266,7 +284,16 @@ defaultPrompt:
* cleanup on exit. The Tcl_Eval call should never return.
*/
-done:
+ done:
+ if (commandPtr != NULL) {
+ Tcl_DecrRefCount(commandPtr);
+ }
+ if (prompt1NamePtr != NULL) {
+ Tcl_DecrRefCount(prompt1NamePtr);
+ }
+ if (prompt2NamePtr != NULL) {
+ Tcl_DecrRefCount(prompt2NamePtr);
+ }
sprintf(buffer, "exit %d", exitCode);
Tcl_Eval(interp, buffer);
}
diff --git a/contrib/tcl/generic/tclMath.h b/contrib/tcl/generic/tclMath.h
new file mode 100644
index 000000000000..fdf2ac938d52
--- /dev/null
+++ b/contrib/tcl/generic/tclMath.h
@@ -0,0 +1,27 @@
+/*
+ * tclMath.h --
+ *
+ * This file is necessary because of Metrowerks CodeWarrior Pro 1
+ * on the Macintosh. With 8-byte doubles turned on, the definitions of
+ * sin, cos, acos, etc., are screwed up. They are fine as long as
+ * they are used as function calls, but if the function pointers
+ * are passed around and used, they will crash hard on the 68K.
+ *
+ * Copyright (c) 1997 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclMath.h 1.2 97/07/23 17:39:14
+ */
+
+#ifndef _TCLMATH
+#define _TCLMATH
+
+#if defined(MAC_TCL)
+# include "tclMacMath.h"
+#else
+# include <math.h>
+#endif
+
+#endif /* _TCLMATH */
diff --git a/contrib/tcl/generic/tclNamesp.c b/contrib/tcl/generic/tclNamesp.c
index 2155ddf40b89..d4ace4330804 100644
--- a/contrib/tcl/generic/tclNamesp.c
+++ b/contrib/tcl/generic/tclNamesp.c
@@ -18,7 +18,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclNamesp.c 1.21 97/06/20 15:21:04
+ * SCCS: @(#) tclNamesp.c 1.29 97/08/04 09:32:38
*/
#include "tclInt.h"
@@ -456,19 +456,20 @@ Tcl_CreateNamespace(interp, name, clientData, deleteProc)
/* Procedure called to delete client
* data when the namespace is deleted.
* NULL if no procedure should be
- * called.*/
+ * called. */
{
Interp *iPtr = (Interp *) interp;
register Namespace *nsPtr, *ancestorPtr;
Namespace *parentPtr, *dummy1Ptr, *dummy2Ptr;
Namespace *globalNsPtr = iPtr->globalNsPtr;
+ char *simpleName;
Tcl_HashEntry *entryPtr;
Tcl_DString buffer1, buffer2;
int newEntry, result;
/*
- * Check first if there is no active namespace. If so, we assume
- * the interpreter is being initialized.
+ * If there is no active namespace, the interpreter is being
+ * initialized.
*/
if ((globalNsPtr == NULL) && (iPtr->varFramePtr == NULL)) {
@@ -478,33 +479,41 @@ Tcl_CreateNamespace(interp, name, clientData, deleteProc)
*/
parentPtr = NULL;
- name = "";
+ simpleName = "";
+ } else if (*name == '\0') {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "can't create namespace \"\": only global namespace can have empty name", (char *) NULL);
+ return NULL;
} else {
/*
- * There is no active namespace. Find the parent namespace that will
- * contain the new namespace.
+ * Find the parent for the new namespace.
*/
result = TclGetNamespaceForQualName(interp, name,
(Namespace *) NULL,
/*flags*/ (CREATE_NS_IF_UNKNOWN | TCL_LEAVE_ERR_MSG),
- &parentPtr, &dummy1Ptr, &dummy2Ptr, &name);
+ &parentPtr, &dummy1Ptr, &dummy2Ptr, &simpleName);
if (result != TCL_OK) {
return NULL;
}
+ /*
+ * If the unqualified name at the end is empty, there were trailing
+ * "::"s after the namespace's name which we ignore. The new
+ * namespace was already (recursively) created and is pointed to
+ * by parentPtr.
+ */
+
+ if (*simpleName == '\0') {
+ return (Tcl_Namespace *) parentPtr;
+ }
+
/*
* Check for a bad namespace name and make sure that the name
* does not already exist in the parent namespace.
*/
- if ((name == NULL) || (*name == '\0')) {
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "can't create namespace \"", name,
- "\": invalid name", (char *) NULL);
- return NULL;
- }
- if (Tcl_FindHashEntry(&parentPtr->childTable, name) != NULL) {
+ if (Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"can't create namespace \"", name,
"\": already exists", (char *) NULL);
@@ -520,8 +529,8 @@ Tcl_CreateNamespace(interp, name, clientData, deleteProc)
numNsCreated++;
nsPtr = (Namespace *) ckalloc(sizeof(Namespace));
- nsPtr->name = (char *) ckalloc((unsigned) (strlen(name)+1));
- strcpy(nsPtr->name, name);
+ nsPtr->name = (char *) ckalloc((unsigned) (strlen(simpleName)+1));
+ strcpy(nsPtr->name, simpleName);
nsPtr->fullName = NULL; /* set below */
nsPtr->clientData = clientData;
nsPtr->deleteProc = deleteProc;
@@ -540,7 +549,7 @@ Tcl_CreateNamespace(interp, name, clientData, deleteProc)
nsPtr->cmdRefEpoch = 0;
if (parentPtr != NULL) {
- entryPtr = Tcl_CreateHashEntry(&parentPtr->childTable, name,
+ entryPtr = Tcl_CreateHashEntry(&parentPtr->childTable, simpleName,
&newEntry);
Tcl_SetHashValue(entryPtr, (ClientData) nsPtr);
}
@@ -703,7 +712,6 @@ TclTeardownNamespace(nsPtr)
{
Interp *iPtr = (Interp *) nsPtr->interp;
register Tcl_HashEntry *entryPtr;
- Tcl_HashEntry *hPtr;
Tcl_HashSearch search;
Tcl_Namespace *childNsPtr;
Tcl_Command cmd;
@@ -798,16 +806,9 @@ TclTeardownNamespace(nsPtr)
/*
* Delete all commands in this namespace. Be careful when traversing the
* hash table: when each command is deleted, it removes itself from the
- * command table. There's a special hack here because "tkerror" is just
- * a synonym for "bgerror" (they share a Command structure). Just
- * delete the hash table entry for "tkerror" without invoking its
- * callback or cleaning up its Command structure.
+ * command table.
*/
- hPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, "tkerror");
- if (hPtr != NULL) {
- Tcl_DeleteHashEntry(hPtr);
- }
for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
entryPtr != NULL;
entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search)) {
@@ -889,7 +890,7 @@ NamespaceFree(nsPtr)
*
* Tcl_Export --
*
- * Makes all the commands matching a pattern available to later ber
+ * Makes all the commands matching a pattern available to later be
* imported from the namespace specified by contextNsPtr (or the
* current namespace if contextNsPtr is NULL). The specified pattern is
* appended onto the namespace's export pattern list, which is
@@ -924,7 +925,7 @@ Tcl_Export(interp, namespacePtr, pattern, resetListFirst)
* cmd conflicts with an existing one. */
{
#define INIT_EXPORT_PATTERNS 5
- Namespace *nsPtr, *exportNsPtr, *altNsPtr, *dummyPtr;
+ Namespace *nsPtr, *exportNsPtr, *dummyPtr;
Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
char *simplePattern, *patternCpy;
int neededElems, len, i, result;
@@ -961,16 +962,12 @@ Tcl_Export(interp, namespacePtr, pattern, resetListFirst)
*/
result = TclGetNamespaceForQualName(interp, pattern, nsPtr,
- /*flags*/ TCL_LEAVE_ERR_MSG, &exportNsPtr, &altNsPtr,
+ /*flags*/ TCL_LEAVE_ERR_MSG, &exportNsPtr, &dummyPtr,
&dummyPtr, &simplePattern);
if (result != TCL_OK) {
return result;
}
- if (exportNsPtr == NULL) {
- exportNsPtr = altNsPtr;
- }
- if ((exportNsPtr != currNsPtr)
- || (strcmp(pattern, simplePattern) != 0)) {
+ if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"invalid export pattern \"", pattern,
"\": pattern can't specify a namespace",
@@ -983,23 +980,23 @@ Tcl_Export(interp, namespacePtr, pattern, resetListFirst)
* new pattern.
*/
- neededElems = currNsPtr->numExportPatterns + 1;
- if (currNsPtr->exportArrayPtr == NULL) {
- currNsPtr->exportArrayPtr = (char **)
+ neededElems = nsPtr->numExportPatterns + 1;
+ if (nsPtr->exportArrayPtr == NULL) {
+ nsPtr->exportArrayPtr = (char **)
ckalloc((unsigned) (INIT_EXPORT_PATTERNS * sizeof(char *)));
- currNsPtr->numExportPatterns = 0;
- currNsPtr->maxExportPatterns = INIT_EXPORT_PATTERNS;
- } else if (neededElems > currNsPtr->maxExportPatterns) {
- int numNewElems = 2 * currNsPtr->maxExportPatterns;
- size_t currBytes = currNsPtr->numExportPatterns * sizeof(char *);
+ nsPtr->numExportPatterns = 0;
+ nsPtr->maxExportPatterns = INIT_EXPORT_PATTERNS;
+ } else if (neededElems > nsPtr->maxExportPatterns) {
+ int numNewElems = 2 * nsPtr->maxExportPatterns;
+ size_t currBytes = nsPtr->numExportPatterns * sizeof(char *);
size_t newBytes = numNewElems * sizeof(char *);
char **newPtr = (char **) ckalloc((unsigned) newBytes);
- memcpy((VOID *) newPtr, (VOID *) currNsPtr->exportArrayPtr,
+ memcpy((VOID *) newPtr, (VOID *) nsPtr->exportArrayPtr,
currBytes);
- ckfree((char *) currNsPtr->exportArrayPtr);
- currNsPtr->exportArrayPtr = (char **) newPtr;
- currNsPtr->maxExportPatterns = numNewElems;
+ ckfree((char *) nsPtr->exportArrayPtr);
+ nsPtr->exportArrayPtr = (char **) newPtr;
+ nsPtr->maxExportPatterns = numNewElems;
}
/*
@@ -1010,8 +1007,8 @@ Tcl_Export(interp, namespacePtr, pattern, resetListFirst)
patternCpy = (char *) ckalloc((unsigned) (len + 1));
strcpy(patternCpy, pattern);
- currNsPtr->exportArrayPtr[currNsPtr->numExportPatterns] = patternCpy;
- currNsPtr->numExportPatterns++;
+ nsPtr->exportArrayPtr[nsPtr->numExportPatterns] = patternCpy;
+ nsPtr->numExportPatterns++;
return TCL_OK;
#undef INIT_EXPORT_PATTERNS
}
@@ -1111,7 +1108,7 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite)
* cmd conflicts with an existing one. */
{
Interp *iPtr = (Interp *) interp;
- Namespace *nsPtr, *importNsPtr, *dummyPtr, *actualCtxPtr;
+ Namespace *nsPtr, *importNsPtr, *dummyPtr;
Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
char *simplePattern, *cmdName;
register Tcl_HashEntry *hPtr;
@@ -1145,7 +1142,7 @@ Tcl_Import(interp, namespacePtr, pattern, allowOverwrite)
}
result = TclGetNamespaceForQualName(interp, pattern, nsPtr,
/*flags*/ TCL_LEAVE_ERR_MSG, &importNsPtr, &dummyPtr,
- &actualCtxPtr, &simplePattern);
+ &dummyPtr, &simplePattern);
if (result != TCL_OK) {
return TCL_ERROR;
}
@@ -1620,7 +1617,11 @@ TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags,
} else if (flags & TCL_GLOBAL_ONLY) {
nsPtr = globalNsPtr;
} else if (nsPtr == NULL) {
- nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp);
+ if (iPtr->varFramePtr != NULL) {
+ nsPtr = iPtr->varFramePtr->nsPtr;
+ } else {
+ nsPtr = iPtr->globalNsPtr;
+ }
}
start = qualName; /* pts to start of qualifying namespace */
@@ -1680,7 +1681,7 @@ TclGetNamespaceForQualName(interp, qualName, cxtNsPtr, flags,
}
if ((*end == '\0')
- && !((len >= 2) && (*(end-1) == ':') && (*(end-2) == ':'))) {
+ && !((end-start >= 2) && (*(end-1) == ':') && (*(end-2) == ':'))) {
/*
* qualName ended with a simple name at start. If FIND_ONLY_NS
* was specified, look this up as a namespace. Otherwise,
@@ -2337,15 +2338,9 @@ Tcl_NamespaceObjCmd(clientData, interp, objc, objv)
* Return an index reflecting the particular subcommand.
*/
- result = Tcl_GetIndexFromObj((Tcl_Interp *) NULL, objv[1], subCmds,
- "subcommand", /*flags*/ 0, (int *) &index);
+ result = Tcl_GetIndexFromObj((Tcl_Interp *) interp, objv[1], subCmds,
+ "option", /*flags*/ 0, (int *) &index);
if (result != TCL_OK) {
- Tcl_ResetResult(interp);
- Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
- "bad namespace subcommand \"",
- Tcl_GetStringFromObj(objv[1], (int *) NULL),
- "\": should be children, code, current, delete, eval, export, forget, import, inscope, origin, parent, qualifiers, tail, or which",
- (char *) NULL);
return result;
}
@@ -2452,7 +2447,7 @@ NamespaceChildrenCmd(dummy, interp, objc, objv)
}
nsPtr = (Namespace *) namespacePtr;
} else {
- Tcl_WrongNumArgs(interp, 1, objv, "children ?name? ?pattern?");
+ Tcl_WrongNumArgs(interp, 2, objv, "?name? ?pattern?");
return TCL_ERROR;
}
@@ -2539,7 +2534,7 @@ NamespaceCodeCmd(dummy, interp, objc, objv)
int length;
if (objc != 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "code arg");
+ Tcl_WrongNumArgs(interp, 2, objv, "arg");
return TCL_ERROR;
}
@@ -2619,7 +2614,7 @@ NamespaceCurrentCmd(dummy, interp, objc, objv)
register Namespace *currNsPtr;
if (objc != 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "current");
+ Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
@@ -2685,7 +2680,7 @@ NamespaceDeleteCmd(dummy, interp, objc, objv)
register int i;
if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "delete ?name name...?");
+ Tcl_WrongNumArgs(interp, 2, objv, "?name name...?");
return TCL_ERROR;
}
@@ -2765,7 +2760,7 @@ NamespaceEvalCmd(dummy, interp, objc, objv)
int length, result;
if (objc < 4) {
- Tcl_WrongNumArgs(interp, 1, objv, "eval name arg ?arg...?");
+ Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?");
return TCL_ERROR;
}
@@ -2875,8 +2870,8 @@ NamespaceExportCmd(dummy, interp, objc, objv)
int firstArg, patternCt, i, result;
if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "export ?-clear? ?pattern pattern...?");
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "?-clear? ?pattern pattern...?");
return TCL_ERROR;
}
@@ -2970,7 +2965,7 @@ NamespaceForgetCmd(dummy, interp, objc, objv)
register int i, result;
if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv, "forget ?pattern pattern...?");
+ Tcl_WrongNumArgs(interp, 2, objv, "?pattern pattern...?");
return TCL_ERROR;
}
@@ -3034,8 +3029,8 @@ NamespaceImportCmd(dummy, interp, objc, objv)
int firstArg;
if (objc < 2) {
- Tcl_WrongNumArgs(interp, 1, objv,
- "import ?-force? ?pattern pattern...?");
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "?-force? ?pattern pattern...?");
return TCL_ERROR;
}
@@ -3117,7 +3112,7 @@ NamespaceInscopeCmd(dummy, interp, objc, objv)
int i, result;
if (objc < 4) {
- Tcl_WrongNumArgs(interp, 1, objv, "inscope name arg ?arg...?");
+ Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?");
return TCL_ERROR;
}
@@ -3233,7 +3228,7 @@ NamespaceOriginCmd(dummy, interp, objc, objv)
Tcl_Command command, origCommand;
if (objc != 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "origin name");
+ Tcl_WrongNumArgs(interp, 2, objv, "name");
return TCL_ERROR;
}
@@ -3306,7 +3301,7 @@ NamespaceParentCmd(dummy, interp, objc, objv)
return TCL_ERROR;
}
} else {
- Tcl_WrongNumArgs(interp, 1, objv, "parent ?name?");
+ Tcl_WrongNumArgs(interp, 2, objv, "?name?");
return TCL_ERROR;
}
@@ -3358,7 +3353,7 @@ NamespaceQualifiersCmd(dummy, interp, objc, objv)
int length;
if (objc != 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "qualifiers string");
+ Tcl_WrongNumArgs(interp, 2, objv, "string");
return TCL_ERROR;
}
@@ -3374,7 +3369,7 @@ NamespaceQualifiersCmd(dummy, interp, objc, objv)
while (--p >= name) {
if ((*p == ':') && (p > name) && (*(p-1) == ':')) {
p -= 2; /* back up over the :: */
- while ((*p == ':') && (p >= name)) {
+ while ((p >= name) && (*p == ':')) {
p--; /* back up over the preceeding : */
}
break;
@@ -3424,7 +3419,7 @@ NamespaceTailCmd(dummy, interp, objc, objv)
register char *name, *p;
if (objc != 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "tail string");
+ Tcl_WrongNumArgs(interp, 2, objv, "string");
return TCL_ERROR;
}
@@ -3438,7 +3433,7 @@ NamespaceTailCmd(dummy, interp, objc, objv)
/* empty body */
}
while (--p > name) {
- if ((*p == ':') && (p > name) && (*(p-1) == ':')) {
+ if ((*p == ':') && (*(p-1) == ':')) {
p++; /* just after the last "::" */
break;
}
@@ -3486,8 +3481,8 @@ NamespaceWhichCmd(dummy, interp, objc, objv)
if (objc < 3) {
badArgs:
- Tcl_WrongNumArgs(interp, 1, objv,
- "which ?-command? ?-variable? name");
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "?-command? ?-variable? name");
return TCL_ERROR;
}
diff --git a/contrib/tcl/generic/tclObj.c b/contrib/tcl/generic/tclObj.c
index 5d4afe589542..bc697f391f87 100644
--- a/contrib/tcl/generic/tclObj.c
+++ b/contrib/tcl/generic/tclObj.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclObj.c 1.44 97/06/20 15:19:32
+ * SCCS: @(#) tclObj.c 1.45 97/07/07 18:26:00
*/
#include "tclInt.h"
@@ -2019,3 +2019,123 @@ Tcl_GetLongFromObj(interp, objPtr, longPtr)
}
return result;
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DbIncrRefCount --
+ *
+ * This procedure is normally called when debugging: i.e., when
+ * TCL_MEM_DEBUG is defined. This checks to see whether or not
+ * the memory has been freed before incrementing the ref count.
+ *
+ * When TCL_MEM_DEBUG is not defined, this procedure just increments
+ * the reference count of the object.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The object's ref count is incremented.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_DbIncrRefCount(objPtr, file, line)
+ register Tcl_Obj *objPtr; /* The object we are adding a reference to. */
+ char *file; /* The name of the source file calling this
+ * procedure; used for debugging. */
+ int line; /* Line number in the source file; used
+ * for debugging. */
+{
+#ifdef TCL_MEM_DEBUG
+ if (objPtr->refCount == 0x61616161) {
+ fprintf(stderr, "file = %s, line = %d\n", file, line);
+ fflush(stderr);
+ panic("Trying to increment refCount of previously disposed object.");
+ }
+#endif
+ ++(objPtr)->refCount;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DbDecrRefCount --
+ *
+ * This procedure is normally called when debugging: i.e., when
+ * TCL_MEM_DEBUG is defined. This checks to see whether or not
+ * the memory has been freed before incrementing the ref count.
+ *
+ * When TCL_MEM_DEBUG is not defined, this procedure just increments
+ * the reference count of the object.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The object's ref count is incremented.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+Tcl_DbDecrRefCount(objPtr, file, line)
+ register Tcl_Obj *objPtr; /* The object we are adding a reference to. */
+ char *file; /* The name of the source file calling this
+ * procedure; used for debugging. */
+ int line; /* Line number in the source file; used
+ * for debugging. */
+{
+#ifdef TCL_MEM_DEBUG
+ if (objPtr->refCount == 0x61616161) {
+ fprintf(stderr, "file = %s, line = %d\n", file, line);
+ fflush(stderr);
+ panic("Trying to increment refCount of previously disposed object.");
+ }
+#endif
+ if (--(objPtr)->refCount <= 0) {
+ TclFreeObj(objPtr);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DbIsShared --
+ *
+ * This procedure is normally called when debugging: i.e., when
+ * TCL_MEM_DEBUG is defined. This checks to see whether or not
+ * the memory has been freed before incrementing the ref count.
+ *
+ * When TCL_MEM_DEBUG is not defined, this procedure just decrements
+ * the reference count of the object and throws it away if the count
+ * is 0 or less.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The object's ref count is incremented.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_DbIsShared(objPtr, file, line)
+ register Tcl_Obj *objPtr; /* The object we are adding a reference to. */
+ char *file; /* The name of the source file calling this
+ * procedure; used for debugging. */
+ int line; /* Line number in the source file; used
+ * for debugging. */
+{
+#ifdef TCL_MEM_DEBUG
+ if (objPtr->refCount == 0x61616161) {
+ fprintf(stderr, "file = %s, line = %d\n", file, line);
+ fflush(stderr);
+ panic("Trying to increment refCount of previously disposed object.");
+ }
+#endif
+ return ((objPtr)->refCount > 1);
+}
diff --git a/contrib/tcl/generic/tclParse.c b/contrib/tcl/generic/tclParse.c
index 57ba1e12c119..69a9e0026f54 100644
--- a/contrib/tcl/generic/tclParse.c
+++ b/contrib/tcl/generic/tclParse.c
@@ -6,12 +6,12 @@
* strings or nested sub-commands).
*
* Copyright (c) 1987-1993 The Regents of the University of California.
- * Copyright (c) 1994-1996 Sun Microsystems, Inc.
+ * Copyright (c) 1994-1997 Sun Microsystems, Inc.
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclParse.c 1.55 97/05/14 13:23:19
+ * SCCS: @(#) tclParse.c 1.56 97/07/29 18:40:03
*/
#include "tclInt.h"
@@ -902,3 +902,37 @@ Tcl_CommandComplete(cmd)
p = ScriptEnd(cmd, cmd+strlen(cmd), 0);
return (*p != 0);
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclObjCommandComplete --
+ *
+ * Given a partial or complete Tcl command in a Tcl object, this
+ * procedure determines whether the command is complete in the sense of
+ * having matched braces and quotes and brackets.
+ *
+ * Results:
+ * 1 is returned if the command is complete, 0 otherwise.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclObjCommandComplete(cmdPtr)
+ Tcl_Obj *cmdPtr; /* Points to object holding command
+ * to check. */
+{
+ char *cmd, *p;
+ int length;
+
+ cmd = Tcl_GetStringFromObj(cmdPtr, &length);
+ if (length == 0) {
+ return 1;
+ }
+ p = ScriptEnd(cmd, cmd+length, /*nested*/ 0);
+ return (*p != 0);
+}
diff --git a/contrib/tcl/generic/tclProc.c b/contrib/tcl/generic/tclProc.c
index 14238d9f5626..7cd94ec865e2 100644
--- a/contrib/tcl/generic/tclProc.c
+++ b/contrib/tcl/generic/tclProc.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclProc.c 1.113 97/06/23 15:51:52
+ * SCCS: @(#) tclProc.c 1.115 97/08/12 13:36:11
*/
#include "tclInt.h"
@@ -56,6 +56,7 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv)
char **argArray = NULL;
Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
Tcl_Obj *defPtr, *bodyPtr;
+ Tcl_Command cmd;
Tcl_DString ds;
int numArgs, length, result, i;
register CompiledLocal *localPtr;
@@ -120,8 +121,11 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv)
}
/*
- * We increment the ref count of the procedure's body object since
- * there will be a reference to it in the Proc structure.
+ * Create and initialize a Proc structure for the procedure. Note that
+ * we initialize its cmdPtr field below after we've created the command
+ * for the procedure. We increment the ref count of the procedure's
+ * body object since there will be a reference to it in the Proc
+ * structure.
*/
Tcl_IncrRefCount(bodyPtr);
@@ -129,7 +133,6 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv)
procPtr = (Proc *) ckalloc(sizeof(Proc));
procPtr->iPtr = iPtr;
procPtr->refCount = 1;
- procPtr->nsPtr = nsPtr;
procPtr->bodyPtr = bodyPtr;
procPtr->numArgs = 0; /* actual argument count is set below. */
procPtr->numCompiledLocals = 0;
@@ -243,10 +246,10 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv)
}
/*
- * Now create a command for the procedure. This will be in the current
- * namespace unless the procedure's name included namespace qualifiers.
- * To create the new command in the right namespace, we generate a
- * fully qualified name for it.
+ * Now create a command for the procedure. This will initially be in
+ * the current namespace unless the procedure's name included namespace
+ * qualifiers. To create the new command in the right namespace, we
+ * generate a fully qualified name for it.
*/
Tcl_DStringInit(&ds);
@@ -258,8 +261,18 @@ Tcl_ProcObjCmd(dummy, interp, objc, objv)
Tcl_CreateCommand(interp, Tcl_DStringValue(&ds), InterpProc,
(ClientData) procPtr, ProcDeleteProc);
- Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds), TclObjInterpProc,
- (ClientData) procPtr, ProcDeleteProc);
+ cmd = Tcl_CreateObjCommand(interp, Tcl_DStringValue(&ds),
+ TclObjInterpProc, (ClientData) procPtr, ProcDeleteProc);
+
+ /*
+ * Now initialize the new procedure's cmdPtr field. This will be used
+ * later when the procedure is called to determine what namespace the
+ * procedure will run in. This will be different than the current
+ * namespace if the proc was renamed into a different namespace.
+ */
+
+ procPtr->cmdPtr = (Command *) cmd;
+
ckfree((char *) argArray);
return TCL_OK;
@@ -744,11 +757,14 @@ TclObjInterpProc(clientData, interp, objc, objv)
/*
* Set up and push a new call frame for the new procedure invocation.
* This call frame will execute in the proc's namespace, which might
- * be different than the current namespace.
+ * be different than the current namespace. The proc's namespace is
+ * that of its command, which can change if the command is renamed
+ * from one namespace to another.
*/
result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr,
- (Tcl_Namespace *) procPtr->nsPtr, /*isProcCallFrame*/ 1);
+ (Tcl_Namespace *) procPtr->cmdPtr->nsPtr,
+ /*isProcCallFrame*/ 1);
if (result != TCL_OK) {
return result;
}
@@ -768,7 +784,7 @@ TclObjInterpProc(clientData, interp, objc, objv)
localPtr = localPtr->nextPtr) {
varPtr->value.objPtr = NULL;
varPtr->name = localPtr->name; /* will be just '\0' if temp var */
- varPtr->nsPtr = procPtr->nsPtr;
+ varPtr->nsPtr = procPtr->cmdPtr->nsPtr;
varPtr->hPtr = NULL;
varPtr->refCount = 0;
varPtr->tracePtr = NULL;
@@ -826,6 +842,7 @@ TclObjInterpProc(clientData, interp, objc, objv)
Tcl_IncrRefCount(objPtr); /* since the local variable now has
* another reference to object. */
} else {
+ Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"no value given for parameter \"", localPtr->name,
"\" to \"", Tcl_GetStringFromObj(objv[0], (int *) NULL),
diff --git a/contrib/tcl/generic/tclStringObj.c b/contrib/tcl/generic/tclStringObj.c
index e4218335dcf7..beed142d2e83 100644
--- a/contrib/tcl/generic/tclStringObj.c
+++ b/contrib/tcl/generic/tclStringObj.c
@@ -14,7 +14,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclStringObj.c 1.29 97/06/13 18:17:19
+ * SCCS: @(#) tclStringObj.c 1.30 97/07/24 18:53:30
*/
#include "tclInt.h"
@@ -98,7 +98,7 @@ Tcl_NewStringObj(bytes, length)
register Tcl_Obj *objPtr;
if (length < 0) {
- length = strlen(bytes);
+ length = bytes ? strlen(bytes) : 0 ;
}
TclNewObj(objPtr);
TclInitStringRep(objPtr, bytes, length);
diff --git a/contrib/tcl/generic/tclTest.c b/contrib/tcl/generic/tclTest.c
index 7ee313b9434b..ecc2abfdd429 100644
--- a/contrib/tcl/generic/tclTest.c
+++ b/contrib/tcl/generic/tclTest.c
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclTest.c 1.111 97/06/26 14:33:03
+ * SCCS: @(#) tclTest.c 1.115 97/08/13 10:27:26
*/
#define TCL_TEST
@@ -84,6 +84,10 @@ static int CmdProc1 _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, char **argv));
static int CmdProc2 _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, char **argv));
+static void CmdTraceProc _ANSI_ARGS_((ClientData clientData,
+ Tcl_Interp *interp, int level, char *command,
+ Tcl_CmdProc *cmdProc, ClientData cmdClientData,
+ int argc, char **argv));
static int CreatedCommandProc _ANSI_ARGS_((
ClientData clientData, Tcl_Interp *interp,
int argc, char **argv));
@@ -111,6 +115,8 @@ static int TestcmdinfoCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, char **argv));
static int TestcmdtokenCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, char **argv));
+static int TestcmdtraceCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int argc, char **argv));
static int TestchmodCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, char **argv));
static int TestcreatecommandCmd _ANSI_ARGS_((ClientData dummy,
@@ -127,6 +133,8 @@ static int TestexithandlerCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, char **argv));
static int TestexprlongCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, char **argv));
+static int TestexprstringCmd _ANSI_ARGS_((ClientData dummy,
+ Tcl_Interp *interp, int argc, char **argv));
static int TestfileCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, char **argv));
static int TestfeventCmd _ANSI_ARGS_((ClientData dummy,
@@ -225,6 +233,8 @@ Tcltest_Init(interp)
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testcmdinfo", TestcmdinfoCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateCommand(interp, "testcmdtrace", TestcmdtraceCmd,
+ (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testcreatecommand", TestcreatecommandCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testdcall", TestdcallCmd, (ClientData) 0,
@@ -240,6 +250,8 @@ Tcltest_Init(interp)
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testexprlong", TestexprlongCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+ Tcl_CreateCommand(interp, "testexprstring", TestexprstringCmd,
+ (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testfile", TestfileCmd,
(ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testgetassocdata", TestgetassocdataCmd,
@@ -626,6 +638,85 @@ TestcmdtokenCmd(dummy, interp, argc, argv)
/*
*----------------------------------------------------------------------
*
+ * TestcmdtraceCmd --
+ *
+ * This procedure implements the "testcmdtrace" command. It is used
+ * to test Tcl_CreateTrace and Tcl_DeleteTrace.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Creates and deletes a command trace, and tests the invocation of
+ * a procedure by the command trace.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+static int
+TestcmdtraceCmd(dummy, interp, argc, argv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int argc; /* Number of arguments. */
+ char **argv; /* Argument strings. */
+{
+ Tcl_Trace trace;
+ Tcl_DString buffer;
+ int result;
+
+ if (argc != 2) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " script\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ Tcl_DStringInit(&buffer);
+ trace = Tcl_CreateTrace(interp, 50000,
+ (Tcl_CmdTraceProc *) CmdTraceProc, (ClientData) &buffer);
+
+ result = Tcl_Eval(interp, argv[1]);
+ if (result == TCL_OK) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL);
+ }
+
+ Tcl_DeleteTrace(interp, trace);
+ Tcl_DStringFree(&buffer);
+ return TCL_OK;
+}
+
+static void
+CmdTraceProc(clientData, interp, level, command, cmdProc, cmdClientData,
+ argc, argv)
+ ClientData clientData; /* Pointer to buffer in which the
+ * command and arguments are appended.
+ * Accumulates test result. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int level; /* Current trace level. */
+ char *command; /* The command being traced (after
+ * substitutions). */
+ Tcl_CmdProc *cmdProc; /* Points to command's command procedure. */
+ ClientData cmdClientData; /* Client data associated with command
+ * procedure. */
+ int argc; /* Number of arguments. */
+ char **argv; /* Argument strings. */
+{
+ Tcl_DString *bufPtr = (Tcl_DString *) clientData;
+ int i;
+
+ Tcl_DStringAppendElement(bufPtr, command);
+
+ Tcl_DStringStartSublist(bufPtr);
+ for (i = 0; i < argc; i++) {
+ Tcl_DStringAppendElement(bufPtr, argv[i]);
+ }
+ Tcl_DStringEndSublist(bufPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TestcreatecommandCmd --
*
* This procedure implements the "testcreatecommand" command. It is
@@ -1133,6 +1224,37 @@ TestexprlongCmd(clientData, interp, argc, argv)
/*
*----------------------------------------------------------------------
*
+ * TestexprstringCmd --
+ *
+ * This procedure tests the basic operation of Tcl_ExprString.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestexprstringCmd(clientData, interp, argc, argv)
+ ClientData clientData; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int argc; /* Number of arguments. */
+ char **argv; /* Argument strings. */
+{
+ if (argc != 2) {
+ Tcl_AppendResult(interp, "wrong # arguments: should be \"", argv[0],
+ " expression\"", (char *) NULL);
+ return TCL_ERROR;
+ }
+ return Tcl_ExprString(interp, argv[1]);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TestgetassocdataCmd --
*
* This procedure implements the "testgetassocdata" command. It is
diff --git a/contrib/tcl/generic/tclTimer.c b/contrib/tcl/generic/tclTimer.c
index 2a91f65cecf5..7bb8e7d5f76f 100644
--- a/contrib/tcl/generic/tclTimer.c
+++ b/contrib/tcl/generic/tclTimer.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclTimer.c 1.6 97/05/20 11:08:02
+ * SCCS: @(#) tclTimer.c 1.9 97/07/29 16:21:53
*/
#include "tclInt.h"
@@ -692,7 +692,7 @@ TclServiceIdle()
/*
*----------------------------------------------------------------------
*
- * Tcl_AfterCmd --
+ * Tcl_AfterObjCmd --
*
* This procedure is invoked to process the "after" Tcl command.
* See the user documentation for details on what it does.
@@ -708,13 +708,13 @@ TclServiceIdle()
/* ARGSUSED */
int
-Tcl_AfterCmd(clientData, interp, argc, argv)
+Tcl_AfterObjCmd(clientData, interp, objc, objv)
ClientData clientData; /* Points to the "tclAfter" assocData for
* this interpreter, or NULL if the assocData
* hasn't been created yet.*/
Tcl_Interp *interp; /* Current interpreter. */
- int argc; /* Number of arguments. */
- char **argv; /* Argument strings. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
{
/*
* The variable below is used to generate unique identifiers for
@@ -731,11 +731,15 @@ Tcl_AfterCmd(clientData, interp, argc, argv)
AfterInfo *afterPtr;
AfterAssocData *assocPtr = (AfterAssocData *) clientData;
Tcl_CmdInfo cmdInfo;
- size_t length;
-
- if (argc < 2) {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], " option ?arg arg ...?\"", (char *) NULL);
+ int length;
+ char *arg;
+ int index, result;
+ static char *subCmds[] = {
+ "cancel", "idle", "info",
+ (char *) NULL};
+
+ if (objc < 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?");
return TCL_ERROR;
}
@@ -752,39 +756,44 @@ Tcl_AfterCmd(clientData, interp, argc, argv)
assocPtr->firstAfterPtr = NULL;
Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc,
(ClientData) assocPtr);
- cmdInfo.proc = Tcl_AfterCmd;
- cmdInfo.clientData = (ClientData) assocPtr;
- cmdInfo.objProc = NULL;
- cmdInfo.objClientData = (ClientData) NULL;
+ cmdInfo.proc = NULL;
+ cmdInfo.clientData = (ClientData) NULL;
+ cmdInfo.objProc = Tcl_AfterObjCmd;
+ cmdInfo.objClientData = (ClientData) assocPtr;
cmdInfo.deleteProc = NULL;
cmdInfo.deleteData = (ClientData) assocPtr;
- Tcl_SetCommandInfo(interp, argv[0], &cmdInfo);
+ Tcl_SetCommandInfo(interp, Tcl_GetStringFromObj(objv[0], &length),
+ &cmdInfo);
}
/*
- * Parse the command.
+ * First lets see if the command was passed a number as the first argument.
*/
-
- length = strlen(argv[1]);
- if (isdigit(UCHAR(argv[1][0]))) {
- if (Tcl_GetInt(interp, argv[1], &ms) != TCL_OK) {
+
+ arg = Tcl_GetStringFromObj(objv[1], &length);
+ if (isdigit(UCHAR(arg[0]))) {
+ if (Tcl_GetIntFromObj(interp, objv[1], &ms) != TCL_OK) {
return TCL_ERROR;
}
if (ms < 0) {
ms = 0;
}
- if (argc == 2) {
+ if (objc == 2) {
Tcl_Sleep(ms);
return TCL_OK;
}
afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo)));
afterPtr->assocPtr = assocPtr;
- if (argc == 3) {
- afterPtr->command = (char *) ckalloc((unsigned)
- (strlen(argv[2]) + 1));
- strcpy(afterPtr->command, argv[2]);
+ if (objc == 3) {
+ arg = Tcl_GetStringFromObj(objv[2], &length);
+ afterPtr->command = (char *) ckalloc((unsigned) (length + 1));
+ strcpy(afterPtr->command, arg);
} else {
- afterPtr->command = Tcl_Concat(argc-2, argv+2);
+ Tcl_Obj *objPtr = Tcl_ConcatObj(objc-2, objv+2);
+ arg = Tcl_GetStringFromObj(objPtr, &length);
+ afterPtr->command = (char *) ckalloc((unsigned) (length + 1));
+ strcpy(afterPtr->command, arg);
+ Tcl_DecrRefCount(objPtr);
}
afterPtr->id = nextId;
nextId += 1;
@@ -793,95 +802,113 @@ Tcl_AfterCmd(clientData, interp, argc, argv)
afterPtr->nextPtr = assocPtr->firstAfterPtr;
assocPtr->firstAfterPtr = afterPtr;
sprintf(interp->result, "after#%d", afterPtr->id);
- } else if (strncmp(argv[1], "cancel", length) == 0) {
- char *arg;
+ return TCL_OK;
+ }
- if (argc < 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], " cancel id|command\"", (char *) NULL);
- return TCL_ERROR;
- }
- if (argc == 3) {
- arg = argv[2];
- } else {
- arg = Tcl_Concat(argc-2, argv+2);
- }
- for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
- afterPtr = afterPtr->nextPtr) {
- if (strcmp(afterPtr->command, arg) == 0) {
+ /*
+ * If it's not a number it must be a subcommand.
+ */
+ result = Tcl_GetIndexFromObj(NULL, objv[1], subCmds, "option",
+ 0, (int *) &index);
+ if (result != TCL_OK) {
+ Tcl_AppendResult(interp, "bad argument \"", arg,
+ "\": must be cancel, idle, info, or a number",
+ (char *) NULL);
+ return TCL_ERROR;
+ }
+
+ switch (index) {
+ case 0: /* cancel */
+ {
+ char *arg;
+ Tcl_Obj *objPtr = NULL;
+
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "id|command");
+ return TCL_ERROR;
+ }
+ if (objc == 3) {
+ arg = Tcl_GetStringFromObj(objv[2], &length);
+ } else {
+ objPtr = Tcl_ConcatObj(objc-2, objv+2);;
+ arg = Tcl_GetStringFromObj(objPtr, &length);
+ }
+ for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
+ afterPtr = afterPtr->nextPtr) {
+ if (strcmp(afterPtr->command, arg) == 0) {
+ break;
+ }
+ }
+ if (afterPtr == NULL) {
+ afterPtr = GetAfterEvent(assocPtr, arg);
+ }
+ if (objPtr != NULL) {
+ Tcl_DecrRefCount(objPtr);
+ }
+ if (afterPtr != NULL) {
+ if (afterPtr->token != NULL) {
+ Tcl_DeleteTimerHandler(afterPtr->token);
+ } else {
+ Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr);
+ }
+ FreeAfterPtr(afterPtr);
+ }
break;
}
- }
- if (afterPtr == NULL) {
- afterPtr = GetAfterEvent(assocPtr, arg);
- }
- if (arg != argv[2]) {
- ckfree(arg);
- }
- if (afterPtr != NULL) {
- if (afterPtr->token != NULL) {
- Tcl_DeleteTimerHandler(afterPtr->token);
+ case 1: /* idle */
+ if (objc < 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "script script ...");
+ return TCL_ERROR;
+ }
+ afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo)));
+ afterPtr->assocPtr = assocPtr;
+ if (objc == 3) {
+ arg = Tcl_GetStringFromObj(objv[2], &length);
+ afterPtr->command = (char *) ckalloc((unsigned) length + 1);
+ strcpy(afterPtr->command, arg);
} else {
- Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr);
+ Tcl_Obj *objPtr = Tcl_ConcatObj(objc-2, objv+2);;
+ arg = Tcl_GetStringFromObj(objPtr, &length);
+ afterPtr->command = (char *) ckalloc((unsigned) (length + 1));
+ strcpy(afterPtr->command, arg);
+ Tcl_DecrRefCount(objPtr);
}
- FreeAfterPtr(afterPtr);
- }
- } else if ((strncmp(argv[1], "idle", length) == 0)
- && (length >= 2)) {
- if (argc < 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], " idle script script ...\"", (char *) NULL);
- return TCL_ERROR;
- }
- afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo)));
- afterPtr->assocPtr = assocPtr;
- if (argc == 3) {
- afterPtr->command = (char *) ckalloc((unsigned)
- (strlen(argv[2]) + 1));
- strcpy(afterPtr->command, argv[2]);
- } else {
- afterPtr->command = Tcl_Concat(argc-2, argv+2);
- }
- afterPtr->id = nextId;
- nextId += 1;
- afterPtr->token = NULL;
- afterPtr->nextPtr = assocPtr->firstAfterPtr;
- assocPtr->firstAfterPtr = afterPtr;
- Tcl_DoWhenIdle(AfterProc, (ClientData) afterPtr);
- sprintf(interp->result, "after#%d", afterPtr->id);
- } else if ((strncmp(argv[1], "info", length) == 0)
- && (length >= 2)) {
- if (argc == 2) {
- char buffer[30];
+ afterPtr->id = nextId;
+ nextId += 1;
+ afterPtr->token = NULL;
+ afterPtr->nextPtr = assocPtr->firstAfterPtr;
+ assocPtr->firstAfterPtr = afterPtr;
+ Tcl_DoWhenIdle(AfterProc, (ClientData) afterPtr);
+ sprintf(interp->result, "after#%d", afterPtr->id);
+ break;
+ case 2: /* info */
+ if (objc == 2) {
+ char buffer[30];
- for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
- afterPtr = afterPtr->nextPtr) {
- if (assocPtr->interp == interp) {
- sprintf(buffer, "after#%d", afterPtr->id);
- Tcl_AppendElement(interp, buffer);
+ for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
+ afterPtr = afterPtr->nextPtr) {
+ if (assocPtr->interp == interp) {
+ sprintf(buffer, "after#%d", afterPtr->id);
+ Tcl_AppendElement(interp, buffer);
+ }
}
+ return TCL_OK;
}
- return TCL_OK;
- }
- if (argc != 3) {
- Tcl_AppendResult(interp, "wrong # args: should be \"",
- argv[0], " info ?id?\"", (char *) NULL);
- return TCL_ERROR;
- }
- afterPtr = GetAfterEvent(assocPtr, argv[2]);
- if (afterPtr == NULL) {
- Tcl_AppendResult(interp, "event \"", argv[2],
- "\" doesn't exist", (char *) NULL);
- return TCL_ERROR;
- }
- Tcl_AppendElement(interp, afterPtr->command);
- Tcl_AppendElement(interp,
- (afterPtr->token == NULL) ? "idle" : "timer");
- } else {
- Tcl_AppendResult(interp, "bad argument \"", argv[1],
- "\": must be cancel, idle, info, or a number",
- (char *) NULL);
- return TCL_ERROR;
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "?id?");
+ return TCL_ERROR;
+ }
+ arg = Tcl_GetStringFromObj(objv[2], &length);
+ afterPtr = GetAfterEvent(assocPtr, arg);
+ if (afterPtr == NULL) {
+ Tcl_AppendResult(interp, "event \"", arg,
+ "\" doesn't exist", (char *) NULL);
+ return TCL_ERROR;
+ }
+ Tcl_AppendElement(interp, afterPtr->command);
+ Tcl_AppendElement(interp,
+ (afterPtr->token == NULL) ? "idle" : "timer");
+ break;
}
return TCL_OK;
}
diff --git a/contrib/tcl/generic/tclUtil.c b/contrib/tcl/generic/tclUtil.c
index 2eca40cccf9c..e43482f8b452 100644
--- a/contrib/tcl/generic/tclUtil.c
+++ b/contrib/tcl/generic/tclUtil.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclUtil.c 1.154 97/06/26 13:49:14
+ * SCCS: @(#) tclUtil.c 1.161 97/08/12 17:07:18
*/
#include "tclInt.h"
@@ -38,6 +38,23 @@
#define BRACES_UNMATCHED 4
/*
+ * The following values determine the precision used when converting
+ * floating-point values to strings. This information is linked to all
+ * of the tcl_precision variables in all interpreters via the procedure
+ * TclPrecTraceProc.
+ *
+ * NOTE: these variables are not thread-safe.
+ */
+
+static char precisionString[10] = "12";
+ /* The string value of all the tcl_precision
+ * variables. */
+static char precisionFormat[10] = "%.12g";
+ /* The format string actually used in calls
+ * to sprintf. */
+
+
+/*
* Function prototypes for local procedures in this file:
*/
@@ -99,7 +116,7 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr,
* to indicate that arg was/wasn't
* in braces. */
{
- register char *p = list;
+ char *p = list;
char *elemStart; /* Points to first byte of first element. */
char *limit; /* Points just after list's last byte. */
int openBraces = 0; /* Brace nesting level during parse. */
@@ -313,10 +330,10 @@ TclFindElement(interp, list, listLength, elementPtr, nextPtr, sizePtr,
int
TclCopyAndCollapse(count, src, dst)
int count; /* Number of characters to copy from src. */
- register char *src; /* Copy from here... */
- register char *dst; /* ... to here. */
+ char *src; /* Copy from here... */
+ char *dst; /* ... to here. */
{
- register char c;
+ char c;
int numRead;
int newCount = 0;
@@ -378,7 +395,7 @@ Tcl_SplitList(interp, list, argcPtr, argvPtr)
* array of pointers to list elements. */
{
char **argv;
- register char *p;
+ char *p;
int length, size, i, result, elSize, brace;
char *element;
@@ -422,7 +439,7 @@ Tcl_SplitList(interp, list, argcPtr, argvPtr)
}
argv[i] = p;
if (brace) {
- (void) strncpy(p, element, (size_t) elSize);
+ memcpy((VOID *) p, (VOID *) element, (size_t) elSize);
p += elSize;
*p = 0;
p++;
@@ -463,7 +480,7 @@ Tcl_SplitList(interp, list, argcPtr, argvPtr)
int
Tcl_ScanElement(string, flagPtr)
- char *string; /* String to convert to Tcl list element. */
+ CONST char *string; /* String to convert to Tcl list element. */
int *flagPtr; /* Where to store information to guide
* Tcl_ConvertCountedElement. */
{
@@ -497,14 +514,13 @@ Tcl_ScanElement(string, flagPtr)
int
Tcl_ScanCountedElement(string, length, flagPtr)
- char *string; /* String to convert to Tcl list element. */
+ CONST char *string; /* String to convert to Tcl list element. */
int length; /* Number of bytes in string, or -1. */
int *flagPtr; /* Where to store information to guide
* Tcl_ConvertElement. */
{
int flags, nestingLevel;
- register char *p;
- char *lastChar;
+ CONST char *p, *lastChar;
/*
* This procedure and Tcl_ConvertElement together do two things:
@@ -632,7 +648,7 @@ Tcl_ScanCountedElement(string, length, flagPtr)
int
Tcl_ConvertElement(src, dst, flags)
- register char *src; /* Source information for list element. */
+ CONST char *src; /* Source information for list element. */
char *dst; /* Place to put list-ified element. */
int flags; /* Flags produced by Tcl_ScanElement. */
{
@@ -664,13 +680,13 @@ Tcl_ConvertElement(src, dst, flags)
int
Tcl_ConvertCountedElement(src, length, dst, flags)
- register char *src; /* Source information for list element. */
+ CONST char *src; /* Source information for list element. */
int length; /* Number of bytes in src, or -1. */
char *dst; /* Place to put list-ified element. */
int flags; /* Flags produced by Tcl_ScanElement. */
{
- register char *p = dst;
- char *lastChar;
+ char *p = dst;
+ CONST char *lastChar;
/*
* See the comment block at the beginning of the Tcl_ScanElement
@@ -807,7 +823,7 @@ Tcl_Merge(argc, argv)
int localFlags[LOCAL_SIZE], *flagPtr;
int numChars;
char *result;
- register char *dst;
+ char *dst;
int i;
/*
@@ -873,7 +889,7 @@ Tcl_Concat(argc, argv)
char **argv; /* Array of strings to concatenate. */
{
int totalSize, i;
- register char *p;
+ char *p;
char *result;
for (totalSize = 1, i = 0; i < argc; i++) {
@@ -899,14 +915,15 @@ Tcl_Concat(argc, argv)
element++;
}
for (length = strlen(element);
- (length > 0) && (isspace(UCHAR(element[length-1])));
+ (length > 0) && (isspace(UCHAR(element[length-1])))
+ && ((length < 2) || (element[length-2] != '\\'));
length--) {
/* Null loop body. */
}
if (length == 0) {
continue;
}
- (void) strncpy(p, element, (size_t) length);
+ memcpy((VOID *) p, (VOID *) element, (size_t) length);
p += length;
*p = ' ';
p++;
@@ -943,10 +960,10 @@ Tcl_ConcatObj(objc, objv)
Tcl_Obj *CONST objv[]; /* Array of objects to concatenate. */
{
int allocSize, finalSize, length, elemLength, i;
- register char *p;
- register char *element;
+ char *p;
+ char *element;
char *concatStr;
- register Tcl_Obj *objPtr;
+ Tcl_Obj *objPtr;
allocSize = 0;
for (i = 0; i < objc; i++) {
@@ -986,8 +1003,16 @@ Tcl_ConcatObj(objc, objv)
element++;
elemLength--;
}
+
+ /*
+ * Trim trailing white space. But, be careful not to trim
+ * a space character if it is preceded by a backslash: in
+ * this case it could be significant.
+ */
+
while ((elemLength > 0)
- && isspace(UCHAR(element[elemLength-1]))) {
+ && isspace(UCHAR(element[elemLength-1]))
+ && ((elemLength < 2) || (element[elemLength-2] != '\\'))) {
elemLength--;
}
if (elemLength == 0) {
@@ -1034,9 +1059,9 @@ Tcl_ConcatObj(objc, objv)
int
Tcl_StringMatch(string, pattern)
- register char *string; /* String. */
- register char *pattern; /* Pattern, which may contain
- * special characters. */
+ char *string; /* String. */
+ char *pattern; /* Pattern, which may contain special
+ * characters. */
{
char c2;
@@ -1171,13 +1196,13 @@ void
Tcl_SetResult(interp, string, freeProc)
Tcl_Interp *interp; /* Interpreter with which to associate the
* return value. */
- register char *string; /* Value to be returned. If NULL,
- * the result is set to an empty string. */
+ char *string; /* Value to be returned. If NULL, the
+ * result is set to an empty string. */
Tcl_FreeProc *freeProc; /* Gives information about the string:
* TCL_STATIC, TCL_VOLATILE, or the address
* of a Tcl_FreeProc such as free. */
{
- register Interp *iPtr = (Interp *) interp;
+ Interp *iPtr = (Interp *) interp;
int length;
Tcl_FreeProc *oldFreeProc = iPtr->freeProc;
char *oldResult = iPtr->result;
@@ -1242,7 +1267,7 @@ Tcl_SetResult(interp, string, freeProc)
char *
Tcl_GetStringResult(interp)
- register Tcl_Interp *interp; /* Interpreter whose result to return. */
+ Tcl_Interp *interp; /* Interpreter whose result to return. */
{
/*
* If the string result is empty, move the object result to the
@@ -1282,12 +1307,12 @@ void
Tcl_SetObjResult(interp, objPtr)
Tcl_Interp *interp; /* Interpreter with which to associate the
* return object value. */
- register Tcl_Obj *objPtr; /* Tcl object to be returned. If NULL, the
+ Tcl_Obj *objPtr; /* Tcl object to be returned. If NULL, the
* obj result is made an empty string
* object. */
{
- register Interp *iPtr = (Interp *) interp;
- register Tcl_Obj *oldObjResult = iPtr->objResultPtr;
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Obj *oldObjResult = iPtr->objResultPtr;
iPtr->objResultPtr = objPtr;
Tcl_IncrRefCount(objPtr); /* since interp result is a reference */
@@ -1341,9 +1366,9 @@ Tcl_Obj *
Tcl_GetObjResult(interp)
Tcl_Interp *interp; /* Interpreter whose result to return. */
{
- register Interp *iPtr = (Interp *) interp;
- register Tcl_Obj *objResultPtr;
- register int length;
+ Interp *iPtr = (Interp *) interp;
+ Tcl_Obj *objResultPtr;
+ int length;
/*
* If the string result is non-empty, move the string result to the
@@ -1398,8 +1423,8 @@ void
Tcl_AppendResult TCL_VARARGS_DEF(Tcl_Interp *,arg1)
{
va_list argList;
- register Interp *iPtr;
- register char *string;
+ Interp *iPtr;
+ char *string;
int newSpace;
/*
@@ -1488,9 +1513,9 @@ Tcl_AppendElement(interp, string)
char *string; /* String to convert to list element and
* add to result. */
{
- register Interp *iPtr = (Interp *) interp;
+ Interp *iPtr = (Interp *) interp;
char *dst;
- register int size;
+ int size;
int flags;
/*
@@ -1552,7 +1577,7 @@ Tcl_AppendElement(interp, string)
static void
SetupAppendBuffer(iPtr, newSpace)
- register Interp *iPtr; /* Interpreter whose result is being set up. */
+ Interp *iPtr; /* Interpreter whose result is being set up. */
int newSpace; /* Make sure that at least this many bytes
* of new information may be added. */
{
@@ -1635,9 +1660,9 @@ SetupAppendBuffer(iPtr, newSpace)
void
Tcl_FreeResult(interp)
- register Tcl_Interp *interp; /* Interpreter for which to free result. */
+ Tcl_Interp *interp; /* Interpreter for which to free result. */
{
- register Interp *iPtr = (Interp *) interp;
+ Interp *iPtr = (Interp *) interp;
if (iPtr->freeProc != NULL) {
if ((iPtr->freeProc == TCL_DYNAMIC)
@@ -1676,7 +1701,7 @@ void
Tcl_ResetResult(interp)
Tcl_Interp *interp; /* Interpreter for which to clear result. */
{
- register Interp *iPtr = (Interp *) interp;
+ Interp *iPtr = (Interp *) interp;
TclResetObjResult(iPtr);
@@ -1805,7 +1830,7 @@ Tcl_RegExpCompile(interp, string)
char *string; /* String for which to produce
* compiled regular expression. */
{
- register Interp *iPtr = (Interp *) interp;
+ Interp *iPtr = (Interp *) interp;
int i, length;
regexp *result;
@@ -2009,8 +2034,7 @@ Tcl_RegExpMatch(interp, string, pattern)
void
Tcl_DStringInit(dsPtr)
- register Tcl_DString *dsPtr; /* Pointer to structure for
- * dynamic string. */
+ Tcl_DString *dsPtr; /* Pointer to structure for dynamic string. */
{
dsPtr->string = dsPtr->staticSpace;
dsPtr->length = 0;
@@ -2038,17 +2062,16 @@ Tcl_DStringInit(dsPtr)
char *
Tcl_DStringAppend(dsPtr, string, length)
- register Tcl_DString *dsPtr; /* Structure describing dynamic
- * string. */
- char *string; /* String to append. If length is
- * -1 then this must be
- * null-terminated. */
- int length; /* Number of characters from string
- * to append. If < 0, then append all
- * of string, up to null at end. */
+ Tcl_DString *dsPtr; /* Structure describing dynamic string. */
+ CONST char *string; /* String to append. If length is -1 then
+ * this must be null-terminated. */
+ int length; /* Number of characters from string to
+ * append. If < 0, then append all of string,
+ * up to null at end. */
{
int newSize;
- char *newString, *dst, *end;
+ char *newString, *dst;
+ CONST char *end;
if (length < 0) {
length = strlen(string);
@@ -2081,7 +2104,7 @@ Tcl_DStringAppend(dsPtr, string, length)
string < end; string++, dst++) {
*dst = *string;
}
- *dst = 0;
+ *dst = '\0';
dsPtr->length += length;
return dsPtr->string;
}
@@ -2106,10 +2129,9 @@ Tcl_DStringAppend(dsPtr, string, length)
char *
Tcl_DStringAppendElement(dsPtr, string)
- register Tcl_DString *dsPtr; /* Structure describing dynamic
- * string. */
- char *string; /* String to append. Must be
- * null-terminated. */
+ Tcl_DString *dsPtr; /* Structure describing dynamic string. */
+ CONST char *string; /* String to append. Must be
+ * null-terminated. */
{
int newSize, flags;
char *dst, *newString;
@@ -2173,9 +2195,8 @@ Tcl_DStringAppendElement(dsPtr, string)
void
Tcl_DStringSetLength(dsPtr, length)
- register Tcl_DString *dsPtr; /* Structure describing dynamic
- * string. */
- int length; /* New length for dynamic string. */
+ Tcl_DString *dsPtr; /* Structure describing dynamic string. */
+ int length; /* New length for dynamic string. */
{
if (length < 0) {
length = 0;
@@ -2223,8 +2244,7 @@ Tcl_DStringSetLength(dsPtr, length)
void
Tcl_DStringFree(dsPtr)
- register Tcl_DString *dsPtr; /* Structure describing dynamic
- * string. */
+ Tcl_DString *dsPtr; /* Structure describing dynamic string. */
{
if (dsPtr->string != dsPtr->staticSpace) {
ckfree(dsPtr->string);
@@ -2257,10 +2277,9 @@ Tcl_DStringFree(dsPtr)
void
Tcl_DStringResult(interp, dsPtr)
- Tcl_Interp *interp; /* Interpreter whose result is to be
- * reset. */
- register Tcl_DString *dsPtr; /* Dynamic string that is to become
- * the result of interp. */
+ Tcl_Interp *interp; /* Interpreter whose result is to be reset. */
+ Tcl_DString *dsPtr; /* Dynamic string that is to become the
+ * result of interp. */
{
Tcl_ResetResult(interp);
@@ -2302,12 +2321,11 @@ Tcl_DStringResult(interp, dsPtr)
void
Tcl_DStringGetResult(interp, dsPtr)
- Tcl_Interp *interp; /* Interpreter whose result is to be
- * reset. */
- register Tcl_DString *dsPtr; /* Dynamic string that is to become the
- * result of interp. */
+ Tcl_Interp *interp; /* Interpreter whose result is to be reset. */
+ Tcl_DString *dsPtr; /* Dynamic string that is to become the
+ * result of interp. */
{
- register Interp *iPtr = (Interp *) interp;
+ Interp *iPtr = (Interp *) interp;
if (dsPtr->string != dsPtr->staticSpace) {
ckfree(dsPtr->string);
@@ -2438,9 +2456,9 @@ Tcl_PrintDouble(interp, value, dst)
* must have at least TCL_DOUBLE_SPACE
* characters. */
{
- register char *p;
+ char *p;
- sprintf(dst, "%.17g", value);
+ sprintf(dst, precisionFormat, value);
/*
* If the ASCII result looks like an integer, add ".0" so that it
@@ -2461,6 +2479,92 @@ Tcl_PrintDouble(interp, value, dst)
/*
*----------------------------------------------------------------------
*
+ * TclPrecTraceProc --
+ *
+ * This procedure is invoked whenever the variable "tcl_precision"
+ * is written.
+ *
+ * Results:
+ * Returns NULL if all went well, or an error message if the
+ * new value for the variable doesn't make sense.
+ *
+ * Side effects:
+ * If the new value doesn't make sense then this procedure
+ * undoes the effect of the variable modification. Otherwise
+ * it modifies the format string that's used by Tcl_PrintDouble.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+char *
+TclPrecTraceProc(clientData, interp, name1, name2, flags)
+ ClientData clientData; /* Not used. */
+ Tcl_Interp *interp; /* Interpreter containing variable. */
+ char *name1; /* Name of variable. */
+ char *name2; /* Second part of variable name. */
+ int flags; /* Information about what happened. */
+{
+ char *value, *end;
+ int prec;
+
+ /*
+ * If the variable is unset, then recreate the trace.
+ */
+
+ if (flags & TCL_TRACE_UNSETS) {
+ if ((flags & TCL_TRACE_DESTROYED) && !(flags & TCL_INTERP_DESTROYED)) {
+ Tcl_TraceVar2(interp, name1, name2,
+ TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES
+ |TCL_TRACE_UNSETS, TclPrecTraceProc, clientData);
+ }
+ return (char *) NULL;
+ }
+
+ /*
+ * When the variable is read, reset its value from our shared
+ * value. This is needed in case the variable was modified in
+ * some other interpreter so that this interpreter's value is
+ * out of date.
+ */
+
+ if (flags & TCL_TRACE_READS) {
+ Tcl_SetVar2(interp, name1, name2, precisionString,
+ flags & TCL_GLOBAL_ONLY);
+ return (char *) NULL;
+ }
+
+ /*
+ * The variable is being written. Check the new value and disallow
+ * it if it isn't reasonable or if this is a safe interpreter (we
+ * don't want safe interpreters messing up the precision of other
+ * interpreters).
+ */
+
+ if (Tcl_IsSafe(interp)) {
+ Tcl_SetVar2(interp, name1, name2, precisionString,
+ flags & TCL_GLOBAL_ONLY);
+ return "can't modify precision from a safe interpreter";
+ }
+ value = Tcl_GetVar2(interp, name1, name2, flags & TCL_GLOBAL_ONLY);
+ if (value == NULL) {
+ value = "";
+ }
+ prec = strtoul(value, &end, 10);
+ if ((prec <= 0) || (prec > TCL_MAX_PREC) || (prec > 100) ||
+ (end == value) || (*end != 0)) {
+ Tcl_SetVar2(interp, name1, name2, precisionString,
+ flags & TCL_GLOBAL_ONLY);
+ return "improper value for precision";
+ }
+ TclFormatInt(precisionString, prec);
+ sprintf(precisionFormat, "%%.%dg", prec);
+ return (char *) NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclNeedSpace --
*
* This procedure checks to see whether it is appropriate to
@@ -2539,12 +2643,12 @@ TclNeedSpace(start, end)
int
TclFormatInt(buffer, n)
- register char *buffer; /* Points to the storage into which the
+ char *buffer; /* Points to the storage into which the
* formatted characters are written. */
long n; /* The integer to format. */
{
- register long intVal;
- register int i;
+ long intVal;
+ int i;
int numFormatted, j;
char *digits = "0123456789";
@@ -2612,7 +2716,7 @@ TclFormatInt(buffer, n)
int
TclLooksLikeInt(p)
- register char *p; /* Pointer to string. */
+ char *p; /* Pointer to string. */
{
while (isspace(UCHAR(*p))) {
p++;
@@ -2636,54 +2740,6 @@ TclLooksLikeInt(p)
/*
*----------------------------------------------------------------------
*
- * Tcl_WrongNumArgs --
- *
- * This procedure generates a "wrong # args" error message in an
- * interpreter. It is used as a utility function by many command
- * procedures.
- *
- * Results:
- * None.
- *
- * Side effects:
- * An error message is generated in interp's result object to
- * indicate that a command was invoked with the wrong number of
- * arguments. The message has the form
- * wrong # args: should be "foo bar additional stuff"
- * where "foo" and "bar" are the initial objects in objv (objc
- * determines how many of these are printed) and "additional stuff"
- * is the contents of the message argument.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_WrongNumArgs(interp, objc, objv, message)
- Tcl_Interp *interp; /* Current interpreter. */
- int objc; /* Number of arguments to print
- * from objv. */
- Tcl_Obj *CONST objv[]; /* Initial argument objects, which
- * should be included in the error
- * message. */
- char *message; /* Error message to print after the
- * leading objects in objv. */
-{
- Tcl_Obj *objPtr;
- int i;
-
- objPtr = Tcl_GetObjResult(interp);
- Tcl_AppendToObj(objPtr, "wrong # args: should be \"", -1);
- for (i = 0; i < objc; i++) {
- Tcl_AppendStringsToObj(objPtr,
- Tcl_GetStringFromObj(objv[i], (int *) NULL), " ",
- (char *) NULL);
- }
- Tcl_AppendStringsToObj(objPtr, message, "\"", (char *) NULL);
-}
-
-/*
- *----------------------------------------------------------------------
- *
* TclGetIntForIndex --
*
* This procedure returns an integer corresponding to the list index
@@ -2711,15 +2767,15 @@ TclGetIntForIndex(interp, objPtr, endValue, indexPtr)
Tcl_Interp *interp; /* Interpreter to use for error reporting.
* If NULL, then no error message is left
* after errors. */
- register Tcl_Obj *objPtr; /* Points to an object containing either
+ Tcl_Obj *objPtr; /* Points to an object containing either
* "end" or an integer. */
int endValue; /* The value to be stored at "indexPtr" if
* "objPtr" holds "end". */
- register int *indexPtr; /* Location filled in with an integer
+ int *indexPtr; /* Location filled in with an integer
* representing an index. */
{
Interp *iPtr = (Interp *) interp;
- register char *bytes;
+ char *bytes;
int index, length, result;
/*
diff --git a/contrib/tcl/generic/tclVar.c b/contrib/tcl/generic/tclVar.c
index 577ba74716d6..587eca9dd70e 100644
--- a/contrib/tcl/generic/tclVar.c
+++ b/contrib/tcl/generic/tclVar.c
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * SCCS: @(#) tclVar.c 1.113 97/06/25 08:54:16
+ * SCCS: @(#) tclVar.c 1.125 97/08/06 14:47:55
*/
#include "tclInt.h"
@@ -782,6 +782,7 @@ TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg)
* that we return. Initialized to avoid
* compiler warning. */
char *elem, *msg;
+ int new;
#ifdef TCL_COMPILE_DEBUG
Proc *procPtr = varFramePtr->procPtr;
@@ -833,23 +834,34 @@ TclGetElementOfIndexedArray(interp, localIndex, elemPtr, leaveErrorMsg)
}
/*
- * Look up the element.
+ * Look up the element. Note that we must create the element (but leave
+ * it marked undefined) if it does not already exist. This allows a
+ * trace to create new array elements "on the fly" that did not exist
+ * before. A trace is always passed a variable for the array element. If
+ * the trace does not define the variable, it will be deleted below (at
+ * errorReturn) and an error returned.
*/
- hPtr = Tcl_FindHashEntry(arrayPtr->value.tablePtr, elem);
- if (hPtr == NULL) {
- if (leaveErrorMsg) {
- VarErrMsg(interp, arrayName, elem, "read", noSuchElement);
+ hPtr = Tcl_CreateHashEntry(arrayPtr->value.tablePtr, elem, &new);
+ if (new) {
+ if (arrayPtr->searchPtr != NULL) {
+ DeleteSearches(arrayPtr);
}
- goto errorReturn;
+ varPtr = NewVar();
+ Tcl_SetHashValue(hPtr, varPtr);
+ varPtr->hPtr = hPtr;
+ varPtr->nsPtr = varFramePtr->nsPtr;
+ TclSetVarArrayElement(varPtr);
+ } else {
+ varPtr = (Var *) Tcl_GetHashValue(hPtr);
}
- varPtr = (Var *) Tcl_GetHashValue(hPtr);
/*
* Invoke any traces that have been set for the element variable.
*/
- if (varPtr->tracePtr != NULL) {
+ if ((varPtr->tracePtr != NULL)
+ || ((arrayPtr != NULL) && (arrayPtr->tracePtr != NULL))) {
msg = CallTraces(iPtr, arrayPtr, varPtr, arrayName, elem,
TCL_TRACE_READS);
if (msg != NULL) {
@@ -1034,12 +1046,12 @@ Tcl_SetVar2(interp, part1, part2, newValue, flags)
* Tcl_ObjSetVar2 to actually set the variable.
*/
- length = strlen(newValue);
+ length = newValue ? strlen(newValue) : 0;
TclNewObj(valuePtr);
TclInitStringRep(valuePtr, newValue, length);
Tcl_IncrRefCount(valuePtr);
- length = strlen(part1);
+ length = strlen(part1) ;
TclNewObj(part1Ptr);
TclInitStringRep(part1Ptr, part1, length);
Tcl_IncrRefCount(part1Ptr);
@@ -2119,6 +2131,22 @@ Tcl_UnsetVar2(interp, part1, part2, flags)
TclDecrRefCount(objPtr);
dummyVarPtr->value.objPtr = NULL;
}
+
+ /*
+ * If the variable was a namespace variable, decrement its reference
+ * count. We are in the process of destroying its namespace so that
+ * namespace will no longer "refer" to the variable.
+ */
+
+ if (varPtr->flags & VAR_NAMESPACE_VAR) {
+ varPtr->flags &= ~VAR_NAMESPACE_VAR;
+ varPtr->refCount--;
+ }
+
+ /*
+ * It's an error to unset an undefined variable.
+ */
+
if (result != TCL_OK) {
if (flags & TCL_LEAVE_ERR_MSG) {
VarErrMsg(interp, part1, part2, "unset",
@@ -2751,26 +2779,35 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv)
int objc; /* Number of arguments. */
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
+ static char *arrayOptions[] = {"anymore", "donesearch", "exists", "get",
+ "names", "nextelement", "set", "size", "startsearch",
+ (char *) NULL};
Var *varPtr, *arrayPtr;
Tcl_HashEntry *hPtr;
Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
- int notArray, c;
- char *varName, *option;
- int length, result;
+ int notArray;
+ char *varName;
+ int index, result;
+
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "option arrayName ?arg ...?");
return TCL_ERROR;
}
+ if (Tcl_GetIndexFromObj(interp, objv[1], arrayOptions, "option", 0, &index)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+
/*
* Locate the array variable (and it better be an array).
* THIS FAILS IF A NAME OBJECT'S STRING REP HAS A NULL BYTE.
*/
-
varName = TclGetStringFromObj(objv[2], (int *) NULL);
varPtr = TclLookupVar(interp, varName, (char *) NULL, /*flags*/ 0,
/*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr);
+
notArray = 0;
if (varPtr == NULL) {
notArray = 1;
@@ -2780,295 +2817,289 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv)
}
}
- /*
- * Dispatch based on the option.
- * THIS FAILS IF THE OPTIONS OBJECT'S STRING REP HAS A NULL BYTE.
- */
-
- option = TclGetStringFromObj(objv[1], (int *) NULL);
- c = option[0];
- length = strlen(option);
- if ((c == 'a')
- && (strncmp(option, "anymore", (unsigned) length) == 0)) {
- ArraySearch *searchPtr;
- char *searchId;
-
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 1, objv, "anymore arrayName searchId");
- return TCL_ERROR;
- }
- if (notArray) {
- goto error;
- }
- searchId = Tcl_GetStringFromObj(objv[3], (int *) NULL);
- searchPtr = ParseSearchId(interp, varPtr, varName, searchId);
- if (searchPtr == NULL) {
- return TCL_ERROR;
- }
- while (1) {
- Var *varPtr2;
+ switch (index) {
+ case 0: { /* anymore */
+ ArraySearch *searchPtr;
+ char *searchId;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "arrayName searchId");
+ return TCL_ERROR;
+ }
+ if (notArray) {
+ goto error;
+ }
+ searchId = Tcl_GetStringFromObj(objv[3], (int *) NULL);
+ searchPtr = ParseSearchId(interp, varPtr, varName, searchId);
+ if (searchPtr == NULL) {
+ return TCL_ERROR;
+ }
+ while (1) {
+ Var *varPtr2;
- if (searchPtr->nextEntry != NULL) {
- varPtr2 = (Var *) Tcl_GetHashValue(searchPtr->nextEntry);
- if (!TclIsVarUndefined(varPtr2)) {
- break;
+ if (searchPtr->nextEntry != NULL) {
+ varPtr2 = (Var *) Tcl_GetHashValue(searchPtr->nextEntry);
+ if (!TclIsVarUndefined(varPtr2)) {
+ break;
+ }
+ }
+ searchPtr->nextEntry = Tcl_NextHashEntry(&searchPtr->search);
+ if (searchPtr->nextEntry == NULL) {
+ Tcl_SetIntObj(resultPtr, 0);
+ return TCL_OK;
}
}
- searchPtr->nextEntry = Tcl_NextHashEntry(&searchPtr->search);
- if (searchPtr->nextEntry == NULL) {
- Tcl_SetIntObj(resultPtr, 0);
- return TCL_OK;
- }
+ Tcl_SetIntObj(resultPtr, 1);
+ break;
}
- Tcl_SetIntObj(resultPtr, 1);
- return TCL_OK;
- } else if ((c == 'd')
- && (strncmp(option, "donesearch", (unsigned) length) == 0)) {
- ArraySearch *searchPtr, *prevPtr;
- char *searchId;
+ case 1: { /* donesearch */
+ ArraySearch *searchPtr, *prevPtr;
+ char *searchId;
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 1, objv, "donesearch arrayName searchId");
- return TCL_ERROR;
- }
- if (notArray) {
- goto error;
- }
- searchId = Tcl_GetStringFromObj(objv[3], (int *) NULL);
- searchPtr = ParseSearchId(interp, varPtr, varName, searchId);
- if (searchPtr == NULL) {
- return TCL_ERROR;
- }
- if (varPtr->searchPtr == searchPtr) {
- varPtr->searchPtr = searchPtr->nextPtr;
- } else {
- for (prevPtr = varPtr->searchPtr; ;
- prevPtr = prevPtr->nextPtr) {
- if (prevPtr->nextPtr == searchPtr) {
- prevPtr->nextPtr = searchPtr->nextPtr;
- break;
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "arrayName searchId");
+ return TCL_ERROR;
+ }
+ if (notArray) {
+ goto error;
+ }
+ searchId = Tcl_GetStringFromObj(objv[3], (int *) NULL);
+ searchPtr = ParseSearchId(interp, varPtr, varName, searchId);
+ if (searchPtr == NULL) {
+ return TCL_ERROR;
+ }
+ if (varPtr->searchPtr == searchPtr) {
+ varPtr->searchPtr = searchPtr->nextPtr;
+ } else {
+ for (prevPtr = varPtr->searchPtr; ;
+ prevPtr = prevPtr->nextPtr) {
+ if (prevPtr->nextPtr == searchPtr) {
+ prevPtr->nextPtr = searchPtr->nextPtr;
+ break;
+ }
}
}
+ ckfree((char *) searchPtr);
+ break;
}
- ckfree((char *) searchPtr);
- } else if ((c == 'e')
- && (strncmp(option, "exists", (unsigned) length) == 0)) {
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "exists arrayName");
- return TCL_ERROR;
- }
- Tcl_SetIntObj(resultPtr, !notArray);
- } else if ((c == 'g')
- && (strncmp(option, "get", (unsigned) length) == 0)) {
- Tcl_HashSearch search;
- Var *varPtr2;
- char *pattern = NULL;
- char *name;
- Tcl_Obj *namePtr, *valuePtr;
-
- if ((objc != 3) && (objc != 4)) {
- Tcl_WrongNumArgs(interp, 1, objv, "get arrayName ?pattern?");
- return TCL_ERROR;
- }
- if (notArray) {
- return TCL_OK;
- }
- if (objc == 4) {
- pattern = Tcl_GetStringFromObj(objv[3], (int *) NULL);
+ case 2: { /* exists */
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "arrayName");
+ return TCL_ERROR;
+ }
+ Tcl_SetIntObj(resultPtr, !notArray);
+ break;
}
- for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
- hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
- varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
- if (TclIsVarUndefined(varPtr2)) {
- continue;
+ case 3: { /*get*/
+ Tcl_HashSearch search;
+ Var *varPtr2;
+ char *pattern = NULL;
+ char *name;
+ Tcl_Obj *namePtr, *valuePtr;
+
+ if ((objc != 3) && (objc != 4)) {
+ Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?");
+ return TCL_ERROR;
}
- name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
- if ((objc == 4) && !Tcl_StringMatch(name, pattern)) {
- continue; /* element name doesn't match pattern */
+ if (notArray) {
+ return TCL_OK;
}
-
- namePtr = Tcl_NewStringObj(name, -1);
- result = Tcl_ListObjAppendElement(interp, resultPtr, namePtr);
- if (result != TCL_OK) {
- Tcl_DecrRefCount(namePtr); /* free unneeded name object */
- return result;
+ if (objc == 4) {
+ pattern = Tcl_GetStringFromObj(objv[3], (int *) NULL);
}
+ for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
+ hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
+ varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
+ if (TclIsVarUndefined(varPtr2)) {
+ continue;
+ }
+ name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
+ if ((objc == 4) && !Tcl_StringMatch(name, pattern)) {
+ continue; /* element name doesn't match pattern */
+ }
+
+ namePtr = Tcl_NewStringObj(name, -1);
+ result = Tcl_ListObjAppendElement(interp, resultPtr, namePtr);
+ if (result != TCL_OK) {
+ Tcl_DecrRefCount(namePtr); /* free unneeded name object */
+ return result;
+ }
- if (varPtr2->value.objPtr == NULL) {
- TclNewObj(valuePtr);
- } else {
- valuePtr = varPtr2->value.objPtr;
- }
- result = Tcl_ListObjAppendElement(interp, resultPtr, valuePtr);
- if (result != TCL_OK) {
if (varPtr2->value.objPtr == NULL) {
- Tcl_DecrRefCount(valuePtr); /* free unneeded object */
+ TclNewObj(valuePtr);
+ } else {
+ valuePtr = varPtr2->value.objPtr;
+ }
+ result = Tcl_ListObjAppendElement(interp, resultPtr, valuePtr);
+ if (result != TCL_OK) {
+ if (varPtr2->value.objPtr == NULL) {
+ Tcl_DecrRefCount(valuePtr); /* free unneeded object */
+ }
+ return result;
}
- return result;
}
+ break;
}
- } else if ((c == 'n')
- && (strncmp(option, "names", (unsigned) length) == 0)
- && (length >= 2)) {
- Tcl_HashSearch search;
- Var *varPtr2;
- char *pattern = NULL;
- char *name;
- Tcl_Obj *namePtr;
-
- if ((objc != 3) && (objc != 4)) {
- Tcl_WrongNumArgs(interp, 1, objv, "names arrayName ?pattern?");
- return TCL_ERROR;
- }
- if (notArray) {
- return TCL_OK;
- }
- if (objc == 4) {
- pattern = Tcl_GetStringFromObj(objv[3], (int *) NULL);
- }
- for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
- hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
- varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
- if (TclIsVarUndefined(varPtr2)) {
- continue;
+ case 4: { /* names */
+ Tcl_HashSearch search;
+ Var *varPtr2;
+ char *pattern = NULL;
+ char *name;
+ Tcl_Obj *namePtr;
+
+ if ((objc != 3) && (objc != 4)) {
+ Tcl_WrongNumArgs(interp, 2, objv, "arrayName ?pattern?");
+ return TCL_ERROR;
}
- name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
- if ((objc == 4) && !Tcl_StringMatch(name, pattern)) {
- continue; /* element name doesn't match pattern */
+ if (notArray) {
+ return TCL_OK;
}
-
- namePtr = Tcl_NewStringObj(name, -1);
- result = Tcl_ListObjAppendElement(interp, resultPtr, namePtr);
- if (result != TCL_OK) {
- Tcl_DecrRefCount(namePtr); /* free unneeded name object */
- return result;
+ if (objc == 4) {
+ pattern = Tcl_GetStringFromObj(objv[3], (int *) NULL);
}
+ for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
+ hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
+ varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
+ if (TclIsVarUndefined(varPtr2)) {
+ continue;
+ }
+ name = Tcl_GetHashKey(varPtr->value.tablePtr, hPtr);
+ if ((objc == 4) && !Tcl_StringMatch(name, pattern)) {
+ continue; /* element name doesn't match pattern */
+ }
+
+ namePtr = Tcl_NewStringObj(name, -1);
+ result = Tcl_ListObjAppendElement(interp, resultPtr, namePtr);
+ if (result != TCL_OK) {
+ Tcl_DecrRefCount(namePtr); /* free unneeded name object */
+ return result;
+ }
+ }
+ break;
}
- } else if ((c == 'n')
- && (strncmp(option, "nextelement", (unsigned) length) == 0)
- && (length >= 2)) {
- ArraySearch *searchPtr;
- char *searchId;
- Tcl_HashEntry *hPtr;
-
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 1, objv, "nextelement arrayName searchId");
- return TCL_ERROR;
- }
- if (notArray) {
- goto error;
- }
- searchId = Tcl_GetStringFromObj(objv[3], (int *) NULL);
- searchPtr = ParseSearchId(interp, varPtr, varName, searchId);
- if (searchPtr == NULL) {
- return TCL_ERROR;
- }
- while (1) {
- Var *varPtr2;
+ case 5: { /*nextelement*/
+ ArraySearch *searchPtr;
+ char *searchId;
+ Tcl_HashEntry *hPtr;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv,
+ "arrayName searchId");
+ return TCL_ERROR;
+ }
+ if (notArray) {
+ goto error;
+ }
+ searchId = Tcl_GetStringFromObj(objv[3], (int *) NULL);
+ searchPtr = ParseSearchId(interp, varPtr, varName, searchId);
+ if (searchPtr == NULL) {
+ return TCL_ERROR;
+ }
+ while (1) {
+ Var *varPtr2;
- hPtr = searchPtr->nextEntry;
- if (hPtr == NULL) {
- hPtr = Tcl_NextHashEntry(&searchPtr->search);
+ hPtr = searchPtr->nextEntry;
if (hPtr == NULL) {
- return TCL_OK;
+ hPtr = Tcl_NextHashEntry(&searchPtr->search);
+ if (hPtr == NULL) {
+ return TCL_OK;
+ }
+ } else {
+ searchPtr->nextEntry = NULL;
+ }
+ varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
+ if (!TclIsVarUndefined(varPtr2)) {
+ break;
}
- } else {
- searchPtr->nextEntry = NULL;
- }
- varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
- if (!TclIsVarUndefined(varPtr2)) {
- break;
}
+ Tcl_SetStringObj(resultPtr,
+ Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), -1);
+ break;
}
- Tcl_SetStringObj(resultPtr,
- Tcl_GetHashKey(varPtr->value.tablePtr, hPtr), -1);
- } else if ((c == 's')
- && (strncmp(option, "set", (unsigned) length) == 0)
- && (length >= 2)) {
- Tcl_Obj **elemPtrs;
- int listLen, i, result;
-
- if (objc != 4) {
- Tcl_WrongNumArgs(interp, 1, objv, "set arrayName list");
- return TCL_ERROR;
- }
- result = Tcl_ListObjGetElements(interp, objv[3], &listLen, &elemPtrs);
- if (result != TCL_OK) {
+ case 6: { /*set*/
+ Tcl_Obj **elemPtrs;
+ int listLen, i, result;
+
+ if (objc != 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "arrayName list");
+ return TCL_ERROR;
+ }
+ result = Tcl_ListObjGetElements(interp, objv[3], &listLen,
+ &elemPtrs);
+ if (result != TCL_OK) {
+ return result;
+ }
+ if (listLen & 1) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "list must have an even number of elements", -1);
+ return TCL_ERROR;
+ }
+ for (i = 0; i < listLen; i += 2) {
+ if (Tcl_ObjSetVar2(interp, objv[2], elemPtrs[i], elemPtrs[i+1],
+ TCL_LEAVE_ERR_MSG) == NULL) {
+ result = TCL_ERROR;
+ break;
+ }
+ }
return result;
}
- if (listLen & 1) {
- Tcl_ResetResult(interp);
- Tcl_AppendToObj(Tcl_GetObjResult(interp),
- "list must have an even number of elements", -1);
- return TCL_ERROR;
- }
- for (i = 0; i < listLen; i += 2) {
- if (Tcl_ObjSetVar2(interp, objv[2], elemPtrs[i], elemPtrs[i+1],
- TCL_LEAVE_ERR_MSG) == NULL) {
- result = TCL_ERROR;
- break;
+ case 7: { /*size*/
+ Tcl_HashSearch search;
+ Var *varPtr2;
+ int size;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "arrayName");
+ return TCL_ERROR;
}
- }
- return result;
- } else if ((c == 's')
- && (strncmp(option, "size", (unsigned) length) == 0)
- && (length >= 2)) {
- Tcl_HashSearch search;
- Var *varPtr2;
- int size;
-
- if (objc != 3) {
- Tcl_WrongNumArgs(interp, 1, objv, "size arrayName");
- return TCL_ERROR;
- }
- size = 0;
- if (!notArray) {
- for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr, &search);
- hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
- varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
- if (TclIsVarUndefined(varPtr2)) {
- continue;
+ size = 0;
+ if (!notArray) {
+ for (hPtr = Tcl_FirstHashEntry(varPtr->value.tablePtr,
+ &search);
+ hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) {
+ varPtr2 = (Var *) Tcl_GetHashValue(hPtr);
+ if (TclIsVarUndefined(varPtr2)) {
+ continue;
+ }
+ si