summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authordgp <dgp@users.sourceforge.net>2016-04-20 16:44:13 (GMT)
committerdgp <dgp@users.sourceforge.net>2016-04-20 16:44:13 (GMT)
commit1bbd13e8395085f6afe23f0ac7d7cc91eae3cade (patch)
treedeba5d0dcb60194537aea304ca412bd52ef3c1b6 /generic
parent66032e8a327e0498b0d8970307452f66c69be25c (diff)
parent049650b5952e5e5ee1997772750450305dccc6d7 (diff)
downloadtcl-1bbd13e8395085f6afe23f0ac7d7cc91eae3cade.zip
tcl-1bbd13e8395085f6afe23f0ac7d7cc91eae3cade.tar.gz
tcl-1bbd13e8395085f6afe23f0ac7d7cc91eae3cade.tar.bz2
Merge 8.6.5little
Diffstat (limited to 'generic')
-rw-r--r--generic/Lcompile.c2
-rw-r--r--generic/regc_nfa.c12
-rw-r--r--generic/regcustom.h8
-rw-r--r--generic/regex.h60
-rw-r--r--generic/tcl.decls4
-rw-r--r--generic/tcl.h4
-rw-r--r--generic/tclBasic.c10
-rw-r--r--generic/tclClock.c9
-rw-r--r--generic/tclCmdIL.c10
-rw-r--r--generic/tclCompCmds.c45
-rw-r--r--generic/tclCompile.c170
-rw-r--r--generic/tclCompile.h13
-rw-r--r--generic/tclDisassemble.c109
-rw-r--r--generic/tclEnv.c6
-rw-r--r--generic/tclExecute.c5
-rw-r--r--generic/tclIO.c2
-rw-r--r--generic/tclIOSock.c7
-rw-r--r--generic/tclInt.decls5
-rw-r--r--generic/tclInt.h12
-rw-r--r--generic/tclInterp.c1
-rw-r--r--generic/tclListObj.c40
-rw-r--r--generic/tclOO.c114
-rw-r--r--generic/tclOO.h2
-rw-r--r--generic/tclOODefineCmds.c18
-rw-r--r--generic/tclOOInfo.c12
-rw-r--r--generic/tclOOInt.h3
-rw-r--r--generic/tclStubInit.c3
-rw-r--r--generic/tclTest.c67
-rw-r--r--generic/tclTestProcBodyObj.c2
-rw-r--r--generic/tclThreadTest.c6
-rw-r--r--generic/tclTomMath.decls23
-rw-r--r--generic/tclTomMathDecls.h17
-rw-r--r--generic/tclTrace.c3
-rw-r--r--generic/tclUtil.c7
-rw-r--r--generic/tclZlib.c122
35 files changed, 530 insertions, 403 deletions
diff --git a/generic/Lcompile.c b/generic/Lcompile.c
index 38fb447..c1e5973 100644
--- a/generic/Lcompile.c
+++ b/generic/Lcompile.c
@@ -4536,7 +4536,7 @@ compile_foreachArray(ForEach *loop)
varlist->varIndexes[i] = s->idx;
}
info->varLists[0] = varlist;
- infoIndex = TclCreateAuxData(info, &tclForeachInfoType,
+ infoIndex = TclCreateAuxData(info, TclGetAuxDataType("ForeachInfo"),
L->frame->envPtr);
/* The values to iterate through are already on the stack (the
diff --git a/generic/regc_nfa.c b/generic/regc_nfa.c
index 0e0343e..088c6c0 100644
--- a/generic/regc_nfa.c
+++ b/generic/regc_nfa.c
@@ -293,7 +293,7 @@ newarc(
}
}
}
-
+
/* no dup, so create the arc */
createarc(nfa, t, co, from, to);
}
@@ -657,7 +657,7 @@ sortins_cmp(
}
return 0;
}
-
+
/*
* sortouts - sort the out arcs of a state by to/color/type
*/
@@ -2020,7 +2020,7 @@ fixempties(
arcarray[arccount++] = a;
}
}
-
+
/* Reset the tmp fields as we walk back */
nexts = s2->tmp;
s2->tmp = NULL;
@@ -2042,7 +2042,7 @@ fixempties(
}
inarcsorig[s->no] = a;
}
-
+
FREE(arcarray);
FREE(inarcsorig);
@@ -2193,7 +2193,7 @@ fixconstraintloops(
dropstate(nfa, s);
}
}
-
+
/* Nothing to do if no remaining constraint arcs */
if (NISERR() || !hasconstraints) {
return;
@@ -2909,7 +2909,7 @@ carc_cmp(
{
const struct carc *aa = (const struct carc *) a;
const struct carc *bb = (const struct carc *) b;
-
+
if (aa->co < bb->co) {
return -1;
}
diff --git a/generic/regcustom.h b/generic/regcustom.h
index 1c970ea..681b97d 100644
--- a/generic/regcustom.h
+++ b/generic/regcustom.h
@@ -60,12 +60,6 @@
#ifdef __REG_REGOFF_T
#undef __REG_REGOFF_T
#endif
-#ifdef __REG_VOID_T
-#undef __REG_VOID_T
-#endif
-#ifdef __REG_CONST
-#undef __REG_CONST
-#endif
#ifdef __REG_NOFRONT
#undef __REG_NOFRONT
#endif
@@ -75,8 +69,6 @@
/* Interface types */
#define __REG_WIDE_T Tcl_UniChar
#define __REG_REGOFF_T long /* Not really right, but good enough... */
-#define __REG_VOID_T void
-#define __REG_CONST const
/* Names and declarations */
#define __REG_WIDE_COMPILE TclReComp
#define __REG_WIDE_EXEC TclReExec
diff --git a/generic/regex.h b/generic/regex.h
index 53450e5..8845f72 100644
--- a/generic/regex.h
+++ b/generic/regex.h
@@ -92,12 +92,6 @@ extern "C" {
#ifdef __REG_REGOFF_T
#undef __REG_REGOFF_T
#endif
-#ifdef __REG_VOID_T
-#undef __REG_VOID_T
-#endif
-#ifdef __REG_CONST
-#undef __REG_CONST
-#endif
#ifdef __REG_NOFRONT
#undef __REG_NOFRONT
#endif
@@ -107,8 +101,6 @@ extern "C" {
/* interface types */
#define __REG_WIDE_T Tcl_UniChar
#define __REG_REGOFF_T long /* not really right, but good enough... */
-#define __REG_VOID_T void
-#define __REG_CONST const
/* names and declarations */
#define __REG_WIDE_COMPILE TclReComp
#define __REG_WIDE_EXEC TclReExec
@@ -134,26 +126,6 @@ typedef long regoff_t;
#endif
/*
- * For benefit of old compilers, we offer <sys/types.h> the option of
- * overriding the `void' type used to declare nonexistent return types.
- */
-#ifdef __REG_VOID_T
-typedef __REG_VOID_T re_void;
-#else
-typedef void re_void;
-#endif
-
-/*
- * Also for benefit of old compilers, <sys/types.h> can supply a macro which
- * expands to a substitute for `const'.
- */
-#ifndef __REG_CONST
-#define __REG_CONST const
-#endif
-
-
-
-/*
* other interface types
*/
@@ -197,13 +169,13 @@ typedef struct {
/*
* compilation
^ #ifndef __REG_NOCHAR
- ^ int re_comp(regex_t *, __REG_CONST char *, size_t, int);
+ ^ int re_comp(regex_t *, const char *, size_t, int);
^ #endif
^ #ifndef __REG_NOFRONT
- ^ int regcomp(regex_t *, __REG_CONST char *, int);
+ ^ int regcomp(regex_t *, const char *, int);
^ #endif
^ #ifdef __REG_WIDE_T
- ^ int __REG_WIDE_COMPILE(regex_t *, __REG_CONST __REG_WIDE_T *, size_t, int);
+ ^ int __REG_WIDE_COMPILE(regex_t *, const __REG_WIDE_T *, size_t, int);
^ #endif
*/
#define REG_BASIC 000000 /* BREs (convenience) */
@@ -228,14 +200,14 @@ typedef struct {
/*
* execution
^ #ifndef __REG_NOCHAR
- ^ int re_exec(regex_t *, __REG_CONST char *, size_t,
+ ^ int re_exec(regex_t *, const char *, size_t,
^ rm_detail_t *, size_t, regmatch_t [], int);
^ #endif
^ #ifndef __REG_NOFRONT
- ^ int regexec(regex_t *, __REG_CONST char *, size_t, regmatch_t [], int);
+ ^ int regexec(regex_t *, const char *, size_t, regmatch_t [], int);
^ #endif
^ #ifdef __REG_WIDE_T
- ^ int __REG_WIDE_EXEC(regex_t *, __REG_CONST __REG_WIDE_T *, size_t,
+ ^ int __REG_WIDE_EXEC(regex_t *, const __REG_WIDE_T *, size_t,
^ rm_detail_t *, size_t, regmatch_t [], int);
^ #endif
*/
@@ -248,7 +220,7 @@ typedef struct {
/*
* misc generics (may be more functions here eventually)
- ^ re_void regfree(regex_t *);
+ ^ void regfree(regex_t *);
*/
/*
@@ -260,7 +232,7 @@ typedef struct {
* of character is used for error reports is independent of what kind is used
* in matching.
*
- ^ extern size_t regerror(int, __REG_CONST regex_t *, char *, size_t);
+ ^ extern size_t regerror(int, const regex_t *, char *, size_t);
*/
#define REG_OKAY 0 /* no errors detected */
#define REG_NOMATCH 1 /* failed to match */
@@ -293,25 +265,25 @@ typedef struct {
/* automatically gathered by fwd; do not hand-edit */
/* === regproto.h === */
#ifndef __REG_NOCHAR
-int re_comp(regex_t *, __REG_CONST char *, size_t, int);
+int re_comp(regex_t *, const char *, size_t, int);
#endif
#ifndef __REG_NOFRONT
-int regcomp(regex_t *, __REG_CONST char *, int);
+int regcomp(regex_t *, const char *, int);
#endif
#ifdef __REG_WIDE_T
-MODULE_SCOPE int __REG_WIDE_COMPILE(regex_t *, __REG_CONST __REG_WIDE_T *, size_t, int);
+MODULE_SCOPE int __REG_WIDE_COMPILE(regex_t *, const __REG_WIDE_T *, size_t, int);
#endif
#ifndef __REG_NOCHAR
-int re_exec(regex_t *, __REG_CONST char *, size_t, rm_detail_t *, size_t, regmatch_t [], int);
+int re_exec(regex_t *, const char *, size_t, rm_detail_t *, size_t, regmatch_t [], int);
#endif
#ifndef __REG_NOFRONT
-int regexec(regex_t *, __REG_CONST char *, size_t, regmatch_t [], int);
+int regexec(regex_t *, const char *, size_t, regmatch_t [], int);
#endif
#ifdef __REG_WIDE_T
-MODULE_SCOPE int __REG_WIDE_EXEC(regex_t *, __REG_CONST __REG_WIDE_T *, size_t, rm_detail_t *, size_t, regmatch_t [], int);
+MODULE_SCOPE int __REG_WIDE_EXEC(regex_t *, const __REG_WIDE_T *, size_t, rm_detail_t *, size_t, regmatch_t [], int);
#endif
-MODULE_SCOPE re_void regfree(regex_t *);
-MODULE_SCOPE size_t regerror(int, __REG_CONST regex_t *, char *, size_t);
+MODULE_SCOPE void regfree(regex_t *);
+MODULE_SCOPE size_t regerror(int, const regex_t *, char *, size_t);
/* automatically gathered by fwd; do not hand-edit */
/* =====^!^===== end forwards =====^!^===== */
diff --git a/generic/tcl.decls b/generic/tcl.decls
index 797a5a7..574b49b 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -2,8 +2,8 @@
#
# This file contains the declarations for all supported public
# functions that are exported by the Tcl library via the stubs table.
-# This file is used to generate the tclDecls.h, tclPlatDecls.h,
-# tclStub.c, and tclPlatStub.c files.
+# This file is used to generate the tclDecls.h, tclPlatDecls.h
+# and tclStubInit.c files.
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2001, 2002 by Kevin B. Kenny. All rights reserved.
diff --git a/generic/tcl.h b/generic/tcl.h
index 7280b03..78972c2 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -57,10 +57,10 @@ extern "C" {
#define TCL_MAJOR_VERSION 8
#define TCL_MINOR_VERSION 6
#define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE
-#define TCL_RELEASE_SERIAL 4
+#define TCL_RELEASE_SERIAL 5
#define TCL_VERSION "8.6"
-#define TCL_PATCH_LEVEL "8.6.4"
+#define TCL_PATCH_LEVEL "8.6.5"
/*
*----------------------------------------------------------------------------
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 0cb278b..306123d 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -23,10 +23,7 @@
#include "tclCompile.h"
#include "tommath.h"
#include <math.h>
-
-#if NRE_ENABLE_ASSERTS
#include <assert.h>
-#endif
#define INTERP_STACK_INITIAL_SIZE 2000
#define CORO_STACK_INITIAL_SIZE 200
@@ -946,6 +943,13 @@ Tcl_CreateInterp(void)
TclInitEmbeddedConfigurationInformation(interp);
/*
+ * TIP #440: Declare the name of the script engine to be "Tcl".
+ */
+
+ Tcl_SetVar2(interp, "tcl_platform", "engine", "Tcl",
+ TCL_GLOBAL_ONLY);
+
+ /*
* Compute the byte order of this machine.
*/
diff --git a/generic/tclClock.c b/generic/tclClock.c
index 9d4bcd6..949cb1c 100644
--- a/generic/tclClock.c
+++ b/generic/tclClock.c
@@ -2005,22 +2005,23 @@ ClockSecondsObjCmd(
static void
TzsetIfNecessary(void)
{
- static char *tzWas = NULL; /* Previous value of TZ, protected by
+ static char* tzWas = INT2PTR(-1); /* Previous value of TZ, protected by
* clockMutex. */
const char *tzIsNow; /* Current value of TZ */
Tcl_MutexLock(&clockMutex);
tzIsNow = getenv("TZ");
- if (tzIsNow != NULL && (tzWas == NULL || strcmp(tzIsNow, tzWas) != 0)) {
+ if (tzIsNow != NULL && (tzWas == NULL || tzWas == INT2PTR(-1)
+ || strcmp(tzIsNow, tzWas) != 0)) {
tzset();
- if (tzWas != NULL) {
+ if (tzWas != NULL && tzWas != INT2PTR(-1)) {
ckfree(tzWas);
}
tzWas = ckalloc(strlen(tzIsNow) + 1);
strcpy(tzWas, tzIsNow);
} else if (tzIsNow == NULL && tzWas != NULL) {
tzset();
- ckfree(tzWas);
+ if (tzWas != INT2PTR(-1)) ckfree(tzWas);
tzWas = NULL;
}
Tcl_MutexUnlock(&clockMutex);
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index d08ac02..56456b4 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -2391,7 +2391,10 @@ Tcl_LinsertObjCmd(
Tcl_ListObjAppendElement(NULL, listPtr, objv[3]);
} else {
- Tcl_ListObjReplace(NULL, listPtr, index, 0, (objc-3), &(objv[3]));
+ if (TCL_OK != Tcl_ListObjReplace(interp, listPtr, index, 0,
+ (objc-3), &(objv[3]))) {
+ return TCL_ERROR;
+ }
}
/*
@@ -2787,7 +2790,10 @@ Tcl_LreplaceObjCmd(
* optimize this case away.
*/
- Tcl_ListObjReplace(NULL, listPtr, first, numToDelete, objc-4, objv+4);
+ if (TCL_OK != Tcl_ListObjReplace(interp, listPtr, first, numToDelete,
+ objc-4, objv+4)) {
+ return TCL_ERROR;
+ }
/*
* Set the interpreter's object result.
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 436be2a..09e2144 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -55,7 +55,7 @@ static int CompileDictEachCmd(Tcl_Interp *interp,
* The structures below define the AuxData types defined in this file.
*/
-const AuxDataType tclForeachInfoType = {
+static const AuxDataType foreachInfoType = {
"ForeachInfo", /* name */
DupForeachInfo, /* dupProc */
FreeForeachInfo, /* freeProc */
@@ -63,7 +63,7 @@ const AuxDataType tclForeachInfoType = {
DisassembleForeachInfo /* disassembleProc */
};
-const AuxDataType tclNewForeachInfoType = {
+static const AuxDataType newForeachInfoType = {
"NewForeachInfo", /* name */
DupForeachInfo, /* dupProc */
FreeForeachInfo, /* freeProc */
@@ -71,7 +71,7 @@ const AuxDataType tclNewForeachInfoType = {
DisassembleNewForeachInfo /* disassembleProc */
};
-const AuxDataType tclDictUpdateInfoType = {
+static const AuxDataType dictUpdateInfoType = {
"DictUpdateInfo", /* name */
DupDictUpdateInfo, /* dupProc */
FreeDictUpdateInfo, /* freeProc */
@@ -82,6 +82,39 @@ const AuxDataType tclDictUpdateInfoType = {
/*
*----------------------------------------------------------------------
*
+ * TclGetAuxDataType --
+ *
+ * This procedure looks up an Auxdata type by name.
+ *
+ * Results:
+ * If an AuxData type with name matching "typeName" is found, a pointer
+ * to its AuxDataType structure is returned; otherwise, NULL is returned.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+const AuxDataType *
+TclGetAuxDataType(
+ const char *typeName) /* Name of AuxData type to look up. */
+{
+ if (!strcmp(typeName, foreachInfoType.name)) {
+ return &foreachInfoType;
+ } else if (!strcmp(typeName, newForeachInfoType.name)) {
+ return &newForeachInfoType;
+ } else if (!strcmp(typeName, dictUpdateInfoType.name)) {
+ return &dictUpdateInfoType;
+ } else if (!strcmp(typeName, tclJumptableInfoType.name)) {
+ return &tclJumptableInfoType;
+ }
+ return NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclCompileAppendCmd --
*
* Procedure called to compile the "append" command.
@@ -366,7 +399,7 @@ TclCompileArraySetCmd(
infoPtr->varLists[0]->numVars = 2;
infoPtr->varLists[0]->varIndexes[0] = keyVar;
infoPtr->varLists[0]->varIndexes[1] = valVar;
- infoIndex = TclCreateAuxData(infoPtr, &tclForeachInfoType, envPtr);
+ infoIndex = TclCreateAuxData(infoPtr, &newForeachInfoType, envPtr);
/*
* Start issuing instructions to write to the array.
@@ -1670,7 +1703,7 @@ TclCompileDictUpdateCmd(
* can't be snagged by literal sharing and forced to shimmer dangerously.
*/
- infoIndex = TclCreateAuxData(duiPtr, &tclDictUpdateInfoType, envPtr);
+ infoIndex = TclCreateAuxData(duiPtr, &dictUpdateInfoType, envPtr);
for (i=0 ; i<numVars ; i++) {
CompileWord(envPtr, keyTokenPtrs[i], interp, 2*i+2);
@@ -2633,7 +2666,7 @@ CompileEachloopCmd(
* We will compile the foreach command.
*/
- infoIndex = TclCreateAuxData(infoPtr, &tclNewForeachInfoType, envPtr);
+ infoIndex = TclCreateAuxData(infoPtr, &newForeachInfoType, envPtr);
/*
* Create the collecting object, unshared.
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 2d959c0..9211415 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -18,15 +18,6 @@
#include <assert.h>
/*
- * Table of all AuxData types.
- */
-
-static Tcl_HashTable auxDataTypeTable;
-static int auxDataTypeTableInitialized; /* 0 means not yet initialized. */
-
-TCL_DECLARE_MUTEX(tableMutex)
-
-/*
* Variable that controls whether compilation tracing is enabled and, if so,
* what level of tracing is desired:
* 0: no compilation tracing
@@ -734,7 +725,6 @@ static int IsCompactibleCompileEnv(Tcl_Interp *interp,
#ifdef TCL_COMPILE_STATS
static void RecordByteCodeStats(ByteCode *codePtr);
#endif /* TCL_COMPILE_STATS */
-static void RegisterAuxDataType(const AuxDataType *typePtr);
static int SetByteCodeFromAny(Tcl_Interp *interp,
Tcl_Obj *objPtr);
static void StartExpanding(CompileEnv *envPtr);
@@ -4317,166 +4307,6 @@ TclGetInstructionTable(void)
}
/*
- *--------------------------------------------------------------
- *
- * RegisterAuxDataType --
- *
- * This procedure is called to register a new AuxData type in the table
- * of all AuxData types supported by Tcl.
- *
- * Results:
- * None.
- *
- * Side effects:
- * The type is registered in the AuxData type table. If there was already
- * a type with the same name as in typePtr, it is replaced with the new
- * type.
- *
- *--------------------------------------------------------------
- */
-
-static void
-RegisterAuxDataType(
- const AuxDataType *typePtr) /* Information about object type; storage must
- * be statically allocated (must live forever;
- * will not be deallocated). */
-{
- register Tcl_HashEntry *hPtr;
- int isNew;
-
- Tcl_MutexLock(&tableMutex);
- if (!auxDataTypeTableInitialized) {
- TclInitAuxDataTypeTable();
- }
-
- /*
- * If there's already a type with the given name, remove it.
- */
-
- hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typePtr->name);
- if (hPtr != NULL) {
- Tcl_DeleteHashEntry(hPtr);
- }
-
- /*
- * Now insert the new object type.
- */
-
- hPtr = Tcl_CreateHashEntry(&auxDataTypeTable, typePtr->name, &isNew);
- if (isNew) {
- Tcl_SetHashValue(hPtr, typePtr);
- }
- Tcl_MutexUnlock(&tableMutex);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclGetAuxDataType --
- *
- * This procedure looks up an Auxdata type by name.
- *
- * Results:
- * If an AuxData type with name matching "typeName" is found, a pointer
- * to its AuxDataType structure is returned; otherwise, NULL is returned.
- *
- * Side effects:
- * None.
- *
- *----------------------------------------------------------------------
- */
-
-const AuxDataType *
-TclGetAuxDataType(
- const char *typeName) /* Name of AuxData type to look up. */
-{
- register Tcl_HashEntry *hPtr;
- const AuxDataType *typePtr = NULL;
-
- Tcl_MutexLock(&tableMutex);
- if (!auxDataTypeTableInitialized) {
- TclInitAuxDataTypeTable();
- }
-
- hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typeName);
- if (hPtr != NULL) {
- typePtr = Tcl_GetHashValue(hPtr);
- }
- Tcl_MutexUnlock(&tableMutex);
-
- return typePtr;
-}
-
-/*
- *--------------------------------------------------------------
- *
- * TclInitAuxDataTypeTable --
- *
- * This procedure is invoked to perform once-only initialization of the
- * AuxData type table. It also registers the AuxData types defined in
- * this file.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Initializes the table of defined AuxData types "auxDataTypeTable" with
- * builtin AuxData types defined in this file.
- *
- *--------------------------------------------------------------
- */
-
-void
-TclInitAuxDataTypeTable(void)
-{
- /*
- * The table mutex must already be held before this routine is invoked.
- */
-
- auxDataTypeTableInitialized = 1;
- Tcl_InitHashTable(&auxDataTypeTable, TCL_STRING_KEYS);
-
- /*
- * There are only four AuxData types at this time, so register them here.
- */
-
- RegisterAuxDataType(&tclForeachInfoType);
- RegisterAuxDataType(&tclNewForeachInfoType);
- RegisterAuxDataType(&tclJumptableInfoType);
- RegisterAuxDataType(&tclDictUpdateInfoType);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclFinalizeAuxDataTypeTable --
- *
- * This procedure is called by Tcl_Finalize after all exit handlers have
- * been run to free up storage associated with the table of AuxData
- * types. This procedure is called by TclFinalizeExecution() which is
- * called by Tcl_Finalize().
- *
- * Results:
- * None.
- *
- * Side effects:
- * Deletes all entries in the hash table of AuxData types.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclFinalizeAuxDataTypeTable(void)
-{
- Tcl_MutexLock(&tableMutex);
- if (auxDataTypeTableInitialized) {
- Tcl_DeleteHashTable(&auxDataTypeTable);
- auxDataTypeTableInitialized = 0;
- }
- Tcl_MutexUnlock(&tableMutex);
-}
-
-/*
*----------------------------------------------------------------------
*
* GetCmdLocEncodingSize --
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index ce20f4a..a59b194 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -1013,12 +1013,6 @@ typedef struct ForeachInfo {
* LAST FIELD IN THE STRUCTURE! */
} ForeachInfo;
-MODULE_SCOPE const AuxDataType tclForeachInfoType;
-MODULE_SCOPE const AuxDataType tclNewForeachInfoType;
-
-#define FOREACHINFO(envPtr, index) \
- ((ForeachInfo*)((envPtr)->auxDataArrayPtr[TclGetUInt4AtPtr(index)].clientData))
-
/*
* Structure used to hold information about a switch command that is needed
* during program execution. These structures are stored in CompileEnv and
@@ -1051,11 +1045,6 @@ typedef struct {
* STRUCTURE. */
} DictUpdateInfo;
-MODULE_SCOPE const AuxDataType tclDictUpdateInfoType;
-
-#define DICTUPDATEINFO(envPtr, index) \
- ((DictUpdateInfo*)((envPtr)->auxDataArrayPtr[TclGetUInt4AtPtr(index)].clientData))
-
/*
* ClientData type used by the math operator commands.
*/
@@ -1141,7 +1130,6 @@ MODULE_SCOPE void TclExpandJumpFixupArray(JumpFixupArray *fixupArrayPtr);
MODULE_SCOPE int TclNRExecuteByteCode(Tcl_Interp *interp,
ByteCode *codePtr);
MODULE_SCOPE Tcl_Obj * TclFetchLiteral(CompileEnv *envPtr, unsigned int index);
-MODULE_SCOPE void TclFinalizeAuxDataTypeTable(void);
MODULE_SCOPE int TclFindCompiledLocal(const char *name, int nameChars,
int create, CompileEnv *envPtr);
MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr,
@@ -1149,7 +1137,6 @@ MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr,
int distThreshold);
MODULE_SCOPE void TclFreeCompileEnv(CompileEnv *envPtr);
MODULE_SCOPE void TclFreeJumpFixupArray(JumpFixupArray *fixupArrayPtr);
-MODULE_SCOPE void TclInitAuxDataTypeTable(void);
MODULE_SCOPE void TclInitByteCodeObj(Tcl_Obj *objPtr,
CompileEnv *envPtr);
MODULE_SCOPE void TclInitCompileEnv(Tcl_Interp *interp,
diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c
index 027b2c4..5c1bc37 100644
--- a/generic/tclDisassemble.c
+++ b/generic/tclDisassemble.c
@@ -21,9 +21,15 @@
* Prototypes for procedures defined later in this file:
*/
-static Tcl_Obj * DisassembleByteCodeAsDicts(Tcl_Obj *objPtr);
+static Tcl_Obj * DisassembleByteCodeAsDicts(Tcl_Interp *interp,
+ Tcl_Obj *objPtr);
+static Tcl_Obj * DisassembleByteCodeObj(Tcl_Interp *interp,
+ Tcl_Obj *objPtr);
static int FormatInstruction(ByteCode *codePtr,
const unsigned char *pc, Tcl_Obj *bufferObj);
+static void GetLocationInformation(Tcl_Interp *interp,
+ Proc *procPtr, Tcl_Obj **fileObjPtr,
+ int *linePtr);
static void PrintSourceToObj(Tcl_Obj *appendObj,
const char *stringPtr, int maxChars);
static void UpdateStringOfInstName(Tcl_Obj *objPtr);
@@ -48,6 +54,57 @@ static const Tcl_ObjType tclInstNameType = {
#define BYTECODE(objPtr) \
((ByteCode *) (objPtr)->internalRep.twoPtrValue.ptr1)
+/*
+ *----------------------------------------------------------------------
+ *
+ * GetLocationInformation --
+ *
+ * This procedure looks up the information about where a procedure was
+ * originally declared.
+ *
+ * Results:
+ * Writes to the variables pointed at by fileObjPtr and linePtr.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+GetLocationInformation(
+ Tcl_Interp *interp, /* Where to look up the location
+ * information. */
+ Proc *procPtr, /* What to look up the information for. */
+ Tcl_Obj **fileObjPtr, /* Where to write the information about what
+ * file the code came from. Will be written
+ * to, either with the object (assume shared!)
+ * that describes what the file was, or with
+ * NULL if the information is not
+ * available. */
+ int *linePtr) /* Where to write the information about what
+ * line number represented the start of the
+ * code in question. Will be written to,
+ * either with the line number or with -1 if
+ * the information is not available. */
+{
+ Interp *iPtr = (Interp *) interp;
+ Tcl_HashEntry *hePtr;
+ CmdFrame *cfPtr;
+
+ *fileObjPtr = NULL;
+ *linePtr = -1;
+ if (iPtr != NULL && procPtr != NULL) {
+ hePtr = Tcl_FindHashEntry(iPtr->linePBodyPtr, procPtr);
+ if (hePtr != NULL && (cfPtr = Tcl_GetHashValue(hePtr)) != NULL) {
+ *linePtr = cfPtr->line[0];
+ if (cfPtr->type == TCL_LOCATION_SOURCE) {
+ *fileObjPtr = cfPtr->data.eval.path;
+ }
+ }
+ }
+}
+
#ifdef TCL_COMPILE_DEBUG
/*
*----------------------------------------------------------------------
@@ -68,10 +125,10 @@ static const Tcl_ObjType tclInstNameType = {
void
TclPrintByteCodeObj(
- Tcl_Interp *interp, /* Used only for Tcl_GetStringFromObj. */
+ Tcl_Interp *interp, /* Used only for getting location info. */
Tcl_Obj *objPtr) /* The bytecode object to disassemble. */
{
- Tcl_Obj *bufPtr = TclDisassembleByteCodeObj(objPtr);
+ Tcl_Obj *bufPtr = DisassembleByteCodeObj(interp, objPtr);
fprintf(stdout, "\n%s", TclGetString(bufPtr));
Tcl_DecrRefCount(bufPtr);
@@ -176,7 +233,7 @@ TclPrintSource(
/*
*----------------------------------------------------------------------
*
- * TclDisassembleByteCodeObj --
+ * DisassembleByteCodeObj --
*
* Given an object which is of bytecode type, return a disassembled
* version of the bytecode (in a new refcount 0 object). No guarantees
@@ -185,17 +242,18 @@ TclPrintSource(
*----------------------------------------------------------------------
*/
-Tcl_Obj *
-TclDisassembleByteCodeObj(
+static Tcl_Obj *
+DisassembleByteCodeObj(
+ Tcl_Interp *interp,
Tcl_Obj *objPtr) /* The bytecode object to disassemble. */
{
ByteCode *codePtr = BYTECODE(objPtr);
unsigned char *codeStart, *codeLimit, *pc;
unsigned char *codeDeltaNext, *codeLengthNext;
unsigned char *srcDeltaNext, *srcLengthNext;
- int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i;
+ int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i, line;
Interp *iPtr = (Interp *) *codePtr->interpHandle;
- Tcl_Obj *bufferObj;
+ Tcl_Obj *bufferObj, *fileObj;
char ptrBuf1[20], ptrBuf2[20];
TclNewObj(bufferObj);
@@ -220,6 +278,11 @@ TclDisassembleByteCodeObj(
Tcl_AppendToObj(bufferObj, " Source ", -1);
PrintSourceToObj(bufferObj, codePtr->source,
TclMin(codePtr->numSrcBytes, 55));
+ GetLocationInformation(interp, codePtr->procPtr, &fileObj, &line);
+ if (line > -1 && fileObj != NULL) {
+ Tcl_AppendPrintfToObj(bufferObj, "\n File \"%s\" Line %d",
+ Tcl_GetString(fileObj), line);
+ }
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,
@@ -307,7 +370,7 @@ TclDisassembleByteCodeObj(
rangePtr->catchOffset);
break;
default:
- Tcl_Panic("TclDisassembleByteCodeObj: bad ExceptionRange type %d",
+ Tcl_Panic("DisassembleByteCodeObj: bad ExceptionRange type %d",
rangePtr->type);
}
}
@@ -853,14 +916,16 @@ PrintSourceToObj(
static Tcl_Obj *
DisassembleByteCodeAsDicts(
+ Tcl_Interp *interp, /* Used for looking up the CmdFrame for the
+ * procedure, if one exists. */
Tcl_Obj *objPtr) /* The bytecode-holding value to take apart */
{
ByteCode *codePtr = BYTECODE(objPtr);
Tcl_Obj *description, *literals, *variables, *instructions, *inst;
- Tcl_Obj *aux, *exn, *commands;
+ Tcl_Obj *aux, *exn, *commands, *file;
unsigned char *pc, *opnd, *codeOffPtr, *codeLenPtr, *srcOffPtr, *srcLenPtr;
int codeOffset, codeLength, sourceOffset, sourceLength;
- int i, val;
+ int i, val, line;
/*
* Get the literals from the bytecode.
@@ -1124,6 +1189,13 @@ DisassembleByteCodeAsDicts(
#undef Decode
/*
+ * Get the source file and line number information from the CmdFrame
+ * system if it is available.
+ */
+
+ GetLocationInformation(interp, codePtr->procPtr, &file, &line);
+
+ /*
* Build the overall result.
*/
@@ -1146,6 +1218,15 @@ DisassembleByteCodeAsDicts(
Tcl_NewIntObj(codePtr->maxStackDepth));
Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("exceptdepth", -1),
Tcl_NewIntObj(codePtr->maxExceptDepth));
+ if (line > -1) {
+ Tcl_DictObjPut(NULL, description,
+ Tcl_NewStringObj("initiallinenumber", -1),
+ Tcl_NewIntObj(line));
+ }
+ if (file) {
+ Tcl_DictObjPut(NULL, description,
+ Tcl_NewStringObj("sourcefile", -1), file);
+ }
return description;
}
@@ -1368,9 +1449,11 @@ Tcl_DisassembleObjCmd(
*/
if (PTR2INT(clientData)) {
- Tcl_SetObjResult(interp, DisassembleByteCodeAsDicts(codeObjPtr));
+ Tcl_SetObjResult(interp,
+ DisassembleByteCodeAsDicts(interp, codeObjPtr));
} else {
- Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(codeObjPtr));
+ Tcl_SetObjResult(interp,
+ DisassembleByteCodeObj(interp, codeObjPtr));
}
return TCL_OK;
}
diff --git a/generic/tclEnv.c b/generic/tclEnv.c
index 2cb240d..66ddb57 100644
--- a/generic/tclEnv.c
+++ b/generic/tclEnv.c
@@ -551,7 +551,8 @@ TclGetEnv(
* array.
*
* Results:
- * Always returns NULL to indicate success.
+ * Returns NULL to indicate success, or an error-message if the array
+ * element being handled doesn't exist.
*
* Side effects:
* Environment variable changes get propagated. If the whole "env" array
@@ -609,8 +610,7 @@ EnvTraceProc(
const char *value = TclGetEnv(name2, &valueString);
if (value == NULL) {
- Tcl_UnsetVar2(interp, name1, name2, 0);
- return NULL;
+ return (char *) "no such variable";
}
Tcl_SetVar2(interp, name1, name2, value, 0);
Tcl_DStringFree(&valueString);
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 1510453..60a4c42 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -23,10 +23,7 @@
#include "tommath.h"
#include "Lcompile.h"
#include <math.h>
-
-#if NRE_ENABLE_ASSERTS
#include <assert.h>
-#endif
/*
* Hack to determine whether we may expect IEEE floating point. The hack is
@@ -1217,7 +1214,6 @@ TclCreateExecEnv(
Tcl_MutexLock(&execMutex);
if (!execInitialized) {
- TclInitAuxDataTypeTable();
InitByteCodeExecution(interp);
execInitialized = 1;
}
@@ -1316,7 +1312,6 @@ TclFinalizeExecution(void)
Tcl_MutexLock(&execMutex);
execInitialized = 0;
Tcl_MutexUnlock(&execMutex);
- TclFinalizeAuxDataTypeTable();
}
/*
diff --git a/generic/tclIO.c b/generic/tclIO.c
index 15b37b0..ef79aaf 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -6425,7 +6425,7 @@ TranslateInputEOL(
break;
default:
/* In other modes, at most 2 src bytes become a dst byte. */
- if (srcLen > 2 * dstLen) {
+ if (srcLen/2 > dstLen) {
srcLen = 2 * dstLen;
}
break;
diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c
index 8d8ee67..b435dfa 100644
--- a/generic/tclIOSock.c
+++ b/generic/tclIOSock.c
@@ -171,7 +171,7 @@ TclCreateSocketAddress(
char *native = NULL, portbuf[TCL_INTEGER_SPACE], *portstring;
const char *family = NULL;
Tcl_DString ds;
- int result, i;
+ int result;
if (host != NULL) {
native = Tcl_UtfToExternalDString(NULL, host, -1, &ds);
@@ -279,11 +279,6 @@ TclCreateSocketAddress(
*addrlist = v4head;
}
}
- i = 0;
- for (p = *addrlist; p != NULL; p = p->ai_next) {
- i++;
- }
-
return 1;
}
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index 9f7b106..4e7e422 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -2,9 +2,8 @@
#
# This file contains the declarations for all unsupported
# functions that are exported by the Tcl library. This file
-# is used to generate the tclIntDecls.h, tclIntPlatDecls.h,
-# tclIntStub.c, tclPlatStub.c, tclCompileDecls.h and tclCompileStub.c
-# files
+# is used to generate the tclIntDecls.h, tclIntPlatDecls.h
+# and tclStubInit.c files
#
# Copyright (c) 1998-1999 by Scriptics Corporation.
# Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
diff --git a/generic/tclInt.h b/generic/tclInt.h
index d90fb99..2445455 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3162,7 +3162,6 @@ MODULE_SCOPE void TclFinalizeThreadStorage(void);
MODULE_SCOPE Tcl_WideInt TclpGetWideClicks(void);
MODULE_SCOPE double TclpWideClicksToNanoseconds(Tcl_WideInt clicks);
#endif
-MODULE_SCOPE Tcl_Obj * TclDisassembleByteCodeObj(Tcl_Obj *objPtr);
MODULE_SCOPE int TclZlibInit(Tcl_Interp *interp);
MODULE_SCOPE void * TclpThreadCreateKey(void);
MODULE_SCOPE void TclpThreadDeleteKey(void *keyPtr);
@@ -4505,17 +4504,12 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
/*
*----------------------------------------------------------------------
*
- * Core procedures added to libtommath for bignum manipulation.
+ * Core procedure added to libtommath for bignum manipulation.
*
*----------------------------------------------------------------------
*/
MODULE_SCOPE Tcl_PackageInitProc TclTommath_Init;
-MODULE_SCOPE void TclBNInitBignumFromLong(mp_int *bignum, long initVal);
-MODULE_SCOPE void TclBNInitBignumFromWideInt(mp_int *bignum,
- Tcl_WideInt initVal);
-MODULE_SCOPE void TclBNInitBignumFromWideUInt(mp_int *bignum,
- Tcl_WideUInt initVal);
/*
*----------------------------------------------------------------------
@@ -4866,7 +4860,9 @@ void Tcl_Panic(const char *, ...) __attribute__((analyzer_noreturn));
*/
#define NRE_USE_SMALL_ALLOC 1 /* Only turn off for debugging purposes. */
-#define NRE_ENABLE_ASSERTS 1
+#ifndef NRE_ENABLE_ASSERTS
+#define NRE_ENABLE_ASSERTS 0
+#endif
/*
* This is the main data struct for representing NR commands. It is designed
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 8929102..7f8e4ce 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -1920,7 +1920,6 @@ AliasObjCmd(
cmdv = TclStackAlloc(interp, cmdc * sizeof(Tcl_Obj *));
}
- prefv = &aliasPtr->objPtr;
memcpy(cmdv, prefv, (size_t) (prefc * sizeof(Tcl_Obj *)));
memcpy(cmdv+prefc, objv+1, (size_t) ((objc-1) * sizeof(Tcl_Obj *)));
diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index 72bc6da..031a828 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -859,7 +859,7 @@ Tcl_ListObjReplace(
{
List *listRepPtr;
register Tcl_Obj **elemPtrs;
- int numElems, numRequired, numAfterLast, start, i, j, isShared;
+ int needGrow, numElems, numRequired, numAfterLast, start, i, j, isShared;
if (Tcl_IsShared(listPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace");
@@ -909,14 +909,46 @@ Tcl_ListObjReplace(
count = numElems - first;
}
+ if (objc > LIST_MAX - (numElems - count)) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "max length of a Tcl list (%d elements) exceeded", LIST_MAX));
+ return TCL_ERROR;
+ }
isShared = (listRepPtr->refCount > 1);
- numRequired = numElems - count + objc;
+ numRequired = numElems - count + objc; /* Known <= LIST_MAX */
+ needGrow = numRequired > listRepPtr->maxElemCount;
for (i = 0; i < objc; i++) {
Tcl_IncrRefCount(objv[i]);
}
- if ((numRequired <= listRepPtr->maxElemCount) && !isShared) {
+ if (needGrow && !isShared) {
+ /* Try to use realloc */
+ List *newPtr = NULL;
+ int attempt = 2 * numRequired;
+ if (attempt <= LIST_MAX) {
+ newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
+ }
+ if (newPtr == NULL) {
+ attempt = numRequired + 1 + TCL_MIN_ELEMENT_GROWTH;
+ if (attempt > LIST_MAX) {
+ attempt = LIST_MAX;
+ }
+ newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
+ }
+ if (newPtr == NULL) {
+ attempt = numRequired;
+ newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
+ }
+ if (newPtr) {
+ listRepPtr = newPtr;
+ listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr;
+ elemPtrs = &listRepPtr->elements;
+ listRepPtr->maxElemCount = attempt;
+ needGrow = numRequired > listRepPtr->maxElemCount;
+ }
+ }
+ if (!needGrow && !isShared) {
int shift;
/*
@@ -953,7 +985,7 @@ Tcl_ListObjReplace(
Tcl_Obj **oldPtrs = elemPtrs;
int newMax;
- if (numRequired > listRepPtr->maxElemCount){
+ if (needGrow){
newMax = 2 * numRequired;
} else {
newMax = listRepPtr->maxElemCount;
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 84bb85a..9df5029 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -58,6 +58,8 @@ static const struct {
static Class * AllocClass(Tcl_Interp *interp, Object *useThisObj);
static Object * AllocObject(Tcl_Interp *interp, const char *nameStr,
const char *nsNameStr);
+static void ClearMixins(Class *clsPtr);
+static void ClearSuperclasses(Class *clsPtr);
static int CloneClassMethod(Tcl_Interp *interp, Class *clsPtr,
Method *mPtr, Tcl_Obj *namePtr,
Method **newMPtrPtr);
@@ -896,6 +898,55 @@ ObjectRenamedTrace(
/*
* ----------------------------------------------------------------------
*
+ * ClearMixins, ClearSuperclasses --
+ *
+ * Utility functions for correctly clearing the list of mixins or
+ * superclasses of a class. Will ckfree() the list storage.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static void
+ClearMixins(
+ Class *clsPtr)
+{
+ int i;
+ Class *mixinPtr;
+
+ if (clsPtr->mixins.num == 0) {
+ return;
+ }
+
+ FOREACH(mixinPtr, clsPtr->mixins) {
+ TclOORemoveFromMixinSubs(clsPtr, mixinPtr);
+ }
+ ckfree(clsPtr->mixins.list);
+ clsPtr->mixins.list = NULL;
+ clsPtr->mixins.num = 0;
+}
+
+static void
+ClearSuperclasses(
+ Class *clsPtr)
+{
+ int i;
+ Class *superPtr;
+
+ if (clsPtr->superclasses.num == 0) {
+ return;
+ }
+
+ FOREACH(superPtr, clsPtr->superclasses) {
+ TclOORemoveFromSubclasses(clsPtr, superPtr);
+ }
+ ckfree(clsPtr->superclasses.list);
+ clsPtr->superclasses.list = NULL;
+ clsPtr->superclasses.num = 0;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
* ReleaseClassContents --
*
* Tear down the special class data structure, including deleting all
@@ -951,6 +1002,16 @@ ReleaseClassContents(
}
if (!IsRootClass(oPtr)) {
FOREACH(instancePtr, clsPtr->instances) {
+ int j;
+ if (instancePtr->selfCls == clsPtr) {
+ instancePtr->flags |= CLASS_GONE;
+ }
+ for(j=0 ; j<instancePtr->mixins.num ; j++) {
+ Class *mixin = instancePtr->mixins.list[j];
+ if (mixin == clsPtr) {
+ instancePtr->mixins.list[j] = NULL;
+ }
+ }
if (instancePtr != NULL && !IsRoot(instancePtr)) {
AddRef(instancePtr);
}
@@ -962,13 +1023,11 @@ ReleaseClassContents(
*/
FOREACH(mixinSubclassPtr, clsPtr->mixinSubs) {
- if (mixinSubclassPtr == NULL) {
- continue;
- }
if (!Deleted(mixinSubclassPtr->thisPtr)) {
Tcl_DeleteCommandFromToken(interp,
mixinSubclassPtr->thisPtr->command);
}
+ ClearMixins(mixinSubclassPtr);
DelRef(mixinSubclassPtr->thisPtr);
DelRef(mixinSubclassPtr);
}
@@ -983,12 +1042,13 @@ ReleaseClassContents(
*/
FOREACH(subclassPtr, clsPtr->subclasses) {
- if (subclassPtr == NULL || IsRoot(subclassPtr)) {
+ if (IsRoot(subclassPtr)) {
continue;
}
if (!Deleted(subclassPtr->thisPtr)) {
Tcl_DeleteCommandFromToken(interp, subclassPtr->thisPtr->command);
}
+ ClearSuperclasses(subclassPtr);
DelRef(subclassPtr->thisPtr);
DelRef(subclassPtr);
}
@@ -1131,12 +1191,14 @@ ObjectNamespaceDeleted(
* methods on the object.
*/
- if (!IsRootObject(oPtr)) {
+ if (!IsRootObject(oPtr) && !(oPtr->flags & CLASS_GONE)) {
TclOORemoveFromInstances(oPtr, oPtr->selfCls);
}
FOREACH(mixinPtr, oPtr->mixins) {
- TclOORemoveFromInstances(oPtr, mixinPtr);
+ if (mixinPtr) {
+ TclOORemoveFromInstances(oPtr, mixinPtr);
+ }
}
if (i) {
ckfree(oPtr->mixins.list);
@@ -1182,8 +1244,11 @@ ObjectNamespaceDeleted(
oPtr->metadataPtr = NULL;
}
+ /*
+ * If this was a class, there's additional deletion work to do.
+ */
+
if (clsPtr != NULL) {
- Class *superPtr;
Tcl_ObjectMetadataType *metadataTypePtr;
ClientData value;
@@ -1203,24 +1268,11 @@ ObjectNamespaceDeleted(
ckfree(clsPtr->filters.list);
clsPtr->filters.num = 0;
}
- FOREACH(mixinPtr, clsPtr->mixins) {
- if (!Deleted(mixinPtr->thisPtr)) {
- TclOORemoveFromMixinSubs(clsPtr, mixinPtr);
- }
- }
- if (i) {
- ckfree(clsPtr->mixins.list);
- clsPtr->mixins.num = 0;
- }
- FOREACH(superPtr, clsPtr->superclasses) {
- if (!Deleted(superPtr->thisPtr)) {
- TclOORemoveFromSubclasses(clsPtr, superPtr);
- }
- }
- if (i) {
- ckfree(clsPtr->superclasses.list);
- clsPtr->superclasses.num = 0;
- }
+
+ ClearMixins(clsPtr);
+
+ ClearSuperclasses(clsPtr);
+
if (clsPtr->subclasses.list) {
ckfree(clsPtr->subclasses.list);
clsPtr->subclasses.num = 0;
@@ -1362,9 +1414,7 @@ TclOORemoveFromSubclasses(
return;
removeSubclass:
- if (Deleted(superPtr->thisPtr)) {
- superPtr->subclasses.list[i] = NULL;
- } else {
+ if (!Deleted(superPtr->thisPtr)) {
superPtr->subclasses.num--;
if (i < superPtr->subclasses.num) {
superPtr->subclasses.list[i] =
@@ -1435,9 +1485,7 @@ TclOORemoveFromMixinSubs(
return;
removeSubclass:
- if (Deleted(superPtr->thisPtr)) {
- superPtr->mixinSubs.list[i] = NULL;
- } else {
+ if (!Deleted(superPtr->thisPtr)) {
superPtr->mixinSubs.num--;
if (i < superPtr->mixinSubs.num) {
superPtr->mixinSubs.list[i] =
@@ -1908,13 +1956,13 @@ Tcl_CopyObjectInstance(
*/
FOREACH(mixinPtr, o2Ptr->mixins) {
- if (mixinPtr != o2Ptr->selfCls) {
+ if (mixinPtr && mixinPtr != o2Ptr->selfCls) {
TclOORemoveFromInstances(o2Ptr, mixinPtr);
}
}
DUPLICATE(o2Ptr->mixins, oPtr->mixins, Class *);
FOREACH(mixinPtr, o2Ptr->mixins) {
- if (mixinPtr != o2Ptr->selfCls) {
+ if (mixinPtr && mixinPtr != o2Ptr->selfCls) {
TclOOAddToInstances(o2Ptr, mixinPtr);
}
}
diff --git a/generic/tclOO.h b/generic/tclOO.h
index a7116dc..696908a 100644
--- a/generic/tclOO.h
+++ b/generic/tclOO.h
@@ -24,7 +24,7 @@
* win/tclooConfig.sh
*/
-#define TCLOO_VERSION "1.0.3"
+#define TCLOO_VERSION "1.0.4"
#define TCLOO_PATCHLEVEL TCLOO_VERSION
#include "tcl.h"
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index c3184be..c880754 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -323,7 +323,9 @@ TclOOObjectSetMixins(
if (numMixins == 0) {
if (oPtr->mixins.num != 0) {
FOREACH(mixinPtr, oPtr->mixins) {
- TclOORemoveFromInstances(oPtr, mixinPtr);
+ if (mixinPtr) {
+ TclOORemoveFromInstances(oPtr, mixinPtr);
+ }
}
ckfree(oPtr->mixins.list);
oPtr->mixins.num = 0;
@@ -332,7 +334,7 @@ TclOOObjectSetMixins(
} else {
if (oPtr->mixins.num != 0) {
FOREACH(mixinPtr, oPtr->mixins) {
- if (mixinPtr != oPtr->selfCls) {
+ if (mixinPtr && mixinPtr != oPtr->selfCls) {
TclOORemoveFromInstances(oPtr, mixinPtr);
}
}
@@ -887,6 +889,7 @@ TclOODefineObjCmd(
Tcl_GetCommandFullName(interp, cmd, obj2Ptr);
}
Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);
+ /* TODO: overflow? */
Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-3, objv+3);
Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs);
@@ -1001,6 +1004,7 @@ TclOOObjDefObjCmd(
Tcl_GetCommandFullName(interp, cmd, obj2Ptr);
}
Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);
+ /* TODO: overflow? */
Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-3, objv+3);
Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs);
@@ -1115,6 +1119,7 @@ TclOODefineSelfObjCmd(
Tcl_GetCommandFullName(interp, cmd, obj2Ptr);
}
Tcl_ListObjAppendElement(NULL, objPtr, obj2Ptr);
+ /* TODO: overflow? */
Tcl_ListObjReplace(NULL, objPtr, 1, 0, objc-2, objv+2);
Tcl_ListObjGetElements(NULL, objPtr, &dummy, &objs);
@@ -1210,6 +1215,9 @@ TclOODefineClassObjCmd(
TclOORemoveFromInstances(oPtr, oPtr->selfCls);
oPtr->selfCls = clsPtr;
TclOOAddToInstances(oPtr, oPtr->selfCls);
+ if (!(clsPtr->thisPtr->flags & OBJECT_DELETED)) {
+ oPtr->flags &= ~CLASS_GONE;
+ }
if (oPtr->classPtr != NULL) {
BumpGlobalEpoch(interp, oPtr->classPtr);
} else {
@@ -2506,8 +2514,10 @@ ObjMixinGet(
resultObj = Tcl_NewObj();
FOREACH(mixinPtr, oPtr->mixins) {
- Tcl_ListObjAppendElement(NULL, resultObj,
- TclOOObjectName(interp, mixinPtr->thisPtr));
+ if (mixinPtr) {
+ Tcl_ListObjAppendElement(NULL, resultObj,
+ TclOOObjectName(interp, mixinPtr->thisPtr));
+ }
}
Tcl_SetObjResult(interp, resultObj);
return TCL_OK;
diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c
index 0c22bcf..76eaef5 100644
--- a/generic/tclOOInfo.c
+++ b/generic/tclOOInfo.c
@@ -196,6 +196,9 @@ InfoObjectClassCmd(
}
FOREACH(mixinPtr, oPtr->mixins) {
+ if (!mixinPtr) {
+ continue;
+ }
if (TclOOIsReachable(o2clsPtr, mixinPtr)) {
Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
return TCL_OK;
@@ -467,6 +470,9 @@ InfoObjectIsACmd(
Class *mixinPtr;
FOREACH(mixinPtr, oPtr->mixins) {
+ if (!mixinPtr) {
+ continue;
+ }
if (TclOOIsReachable(o2Ptr->classPtr, mixinPtr)) {
result = 1;
break;
@@ -665,6 +671,9 @@ InfoObjectMixinsCmd(
resultObj = Tcl_NewObj();
FOREACH(mixinPtr, oPtr->mixins) {
+ if (!mixinPtr) {
+ continue;
+ }
Tcl_ListObjAppendElement(NULL, resultObj,
TclOOObjectName(interp, mixinPtr->thisPtr));
}
@@ -1281,6 +1290,9 @@ InfoClassMixinsCmd(
resultObj = Tcl_NewObj();
FOREACH(mixinPtr, clsPtr->mixins) {
+ if (!mixinPtr) {
+ continue;
+ }
Tcl_ListObjAppendElement(NULL, resultObj,
TclOOObjectName(interp, mixinPtr->thisPtr));
}
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index 208e32c..b75ffdb 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -193,6 +193,9 @@ typedef struct Object {
* destroyed. */
#define DESTRUCTOR_CALLED 2 /* Flag to say that the destructor has been
* called. */
+#define CLASS_GONE 4 /* Indicates that the class of this object has
+ * been deleted, and so the object should not
+ * attempt to remove itself from its class. */
#define ROOT_OBJECT 0x1000 /* Flag to say that this object is the root of
* the class hierarchy and should be treated
* specially during teardown. */
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 7d44163..5b7a1cd 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -746,6 +746,9 @@ const TclTomMathStubs tclTomMathStubs = {
TclBN_mp_init_set_int, /* 61 */
TclBN_mp_set_int, /* 62 */
TclBN_mp_cnt_lsb, /* 63 */
+ TclBNInitBignumFromLong, /* 64 */
+ TclBNInitBignumFromWideInt, /* 65 */
+ TclBNInitBignumFromWideUInt, /* 66 */
};
static const TclStubHooks tclStubHooks = {
diff --git a/generic/tclTest.c b/generic/tclTest.c
index 600f5ec..9794f59 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -412,6 +412,12 @@ static int TestNumUtfCharsCmd(ClientData clientData,
static int TestHashSystemHashCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
+
+static int NREUnwind_callback(ClientData data[], Tcl_Interp *interp,
+ int result);
+static int TestNREUnwind(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
static int TestNRELevels(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
@@ -697,6 +703,8 @@ Tcltest_Init(
NULL);
#endif /* TCL_NO_DEPRECATED */
+ Tcl_CreateObjCommand(interp, "testnreunwind", TestNREUnwind,
+ NULL, NULL);
Tcl_CreateObjCommand(interp, "testnrelevels", TestNRELevels,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testinterpresolver", TestInterpResolverCmd,
@@ -958,7 +966,7 @@ AsyncHandlerProc(
listArgv[3] = NULL;
cmd = Tcl_Merge(3, listArgv);
if (interp != NULL) {
- code = Tcl_Eval(interp, cmd);
+ code = Tcl_EvalEx(interp, cmd, -1, 0);
} else {
/*
* this should not happen, but by definition of how async handlers are
@@ -1241,7 +1249,7 @@ TestcmdtraceCmd(
if (strcmp(argv[1], "tracetest") == 0) {
Tcl_DStringInit(&buffer);
cmdTrace = Tcl_CreateTrace(interp, 50000, CmdTraceProc, &buffer);
- result = Tcl_Eval(interp, argv[2]);
+ result = Tcl_EvalEx(interp, argv[2], -1, 0);
if (result == TCL_OK) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL);
@@ -1257,13 +1265,13 @@ TestcmdtraceCmd(
*/
cmdTrace = Tcl_CreateTrace(interp, 50000, CmdTraceDeleteProc, NULL);
- Tcl_Eval(interp, argv[2]);
+ Tcl_EvalEx(interp, argv[2], -1, 0);
} else if (strcmp(argv[1], "leveltest") == 0) {
Interp *iPtr = (Interp *) interp;
Tcl_DStringInit(&buffer);
cmdTrace = Tcl_CreateTrace(interp, iPtr->numLevels + 4, CmdTraceProc,
&buffer);
- result = Tcl_Eval(interp, argv[2]);
+ result = Tcl_EvalEx(interp, argv[2], -1, 0);
if (result == TCL_OK) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL);
@@ -1987,7 +1995,7 @@ EncodingToUtfProc(
TclEncoding *encodingPtr;
encodingPtr = (TclEncoding *) clientData;
- Tcl_GlobalEval(encodingPtr->interp, encodingPtr->toUtfCmd);
+ Tcl_EvalEx(encodingPtr->interp,encodingPtr->toUtfCmd,-1,TCL_EVAL_GLOBAL);
len = strlen(Tcl_GetStringResult(encodingPtr->interp));
if (len > dstLen) {
@@ -2019,7 +2027,7 @@ EncodingFromUtfProc(
TclEncoding *encodingPtr;
encodingPtr = (TclEncoding *) clientData;
- Tcl_GlobalEval(encodingPtr->interp, encodingPtr->fromUtfCmd);
+ Tcl_EvalEx(encodingPtr->interp, encodingPtr->fromUtfCmd,-1,TCL_EVAL_GLOBAL);
len = strlen(Tcl_GetStringResult(encodingPtr->interp));
if (len > dstLen) {
@@ -4507,7 +4515,7 @@ TestfeventCmd(
return TCL_ERROR;
}
if (interp2 != NULL) {
- code = Tcl_GlobalEval(interp2, argv[2]);
+ code = Tcl_EvalEx(interp2, argv[2], -1, TCL_EVAL_GLOBAL);
Tcl_SetObjResult(interp, Tcl_GetObjResult(interp2));
return code;
} else {
@@ -6846,6 +6854,51 @@ TestgetintCmd(
}
static int
+NREUnwind_callback(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ int none;
+
+ if (data[0] == INT2PTR(-1)) {
+ Tcl_NRAddCallback(interp, NREUnwind_callback, &none, INT2PTR(-1),
+ INT2PTR(-1), NULL);
+ } else if (data[1] == INT2PTR(-1)) {
+ Tcl_NRAddCallback(interp, NREUnwind_callback, data[0], &none,
+ INT2PTR(-1), NULL);
+ } else if (data[2] == INT2PTR(-1)) {
+ Tcl_NRAddCallback(interp, NREUnwind_callback, data[0], data[1],
+ &none, NULL);
+ } else {
+ Tcl_Obj *idata[3];
+ idata[0] = Tcl_NewIntObj((int) ((char *) data[1] - (char *) data[0]));
+ idata[1] = Tcl_NewIntObj((int) ((char *) data[2] - (char *) data[0]));
+ idata[2] = Tcl_NewIntObj((int) ((char *) &none - (char *) data[0]));
+ Tcl_SetObjResult(interp, Tcl_NewListObj(3, idata));
+ }
+ return TCL_OK;
+}
+
+static int
+TestNREUnwind(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ /*
+ * Insure that callbacks effectively run at the proper level during the
+ * unwinding of the NRE stack.
+ */
+
+ Tcl_NRAddCallback(interp, NREUnwind_callback, INT2PTR(-1), INT2PTR(-1),
+ INT2PTR(-1), NULL);
+ return TCL_OK;
+}
+
+
+static int
TestNRELevels(
ClientData clientData,
Tcl_Interp *interp,
diff --git a/generic/tclTestProcBodyObj.c b/generic/tclTestProcBodyObj.c
index 0d3617e..4d32c5a 100644
--- a/generic/tclTestProcBodyObj.c
+++ b/generic/tclTestProcBodyObj.c
@@ -143,7 +143,7 @@ RegisterCommand(
if (cmdTablePtr->exportIt) {
sprintf(buf, "namespace eval %s { namespace export %s }",
namespace, cmdTablePtr->cmdName);
- if (Tcl_Eval(interp, buf) != TCL_OK) {
+ if (Tcl_EvalEx(interp, buf, -1, 0) != TCL_OK) {
return TCL_ERROR;
}
}
diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c
index 02ee038..75f8a15 100644
--- a/generic/tclThreadTest.c
+++ b/generic/tclThreadTest.c
@@ -613,7 +613,7 @@ NewTestThread(
*/
Tcl_Preserve(tsdPtr->interp);
- result = Tcl_Eval(tsdPtr->interp, threadEvalScript);
+ result = Tcl_EvalEx(tsdPtr->interp, threadEvalScript, -1, 0);
if (result != TCL_OK) {
ThreadErrorProc(tsdPtr->interp);
}
@@ -834,7 +834,7 @@ ThreadSend(
if (threadId == Tcl_GetCurrentThread()) {
Tcl_MutexUnlock(&threadMutex);
- return Tcl_GlobalEval(interp, script);
+ return Tcl_EvalEx(interp, script,-1,TCL_EVAL_GLOBAL);
}
/*
@@ -1029,7 +1029,7 @@ ThreadEventProc(
Tcl_Preserve(interp);
Tcl_ResetResult(interp);
Tcl_CreateThreadExitHandler(ThreadFreeProc, threadEventPtr->script);
- code = Tcl_GlobalEval(interp, threadEventPtr->script);
+ code = Tcl_EvalEx(interp, threadEventPtr->script,-1,TCL_EVAL_GLOBAL);
Tcl_DeleteThreadExitHandler(ThreadFreeProc, threadEventPtr->script);
if (code != TCL_OK) {
errorCode = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY);
diff --git a/generic/tclTomMath.decls b/generic/tclTomMath.decls
index ea3abb1..610a031 100644
--- a/generic/tclTomMath.decls
+++ b/generic/tclTomMath.decls
@@ -1,9 +1,8 @@
# tclTomMath.decls --
#
-# This file contains the declarations for the functions in
-# 'libtommath' that are contained within the Tcl library.
-# This file is used to generate the 'tclTomMathDecls.h' and
-# 'tclTomMathStub.c' files.
+# This file contains the declarations for the functions in 'libtommath'
+# that are contained within the Tcl library. This file is used to
+# generate the 'tclTomMathDecls.h' and 'tclStubInit.c' files.
#
# If you edit this file, advance the revision number (and the epoch
# if the new stubs are not backward compatible) in tclTomMathDecls.h
@@ -221,3 +220,19 @@ declare 62 {
declare 63 {
int TclBN_mp_cnt_lsb(const mp_int *a)
}
+
+# Formerly internal API to allow initialisation of bignums without knowing the
+# typedefs of how a bignum works internally.
+declare 64 {
+ void TclBNInitBignumFromLong(mp_int *bignum, long initVal)
+}
+declare 65 {
+ void TclBNInitBignumFromWideInt(mp_int *bignum, Tcl_WideInt initVal)
+}
+declare 66 {
+ void TclBNInitBignumFromWideUInt(mp_int *bignum, Tcl_WideUInt initVal)
+}
+
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/generic/tclTomMathDecls.h b/generic/tclTomMathDecls.h
index 69b095c..2ce9d5a 100644
--- a/generic/tclTomMathDecls.h
+++ b/generic/tclTomMathDecls.h
@@ -279,6 +279,14 @@ EXTERN int TclBN_mp_init_set_int(mp_int *a, unsigned long i);
EXTERN int TclBN_mp_set_int(mp_int *a, unsigned long i);
/* 63 */
EXTERN int TclBN_mp_cnt_lsb(const mp_int *a);
+/* 64 */
+EXTERN void TclBNInitBignumFromLong(mp_int *bignum, long initVal);
+/* 65 */
+EXTERN void TclBNInitBignumFromWideInt(mp_int *bignum,
+ Tcl_WideInt initVal);
+/* 66 */
+EXTERN void TclBNInitBignumFromWideUInt(mp_int *bignum,
+ Tcl_WideUInt initVal);
typedef struct TclTomMathStubs {
int magic;
@@ -348,6 +356,9 @@ typedef struct TclTomMathStubs {
int (*tclBN_mp_init_set_int) (mp_int *a, unsigned long i); /* 61 */
int (*tclBN_mp_set_int) (mp_int *a, unsigned long i); /* 62 */
int (*tclBN_mp_cnt_lsb) (const mp_int *a); /* 63 */
+ void (*tclBNInitBignumFromLong) (mp_int *bignum, long initVal); /* 64 */
+ void (*tclBNInitBignumFromWideInt) (mp_int *bignum, Tcl_WideInt initVal); /* 65 */
+ void (*tclBNInitBignumFromWideUInt) (mp_int *bignum, Tcl_WideUInt initVal); /* 66 */
} TclTomMathStubs;
extern const TclTomMathStubs *tclTomMathStubsPtr;
@@ -490,6 +501,12 @@ extern const TclTomMathStubs *tclTomMathStubsPtr;
(tclTomMathStubsPtr->tclBN_mp_set_int) /* 62 */
#define TclBN_mp_cnt_lsb \
(tclTomMathStubsPtr->tclBN_mp_cnt_lsb) /* 63 */
+#define TclBNInitBignumFromLong \
+ (tclTomMathStubsPtr->tclBNInitBignumFromLong) /* 64 */
+#define TclBNInitBignumFromWideInt \
+ (tclTomMathStubsPtr->tclBNInitBignumFromWideInt) /* 65 */
+#define TclBNInitBignumFromWideUInt \
+ (tclTomMathStubsPtr->tclBNInitBignumFromWideUInt) /* 66 */
#endif /* defined(USE_TCL_STUBS) */
diff --git a/generic/tclTrace.c b/generic/tclTrace.c
index fe52d59..4e74c54 100644
--- a/generic/tclTrace.c
+++ b/generic/tclTrace.c
@@ -1889,7 +1889,8 @@ TraceExecutionProc(
* interpreter.
*/
- traceCode = Tcl_Eval(interp, Tcl_DStringValue(&cmd));
+ traceCode = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd),
+ Tcl_DStringLength(&cmd), 0);
tcmdPtr->flags &= ~TCL_TRACE_EXEC_IN_PROGRESS;
/*
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index 8de0267..2b0fb72 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -1981,7 +1981,11 @@ Tcl_ConcatObj(
continue;
}
if (resPtr) {
- Tcl_ListObjAppendList(NULL, resPtr, objPtr);
+ if (TCL_OK != Tcl_ListObjAppendList(NULL, resPtr, objPtr)) {
+ /* Abandon ship! */
+ Tcl_DecrRefCount(resPtr);
+ goto slow;
+ }
} else {
resPtr = TclListObjCopy(NULL, objPtr);
}
@@ -1992,6 +1996,7 @@ Tcl_ConcatObj(
return resPtr;
}
+ slow:
/*
* Something cannot be determined to be safe, so build the concatenation
* the slow way, using the string representations.
diff --git a/generic/tclZlib.c b/generic/tclZlib.c
index 44dd9e0..50d9a30 100644
--- a/generic/tclZlib.c
+++ b/generic/tclZlib.c
@@ -762,7 +762,7 @@ Tcl_ZlibStreamInit(
*/
if (interp != NULL) {
- if (Tcl_Eval(interp, "::incr ::tcl::zlib::cmdcounter") != TCL_OK) {
+ if (Tcl_EvalEx(interp, "::incr ::tcl::zlib::cmdcounter", -1, 0) != TCL_OK) {
goto error;
}
Tcl_DStringInit(&cmdname);
@@ -1164,6 +1164,14 @@ Tcl_ZlibStreamPut(
zshPtr->stream.next_in = Tcl_GetByteArrayFromObj(data, &size);
zshPtr->stream.avail_in = size;
+ /*
+ * Must not do a zero-length compress. [Bug 25842c161]
+ */
+
+ if (size == 0) {
+ return TCL_OK;
+ }
+
if (HaveDictToSet(zshPtr)) {
e = SetDeflateDictionary(&zshPtr->stream, zshPtr->compDictObj);
if (e != Z_OK) {
@@ -1186,32 +1194,27 @@ Tcl_ZlibStreamPut(
zshPtr->stream.next_out = (Bytef *) dataTmp;
e = deflate(&zshPtr->stream, flush);
- if ((e==Z_OK || e==Z_BUF_ERROR) && (zshPtr->stream.avail_out == 0)) {
- if (outSize - zshPtr->stream.avail_out > 0) {
- /*
- * Output buffer too small.
- */
-
- obj = Tcl_NewByteArrayObj((unsigned char *) dataTmp,
- outSize - zshPtr->stream.avail_out);
+ while (e == Z_BUF_ERROR) {
+ /*
+ * Output buffer too small to hold the data being generated; so
+ * put a new buffer into place after saving the old generated
+ * data to the outData list.
+ */
- /*
- * Now append the compressed data to the outData list.
- */
+ obj = Tcl_NewByteArrayObj((unsigned char *) dataTmp, outSize);
+ Tcl_ListObjAppendElement(NULL, zshPtr->outData, obj);
- Tcl_ListObjAppendElement(NULL, zshPtr->outData, obj);
- }
if (outSize < 0xFFFF) {
outSize = 0xFFFF; /* There may be *lots* of data left to
* output... */
- ckfree(dataTmp);
- dataTmp = ckalloc(outSize);
+ dataTmp = ckrealloc(dataTmp, outSize);
}
zshPtr->stream.avail_out = outSize;
zshPtr->stream.next_out = (Bytef *) dataTmp;
e = deflate(&zshPtr->stream, flush);
}
+
if (e != Z_OK && !(flush==Z_FINISH && e==Z_STREAM_END)) {
if (zshPtr->interp) {
ConvertError(zshPtr->interp, e, zshPtr->stream.adler);
@@ -3106,6 +3109,64 @@ ZlibTransformOutput(
/*
*----------------------------------------------------------------------
*
+ * ZlibTransformFlush --
+ *
+ * How to perform a flush of a compressing transform.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+ZlibTransformFlush(
+ Tcl_Interp *interp,
+ ZlibChannelData *cd,
+ int flushType)
+{
+ int e, len;
+
+ cd->outStream.avail_in = 0;
+ do {
+ /*
+ * Get the bytes to go out of the compression engine.
+ */
+
+ cd->outStream.next_out = (Bytef *) cd->outBuffer;
+ cd->outStream.avail_out = cd->outAllocated;
+
+ e = deflate(&cd->outStream, flushType);
+ if (e != Z_OK && e != Z_BUF_ERROR) {
+ ConvertError(interp, e, cd->outStream.adler);
+ return TCL_ERROR;
+ }
+
+ /*
+ * Write the bytes we've received to the next layer.
+ */
+
+ len = cd->outStream.next_out - (Bytef *) cd->outBuffer;
+ if (len > 0 && Tcl_WriteRaw(cd->parent, cd->outBuffer, len) < 0) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "problem flushing channel: %s",
+ Tcl_PosixError(interp)));
+ return TCL_ERROR;
+ }
+
+ /*
+ * If we get to this point, either we're in the Z_OK or the
+ * Z_BUF_ERROR state. In the former case, we're done. In the latter
+ * case, it's because there's more bytes to go than would fit in the
+ * buffer we provided, and we need to go round again to get some more.
+ *
+ * We also stop the loop if we would have done a zero-length write.
+ * Those can cause problems at the OS level.
+ */
+ } while (len > 0 && e == Z_BUF_ERROR);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* ZlibTransformSetOption --
*
* Writing side of [fconfigure] on our channel.
@@ -3178,32 +3239,7 @@ ZlibTransformSetOption( /* not used */
* Try to actually do the flush now.
*/
- cd->outStream.avail_in = 0;
- while (1) {
- int e;
-
- cd->outStream.next_out = (Bytef *) cd->outBuffer;
- cd->outStream.avail_out = cd->outAllocated;
-
- e = deflate(&cd->outStream, flushType);
- if (e == Z_BUF_ERROR) {
- break;
- } else if (e != Z_OK) {
- ConvertError(interp, e, cd->outStream.adler);
- return TCL_ERROR;
- } else if (cd->outStream.avail_out == 0) {
- break;
- }
-
- if (Tcl_WriteRaw(cd->parent, cd->outBuffer,
- cd->outStream.next_out - (Bytef *) cd->outBuffer)<0) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "problem flushing channel: %s",
- Tcl_PosixError(interp)));
- return TCL_ERROR;
- }
- }
- return TCL_OK;
+ return ZlibTransformFlush(interp, cd, flushType);
}
} else {
if (optionName && strcmp(optionName, "-limit") == 0) {
@@ -3816,7 +3852,7 @@ TclZlibInit(
* commands.
*/
- Tcl_Eval(interp, "namespace eval ::tcl::zlib {variable cmdcounter 0}");
+ Tcl_EvalEx(interp, "namespace eval ::tcl::zlib {variable cmdcounter 0}", -1, 0);
/*
* Create the public scripted interface to this file's functionality.