summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog91
-rw-r--r--README4
-rw-r--r--changes106
-rw-r--r--doc/load.n4
-rw-r--r--generic/tcl.decls5
-rw-r--r--generic/tcl.h8
-rw-r--r--generic/tclBasic.c17
-rw-r--r--generic/tclCompCmds.c46
-rw-r--r--generic/tclCompile.c354
-rw-r--r--generic/tclCompile.h21
-rw-r--r--generic/tclInt.h6
-rw-r--r--generic/tclProc.c128
-rw-r--r--library/init.tcl4
-rw-r--r--library/tclIndex1
-rw-r--r--tools/tcl.wse.in2
-rw-r--r--unix/README6
-rwxr-xr-xunix/configure2
-rw-r--r--unix/configure.in4
-rw-r--r--unix/tcl.spec4
-rwxr-xr-xwin/configure2
-rw-r--r--win/configure.in4
21 files changed, 597 insertions, 222 deletions
diff --git a/ChangeLog b/ChangeLog
index 7afedb8..83a84f2 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,22 +1,68 @@
+2007-10-02 Don Porter <dgp@users.sourceforge.net>
+
+ [core-stabilizer-branch]
+
+ * README: Bump version number to 8.5.0
+ * generic/tcl.h:
+ * library/init.tcl:
+ * tools/tcl.wse.in:
+ * unix/configure.in:
+ * unix/tcl.spec:
+ * win/configure.in:
+
+ * unix/configure: autoconf (2.59)
+ * win/configure:
+
+2007-10-02 Andreas Kupries <andreask@activestate.com>
+
+ * library/tclIndex: Added 'tcl::tm::path' to the tclIndex. This
+ fixes [SF Bug 1806422] reported by Don Porter.
+
+2007-09-25 Donal K. Fellows <donal.k.fellows@manchester.ac.uk>
+
+ * generic/tclProc.c (Tcl_DisassembleObjCmd): Define a command,
+ ::tcl::unsupported::disassemble, which can disassemble procedures,
+ lambdas and general scripts.
+ * generic/tclCompile.c (TclDisassembleByteCodeObj): Split apart the
+ code to print disassemblies of bytecode so that there is reusable code
+ that spits it out in a Tcl_Obj and then that code is used when doing
+ tracing.
+
+2007-09-20 Don Porter <dgp@users.sourceforge.net>
+
+ *** 8.5b1 TAGGED FOR RELEASE ***
+
+ * changes: updates for 8.5b1 release.
+
+2007-09-19 Don Porter <dgp@users.sourceforge.net>
+
+ * README: Bump version number to 8.5b1
+ * generic/tcl.h: Merge from core-stabilizer-branch.
+ * library/init.tcl: Stabilizing toward 8.5b1 release now done on
+ * tools/tcl.wse.in: the HEAD. core-stabilizer-branch is now
+ * unix/configure.in: suspended.
+ * unix/tcl.spec:
+ * win/configure.in:
+
2007-09-19 Pat Thoyts <patthoyts@users.sourceforge.net>
-
+
* generic/tclStubLib.: Replaced isdigit with internal implementation.
2007-09-18 Don Porter <dgp@users.sourceforge.net>
- * generic/tclStubLib.c: Remove C library calls from Tcl_InitStubs()
- * win/makefile.vc: so that we don't need the C library linked
- in to libtclStub.
+ * generic/tclStubLib.c: Remove C library calls from Tcl_InitStubs() so
+ * win/makefile.vc: that we don't need the C library linked in to
+ libtclStub.
2007-09-17 Pat Thoyts <patthoyts@users.sourceforge.net>
- * win/makefile.vc: Add crt flags for tclStubLib now it uses
- C-library functions
+ * win/makefile.vc: Add crt flags for tclStubLib now it uses C-library
+ functions.
2007-09-17 Joe English <jenglish@users.sourceforge.net>
- * tcl.m4: use '${CC} -shared' instead of 'ld -Bshareable'
- to build shared libraries on current NetBSDs [#1749251].
+ * tcl.m4: use '${CC} -shared' instead of 'ld -Bshareable' to build
+ shared libraries on current NetBSDs. [Bug 1749251]
* unix/configure: regenerated (autoconf-2.59).
2007-09-17 Don Porter <dgp@users.sourceforge.net>
@@ -26,12 +72,12 @@
* generic/tcl.h: Revised Tcl_InitStubs() to restore Tcl 8.4
* generic/tclPkg.c: source compatibility with callers of
- * generic/tclStubLib.c: Tcl_InitStubs(interp, TCL_VERSION, 1).
- [Bug 1578344].
+ * generic/tclStubLib.c: Tcl_InitStubs(interp, TCL_VERSION, 1). [Bug
+ 1578344]
2007-09-17 Donal K. Fellows <donal.k.fellows@man.ac.uk>
- * generic/tclTrace.c (Tcl_TraceObjCmd, TraceExecutionObjCmd)
+ * generic/tclTrace.c (Tcl_TraceObjCmd, TraceExecutionObjCmd)
(TraceCommandObjCmd, TraceVariableObjCmd): Generate literal values
* generic/tclNamesp.c (NamespaceCodeCmd): more efficiently using
* generic/tclFCmd.c (CopyRenameOneFile): TclNewLiteralStringObj
@@ -104,7 +150,7 @@
* generic/tclCompCmds.c (TclCompileDictCmd-update):
* generic/tclCompile.c (tclInstructionTable):
* generic/tclExecute.c (INST_DICT_UPDATE_END): fix stack management in
- [dict update]. [Bug 1786481]
+ compiled [dict update]. [Bug 1786481]
***POTENTIAL INCOMPATIBILITY***
Scripts that were precompiled on earlier versions of 8.5 and use [dict
@@ -168,8 +214,8 @@
2007-09-08 Miguel Sofer <msofer@users.sf.net>
- * generic/tclVar.c (Tcl_SetVar2, TclPtrSetVar): [Bug 1710710]
- fixed correctly, reverted fix of 2007-05-01.
+ * generic/tclVar.c (Tcl_SetVar2, TclPtrSetVar): [Bug 1710710] fixed
+ correctly, reverted fix of 2007-05-01.
2007-09-08 Donal K. Fellows <dkf@users.sf.net>
@@ -349,8 +395,8 @@
2007-08-24 Miguel Sofer <msofer@users.sf.net>
- * generic/tclCompile.c: replaced copy loop that tripped some
- compilers with memmove [Bug 1780870]
+ * generic/tclCompile.c: replaced copy loop that tripped some compilers
+ with memmove. [Bug 1780870]
2007-08-23 Don Porter <dgp@users.sourceforge.net>
@@ -474,7 +520,7 @@
2007-08-10 Miguel Sofer <msofer@users.sf.net>
- * generic/tclInt.h: remove redundant ops in TclNewStringObj macro
+ * generic/tclInt.h: remove redundant ops in TclNewStringObj macro.
2007-08-10 Miguel Sofer <msofer@users.sf.net>
@@ -521,10 +567,8 @@
non-resolved case, as the function is never called in that case.
Renamed the function to InitResolvedLocals to calrify the point.
-2007-08-07 Miguel Sofer <msofer@users.sf.net>
-
- * generic/tclInt.decls: Exporting via stubs to help
- * generic/tclInt.h: xotcl adapt to VarReform.
+ * generic/tclInt.decls: Exporting via stubs to help xotcl adapt to
+ * generic/tclInt.h: VarReform.
* generic/tclIntDecls.h:
* generic/tclStubInit.c:
@@ -558,9 +602,8 @@
* generic/tclGetDate.y: Added a cast to the definition of YYFREE to
silence compiler warnings.
* generic/tclDate.c: Regenerated
- * win/tclWinTest.c: Added a cast to the call to
- GetSecurityDescriptorDacl to silence compiler
- warnings.
+ * win/tclWinTest.c: Added a cast to GetSecurityDescriptorDacl call
+ to silence compiler warnings.
2007-08-04 Miguel Sofer <msofer@users.sf.net>
diff --git a/README b/README
index 516d93e..03a4f44 100644
--- a/README
+++ b/README
@@ -1,11 +1,11 @@
README: Tcl
- This is the Tcl 8.5b1 source distribution.
+ This is the Tcl 8.5.0 source distribution.
Tcl/Tk is also available through NetCVS:
http://tcl.sourceforge.net/
You can get any source release of Tcl from the file distributions
link at the above URL.
-RCS: @(#) $Id: README,v 1.59.2.2 2007/06/12 15:56:41 dgp Exp $
+RCS: @(#) $Id: README,v 1.59.2.3 2007/10/02 20:11:45 dgp Exp $
Contents
--------
diff --git a/changes b/changes
index 4bfe05b..3842e01 100644
--- a/changes
+++ b/changes
@@ -1,6 +1,6 @@
Recent user-visible changes to Tcl:
-RCS: @(#) $Id: changes,v 1.116.2.1 2007/09/19 17:28:37 dgp Exp $
+RCS: @(#) $Id: changes,v 1.116.2.2 2007/10/02 20:11:45 dgp Exp $
1. No more [command1] [command2] construct for grouping multiple
commands on a single command line.
@@ -6918,25 +6918,109 @@ upvar and namespace upvar.
2007-04-20 (enhancement) Documented Tcl_SetNotifier and Tcl_ServiceModeHook.
-2007-04-23 (bug fix) Workaround crashing bug in fts_open() on 64bit Darawin.
+2007-04-23 (bug fix) Workaround crashing bug in fts_open() on 64bit Darwin.
--- Released 8.5a6, April 25, 2007 --- See ChangeLog for details ---
-2007-06-06 (platform support) Darwin: add plist to tclsh.
+2007-04-30 (bug fix)[1705778] many valgrind-detected leaks corrected
-2007-06-23 (bug fix) Darwin: prevent post-fork() abort().
+2007-05-01 (bug fix)[1710709] leak in [string map] (porter)
-2007-06-29 (enhancement) Tcl_Alloc alignment on Darwin.
+2007-05-02 (bug fix)[1710707] leaks in filesystem paths (mistachkin,kenny)
-2007-08-14 (platform support) Darwin: [load] from VFS on intel & 64bit.
+2007-05-18 (feature change) {expand} syntax support removed. (porter)
+ *** POTENTIAL INCOMPATIBILITY with previous 8.5 alphas only ***
+
+2007-05-29 (bug fix)[1712723] Joinable thread death on 64-bit (virden,hobbs)
+
+2007-05-30 (feature change)[1725186] When expanded literals are parsed,
+(example: {*}{1 2 3}), TCL_TOKEN_EXPAND_WORD token is no longer returned.
+Tokens reflecting the expansion are returned instead. (porter)
+ *** POTENTIAL INCOMPATIBILITY with previous 8.5 alphas only ***
+
+2007-06-06 (platform support) Darwin: add plist to tclsh (steffen)
+
+2007-06-12 (enhancement) [info] is now a [namespace ensemble] (fellows)
+
+2007-06-20 (enhancement) better `make html` results (hobbs)
+
+2007-06-21 (feature change)[1740962] leave traces created during execution
+of traced command do not fire (sofer)
+ *** POTENTIAL INCOMPATIBILITY ***
+
+2007-06-23 (bug fix) Darwin: prevent post-fork() abort() (steffen)
+
+2007-06-27 (bug fix)[1743941] Infinite loop in Tcl_CreateTrace traces (porter)
+
+2007-06-29 (enhancement) Tcl_Alloc alignment on Darwin (steffen)
+
+2007-06-30 (bug fix)[1726873] crash in thread sync objects (vasiljevic,twylite)
+
+2007-06-30 (bug fix)[1717186] [lsort -command \{ $l] leak (afredd,fellows)
+
+2007-07-05 (bug fix)[1743676] no command named "" error message (porter,virden)
+
+2007-07-11 (bug fix)[1752146] [while 1 {}] & [interp limit] on commands (sofer)
+
+2007-07-31 (bug fix)[681877] tcl_platform(user) from system, not env (fellows)
+
+2007-07-31 (enhancement)[1750051] space efficiency of Tcl variables (sofer)
+ *** POTENTIAL INCOMPATIBILITY for C code that accesses internal
+ Tcl structs Var, Bytecode, Namespace, or CallFrame. ***
+
+2007-08-01 (enhancement)[1764318] word.tcl proc rewrites (petasis,fellows)
+
+2007-08-08 (bug fix)[1770224] [tcl::mathop::>> $big1 $big2] errors (porter)
-2007-09-03 (compat support) Restore registration of "wideInt" Tcl_ObjType.
+2007-08-14 (platform support) Darwin [load] from VFS on intel & 64bit (steffen)
+
+2007-08-15 (bug fix)[1773127] corrected open mode "a+" (rottman,fellows)
+
+2007-08-16 (bug fix)[1773040] ::errorInfo trace crash (janssen,porter)
+
+2007-08-16 (performance)[1564517] pre-compile constant expressions (porter)
+
+2007-08-21 (bug fix)[1775878] 'puts \' in interactive tclsh failed to move to
+prompt for continuation line (porter)
+
+2007-08-25 (bug fix)[1781282] [clock scan] case senstivity (kenny)
+
+2007-08-25 (performance)[1767293] ** on native integer types (kenny)
+
+2007-09-03 clock tzdata updated to Olson's tzdata2007g (kenny)
2007-09-06 (platform support) Darwin: drop support for Xcode 1.5 project, add
-project for Xcode 3.0.
+project for Xcode 3.0 (steffen)
+
+2007-09-08 (bug fix)[1786481] nested [dict update] crash (fellows)
+
+2007-09-08 (bug fix)[1710710] TclPtrSetVar leak (mistachkin,sofer)
+
+2005-09-09 (feature removed) Tcl_ObjType "nsName" no longer registered (porter)
+ *** POTENTIAL INCOMPATIBILITY for Tcl_GetObjType("nsName") ***
+
+2007-09-10 (bug fix)[1740631] Linked variable unlink prevention (maros,hobbs)
+
+2007-09-11 (bug fix)[1786481] [dict update] stack management (sofer)
+ *** POTENTIAL INCOMPATIBILITY with previous 8.5 alpha bytecode only ***
+
+2007-09-11 (bug fix)[1578344] [package require -exact] 8.4 compat (porter)
+ *** POTENTIAL INCOMPATIBILITY with previous 8.5 alphas only ***
+
+2007-09-11 (bug fix)[1772989,1071322] Support _, : in test constraints (porter)
+=> tcltest 2.3b1
+
+2007-09-11 (platform support) Windows AMD64 support (thoyts)
+
+2007-09-14 (enhancement)[1793984] DTrace provider for Tcl (steffen)
+
+2007-09-14 (bug fix)[1519940] surplus ns path invalidation (fellows,bauer)
+
+2007-09-15 (platform support) SunOS-5.1x link with cc, not ld (steffen)
-2007-09-14 (enhancement)[1793984] DTrace provider for Tcl.
+2007-09-17 (platform support)[1748251] Fix NetBSD link failures (english)
-2007-09-15 (platform support) SunOS-5.1x link with cc, not ld.
+(bug fix)[1066755] Several stack efficiency efforts increases recursion limit
+on Windows to be larger than the default [interp recursionlimit] value.
---- Released 8.5b1, September ??, 2007 --- See ChangeLog for details ---
+--- Released 8.5b1, September 26, 2007 --- See ChangeLog for details ---
diff --git a/doc/load.n b/doc/load.n
index 6cf0d42..38ae877 100644
--- a/doc/load.n
+++ b/doc/load.n
@@ -4,7 +4,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" RCS: @(#) $Id: load.n,v 1.16 2005/05/16 08:41:09 dkf Exp $
+'\" RCS: @(#) $Id: load.n,v 1.16.8.1 2007/10/02 20:11:47 dgp Exp $
'\"
.so man.macros
.TH load n 7.5 Tcl "Tcl Built-In Commands"
@@ -158,7 +158,7 @@ switch $tcl_platform(platform) {
\fBload\fR [file join [pwd] foo.dll]
}
unix {
- \fBload\fR ./libfoo[info sharedlibextension]
+ \fBload\fR [file join [pwd] libfoo[info sharedlibextension]]
}
}
diff --git a/generic/tcl.decls b/generic/tcl.decls
index 558a0a0..b0b2cc5 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -11,7 +11,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: tcl.decls,v 1.126 2007/05/16 21:18:22 das Exp $
+# RCS: @(#) $Id: tcl.decls,v 1.126.2.1 2007/10/02 20:11:47 dgp Exp $
library tcl
@@ -2145,6 +2145,9 @@ declare 1 macosx {
# CONST char *Tcl_InitStubs(Tcl_Interp *interp, CONST char *version, int exact)
# CONST char *TclTomMathInitializeStubs(Tcl_Interp* interp,
# CONST char* version, int epoch, int revision
+# CONST char *Tcl_PkgInitStubsCheck(Tcl_Interp *interp, CONST char *version,
+# int exact);
+
# Global variables that need to be exported from the tcl shared library:
# (listed here _as comments_ so that the 'checkstubs' make target does not
diff --git a/generic/tcl.h b/generic/tcl.h
index 0f54578..3cc3084 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tcl.h,v 1.231.2.5 2007/09/17 15:03:44 dgp Exp $
+ * RCS: @(#) $Id: tcl.h,v 1.231.2.6 2007/10/02 20:11:48 dgp Exp $
*/
#ifndef _TCL
@@ -59,11 +59,11 @@ extern "C" {
#define TCL_MAJOR_VERSION 8
#define TCL_MINOR_VERSION 5
-#define TCL_RELEASE_LEVEL TCL_BETA_RELEASE
-#define TCL_RELEASE_SERIAL 1
+#define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE
+#define TCL_RELEASE_SERIAL 0
#define TCL_VERSION "8.5"
-#define TCL_PATCH_LEVEL "8.5b1"
+#define TCL_PATCH_LEVEL "8.5.0"
/*
* The following definitions set up the proper options for Windows compilers.
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 3d4d3e2..6d77af1 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -14,7 +14,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclBasic.c,v 1.244.2.12 2007/09/14 16:28:32 dgp Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.244.2.13 2007/10/02 20:11:49 dgp Exp $
*/
#include "tclInt.h"
@@ -472,12 +472,12 @@ Tcl_CreateInterp(void)
/*
* Initialise the tables for variable traces and searches *before*
* creating the global ns - so that the trace on errorInfo can be
- * recorded.
+ * recorded.
*/
-
+
Tcl_InitHashTable(&iPtr->varTraces, TCL_ONE_WORD_KEYS);
Tcl_InitHashTable(&iPtr->varSearches, TCL_ONE_WORD_KEYS);
-
+
iPtr->globalNsPtr = NULL; /* Force creation of global ns below */
iPtr->globalNsPtr = (Namespace *) Tcl_CreateNamespace(interp, "",
(ClientData) NULL, NULL);
@@ -656,6 +656,13 @@ Tcl_CreateInterp(void)
Tcl_CreateObjCommand(interp, "::tcl::Bgerror",
TclDefaultBgErrorHandlerObjCmd, NULL, NULL);
+ /*
+ * Create an unsupported command for debugging bytecode.
+ */
+
+ Tcl_CreateObjCommand(interp, "::tcl::unsupported::disassemble",
+ Tcl_DisassembleObjCmd, NULL, NULL);
+
#ifdef USE_DTRACE
/*
* Register the tcl::dtrace command.
@@ -3386,7 +3393,7 @@ TclInterpReady(
Tcl_ResetResult(interp);
Tcl_AppendResult(interp,
"attempt to call eval in deleted interpreter", NULL);
- Tcl_SetErrorCode(interp, "CORE", "IDELETE",
+ Tcl_SetErrorCode(interp, "TCL", "IDELETE",
"attempt to call eval in deleted interpreter", NULL);
return TCL_ERROR;
}
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 2cc9a37..ee5a8cd 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCompCmds.c,v 1.109.2.7 2007/09/11 17:58:24 dgp Exp $
+ * RCS: @(#) $Id: tclCompCmds.c,v 1.109.2.8 2007/10/02 20:11:54 dgp Exp $
*/
#include "tclInt.h"
@@ -138,15 +138,18 @@
static ClientData DupDictUpdateInfo(ClientData clientData);
static void FreeDictUpdateInfo(ClientData clientData);
static void PrintDictUpdateInfo(ClientData clientData,
- ByteCode *codePtr, unsigned int pcOffset);
+ Tcl_Obj *appendObj, ByteCode *codePtr,
+ unsigned int pcOffset);
static ClientData DupForeachInfo(ClientData clientData);
static void FreeForeachInfo(ClientData clientData);
static void PrintForeachInfo(ClientData clientData,
- ByteCode *codePtr, unsigned int pcOffset);
+ Tcl_Obj *appendObj, ByteCode *codePtr,
+ unsigned int pcOffset);
static ClientData DupJumptableInfo(ClientData clientData);
static void FreeJumptableInfo(ClientData clientData);
static void PrintJumptableInfo(ClientData clientData,
- ByteCode *codePtr, unsigned int pcOffset);
+ Tcl_Obj *appendObj, ByteCode *codePtr,
+ unsigned int pcOffset);
static int PushVarName(Tcl_Interp *interp,
Tcl_Token *varTokenPtr, CompileEnv *envPtr,
int flags, int *localIndexPtr,
@@ -1140,6 +1143,7 @@ FreeDictUpdateInfo(
static void
PrintDictUpdateInfo(
ClientData clientData,
+ Tcl_Obj *appendObj,
ByteCode *codePtr,
unsigned int pcOffset)
{
@@ -1148,9 +1152,9 @@ PrintDictUpdateInfo(
for (i=0 ; i<duiPtr->length ; i++) {
if (i) {
- fprintf(stdout, ", ");
+ Tcl_AppendToObj(appendObj, ", ", -1);
}
- fprintf(stdout, "%%v%u", duiPtr->varIndices[i]);
+ Tcl_AppendPrintfToObj(appendObj, "%%v%u", duiPtr->varIndices[i]);
}
}
@@ -1787,6 +1791,7 @@ FreeForeachInfo(
static void
PrintForeachInfo(
ClientData clientData,
+ Tcl_Obj *appendObj,
ByteCode *codePtr,
unsigned int pcOffset)
{
@@ -1794,29 +1799,32 @@ PrintForeachInfo(
register ForeachVarList *varsPtr;
int i, j;
- fprintf(stdout, "data=[");
+ Tcl_AppendToObj(appendObj, "data=[", -1);
for (i=0 ; i<infoPtr->numLists ; i++) {
if (i) {
- fprintf(stdout, ", ");
+ Tcl_AppendToObj(appendObj, ", ", -1);
}
- fprintf(stdout, "%%v%u", (unsigned) (infoPtr->firstValueTemp + i));
+ Tcl_AppendPrintfToObj(appendObj, "%%v%u",
+ (unsigned) (infoPtr->firstValueTemp + i));
}
- fprintf(stdout, "], loop=%%v%u", (unsigned) infoPtr->loopCtTemp);
+ Tcl_AppendPrintfToObj(appendObj, "], loop=%%v%u",
+ (unsigned) infoPtr->loopCtTemp);
for (i=0 ; i<infoPtr->numLists ; i++) {
if (i) {
- fprintf(stdout, ",");
+ Tcl_AppendToObj(appendObj, ",", -1);
}
- fprintf(stdout, "\n\t\t it%%v%u\t[",
+ Tcl_AppendPrintfToObj(appendObj, "\n\t\t it%%v%u\t[",
(unsigned) (infoPtr->firstValueTemp + i));
varsPtr = infoPtr->varLists[i];
for (j=0 ; j<varsPtr->numVars ; j++) {
if (j) {
- fprintf(stdout, ", ");
+ Tcl_AppendToObj(appendObj, ", ", -1);
}
- fprintf(stdout, "%%v%u", (unsigned) varsPtr->varIndexes[j]);
+ Tcl_AppendPrintfToObj(appendObj, "%%v%u",
+ (unsigned) varsPtr->varIndexes[j]);
}
- fprintf(stdout, "]");
+ Tcl_AppendToObj(appendObj, "]", -1);
}
}
@@ -4305,6 +4313,7 @@ FreeJumptableInfo(
static void
PrintJumptableInfo(
ClientData clientData,
+ Tcl_Obj *appendObj,
ByteCode *codePtr,
unsigned int pcOffset)
{
@@ -4320,12 +4329,13 @@ PrintJumptableInfo(
offset = PTR2INT(Tcl_GetHashValue(hPtr));
if (i++) {
- fprintf(stdout, ", ");
+ Tcl_AppendToObj(appendObj, ", ", -1);
if (i%4==0) {
- fprintf(stdout, "\n\t\t");
+ Tcl_AppendToObj(appendObj, "\n\t\t", -1);
}
}
- fprintf(stdout, "\"%s\"->pc %d", keyPtr, pcOffset + offset);
+ Tcl_AppendPrintfToObj(appendObj, "\"%s\"->pc %d",
+ keyPtr, pcOffset + offset);
}
}
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 4249a5c..d08b0b7 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCompile.c,v 1.117.2.9 2007/09/11 17:58:24 dgp Exp $
+ * RCS: @(#) $Id: tclCompile.c,v 1.117.2.10 2007/10/02 20:11:54 dgp Exp $
*/
#include "tclInt.h"
@@ -376,10 +376,10 @@ InstructionDesc tclInstructionTable[] = {
/* finds level and otherName in stack, links to local variable at
* index op1. Leaves the level on stack. */
{"nsupvar", 5, 0, 1, {OPERAND_LVT4}},
- /* finds namespace and otherName in stack, links to local variable at
+ /* finds namespace and otherName in stack, links to local variable at
* index op1. Leaves the namespace on stack. */
{"variable", 5, 0, 1, {OPERAND_LVT4}},
- /* finds namespace and otherName in stack, links to local variable at
+ /* finds namespace and otherName in stack, links to local variable at
* index op1. Leaves the namespace on stack. */
{"syntax", 9, -1, 2, {OPERAND_INT4, OPERAND_UINT4}},
/* Compiled bytecodes to signal syntax error. */
@@ -407,6 +407,10 @@ static void RecordByteCodeStats(ByteCode *codePtr);
#endif /* TCL_COMPILE_STATS */
static int SetByteCodeFromAny(Tcl_Interp *interp,
Tcl_Obj *objPtr);
+static int FormatInstruction(ByteCode *codePtr,
+ unsigned char *pc, Tcl_Obj *bufferObj);
+static void PrintSourceToObj(Tcl_Obj *appendObj,
+ const char *stringPtr, int maxChars);
/*
* TIP #280: Helper for building the per-word line information of all compiled
* commands.
@@ -720,7 +724,7 @@ TclCleanupByteCode(
* 1) decrement the ref counts of the LiteralEntry's in its literal array,
* 2) call the free procs for the auxiliary data items, 3) free the
* localCache if it is unused, and finally 4) free the ByteCode
- * structure's heap object.
+ * structure's heap object.
*
* The case for TCL_BYTECODE_PRECOMPILED (precompiled ByteCodes, like
* those generated from tbcload) is special, as they doesn't make use of
@@ -916,7 +920,7 @@ TclInitCompileEnv(
ctxPtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame));
*ctxPtr = *invoker;
-
+
if (invoker->type == TCL_LOCATION_BC) {
/*
* Note: Type BC => ctx.data.eval.path is not used.
@@ -1162,7 +1166,7 @@ TclCompileScript(
if (Tcl_ParseCommand(interp, p, bytesLeft, 0, parsePtr) != TCL_OK) {
/* Compile bytecodes to report the parse error at runtime. */
- Tcl_LogCommandInfo(interp, script, parsePtr->commandStart,
+ Tcl_LogCommandInfo(interp, script, parsePtr->commandStart,
/* Drop the command terminator (";","]") if appropriate */
(parsePtr->term ==
parsePtr->commandStart + parsePtr->commandSize - 1)?
@@ -1330,7 +1334,7 @@ TclCompileScript(
* case. [Bug 1752146]
* Note that the environment is initialised with
* atCmdStart=1 to avoid emitting ISC for the first
- * command.
+ * command.
*/
if (envPtr->atCmdStart) {
@@ -1341,9 +1345,9 @@ TclCompileScript(
* this depends on the exact layout of the
* INST_START_CMD's operands, so be careful!
*/
-
+
unsigned char *fixPtr = envPtr->codeNext - 4;
-
+
TclStoreInt4AtPtr(TclGetUInt4AtPtr(fixPtr)+1,
fixPtr);
}
@@ -1828,7 +1832,7 @@ TclCompileExprWords(
* Side effects:
* Instructions are added to envPtr to execute a no-op at runtime. No
* result is pushed onto the stack: the compiler has to take care of this
- * itself if the last compiled command is a NoOp.
+ * itself if the last compiled command is a NoOp.
*
*----------------------------------------------------------------------
*/
@@ -3207,15 +3211,135 @@ TclPrintByteCodeObj(
Tcl_Interp *interp, /* Used only for Tcl_GetStringFromObj. */
Tcl_Obj *objPtr) /* The bytecode object to disassemble. */
{
- ByteCode *codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
+ Tcl_Obj *bufPtr = TclDisassembleByteCodeObj(objPtr);
+
+ fprintf(stdout, "\n%s", TclGetString(bufPtr));
+ Tcl_DecrRefCount(bufPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclPrintInstruction --
+ *
+ * This procedure prints ("disassembles") one instruction from a bytecode
+ * object to stdout.
+ *
+ * Results:
+ * Returns the length in bytes of the current instruiction.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclPrintInstruction(
+ ByteCode *codePtr, /* Bytecode containing the instruction. */
+ unsigned char *pc) /* Points to first byte of instruction. */
+{
+ Tcl_Obj *bufferObj;
+
+ TclNewObj(bufferObj);
+ FormatInstruction(codePtr, pc, bufferObj);
+ fprintf(stdout, "%s", TclGetString(bufferObj));
+ Tcl_DecrRefCount(bufferObj);
+ return numBytes;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclPrintObject --
+ *
+ * This procedure prints up to a specified number of characters from the
+ * argument Tcl object's string representation to a specified file.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Outputs characters to the specified file.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclPrintObject(
+ FILE *outFile, /* The file to print the source to. */
+ Tcl_Obj *objPtr, /* Points to the Tcl object whose string
+ * representation should be printed. */
+ int maxChars) /* Maximum number of chars to print. */
+{
+ char *bytes;
+ int length;
+
+ bytes = Tcl_GetStringFromObj(objPtr, &length);
+ TclPrintSource(outFile, bytes, TclMin(length, maxChars));
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclPrintSource --
+ *
+ * This procedure prints up to a specified number of characters from the
+ * argument string to a specified file. It tries to produce legible
+ * output by adding backslashes as necessary.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Outputs characters to the specified file.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclPrintSource(
+ FILE *outFile, /* The file to print the source to. */
+ const char *stringPtr, /* The string to print. */
+ int maxChars) /* Maximum number of chars to print. */
+{
+ Tcl_Obj *bufferObj;
+
+ TclNewObj(bufferObj);
+ PrintSourceToObj(bufferObj, stringPtr, maxChars);
+ fprintf(outFile, TclGetString(bufferObj));
+ Tcl_DecrRefCount(bufferObj);
+}
+#endif /* TCL_COMPILE_DEBUG */
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclDisassembleByteCodeObj --
+ *
+ * Given an object which is of bytecode type, return a disassembled
+ * version of the bytecode (in a new refcount 0 object). No guarantees
+ * are made about the details of the contents of the result.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclDisassembleByteCodeObj(
+ Tcl_Obj *objPtr) /* The bytecode object to disassemble. */
+{
+ ByteCode *codePtr = objPtr->internalRep.otherValuePtr;
unsigned char *codeStart, *codeLimit, *pc;
unsigned char *codeDeltaNext, *codeLengthNext;
unsigned char *srcDeltaNext, *srcLengthNext;
int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i;
Interp *iPtr = (Interp *) *codePtr->interpHandle;
+ Tcl_Obj *bufferObj;
+ char ptrBuf1[20], ptrBuf2[20];
+ TclNewObj(bufferObj);
if (codePtr->refCount <= 0) {
- return; /* already freed */
+ return bufferObj; /* Already freed. */
}
codeStart = codePtr->codeStart;
@@ -3226,14 +3350,17 @@ TclPrintByteCodeObj(
* Print header lines describing the ByteCode.
*/
- fprintf(stdout,
- "\nByteCode 0x%p, refCt %u, epoch %u, interp 0x%p (epoch %u)\n",
- codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr,
+ sprintf(ptrBuf1, "%p", codePtr);
+ sprintf(ptrBuf2, "%p", iPtr);
+ Tcl_AppendPrintfToObj(bufferObj,
+ "ByteCode 0x%s, refCt %u, epoch %u, interp 0x%s (epoch %u)\n",
+ ptrBuf1, codePtr->refCount, codePtr->compileEpoch, ptrBuf2,
iPtr->compileEpoch);
- fprintf(stdout, " Source ");
- TclPrintSource(stdout, codePtr->source,
+ Tcl_AppendToObj(bufferObj, " Source ", -1);
+ PrintSourceToObj(bufferObj, codePtr->source,
TclMin(codePtr->numSrcBytes, 55));
- fprintf(stdout, "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n",
+ Tcl_AppendPrintfToObj(bufferObj,
+ "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n",
numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes,
codePtr->numLitObjects, codePtr->numAuxDataItems,
codePtr->maxStackDepth,
@@ -3244,7 +3371,7 @@ TclPrintByteCodeObj(
0.0);
#ifdef TCL_COMPILE_STATS
- fprintf(stdout,
+ Tcl_AppendPrintfToObj(bufferObj,
" Code %lu = header %lu+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n",
(unsigned long) codePtr->structureSize,
(unsigned long) (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))),
@@ -3264,14 +3391,18 @@ TclPrintByteCodeObj(
if (codePtr->procPtr != NULL) {
Proc *procPtr = codePtr->procPtr;
int numCompiledLocals = procPtr->numCompiledLocals;
- fprintf(stdout,
- " Proc 0x%p, refCt %d, args %d, compiled locals %d\n",
- procPtr, procPtr->refCount, procPtr->numArgs,
+
+ sprintf(ptrBuf1, "%p", procPtr);
+ Tcl_AppendPrintfToObj(bufferObj,
+ " Proc 0x%s, refCt %d, args %d, compiled locals %d\n",
+ ptrBuf1, procPtr->refCount, procPtr->numArgs,
numCompiledLocals);
if (numCompiledLocals > 0) {
CompiledLocal *localPtr = procPtr->firstLocalPtr;
+
for (i = 0; i < numCompiledLocals; i++) {
- fprintf(stdout, " slot %d%s%s%s%s%s%s", i,
+ Tcl_AppendPrintfToObj(bufferObj,
+ " slot %d%s%s%s%s%s%s", i,
(localPtr->flags & (VAR_ARRAY|VAR_LINK)) ? "" : ", scalar",
(localPtr->flags & VAR_ARRAY) ? ", array" : "",
(localPtr->flags & VAR_LINK) ? ", link" : "",
@@ -3279,9 +3410,10 @@ TclPrintByteCodeObj(
(localPtr->flags & VAR_TEMPORARY) ? ", temp" : "",
(localPtr->flags & VAR_RESOLVED) ? ", resolved" : "");
if (TclIsVarTemporary(localPtr)) {
- fprintf(stdout, "\n");
+ Tcl_AppendToObj(bufferObj, "\n", -1);
} else {
- fprintf(stdout, ", \"%s\"\n", localPtr->name);
+ Tcl_AppendPrintfToObj(bufferObj, ", \"%s\"\n",
+ localPtr->name);
}
localPtr = localPtr->nextPtr;
}
@@ -3293,25 +3425,28 @@ TclPrintByteCodeObj(
*/
if (codePtr->numExceptRanges > 0) {
- fprintf(stdout, " Exception ranges %d, depth %d:\n",
+ Tcl_AppendPrintfToObj(bufferObj, " Exception ranges %d, depth %d:\n",
codePtr->numExceptRanges, codePtr->maxExceptDepth);
for (i = 0; i < codePtr->numExceptRanges; i++) {
ExceptionRange *rangePtr = &(codePtr->exceptArrayPtr[i]);
- fprintf(stdout, " %d: level %d, %s, pc %d-%d, ",
+
+ Tcl_AppendPrintfToObj(bufferObj,
+ " %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",
+ Tcl_AppendPrintfToObj(bufferObj, "continue %d, break %d\n",
rangePtr->continueOffset, rangePtr->breakOffset);
break;
case CATCH_EXCEPTION_RANGE:
- fprintf(stdout, "catch %d\n", rangePtr->catchOffset);
+ Tcl_AppendPrintfToObj(bufferObj, "catch %d\n",
+ rangePtr->catchOffset);
break;
default:
- Tcl_Panic("TclPrintByteCodeObj: bad ExceptionRange type %d",
+ Tcl_Panic("TclDisassembleByteCodeObj: bad ExceptionRange type %d",
rangePtr->type);
}
}
@@ -3325,10 +3460,10 @@ TclPrintByteCodeObj(
if (numCmds == 0) {
pc = codeStart;
while (pc < codeLimit) {
- fprintf(stdout, " ");
- pc += TclPrintInstruction(codePtr, pc);
+ Tcl_AppendToObj(bufferObj, " ", -1);
+ pc += FormatInstruction(codePtr, pc, bufferObj);
}
- return;
+ return bufferObj;
}
/*
@@ -3336,7 +3471,7 @@ TclPrintByteCodeObj(
* for each command. These are encoded as a sequence of bytes.
*/
- fprintf(stdout, " Commands %d:", numCmds);
+ Tcl_AppendPrintfToObj(bufferObj, " Commands %d:", numCmds);
codeDeltaNext = codePtr->codeDeltaStart;
codeLengthNext = codePtr->codeLengthStart;
srcDeltaNext = codePtr->srcDeltaStart;
@@ -3381,13 +3516,13 @@ TclPrintByteCodeObj(
srcLengthNext++;
}
- fprintf(stdout, "%s%4d: pc %d-%d, src %d-%d",
+ Tcl_AppendPrintfToObj(bufferObj, "%s%4d: pc %d-%d, src %d-%d",
((i % 2)? " " : "\n "),
(i+1), codeOffset, (codeOffset + codeLen - 1),
srcOffset, (srcOffset + srcLen - 1));
}
if (numCmds > 0) {
- fprintf(stdout, "\n");
+ Tcl_AppendToObj(bufferObj, "\n", -1);
}
/*
@@ -3436,14 +3571,14 @@ TclPrintByteCodeObj(
*/
while ((pc-codeStart) < codeOffset) {
- fprintf(stdout, " ");
- pc += TclPrintInstruction(codePtr, pc);
+ Tcl_AppendToObj(bufferObj, " ", -1);
+ pc += FormatInstruction(codePtr, pc, bufferObj);
}
- fprintf(stdout, " Command %d: ", (i+1));
- TclPrintSource(stdout, (codePtr->source + srcOffset),
+ Tcl_AppendPrintfToObj(bufferObj, " Command %d: ", i+1);
+ PrintSourceToObj(bufferObj, (codePtr->source + srcOffset),
TclMin(srcLen, 55));
- fprintf(stdout, "\n");
+ Tcl_AppendToObj(bufferObj, "\n", -1);
}
if (pc < codeLimit) {
/*
@@ -3451,43 +3586,37 @@ TclPrintByteCodeObj(
*/
while (pc < codeLimit) {
- fprintf(stdout, " ");
- pc += TclPrintInstruction(codePtr, pc);
+ Tcl_AppendToObj(bufferObj, " ", -1);
+ pc += FormatInstruction(codePtr, pc, bufferObj);
}
}
+ return bufferObj;
}
/*
*----------------------------------------------------------------------
*
- * TclPrintInstruction --
+ * FormatInstruction --
*
- * This procedure prints ("disassembles") one instruction from a bytecode
- * object to stdout.
- *
- * Results:
- * Returns the length in bytes of the current instruiction.
- *
- * Side effects:
- * None.
+ * Appends a representation of a bytecode instruction to a Tcl_Obj.
*
*----------------------------------------------------------------------
*/
-int
-TclPrintInstruction(
+static int
+FormatInstruction(
ByteCode *codePtr, /* Bytecode containing the instruction. */
- unsigned char *pc) /* Points to first byte of instruction. */
+ unsigned char *pc, /* Points to first byte of instruction. */
+ Tcl_Obj *bufferObj) /* Object to append instruction info to. */
{
Proc *procPtr = codePtr->procPtr;
unsigned char opCode = *pc;
register InstructionDesc *instDesc = &tclInstructionTable[opCode];
unsigned char *codeStart = codePtr->codeStart;
unsigned int pcOffset = (pc - codeStart);
- int opnd, i, j, numBytes = 1;
+ int opnd = 0, i, j, numBytes = 1;
int localCt = procPtr ? procPtr->numCompiledLocals : 0;
CompiledLocal *localPtr = procPtr ? procPtr->firstLocalPtr : NULL;
-
char suffixBuffer[64]; /* Additional info to print after main opcode
* and immediates. */
char *suffixSrc = NULL;
@@ -3495,7 +3624,7 @@ TclPrintInstruction(
AuxData *auxPtr = NULL;
suffixBuffer[0] = '\0';
- fprintf(stdout, "(%u) %s ", pcOffset, instDesc->name);
+ Tcl_AppendPrintfToObj(bufferObj, "(%u) %s ", pcOffset, instDesc->name);
for (i = 0; i < instDesc->numOperands; i++) {
switch (instDesc->opTypes[i]) {
case OPERAND_INT1:
@@ -3504,7 +3633,7 @@ TclPrintInstruction(
|| opCode == INST_JUMP_FALSE1) {
sprintf(suffixBuffer, "pc %u", pcOffset+opnd);
}
- fprintf(stdout, "%+d ", opnd);
+ Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd);
break;
case OPERAND_INT4:
opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4;
@@ -3514,14 +3643,14 @@ TclPrintInstruction(
} else if (opCode == INST_START_CMD) {
sprintf(suffixBuffer, "next cmd at pc %u", pcOffset+opnd);
}
- fprintf(stdout, "%+d ", opnd);
+ Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd);
break;
case OPERAND_UINT1:
opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++;
if (opCode == INST_PUSH1) {
suffixObj = codePtr->objArrayPtr[opnd];
}
- fprintf(stdout, "%u ", (unsigned int) opnd);
+ Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned int) opnd);
break;
case OPERAND_AUX4:
case OPERAND_UINT4:
@@ -3531,7 +3660,7 @@ TclPrintInstruction(
} else if (opCode == INST_START_CMD && opnd != 1) {
sprintf(suffixBuffer, ", %u cmds start here", opnd);
}
- fprintf(stdout, "%u ", (unsigned int) opnd);
+ Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned int) opnd);
if (instDesc->opTypes[i] == OPERAND_AUX4) {
auxPtr = &codePtr->auxDataArrayPtr[opnd];
}
@@ -3539,11 +3668,11 @@ TclPrintInstruction(
case OPERAND_IDX4:
opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4;
if (opnd >= -1) {
- fprintf(stdout, "%d ", opnd);
+ Tcl_AppendPrintfToObj(bufferObj, "%d ", opnd);
} else if (opnd == -2) {
- fprintf(stdout, "end ");
+ Tcl_AppendPrintfToObj(bufferObj, "end ");
} else {
- fprintf(stdout, "end-%d ", -2-opnd);
+ Tcl_AppendPrintfToObj(bufferObj, "end-%d ", -2-opnd);
}
break;
case OPERAND_LVT1:
@@ -3556,7 +3685,7 @@ TclPrintInstruction(
printLVTindex:
if (localPtr != NULL) {
if (opnd >= localCt) {
- Tcl_Panic("TclPrintInstruction: bad local var index %u (%u locals)",
+ Tcl_Panic("FormatInstruction: bad local var index %u (%u locals)",
(unsigned int) opnd, localCt);
}
for (j = 0; j < opnd; j++) {
@@ -3569,7 +3698,7 @@ TclPrintInstruction(
suffixSrc = localPtr->name;
}
}
- fprintf(stdout, "%%v%u ", (unsigned) opnd);
+ Tcl_AppendPrintfToObj(bufferObj, "%%v%u ", (unsigned) opnd);
break;
case OPERAND_NONE:
default:
@@ -3577,19 +3706,24 @@ TclPrintInstruction(
}
}
if (suffixObj) {
- fprintf(stdout, "\t# ");
- TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40);
+ char *bytes;
+ int length;
+
+ Tcl_AppendToObj(bufferObj, "\t# ", -1);
+ bytes = Tcl_GetStringFromObj(codePtr->objArrayPtr[opnd], &length);
+ PrintSourceToObj(bufferObj, bytes, TclMin(length, 40));
} else if (suffixBuffer[0]) {
- fprintf(stdout, "\t# %s", suffixBuffer);
+ Tcl_AppendPrintfToObj(bufferObj, "\t# %s", suffixBuffer);
if (suffixSrc) {
- TclPrintSource(stdout, suffixSrc, 40);
+ PrintSourceToObj(bufferObj, suffixSrc, 40);
}
}
- fprintf(stdout, "\n");
+ Tcl_AppendToObj(bufferObj, "\n", -1);
if (auxPtr && auxPtr->type->printProc) {
- fprintf(stdout, "\t\t[");
- auxPtr->type->printProc(auxPtr->clientData, codePtr, pcOffset);
- fprintf(stdout, "]\n");
+ Tcl_AppendToObj(bufferObj, "\t\t[", -1);
+ auxPtr->type->printProc(auxPtr->clientData, bufferObj, codePtr,
+ pcOffset);
+ Tcl_AppendToObj(bufferObj, "]\n", -1);
}
return numBytes;
}
@@ -3597,55 +3731,16 @@ TclPrintInstruction(
/*
*----------------------------------------------------------------------
*
- * TclPrintObject --
+ * PrintSourceToObj --
*
- * This procedure prints up to a specified number of characters from the
- * argument Tcl object's string representation to a specified file.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Outputs characters to the specified file.
+ * Appends a quoted representation of a string to a Tcl_Obj.
*
*----------------------------------------------------------------------
*/
-void
-TclPrintObject(
- FILE *outFile, /* The file to print the source to. */
- Tcl_Obj *objPtr, /* Points to the Tcl object whose string
- * representation should be printed. */
- int maxChars) /* Maximum number of chars to print. */
-{
- char *bytes;
- int length;
-
- bytes = Tcl_GetStringFromObj(objPtr, &length);
- TclPrintSource(outFile, bytes, TclMin(length, maxChars));
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclPrintSource --
- *
- * This procedure prints up to a specified number of characters from the
- * argument string to a specified file. It tries to produce legible
- * output by adding backslashes as necessary.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Outputs characters to the specified file.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclPrintSource(
- FILE *outFile, /* The file to print the source to. */
+static void
+PrintSourceToObj(
+ Tcl_Obj *appendObj, /* The object to print the source to. */
const char *stringPtr, /* The string to print. */
int maxChars) /* Maximum number of chars to print. */
{
@@ -3653,40 +3748,39 @@ TclPrintSource(
register int i = 0;
if (stringPtr == NULL) {
- fprintf(outFile, "\"\"");
+ Tcl_AppendToObj(appendObj, "\"\"", -1);
return;
}
- fprintf(outFile, "\"");
+ Tcl_AppendToObj(appendObj, "\"", -1);
p = stringPtr;
for (; (*p != '\0') && (i < maxChars); p++, i++) {
switch (*p) {
case '"':
- fprintf(outFile, "\\\"");
+ Tcl_AppendToObj(appendObj, "\\\"", -1);
continue;
case '\f':
- fprintf(outFile, "\\f");
+ Tcl_AppendToObj(appendObj, "\\f", -1);
continue;
case '\n':
- fprintf(outFile, "\\n");
+ Tcl_AppendToObj(appendObj, "\\n", -1);
continue;
case '\r':
- fprintf(outFile, "\\r");
+ Tcl_AppendToObj(appendObj, "\\r", -1);
continue;
case '\t':
- fprintf(outFile, "\\t");
+ Tcl_AppendToObj(appendObj, "\\t", -1);
continue;
case '\v':
- fprintf(outFile, "\\v");
+ Tcl_AppendToObj(appendObj, "\\v", -1);
continue;
default:
- fprintf(outFile, "%c", *p);
+ Tcl_AppendPrintfToObj(appendObj, "%c", *p);
continue;
}
}
- fprintf(outFile, "\"");
+ Tcl_AppendToObj(appendObj, "\"", -1);
}
-#endif /* TCL_COMPILE_DEBUG */
#ifdef TCL_COMPILE_STATS
/*
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 641963a..c05ba70 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCompile.h,v 1.70.2.7 2007/09/14 16:28:33 dgp Exp $
+ * RCS: @(#) $Id: tclCompile.h,v 1.70.2.8 2007/10/02 20:11:55 dgp Exp $
*/
#ifndef _TCLCOMPILATION
@@ -128,19 +128,19 @@ typedef struct CmdLocation {
*/
typedef struct ECL {
- int srcOffset; /* Command location to find the entry. */
- int nline;
- int *line; /* Line information for all words in the
+ int srcOffset; /* Command location to find the entry. */
+ int nline;
+ int *line; /* Line information for all words in the
* command. */
} ECL;
typedef struct ExtCmdLoc {
- int type; /* Context type. */
- Tcl_Obj *path; /* Path of the sourced file the command is
+ int type; /* Context type. */
+ Tcl_Obj *path; /* Path of the sourced file the command is
* in. */
- ECL *loc; /* Command word locations (lines). */
- int nloc; /* Number of allocated entries in 'loc'. */
- int nuloc; /* Number of used entries in 'loc'. */
+ ECL *loc; /* Command word locations (lines). */
+ int nloc; /* Number of allocated entries in 'loc'. */
+ int nuloc; /* Number of used entries in 'loc'. */
} ExtCmdLoc;
/*
@@ -161,7 +161,8 @@ typedef struct ExtCmdLoc {
typedef ClientData (AuxDataDupProc) (ClientData clientData);
typedef void (AuxDataFreeProc) (ClientData clientData);
typedef void (AuxDataPrintProc)(ClientData clientData,
- struct ByteCode *codePtr, unsigned int pcOffset);
+ Tcl_Obj *appendObj, struct ByteCode *codePtr,
+ unsigned int pcOffset);
/*
* We define a separate AuxDataType struct to hold type-related information
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 2e8af5d..a8a609f 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInt.h,v 1.310.2.10 2007/09/14 16:28:34 dgp Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.310.2.11 2007/10/02 20:11:56 dgp Exp $
*/
#ifndef _TCLINT
@@ -2565,6 +2565,7 @@ MODULE_SCOPE void TclFinalizeThreadStorage(void);
MODULE_SCOPE Tcl_WideInt TclpGetWideClicks(void);
MODULE_SCOPE Tcl_WideInt TclpWideClicksToNanoseconds(Tcl_WideInt clicks);
#endif
+MODULE_SCOPE Tcl_Obj * TclDisassembleByteCodeObj(Tcl_Obj *objPtr);
/*
*----------------------------------------------------------------
@@ -2627,6 +2628,9 @@ MODULE_SCOPE int TclDefaultBgErrorHandlerObjCmd(
MODULE_SCOPE int Tcl_DictObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]);
+MODULE_SCOPE int Tcl_DisassembleObjCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]);
MODULE_SCOPE int Tcl_EncodingObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]);
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 2fa6764..44813f1 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclProc.c,v 1.115.2.12 2007/09/14 16:28:34 dgp Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.115.2.13 2007/10/02 20:11:57 dgp Exp $
*/
#include "tclInt.h"
@@ -1520,7 +1520,7 @@ PushProcCallFrame(
CallFrame *framePtr, **framePtrPtr;
int result;
ByteCode *codePtr;
-
+
/*
* If necessary (i.e. if we haven't got a suitable compilation already
* cached) compile the procedure's body. The compiler will allocate frame
@@ -2729,6 +2729,130 @@ MakeLambdaError(
(overflow ? "..." : ""), interp->errorLine));
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_DisassembleObjCmd --
+ *
+ * Implementation of the "::tcl::unsupported::disassemble" command. This
+ * command is not documented, but will disassemble procedures, lambda
+ * terms and general scripts. Note that will compile terms if necessary
+ * in order to disassemble them.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+Tcl_DisassembleObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *CONST objv[]) /* Argument objects. */
+{
+ static const char *types[] = {
+ "lambda", "proc", "script", NULL
+ };
+ enum Types {
+ DISAS_LAMBDA, DISAS_PROC, DISAS_SCRIPT
+ };
+ int idx, result;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "type procName|lambdaTerm|script");
+ return TCL_ERROR;
+ }
+ if (Tcl_GetIndexFromObj(interp, objv[1], types, "type", 0, &idx)!=TCL_OK){
+ return TCL_ERROR;
+ }
+
+ switch ((enum Types) idx) {
+ case DISAS_LAMBDA: {
+ Proc *procPtr = NULL;
+ Command cmd;
+ Tcl_Obj *nsObjPtr;
+ Tcl_Namespace *nsPtr;
+
+ /*
+ * Compile (if uncompiled) and disassemble a lambda term.
+ */
+
+ if (objv[2]->typePtr == &lambdaType) {
+ procPtr = objv[2]->internalRep.twoPtrValue.ptr1;
+ }
+ if (procPtr == NULL || procPtr->iPtr != (Interp *) interp) {
+ result = SetLambdaFromAny(interp, objv[2]);
+ if (result != TCL_OK) {
+ return result;
+ }
+ procPtr = objv[2]->internalRep.twoPtrValue.ptr1;
+ }
+
+ memset(&cmd, 0, sizeof(Command));
+ nsObjPtr = objv[2]->internalRep.twoPtrValue.ptr2;
+ result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr);
+ if (result != TCL_OK) {
+ return result;
+ }
+ cmd.nsPtr = (Namespace *) nsPtr;
+ procPtr->cmdPtr = &cmd;
+ result = PushProcCallFrame(procPtr, interp, objc, objv, 1);
+ if (result != TCL_OK) {
+ return result;
+ }
+ TclPopStackFrame(interp);
+ if (((ByteCode *) procPtr->bodyPtr->internalRep.otherValuePtr)->flags
+ & TCL_BYTECODE_PRECOMPILED) {
+ Tcl_AppendResult(interp, "may not disassemble prebuilt bytecode",
+ NULL);
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(procPtr->bodyPtr));
+ break;
+ }
+ case DISAS_PROC: {
+ Proc *procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2]));
+
+ if (procPtr == NULL) {
+ Tcl_AppendResult(interp, "\"", TclGetString(objv[2]),
+ "\" isn't a procedure", NULL);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Compile (if uncompiled) and disassemble a procedure.
+ */
+
+ result = PushProcCallFrame(procPtr, interp, 2, objv+1, 1);
+ if (result != TCL_OK) {
+ return result;
+ }
+ TclPopStackFrame(interp);
+ if (((ByteCode *) procPtr->bodyPtr->internalRep.otherValuePtr)->flags
+ & TCL_BYTECODE_PRECOMPILED) {
+ Tcl_AppendResult(interp, "may not disassemble prebuilt bytecode",
+ NULL);
+ return TCL_ERROR;
+ }
+ Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(procPtr->bodyPtr));
+ break;
+ }
+ case DISAS_SCRIPT:
+ /*
+ * Compile and disassemble a script.
+ */
+
+ if (objv[2]->typePtr != &tclByteCodeType) {
+ if (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK){
+ return TCL_ERROR;
+ }
+ }
+ Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(objv[2]));
+ break;
+ }
+ return TCL_OK;
+}
+
/*
* Local Variables:
* mode: c
diff --git a/library/init.tcl b/library/init.tcl
index 1114ad4..e456f3c 100644
--- a/library/init.tcl
+++ b/library/init.tcl
@@ -3,7 +3,7 @@
# Default system startup file for Tcl-based applications. Defines
# "unknown" procedure and auto-load facilities.
#
-# RCS: @(#) $Id: init.tcl,v 1.91.2.3 2007/09/04 17:43:59 dgp Exp $
+# RCS: @(#) $Id: init.tcl,v 1.91.2.4 2007/10/02 20:11:58 dgp Exp $
#
# Copyright (c) 1991-1993 The Regents of the University of California.
# Copyright (c) 1994-1996 Sun Microsystems, Inc.
@@ -17,7 +17,7 @@
if {[info commands package] == ""} {
error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]"
}
-package require -exact Tcl 8.5b1
+package require -exact Tcl 8.5.0
# Compute the auto path to use in this interpreter.
# The values on the path come from several locations:
diff --git a/library/tclIndex b/library/tclIndex
index 3a435d1..2fcf4a5 100644
--- a/library/tclIndex
+++ b/library/tclIndex
@@ -85,3 +85,4 @@ set auto_index(::tcl::tm::remove) [list source [file join $dir tm.tcl]]
set auto_index(::tcl::tm::list) [list source [file join $dir tm.tcl]]
set auto_index(::tcl::tm::UnknownHandler) [list source [file join $dir tm.tcl]]
set auto_index(::tcl::tm::roots) [list source [file join $dir tm.tcl]]
+set auto_index(::tcl::tm::path) [list source [file join $dir tm.tcl]]
diff --git a/tools/tcl.wse.in b/tools/tcl.wse.in
index 9a6572e..0c4c3b4 100644
--- a/tools/tcl.wse.in
+++ b/tools/tcl.wse.in
@@ -12,7 +12,7 @@ item: Global
Log Pathname=%MAINDIR%\INSTALL.LOG
Message Font=MS Sans Serif
Font Size=8
- Disk Label=tcl8.5b1
+ Disk Label=tcl8.5.0
Disk Filename=setup
Patch Flags=0000000000000001
Patch Threshold=85
diff --git a/unix/README b/unix/README
index 045de75..3fc8212 100644
--- a/unix/README
+++ b/unix/README
@@ -1,7 +1,7 @@
Tcl UNIX README
---------------
-RCS: @(#) $Id: README,v 1.26 2005/12/03 00:41:37 das Exp $
+RCS: @(#) $Id: README,v 1.26.8.1 2007/10/02 20:12:00 dgp Exp $
This is the directory where you configure, compile, test, and install
UNIX versions of Tcl. This directory also contains source files for Tcl
@@ -82,6 +82,10 @@ How To Compile And Install Tcl:
should be reachable under several names.
--enable-man-compression=PROG
Compress the manpages using PROG.
+ --enable-dtrace Enable tcl DTrace provider (if DTrace is
+ available on the platform), c.f. tclDTrace.d
+ for descriptions of the probes made available,
+ see http://wiki.tcl.tk/DTrace for more details.
Mac OS X only:
--enable-framework package Tcl as a framework.
--disable-corefoundation disable use of CoreFoundation API and revert to
diff --git a/unix/configure b/unix/configure
index 7a5702e..a08931a 100755
--- a/unix/configure
+++ b/unix/configure
@@ -1334,7 +1334,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu
TCL_VERSION=8.5
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=5
-TCL_PATCH_LEVEL="b1"
+TCL_PATCH_LEVEL=".0"
VERSION=${TCL_VERSION}
#------------------------------------------------------------------------
diff --git a/unix/configure.in b/unix/configure.in
index 686404d..41ca82b 100644
--- a/unix/configure.in
+++ b/unix/configure.in
@@ -3,7 +3,7 @@ dnl This file is an input file used by the GNU "autoconf" program to
dnl generate the file "configure", which is run during Tcl installation
dnl to configure the system for the local environment.
#
-# RCS: @(#) $Id: configure.in,v 1.157.2.4 2007/09/14 16:28:39 dgp Exp $
+# RCS: @(#) $Id: configure.in,v 1.157.2.5 2007/10/02 20:12:07 dgp Exp $
AC_INIT([tcl],[8.5])
AC_PREREQ(2.59)
@@ -27,7 +27,7 @@ m4_ifdef([SC_USE_CONFIG_HEADERS], [
TCL_VERSION=8.5
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=5
-TCL_PATCH_LEVEL="b1"
+TCL_PATCH_LEVEL=".0"
VERSION=${TCL_VERSION}
#------------------------------------------------------------------------
diff --git a/unix/tcl.spec b/unix/tcl.spec
index 6f952e7..43dd1a8 100644
--- a/unix/tcl.spec
+++ b/unix/tcl.spec
@@ -1,11 +1,11 @@
-# $Id: tcl.spec,v 1.27.2.1 2007/05/22 20:34:29 dgp Exp $
+# $Id: tcl.spec,v 1.27.2.2 2007/10/02 20:12:08 dgp Exp $
# This file is the basis for a binary Tcl RPM for Linux.
%{!?directory:%define directory /usr/local}
Name: tcl
Summary: Tcl scripting language development environment
-Version: 8.5b1
+Version: 8.5.0
Release: 2
License: BSD
Group: Development/Languages
diff --git a/win/configure b/win/configure
index eb76682..5827150 100755
--- a/win/configure
+++ b/win/configure
@@ -1267,7 +1267,7 @@ SHELL=/bin/sh
TCL_VERSION=8.5
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=5
-TCL_PATCH_LEVEL="b1"
+TCL_PATCH_LEVEL=".0"
VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION
TCL_DDE_VERSION=1.3
diff --git a/win/configure.in b/win/configure.in
index 8e2ca72..9211cd9 100644
--- a/win/configure.in
+++ b/win/configure.in
@@ -3,7 +3,7 @@
# generate the file "configure", which is run during Tcl installation
# to configure the system for the local environment.
#
-# RCS: @(#) $Id: configure.in,v 1.92.2.2 2007/09/04 17:44:26 dgp Exp $
+# RCS: @(#) $Id: configure.in,v 1.92.2.3 2007/10/02 20:12:09 dgp Exp $
AC_INIT(../generic/tcl.h)
AC_PREREQ(2.59)
@@ -16,7 +16,7 @@ SHELL=/bin/sh
TCL_VERSION=8.5
TCL_MAJOR_VERSION=8
TCL_MINOR_VERSION=5
-TCL_PATCH_LEVEL="b1"
+TCL_PATCH_LEVEL=".0"
VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION
TCL_DDE_VERSION=1.3
generated by cgit v0.12 at 2025-09-15 10:01:20 (GMT)