summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authorjan.nijtmans <nijtmans@users.sourceforge.net>2017-04-13 10:00:43 (GMT)
committerjan.nijtmans <nijtmans@users.sourceforge.net>2017-04-13 10:00:43 (GMT)
commitb9e6ad8c30d7f7b336d09a55bfa1fbcf0ad6d034 (patch)
tree69d60a122f7e49529a41dbbbff1a808319dc1318 /generic
parente1bed6530aea1d09e8256dd2fa27f5682d04a72e (diff)
parent9f8e844f9c423ce1ff450461016db86873db4a45 (diff)
downloadtcl-b9e6ad8c30d7f7b336d09a55bfa1fbcf0ad6d034.zip
tcl-b9e6ad8c30d7f7b336d09a55bfa1fbcf0ad6d034.tar.gz
tcl-b9e6ad8c30d7f7b336d09a55bfa1fbcf0ad6d034.tar.bz2
Diffstat (limited to 'generic')
-rw-r--r--generic/regc_lex.c6
-rw-r--r--generic/regc_locale.c2
-rw-r--r--generic/regc_nfa.c4
-rw-r--r--generic/regcomp.c12
-rw-r--r--generic/regcustom.h7
-rw-r--r--generic/regexec.c4
-rw-r--r--generic/regguts.h34
-rw-r--r--generic/tcl.decls13
-rw-r--r--generic/tcl.h59
-rw-r--r--generic/tclAlloc.c44
-rw-r--r--generic/tclAssembly.c62
-rw-r--r--generic/tclBasic.c120
-rw-r--r--generic/tclBinary.c176
-rw-r--r--generic/tclCkalloc.c100
-rw-r--r--generic/tclClock.c29
-rw-r--r--generic/tclCmdAH.c409
-rw-r--r--generic/tclCmdIL.c61
-rw-r--r--generic/tclCmdMZ.c264
-rw-r--r--generic/tclCompCmds.c110
-rw-r--r--generic/tclCompCmdsSZ.c8
-rw-r--r--generic/tclCompile.c24
-rw-r--r--generic/tclCompile.h8
-rw-r--r--generic/tclConfig.c8
-rw-r--r--generic/tclDecls.h71
-rw-r--r--generic/tclDictObj.c65
-rw-r--r--generic/tclDisassemble.c12
-rw-r--r--generic/tclEncoding.c33
-rw-r--r--generic/tclEnsemble.c16
-rw-r--r--generic/tclEvent.c4
-rw-r--r--generic/tclExecute.c422
-rw-r--r--generic/tclHash.c4
-rw-r--r--generic/tclHistory.c5
-rw-r--r--generic/tclIO.c778
-rw-r--r--generic/tclIO.h2
-rw-r--r--generic/tclIOCmd.c102
-rw-r--r--generic/tclIOGT.c4
-rw-r--r--generic/tclIORChan.c83
-rw-r--r--generic/tclIORTrans.c28
-rw-r--r--generic/tclIOSock.c97
-rw-r--r--generic/tclIOUtil.c58
-rw-r--r--generic/tclIndexObj.c2
-rw-r--r--generic/tclInt.decls2
-rw-r--r--generic/tclInt.h130
-rw-r--r--generic/tclIntPlatDecls.h12
-rw-r--r--generic/tclInterp.c34
-rw-r--r--generic/tclLink.c208
-rw-r--r--generic/tclListObj.c32
-rw-r--r--generic/tclLoad.c57
-rw-r--r--generic/tclNamesp.c12
-rw-r--r--generic/tclOOCall.c2
-rw-r--r--generic/tclOODefineCmds.c12
-rw-r--r--generic/tclOOInt.h2
-rw-r--r--generic/tclObj.c89
-rw-r--r--generic/tclParse.c5
-rw-r--r--generic/tclPathObj.c2
-rw-r--r--generic/tclPipe.c2
-rw-r--r--generic/tclPkg.c144
-rw-r--r--generic/tclPreserve.c10
-rw-r--r--generic/tclProc.c10
-rw-r--r--generic/tclRegexp.c17
-rw-r--r--generic/tclRegexp.h2
-rw-r--r--generic/tclResult.c59
-rw-r--r--generic/tclStrToD.c40
-rw-r--r--generic/tclStringObj.c728
-rw-r--r--generic/tclStringRep.h10
-rw-r--r--generic/tclStubInit.c114
-rw-r--r--generic/tclStubLib.c16
-rw-r--r--generic/tclTest.c229
-rw-r--r--generic/tclTestObj.c51
-rw-r--r--generic/tclThreadAlloc.c51
-rw-r--r--generic/tclThreadTest.c4
-rw-r--r--generic/tclTimer.c12
-rw-r--r--generic/tclTomMath.decls9
-rw-r--r--generic/tclTomMath.h272
-rw-r--r--generic/tclTomMathDecls.h16
-rw-r--r--generic/tclTrace.c8
-rw-r--r--generic/tclUtil.c54
-rw-r--r--generic/tclVar.c20
-rw-r--r--generic/tclZlib.c157
79 files changed, 3916 insertions, 2068 deletions
diff --git a/generic/regc_lex.c b/generic/regc_lex.c
index affcb48..4c8f15f 100644
--- a/generic/regc_lex.c
+++ b/generic/regc_lex.c
@@ -457,7 +457,7 @@ next(
if (ATEOS()) {
FAILW(REG_EESCAPE);
}
- (DISCARD)lexescape(v);
+ (void)lexescape(v);
switch (v->nexttype) { /* not all escapes okay here */
case PLAIN:
return 1;
@@ -716,7 +716,7 @@ next(
}
RETV(PLAIN, *v->now++);
}
- (DISCARD)lexescape(v);
+ (void)lexescape(v);
if (ISERR()) {
FAILW(REG_EESCAPE);
}
@@ -1143,7 +1143,7 @@ skip(
/*
- newline - return the chr for a newline
* This helps confine use of CHR to this source file.
- ^ static chr newline(NOPARMS);
+ ^ static chr newline(void);
*/
static chr
newline(void)
diff --git a/generic/regc_locale.c b/generic/regc_locale.c
index a6958fe..ab3b7f1 100644
--- a/generic/regc_locale.c
+++ b/generic/regc_locale.c
@@ -1227,7 +1227,7 @@ cmp(
const chr *x, const chr *y, /* strings to compare */
size_t len) /* exact length of comparison */
{
- return memcmp(VS(x), VS(y), len*sizeof(chr));
+ return memcmp((void*)(x), (void*)(y), len*sizeof(chr));
}
/*
diff --git a/generic/regc_nfa.c b/generic/regc_nfa.c
index 088c6c0..240fcfe 100644
--- a/generic/regc_nfa.c
+++ b/generic/regc_nfa.c
@@ -843,7 +843,7 @@ moveins(
/*
- copyins - copy in arcs of a state to another state
- ^ static VOID copyins(struct nfa *, struct state *, struct state *, int);
+ ^ static void copyins(struct nfa *, struct state *, struct state *, int);
*/
static void
copyins(
@@ -1100,7 +1100,7 @@ moveouts(
/*
- copyouts - copy out arcs of a state to another state
- ^ static VOID copyouts(struct nfa *, struct state *, struct state *, int);
+ ^ static void copyouts(struct nfa *, struct state *, struct state *, int);
*/
static void
copyouts(
diff --git a/generic/regcomp.c b/generic/regcomp.c
index 211cd70..58d55fb 100644
--- a/generic/regcomp.c
+++ b/generic/regcomp.c
@@ -82,7 +82,7 @@ static int lexescape(struct vars *);
static int lexdigits(struct vars *, int, int, int);
static int brenext(struct vars *, pchr);
static void skip(struct vars *);
-static chr newline(NOPARMS);
+static chr newline(void);
static chr chrnamed(struct vars *, const chr *, const chr *, pchr);
/* === regc_color.c === */
static void initcm(struct vars *, struct colormap *);
@@ -341,13 +341,13 @@ compile(
re->re_info = 0; /* bits get set during parse */
re->re_csize = sizeof(chr);
re->re_guts = NULL;
- re->re_fns = VS(&functions);
+ re->re_fns = (void*)(&functions);
/*
* More complex setup, malloced things.
*/
- re->re_guts = VS(MALLOC(sizeof(struct guts)));
+ re->re_guts = (void*)(MALLOC(sizeof(struct guts)));
if (re->re_guts == NULL) {
return freev(v, REG_ESPACE);
}
@@ -434,7 +434,7 @@ compile(
* Can sacrifice main NFA now, so use it as work area.
*/
- (DISCARD) optimize(v->nfa, debug);
+ (void) optimize(v->nfa, debug);
CNOERR();
makesearch(v, v->nfa);
CNOERR();
@@ -1920,10 +1920,10 @@ nfatree(
assert(t != NULL && t->begin != NULL);
if (t->left != NULL) {
- (DISCARD) nfatree(v, t->left, f);
+ (void) nfatree(v, t->left, f);
}
if (t->right != NULL) {
- (DISCARD) nfatree(v, t->right, f);
+ (void) nfatree(v, t->right, f);
}
return nfanode(v, t, f);
diff --git a/generic/regcustom.h b/generic/regcustom.h
index 681b97d..c4dbc73 100644
--- a/generic/regcustom.h
+++ b/generic/regcustom.h
@@ -36,10 +36,9 @@
* Overrides for regguts.h definitions, if any.
*/
-#define FUNCPTR(name, args) (*name)args
-#define MALLOC(n) VS(attemptckalloc(n))
-#define FREE(p) ckfree(VS(p))
-#define REALLOC(p,n) VS(attemptckrealloc(VS(p),n))
+#define MALLOC(n) (void*)(attemptckalloc(n))
+#define FREE(p) ckfree((void*)(p))
+#define REALLOC(p,n) (void*)(attemptckrealloc((void*)(p),n))
/*
* Do not insert extras between the "begin" and "end" lines - this chunk is
diff --git a/generic/regexec.c b/generic/regexec.c
index 6d12827..128d439 100644
--- a/generic/regexec.c
+++ b/generic/regexec.c
@@ -44,7 +44,7 @@ struct sset { /* state set */
unsigned hash; /* hash of bitvector */
#define HASH(bv, nw) (((nw) == 1) ? *(bv) : hash(bv, nw))
#define HIT(h,bv,ss,nw) ((ss)->hash == (h) && ((nw) == 1 || \
- memcmp(VS(bv), VS((ss)->states), (nw)*sizeof(unsigned)) == 0))
+ memcmp((void*)(bv), (void*)((ss)->states), (nw)*sizeof(unsigned)) == 0))
int flags;
#define STARTER 01 /* the initial state set */
#define POSTSTATE 02 /* includes the goal state */
@@ -268,7 +268,7 @@ exec(
if (st == REG_OKAY && v->pmatch != pmatch && nmatch > 0) {
zapallsubs(pmatch, nmatch);
n = (nmatch < v->nmatch) ? nmatch : v->nmatch;
- memcpy(VS(pmatch), VS(v->pmatch), n*sizeof(regmatch_t));
+ memcpy((void*)(pmatch), (void*)(v->pmatch), n*sizeof(regmatch_t));
}
/*
diff --git a/generic/regguts.h b/generic/regguts.h
index 1ac2465..ad9d5b9 100644
--- a/generic/regguts.h
+++ b/generic/regguts.h
@@ -49,41 +49,15 @@
#include <assert.h>
#endif
-/* voids */
-#ifndef VOID
-#define VOID void /* for function return values */
-#endif
-#ifndef DISCARD
-#define DISCARD void /* for throwing values away */
-#endif
-#ifndef PVOID
-#define PVOID void * /* generic pointer */
-#endif
-#ifndef VS
-#define VS(x) ((void*)(x)) /* cast something to generic ptr */
-#endif
-#ifndef NOPARMS
-#define NOPARMS void /* for empty parm lists */
-#endif
-
-/* function-pointer declarator */
-#ifndef FUNCPTR
-#if __STDC__ >= 1
-#define FUNCPTR(name, args) (*name)args
-#else
-#define FUNCPTR(name, args) (*name)()
-#endif
-#endif
-
/* memory allocation */
#ifndef MALLOC
#define MALLOC(n) malloc(n)
#endif
#ifndef REALLOC
-#define REALLOC(p, n) realloc(VS(p), n)
+#define REALLOC(p, n) realloc(p, n)
#endif
#ifndef FREE
-#define FREE(p) free(VS(p))
+#define FREE(p) free(p)
#endif
/* want size of a char in bits, and max value in bounded quantifiers */
@@ -408,7 +382,7 @@ struct subre {
*/
struct fns {
- void FUNCPTR(free, (regex_t *));
+ void (*free) (regex_t *);
};
/*
@@ -425,7 +399,7 @@ struct guts {
struct cnfa search; /* for fast preliminary search */
int ntree; /* number of subre's, plus one */
struct colormap cmap;
- int FUNCPTR(compare, (const chr *, const chr *, size_t));
+ int (*compare) (const chr *, const chr *, size_t);
struct subre *lacons; /* lookahead-constraint vector */
int nlacons; /* size of lacons */
};
diff --git a/generic/tcl.decls b/generic/tcl.decls
index 574b49b..b2b91a9 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -1059,7 +1059,7 @@ declare 293 {
int Tcl_EvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags)
}
declare 294 {
- void Tcl_ExitThread(int status)
+ TCL_NORETURN void Tcl_ExitThread(int status)
}
declare 295 {
int Tcl_ExternalToUtf(Tcl_Interp *interp, Tcl_Encoding encoding,
@@ -2326,6 +2326,17 @@ declare 630 {
# ----- BASELINE -- FOR -- 8.6.0 ----- #
+# TIP #456
+declare 631 {
+ Tcl_Channel Tcl_OpenTcpServerEx(Tcl_Interp *interp, const char *service,
+ const char *host, unsigned int flags, Tcl_TcpAcceptProc *acceptProc,
+ ClientData callbackData)
+}
+
+# ----- BASELINE -- FOR -- 8.7.0 ----- #
+
+
+
##############################################################################
# Define the platform specific public Tcl interface. These functions are only
diff --git a/generic/tcl.h b/generic/tcl.h
index ded8d0b..6ec47c6 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -41,7 +41,6 @@ extern "C" {
* unix/configure.ac (2 LOC Major, 2 LOC minor, 1 LOC patch)
* win/configure.ac (as above)
* win/tcl.m4 (not patchlevel)
- * win/makefile.bc (not patchlevel) 2 LOC
* README (sections 0 and 2, with and without separator)
* macosx/Tcl.pbproj/project.pbxproj (not patchlevel) 1 LOC
* macosx/Tcl.pbproj/default.pbxuser (not patchlevel) 1 LOC
@@ -376,8 +375,8 @@ typedef long LONG;
* we have one, we can have the other.)
*
* Also defines the following macros:
- * TCL_WIDE_INT_IS_LONG - if wide ints are really longs (i.e. we're on a real
- * 64-bit system.)
+ * TCL_WIDE_INT_IS_LONG - if wide ints are really longs (i.e. we're on a
+ * LP64 system such as modern Solaris or Linux ... not including Win64)
* Tcl_WideAsLong - forgetful converter from wideInt to long.
* Tcl_LongAsWide - sign-extending converter from long to wideInt.
* Tcl_WideAsDouble - converter from wideInt to double.
@@ -394,11 +393,7 @@ typedef long LONG;
#if !defined(TCL_WIDE_INT_TYPE)&&!defined(TCL_WIDE_INT_IS_LONG)
# if defined(_WIN32)
# define TCL_WIDE_INT_TYPE __int64
-# ifdef __BORLANDC__
-# define TCL_LL_MODIFIER "L"
-# else /* __BORLANDC__ */
-# define TCL_LL_MODIFIER "I64"
-# endif /* __BORLANDC__ */
+# define TCL_LL_MODIFIER "I64"
# elif defined(__GNUC__)
# define TCL_WIDE_INT_TYPE long long
# define TCL_LL_MODIFIER "ll"
@@ -424,10 +419,6 @@ typedef TCL_WIDE_INT_TYPE Tcl_WideInt;
typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt;
#ifdef TCL_WIDE_INT_IS_LONG
-# define Tcl_WideAsLong(val) ((long)(val))
-# define Tcl_LongAsWide(val) ((long)(val))
-# define Tcl_WideAsDouble(val) ((double)((long)(val)))
-# define Tcl_DoubleAsWide(val) ((long)((double)(val)))
# ifndef TCL_LL_MODIFIER
# define TCL_LL_MODIFIER "l"
# endif /* !TCL_LL_MODIFIER */
@@ -439,12 +430,13 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt;
# ifndef TCL_LL_MODIFIER
# define TCL_LL_MODIFIER "ll"
# endif /* !TCL_LL_MODIFIER */
-# define Tcl_WideAsLong(val) ((long)((Tcl_WideInt)(val)))
-# define Tcl_LongAsWide(val) ((Tcl_WideInt)((long)(val)))
-# define Tcl_WideAsDouble(val) ((double)((Tcl_WideInt)(val)))
-# define Tcl_DoubleAsWide(val) ((Tcl_WideInt)((double)(val)))
#endif /* TCL_WIDE_INT_IS_LONG */
+#define Tcl_WideAsLong(val) ((long)((Tcl_WideInt)(val)))
+#define Tcl_LongAsWide(val) ((Tcl_WideInt)((long)(val)))
+#define Tcl_WideAsDouble(val) ((double)((Tcl_WideInt)(val)))
+#define Tcl_DoubleAsWide(val) ((Tcl_WideInt)((double)(val)))
+
#if defined(_WIN32)
# ifdef __BORLANDC__
typedef struct stati64 Tcl_StatBuf;
@@ -831,19 +823,20 @@ typedef struct Tcl_Obj {
union { /* The internal representation: */
long longValue; /* - an long integer value. */
double doubleValue; /* - a double-precision floating value. */
- void *otherValuePtr; /* - another, type-specific value,
- not used internally any more. */
+ void *otherValuePtr; /* - another, type-specific value, not used
+ * internally any more. */
Tcl_WideInt wideValue; /* - a long long value. */
struct { /* - internal rep as two pointers.
- * the main use of which is a bignum's
+ * Many uses in Tcl, including a bignum's
* tightly packed fields, where the alloc,
* used and signum flags are packed into
- * ptr2 with everything else hung off ptr1. */
+ * ptr2 with everything else hung off
+ * ptr1. */
void *ptr1;
void *ptr2;
} twoPtrValue;
struct { /* - internal rep as a pointer and a long,
- not used internally any more. */
+ * not used internally any more. */
void *ptr;
unsigned long value;
} ptrAndLongRep;
@@ -1146,8 +1139,13 @@ typedef struct Tcl_DString {
#define TCL_LINK_SHORT 8
#define TCL_LINK_USHORT 9
#define TCL_LINK_UINT 10
+#if defined(TCL_WIDE_INT_IS_LONG) || defined(_WIN32) || defined(__CYGWIN__)
+#define TCL_LINK_LONG ((sizeof(long) != sizeof(int)) ? TCL_LINK_WIDE_INT : TCL_LINK_INT)
+#define TCL_LINK_ULONG ((sizeof(long) != sizeof(int)) ? TCL_LINK_WIDE_UINT : TCL_LINK_UINT)
+#else
#define TCL_LINK_LONG 11
#define TCL_LINK_ULONG 12
+#endif
#define TCL_LINK_FLOAT 13
#define TCL_LINK_WIDE_UINT 14
#define TCL_LINK_READ_ONLY 0x80
@@ -1319,9 +1317,9 @@ typedef struct Tcl_HashSearch {
* TCL_CUSTOM_PTR_KEYS: The keys are pointers to arbitrary types, the
* pointer is stored in the entry.
*
- * While maintaining binary compatability the above have to be distinct values
+ * While maintaining binary compatibility the above have to be distinct values
* as they are used to differentiate between old versions of the hash table
- * which don't have a typePtr and new ones which do. Once binary compatability
+ * which don't have a typePtr and new ones which do. Once binary compatibility
* is discarded in favour of making more wide spread changes TCL_STRING_KEYS
* can be the same as TCL_CUSTOM_TYPE_KEYS, and TCL_ONE_WORD_KEYS can be the
* same as TCL_CUSTOM_PTR_KEYS because they simply determine how the key is
@@ -2371,6 +2369,13 @@ typedef int (Tcl_ArgvGenFuncProc)(ClientData clientData, Tcl_Interp *interp,
/*
*----------------------------------------------------------------------------
+ * Definitions needed for the Tcl_OpenTcpServerEx function. [TIP #456]
+ */
+#define TCL_TCPSERVER_REUSEADDR (1<<0)
+#define TCL_TCPSERVER_REUSEPORT (1<<1)
+
+/*
+ *----------------------------------------------------------------------------
* Single public declaration for NRE.
*/
@@ -2409,10 +2414,6 @@ const char * TclTomMathInitializeStubs(Tcl_Interp *interp,
#endif
/*
- * TODO - tommath stubs export goes here!
- */
-
-/*
* Public functions that are not accessible via the stubs table.
* Tcl_GetMemoryInfo is needed for AOLserver. [Bug 1868171]
*/
@@ -2530,7 +2531,7 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
Tcl_DbNewBignumObj(val, __FILE__, __LINE__)
# undef Tcl_NewBooleanObj
# define Tcl_NewBooleanObj(val) \
- Tcl_DbNewBooleanObj(val, __FILE__, __LINE__)
+ Tcl_DbNewLongObj((val)!=0, __FILE__, __LINE__)
# undef Tcl_NewByteArrayObj
# define Tcl_NewByteArrayObj(bytes, len) \
Tcl_DbNewByteArrayObj(bytes, len, __FILE__, __LINE__)
@@ -2619,7 +2620,9 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
# define Tcl_Ckrealloc Tcl_Realloc
# define Tcl_Return Tcl_SetResult
# define Tcl_TildeSubst Tcl_TranslateFileName
+#if !defined(__APPLE__) /* On OSX, there is a conflict with "mach/mach.h" */
# define panic Tcl_Panic
+#endif
# define panicVA Tcl_PanicVA
#endif /* !TCL_NO_DEPRECATED */
diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c
index cda1f38..64df1a2 100644
--- a/generic/tclAlloc.c
+++ b/generic/tclAlloc.c
@@ -32,7 +32,7 @@
*/
#if defined(_MSC_VER) || defined(__MSVCRT__) || defined(__BORLANDC__)
-typedef unsigned long caddr_t;
+typedef size_t caddr_t;
#endif
/*
@@ -56,7 +56,7 @@ union overhead {
unsigned char magic1; /* other magic number */
#ifndef NDEBUG
unsigned short rmagic; /* range magic number */
- unsigned long size; /* actual block size */
+ size_t size; /* actual block size */
unsigned short unused2; /* padding to 8-byte align */
#endif
} ovu;
@@ -133,7 +133,7 @@ static int allocInit = 0;
* a given block size.
*/
-static unsigned int numMallocs[NBUCKETS+1];
+static size_t numMallocs[NBUCKETS+1];
#endif
#if !defined(NDEBUG)
@@ -148,7 +148,7 @@ static unsigned int numMallocs[NBUCKETS+1];
* Prototypes for functions used only in this file.
*/
-static void MoreCore(int bucket);
+static void MoreCore(size_t bucket);
/*
*-------------------------------------------------------------------------
@@ -254,7 +254,7 @@ TclpAlloc(
unsigned int numBytes) /* Number of bytes to allocate. */
{
register union overhead *overPtr;
- register long bucket;
+ register size_t bucket;
register unsigned amount;
struct block *bigBlockPtr = NULL;
@@ -385,12 +385,12 @@ TclpAlloc(
static void
MoreCore(
- int bucket) /* What bucket to allocat to. */
+ size_t bucket) /* What bucket to allocate to. */
{
register union overhead *overPtr;
- register long size; /* size of desired block */
- long amount; /* amount to allocate */
- int numBlocks; /* how many blocks we get */
+ register size_t size; /* size of desired block */
+ size_t amount; /* amount to allocate */
+ size_t numBlocks; /* how many blocks we get */
struct block *blockPtr;
/*
@@ -398,14 +398,14 @@ MoreCore(
* VAX, I think) or for a negative arg.
*/
- size = 1 << (bucket + 3);
+ size = ((size_t)1) << (bucket + 3);
ASSERT(size > 0);
amount = MAXMALLOC;
numBlocks = amount / size;
ASSERT(numBlocks*size == amount);
- blockPtr = (struct block *) TclpSysAlloc((unsigned)
+ blockPtr = (struct block *) TclpSysAlloc(
(sizeof(struct block) + amount), 1);
/* no more room! */
if (blockPtr == NULL) {
@@ -448,7 +448,7 @@ void
TclpFree(
char *oldPtr) /* Pointer to memory to free. */
{
- register long size;
+ register size_t size;
register union overhead *overPtr;
struct block *bigBlockPtr;
@@ -518,7 +518,7 @@ TclpRealloc(
union overhead *overPtr;
struct block *bigBlockPtr;
int expensive;
- unsigned long maxSize;
+ size_t maxSize;
if (oldPtr == NULL) {
return TclpAlloc(numBytes);
@@ -645,30 +645,30 @@ void
mstats(
char *s) /* Where to write info. */
{
- register int i, j;
+ register unsigned int i, j;
register union overhead *overPtr;
- int totalFree = 0, totalUsed = 0;
+ size_t totalFree = 0, totalUsed = 0;
Tcl_MutexLock(allocMutexPtr);
fprintf(stderr, "Memory allocation statistics %s\nTclpFree:\t", s);
for (i = 0; i < NBUCKETS; i++) {
for (j=0, overPtr=nextf[i]; overPtr; overPtr=overPtr->next, j++) {
- fprintf(stderr, " %d", j);
+ fprintf(stderr, " %u", j);
}
- totalFree += j * (1 << (i + 3));
+ totalFree += ((size_t)j) * (1 << (i + 3));
}
fprintf(stderr, "\nused:\t");
for (i = 0; i < NBUCKETS; i++) {
- fprintf(stderr, " %d", numMallocs[i]);
+ fprintf(stderr, " %" TCL_LL_MODIFIER "d", (Tcl_WideInt)numMallocs[i]);
totalUsed += numMallocs[i] * (1 << (i + 3));
}
- fprintf(stderr, "\n\tTotal small in use: %d, total free: %d\n",
- totalUsed, totalFree);
- fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %d\n",
- MAXMALLOC, numMallocs[NBUCKETS]);
+ fprintf(stderr, "\n\tTotal small in use: %" TCL_LL_MODIFIER "d, total free: %" TCL_LL_MODIFIER "d\n",
+ (Tcl_WideInt)totalUsed, (Tcl_WideInt)totalFree);
+ fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %" TCL_LL_MODIFIER "d\n",
+ MAXMALLOC, (Tcl_WideInt)numMallocs[NBUCKETS]);
Tcl_MutexUnlock(allocMutexPtr);
}
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 06f277f..4c5ae68 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -137,6 +137,8 @@ typedef enum TalInstType {
* ranges */
ASSEM_BOOL, /* One Boolean operand */
ASSEM_BOOL_LVT4, /* One Boolean, one 4-byte LVT ref. */
+ ASSEM_CLOCK_READ, /* 1-byte unsigned-integer case number, in the
+ * range 0-3 */
ASSEM_CONCAT1, /* 1-byte unsigned-integer operand count, must
* be strictly positive, consumes N, produces
* 1 */
@@ -350,6 +352,7 @@ static const TalInstDesc TalInstructionTable[] = {
{"bitnot", ASSEM_1BYTE, INST_BITNOT, 1, 1},
{"bitor", ASSEM_1BYTE, INST_BITOR, 2, 1},
{"bitxor", ASSEM_1BYTE, INST_BITXOR, 2, 1},
+ {"clockRead", ASSEM_CLOCK_READ, INST_CLOCK_READ, 0, 1},
{"concat", ASSEM_CONCAT1, INST_STR_CONCAT1, INT_MIN,1},
{"concatStk", ASSEM_LIST, INST_CONCAT_STK, INT_MIN,1},
{"coroName", ASSEM_1BYTE, INST_COROUTINE_NAME, 0, 1},
@@ -1361,6 +1364,23 @@ AssembleOneLine(
TclEmitInt4(localVar, envPtr);
break;
+ case ASSEM_CLOCK_READ:
+ if (parsePtr->numWords != 2) {
+ Tcl_WrongNumArgs(interp, 1, &instNameObj, "imm8");
+ goto cleanup;
+ }
+ if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
+ goto cleanup;
+ }
+ if (opnd < 0 || opnd > 3) {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("operand must be [0..3]", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ASSEM", "OPERAND<0,>3", NULL);
+ goto cleanup;
+ }
+ BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, opnd);
+ break;
+
case ASSEM_CONCAT1:
if (parsePtr->numWords != 2) {
Tcl_WrongNumArgs(interp, 1, &instNameObj, "imm8");
@@ -1543,7 +1563,7 @@ AssembleOneLine(
* Add the (label_name, address) pair to the hash table.
*/
- if (DefineLabel(assemEnvPtr, Tcl_GetString(operand1Obj)) != TCL_OK) {
+ if (DefineLabel(assemEnvPtr, TclGetString(operand1Obj)) != TCL_OK) {
goto cleanup;
}
break;
@@ -1722,7 +1742,7 @@ AssembleOneLine(
default:
Tcl_Panic("Instruction \"%s\" could not be found, can't happen\n",
- Tcl_GetString(instNameObj));
+ TclGetString(instNameObj));
}
status = TCL_OK;
@@ -1985,15 +2005,15 @@ CreateMirrorJumpTable(
DEBUG_PRINT("jump table {\n");
for (i = 0; i < objc; i+=2) {
- DEBUG_PRINT(" %s -> %s\n", Tcl_GetString(objv[i]),
- Tcl_GetString(objv[i+1]));
- hashEntry = Tcl_CreateHashEntry(jtHashPtr, Tcl_GetString(objv[i]),
+ DEBUG_PRINT(" %s -> %s\n", TclGetString(objv[i]),
+ TclGetString(objv[i+1]));
+ hashEntry = Tcl_CreateHashEntry(jtHashPtr, TclGetString(objv[i]),
&isNew);
if (!isNew) {
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"duplicate entry in jump table for \"%s\"",
- Tcl_GetString(objv[i])));
+ TclGetString(objv[i])));
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPJUMPTABLEENTRY");
DeleteMirrorJumpTable(jtPtr);
return TCL_ERROR;
@@ -2801,7 +2821,7 @@ CalculateJumpRelocations(
if (bbPtr->jumpTarget != NULL) {
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
- Tcl_GetString(bbPtr->jumpTarget));
+ TclGetString(bbPtr->jumpTarget));
if (entry == NULL) {
ReportUndefinedLabel(assemEnvPtr, bbPtr,
bbPtr->jumpTarget);
@@ -2882,10 +2902,10 @@ CheckJumpTableLabels(
symEntryPtr = Tcl_NextHashEntry(&search)) {
symbolObj = Tcl_GetHashValue(symEntryPtr);
valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
- Tcl_GetString(symbolObj));
+ TclGetString(symbolObj));
DEBUG_PRINT(" %s -> %s (%d)\n",
(char*) Tcl_GetHashKey(symHash, symEntryPtr),
- Tcl_GetString(symbolObj), (valEntryPtr != NULL));
+ TclGetString(symbolObj), (valEntryPtr != NULL));
if (valEntryPtr == NULL) {
ReportUndefinedLabel(assemEnvPtr, bbPtr, symbolObj);
return TCL_ERROR;
@@ -2923,9 +2943,9 @@ ReportUndefinedLabel(
if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "undefined label \"%s\"", Tcl_GetString(jumpTarget)));
+ "undefined label \"%s\"", TclGetString(jumpTarget)));
Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOLABEL",
- Tcl_GetString(jumpTarget), NULL);
+ TclGetString(jumpTarget), NULL);
Tcl_SetErrorLine(interp, bbPtr->jumpLine);
}
}
@@ -3008,7 +3028,7 @@ FillInJumpOffsets(
bbPtr = bbPtr->successor1) {
if (bbPtr->jumpTarget != NULL) {
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
- Tcl_GetString(bbPtr->jumpTarget));
+ TclGetString(bbPtr->jumpTarget));
jumpTarget = Tcl_GetHashValue(entry);
fromOffset = bbPtr->jumpOffset;
targetOffset = jumpTarget->startOffset;
@@ -3080,17 +3100,17 @@ ResolveJumpTableTargets(
symEntryPtr != NULL;
symEntryPtr = Tcl_NextHashEntry(&search)) {
symbolObj = Tcl_GetHashValue(symEntryPtr);
- DEBUG_PRINT(" symbol %s\n", Tcl_GetString(symbolObj));
+ DEBUG_PRINT(" symbol %s\n", TclGetString(symbolObj));
valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
- Tcl_GetString(symbolObj));
+ TclGetString(symbolObj));
jumpTargetBBPtr = Tcl_GetHashValue(valEntryPtr);
realJumpEntryPtr = Tcl_CreateHashEntry(realJumpHashPtr,
Tcl_GetHashKey(symHash, symEntryPtr), &junk);
DEBUG_PRINT(" %s -> %s -> bb %p (pc %d) hash entry %p\n",
(char*) Tcl_GetHashKey(symHash, symEntryPtr),
- Tcl_GetString(symbolObj), jumpTargetBBPtr,
+ TclGetString(symbolObj), jumpTargetBBPtr,
jumpTargetBBPtr->startOffset, realJumpEntryPtr);
Tcl_SetHashValue(realJumpEntryPtr,
@@ -3462,7 +3482,7 @@ StackCheckBasicBlock(
if (result == TCL_OK && blockPtr->jumpTarget != NULL) {
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
- Tcl_GetString(blockPtr->jumpTarget));
+ TclGetString(blockPtr->jumpTarget));
jumpTarget = Tcl_GetHashValue(entry);
result = StackCheckBasicBlock(assemEnvPtr, jumpTarget, blockPtr,
stackDepth);
@@ -3479,7 +3499,7 @@ StackCheckBasicBlock(
jtEntry = Tcl_NextHashEntry(&jtSearch)) {
targetLabel = Tcl_GetHashValue(jtEntry);
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
- Tcl_GetString(targetLabel));
+ TclGetString(targetLabel));
jumpTarget = Tcl_GetHashValue(entry);
result = StackCheckBasicBlock(assemEnvPtr, jumpTarget,
blockPtr, stackDepth);
@@ -3784,7 +3804,7 @@ ProcessCatchesInBasicBlock(
}
if (result == TCL_OK && bbPtr->jumpTarget != NULL) {
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
- Tcl_GetString(bbPtr->jumpTarget));
+ TclGetString(bbPtr->jumpTarget));
jumpTarget = Tcl_GetHashValue(entry);
result = ProcessCatchesInBasicBlock(assemEnvPtr, jumpTarget,
jumpEnclosing, jumpState, catchDepth);
@@ -3800,7 +3820,7 @@ ProcessCatchesInBasicBlock(
jtEntry = Tcl_NextHashEntry(&jtSearch)) {
targetLabel = Tcl_GetHashValue(jtEntry);
entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
- Tcl_GetString(targetLabel));
+ TclGetString(targetLabel));
jumpTarget = Tcl_GetHashValue(entry);
result = ProcessCatchesInBasicBlock(assemEnvPtr, jumpTarget,
jumpEnclosing, jumpState, catchDepth);
@@ -4104,7 +4124,7 @@ StackFreshCatches(
range->codeOffset = bbPtr->startOffset;
entryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash,
- Tcl_GetString(catch->jumpTarget));
+ TclGetString(catch->jumpTarget));
if (entryPtr == NULL) {
Tcl_Panic("undefined label in tclAssembly.c:"
"BuildExceptionRanges, can't happen");
@@ -4246,7 +4266,7 @@ AddBasicBlockRangeToErrorInfo(
Tcl_AppendObjToErrorInfo(interp, lineNo);
Tcl_AddErrorInfo(interp, " and ");
if (bbPtr->successor1 != NULL) {
- Tcl_SetIntObj(lineNo, bbPtr->successor1->startLine);
+ TclSetLongObj(lineNo, bbPtr->successor1->startLine);
Tcl_AppendObjToErrorInfo(interp, lineNo);
} else {
Tcl_AddErrorInfo(interp, "end of assembly code");
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 53023d8..c6784a0 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -203,7 +203,7 @@ static const CmdInfo builtInCmds[] = {
{"append", Tcl_AppendObjCmd, TclCompileAppendCmd, NULL, CMD_IS_SAFE},
{"apply", Tcl_ApplyObjCmd, NULL, TclNRApplyObjCmd, CMD_IS_SAFE},
{"break", Tcl_BreakObjCmd, TclCompileBreakCmd, NULL, CMD_IS_SAFE},
-#ifndef EXCLUDE_OBSOLETE_COMMANDS
+#ifndef TCL_NO_DEPRECATED
{"case", Tcl_CaseObjCmd, NULL, NULL, CMD_IS_SAFE},
#endif
{"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, TclNRCatchObjCmd, CMD_IS_SAFE},
@@ -265,7 +265,6 @@ static const CmdInfo builtInCmds[] = {
{"cd", Tcl_CdObjCmd, NULL, NULL, 0},
{"close", Tcl_CloseObjCmd, NULL, NULL, CMD_IS_SAFE},
{"eof", Tcl_EofObjCmd, NULL, NULL, CMD_IS_SAFE},
- {"encoding", Tcl_EncodingObjCmd, NULL, NULL, 0},
{"exec", Tcl_ExecObjCmd, NULL, NULL, 0},
{"exit", Tcl_ExitObjCmd, NULL, NULL, 0},
{"fblocked", Tcl_FblockedObjCmd, NULL, NULL, CMD_IS_SAFE},
@@ -511,7 +510,11 @@ Tcl_CreateInterp(void)
iPtr = ckalloc(sizeof(Interp));
interp = (Tcl_Interp *) iPtr;
+#ifdef TCL_NO_DEPRECATED
+ iPtr->result = &tclEmptyString;
+#else
iPtr->result = iPtr->resultSpace;
+#endif
iPtr->freeProc = NULL;
iPtr->errorLine = 0;
iPtr->objResultPtr = Tcl_NewObj();
@@ -571,9 +574,11 @@ Tcl_CreateInterp(void)
iPtr->rootFramePtr = NULL; /* Initialise as soon as :: is available */
iPtr->lookupNsPtr = NULL;
+#ifndef TCL_NO_DEPRECATED
iPtr->appendResult = NULL;
iPtr->appendAvl = 0;
iPtr->appendUsed = 0;
+#endif
Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS);
iPtr->packageUnknown = NULL;
@@ -588,7 +593,7 @@ Tcl_CreateInterp(void)
iPtr->cmdCount = 0;
TclInitLiteralTable(&iPtr->literalTable);
- iPtr->compileEpoch = 0;
+ iPtr->compileEpoch = 1;
iPtr->compiledProcPtr = NULL;
iPtr->resolverPtr = NULL;
iPtr->evalFlags = 0;
@@ -603,7 +608,9 @@ Tcl_CreateInterp(void)
iPtr->emptyObjPtr = Tcl_NewObj();
/* Another empty object. */
Tcl_IncrRefCount(iPtr->emptyObjPtr);
+#ifndef TCL_NO_DEPRECATED
iPtr->resultSpace[0] = 0;
+#endif
iPtr->threadId = Tcl_GetCurrentThread();
/* TIP #378 */
@@ -790,16 +797,17 @@ Tcl_CreateInterp(void)
}
/*
- * Create the "array", "binary", "chan", "dict", "file", "info",
- * "namespace" and "string" ensembles. Note that all these commands (and
- * their subcommands that are not present in the global namespace) are
- * wholly safe *except* for "file".
+ * Create the "array", "binary", "chan", "clock", "dict", "encoding",
+ * "file", "info", "namespace" and "string" ensembles. Note that all these
+ * commands (and their subcommands that are not present in the global
+ * namespace) are wholly safe *except* for "clock", "encoding" and "file".
*/
TclInitArrayCmd(interp);
TclInitBinaryCmd(interp);
TclInitChanCmd(interp);
TclInitDictCmd(interp);
+ TclInitEncodingCmd(interp);
TclInitFileCmd(interp);
TclInitInfoCmd(interp);
TclInitNamespaceCmd(interp);
@@ -966,11 +974,11 @@ Tcl_CreateInterp(void)
Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs);
if (TclTommath_Init(interp) != TCL_OK) {
- Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp)));
+ Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp)));
}
if (TclOOInit(interp) != TCL_OK) {
- Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp)));
+ Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp)));
}
/*
@@ -980,7 +988,7 @@ Tcl_CreateInterp(void)
#ifdef HAVE_ZLIB
if (TclZlibInit(interp) != TCL_OK) {
- Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp)));
+ Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp)));
}
#endif
@@ -1027,6 +1035,7 @@ TclHideUnsafeCommands(
Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name);
}
}
+ TclMakeEncodingCommandSafe(interp); /* Ugh! */
TclMakeFileCommandSafe(interp); /* Ugh! */
return TCL_OK;
}
@@ -1062,7 +1071,7 @@ Tcl_CallWhenDeleted(
Interp *iPtr = (Interp *) interp;
static Tcl_ThreadDataKey assocDataCounterKey;
int *assocDataCounterPtr =
- Tcl_GetThreadData(&assocDataCounterKey, (int)sizeof(int));
+ Tcl_GetThreadData(&assocDataCounterKey, sizeof(int));
int isNew;
char buffer[32 + TCL_INTEGER_SPACE];
AssocData *dPtr = ckalloc(sizeof(AssocData));
@@ -1534,10 +1543,12 @@ DeleteInterpProc(
if (iPtr->returnOpts) {
Tcl_DecrRefCount(iPtr->returnOpts);
}
+#ifndef TCL_NO_DEPRECATED
if (iPtr->appendResult != NULL) {
ckfree(iPtr->appendResult);
iPtr->appendResult = NULL;
}
+#endif
TclFreePackageInfo(iPtr);
while (iPtr->tracePtr != NULL) {
Tcl_DeleteTrace((Tcl_Interp *) iPtr, (Tcl_Trace) iPtr->tracePtr);
@@ -1635,7 +1646,7 @@ DeleteInterpProc(
}
Tcl_DeleteHashTable(iPtr->lineLAPtr);
- ckfree((char *) iPtr->lineLAPtr);
+ ckfree(iPtr->lineLAPtr);
iPtr->lineLAPtr = NULL;
if (iPtr->lineLABCPtr->numEntries && !TclInExit()) {
@@ -2403,7 +2414,7 @@ TclInvokeStringCommand(
TclStackAlloc(interp, (unsigned)(objc + 1) * sizeof(char *));
for (i = 0; i < objc; i++) {
- argv[i] = Tcl_GetString(objv[i]);
+ argv[i] = TclGetString(objv[i]);
}
argv[objc] = 0;
@@ -2657,7 +2668,7 @@ TclRenameCommand(
}
Tcl_DStringAppend(&newFullName, newTail, -1);
cmdPtr->refCount++;
- CallCommandTraces(iPtr, cmdPtr, Tcl_GetString(oldFullName),
+ CallCommandTraces(iPtr, cmdPtr, TclGetString(oldFullName),
Tcl_DStringValue(&newFullName), TCL_TRACE_RENAME);
Tcl_DStringFree(&newFullName);
@@ -3024,13 +3035,6 @@ Tcl_DeleteCommandFromToken(
Tcl_Command importCmd;
/*
- * Bump the command epoch counter. This will invalidate all cached
- * references that point to this command.
- */
-
- cmdPtr->cmdEpoch++;
-
- /*
* The code here is tricky. We can't delete the hash table entry before
* invoking the deletion callback because there are cases where the
* deletion callback needs to invoke the command (e.g. object systems such
@@ -3052,6 +3056,14 @@ Tcl_DeleteCommandFromToken(
Tcl_DeleteHashEntry(cmdPtr->hPtr);
cmdPtr->hPtr = NULL;
}
+
+ /*
+ * Bump the command epoch counter. This will invalidate all cached
+ * references that point to this command.
+ */
+
+ cmdPtr->cmdEpoch++;
+
return 0;
}
@@ -3154,6 +3166,13 @@ Tcl_DeleteCommandFromToken(
if (cmdPtr->hPtr != NULL) {
Tcl_DeleteHashEntry(cmdPtr->hPtr);
cmdPtr->hPtr = NULL;
+
+ /*
+ * Bump the command epoch counter. This will invalidate all cached
+ * references that point to this command.
+ */
+
+ cmdPtr->cmdEpoch++;
}
/*
@@ -3400,8 +3419,7 @@ TclCleanupCommand(
register Command *cmdPtr) /* Points to the Command structure to
* be freed. */
{
- cmdPtr->refCount--;
- if (cmdPtr->refCount <= 0) {
+ if (cmdPtr->refCount-- <= 1) {
ckfree(cmdPtr);
}
}
@@ -3523,7 +3541,7 @@ OldMathFuncProc(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"argument to math function didn't have numeric value",
-1));
- TclCheckBadOctal(interp, Tcl_GetString(valuePtr));
+ TclCheckBadOctal(interp, TclGetString(valuePtr));
ckfree(args);
return TCL_ERROR;
}
@@ -4698,7 +4716,7 @@ TEOV_RunEnterTraces(
{
Interp *iPtr = (Interp *) interp;
Command *cmdPtr = *cmdPtrPtr;
- int newEpoch, cmdEpoch = cmdPtr->cmdEpoch;
+ size_t newEpoch, cmdEpoch = cmdPtr->cmdEpoch;
int length, traceCode = TCL_OK;
const char *command = TclGetStringFromObj(commandPtr, &length);
@@ -5578,8 +5596,7 @@ TclArgumentRelease(
}
cfwPtr = Tcl_GetHashValue(hPtr);
- cfwPtr->refCount--;
- if (cfwPtr->refCount > 0) {
+ if (cfwPtr->refCount-- > 1) {
continue;
}
@@ -5844,6 +5861,7 @@ TclArgumentGet(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_Eval
int
Tcl_Eval(
@@ -5896,6 +5914,7 @@ Tcl_GlobalEvalObj(
{
return Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -6049,7 +6068,7 @@ TclNREvalObjEx(
TclNRAddCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr,
objPtr, NULL);
- ListObjGetElements(listPtr, objc, objv);
+ TclListObjGetElements(NULL, listPtr, &objc, &objv);
return TclNREvalObjv(interp, objc, objv, flags, NULL);
}
@@ -6696,11 +6715,10 @@ Tcl_AppendObjToErrorInfo(
* pertains. */
Tcl_Obj *objPtr) /* Message to record. */
{
- int length;
- const char *message = TclGetStringFromObj(objPtr, &length);
+ const char *message = TclGetString(objPtr);
Tcl_IncrRefCount(objPtr);
- Tcl_AddObjErrorInfo(interp, message, length);
+ Tcl_AddObjErrorInfo(interp, message, objPtr->length);
Tcl_DecrRefCount(objPtr);
}
@@ -6723,6 +6741,7 @@ Tcl_AppendObjToErrorInfo(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_AddErrorInfo
void
Tcl_AddErrorInfo(
@@ -6732,6 +6751,7 @@ Tcl_AddErrorInfo(
{
Tcl_AddObjErrorInfo(interp, message, -1);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -6904,6 +6924,7 @@ Tcl_VarEval(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_GlobalEval
int
Tcl_GlobalEval(
@@ -6921,6 +6942,7 @@ Tcl_GlobalEval(
iPtr->varFramePtr = savedVarFramePtr;
return result;
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -7884,7 +7906,7 @@ MathFuncWrongNumArgs(
int found, /* Actual parameter count. */
Tcl_Obj *const *objv) /* Actual parameter vector. */
{
- const char *name = Tcl_GetString(objv[0]);
+ const char *name = TclGetString(objv[0]);
const char *tail = name + strlen(name);
while (tail > name+1) {
@@ -8748,6 +8770,35 @@ TclNRCoroutineActivateCallback(
/*
*----------------------------------------------------------------------
*
+ * TclNREvalList --
+ *
+ * Callback to invoke command as list, used in order to delayed
+ * processing of canonical list command in sane environment.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TclNREvalList(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ int objc;
+ Tcl_Obj **objv;
+ Tcl_Obj *listPtr = data[0];
+
+ Tcl_IncrRefCount(listPtr);
+
+ TclMarkTailcall(interp);
+ TclNRAddCallback(interp, TclNRReleaseValues, listPtr, NULL, NULL,NULL);
+ TclListObjGetElements(NULL, listPtr, &objc, &objv);
+ return TclNREvalObjv(interp, objc, objv, 0, NULL);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* NRCoroInjectObjCmd --
*
* Implementation of [::tcl::unsupported::inject] command.
@@ -8799,7 +8850,8 @@ NRCoroInjectObjCmd(
*/
iPtr->execEnvPtr = corPtr->eePtr;
- TclNREvalObjEx(interp, Tcl_NewListObj(objc-2, objv+2), 0, NULL, INT_MIN);
+ TclNRAddCallback(interp, TclNREvalList, Tcl_NewListObj(objc-2, objv+2),
+ NULL, NULL, NULL);
iPtr->execEnvPtr = savedEEPtr;
return TCL_OK;
@@ -8817,7 +8869,7 @@ TclNRInterpCoroutine(
if (!COR_IS_SUSPENDED(corPtr)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"coroutine \"%s\" is already running",
- Tcl_GetString(objv[0])));
+ TclGetString(objv[0])));
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BUSY", NULL);
return TCL_ERROR;
}
diff --git a/generic/tclBinary.c b/generic/tclBinary.c
index 9a5771e..a3e5071 100644
--- a/generic/tclBinary.c
+++ b/generic/tclBinary.c
@@ -155,35 +155,108 @@ static const EnsembleImplMap decodeMap[] = {
};
/*
- * The following object type represents an array of bytes. An array of bytes
- * is not equivalent to an internationalized string. Conceptually, a string is
- * an array of 16-bit quantities organized as a sequence of properly formed
- * UTF-8 characters, while a ByteArray is an array of 8-bit quantities.
- * Accessor functions are provided to convert a ByteArray to a String or a
- * String to a ByteArray. Two or more consecutive bytes in an array of bytes
- * may look like a single UTF-8 character if the array is casually treated as
- * a string. But obtaining the String from a ByteArray is guaranteed to
- * produced properly formed UTF-8 sequences so that there is a one-to-one map
- * between bytes and characters.
- *
- * Converting a ByteArray to a String proceeds by casting each byte in the
- * array to a 16-bit quantity, treating that number as a Unicode character,
- * and storing the UTF-8 version of that Unicode character in the String. For
- * ByteArrays consisting entirely of values 1..127, the corresponding String
- * representation is the same as the ByteArray representation.
- *
- * Converting a String to a ByteArray proceeds by getting the Unicode
- * representation of each character in the String, casting it to a byte by
- * truncating the upper 8 bits, and then storing the byte in the ByteArray.
- * Converting from ByteArray to String and back to ByteArray is not lossy, but
- * converting an arbitrary String to a ByteArray may be.
+ * The following object types represent an array of bytes. The intent is
+ * to allow arbitrary binary data to pass through Tcl as a Tcl value
+ * without loss or damage. Such values are useful for things like
+ * encoded strings or Tk images to name just two.
+ *
+ * It's strange to have two Tcl_ObjTypes in place for this task when
+ * one would do, so a bit of detail and history how we got to this point
+ * and where we might go from here.
+ *
+ * A bytearray is an ordered sequence of bytes. Each byte is an integer
+ * value in the range [0-255]. To be a Tcl value type, we need a way to
+ * encode each value in the value set as a Tcl string. The simplest
+ * encoding is to represent each byte value as the same codepoint value.
+ * A bytearray of N bytes is encoded into a Tcl string of N characters
+ * where the codepoint of each character is the value of corresponding byte.
+ * This approach creates a one-to-one map between all bytearray values
+ * and a subset of Tcl string values.
+ *
+ * When converting a Tcl string value to the bytearray internal rep, the
+ * question arises what to do with strings outside that subset? That is,
+ * those Tcl strings containing at least one codepoint greater than 255?
+ * The obviously correct answer is to raise an error! That string value
+ * does not represent any valid bytearray value. Full Stop. The
+ * setFromAnyProc signature has a completion code return value for just
+ * this reason, to reject invalid inputs.
+ *
+ * Unfortunately this was not the path taken by the authors of the
+ * original tclByteArrayType. They chose to accept all Tcl string values
+ * as acceptable string encodings of the bytearray values that result
+ * from masking away the high bits of any codepoint value at all. This
+ * meant that every bytearray value had multiple accepted string
+ * representations.
+ *
+ * The implications of this choice are truly ugly. When a Tcl value has
+ * a string representation, we are required to accept that as the true
+ * value. Bytearray values that possess a string representation cannot
+ * be processed as bytearrays because we cannot know which true value
+ * that bytearray represents. The consequence is that we drag around
+ * an internal rep that we cannot make any use of. This painful price
+ * is extracted at any point after a string rep happens to be generated
+ * for the value. This happens even when the troublesome codepoints
+ * outside the byte range never show up. This happens rather routinely
+ * in normal Tcl operations unless we burden the script writer with the
+ * cognitive burden of avoiding it. The price is also paid by callers
+ * of the C interface. The routine
+ *
+ * unsigned char *Tcl_GetByteArrayFromObj(objPtr, lenPtr)
+ *
+ * has a guarantee to always return a non-NULL value, but that value
+ * points to a byte sequence that cannot be used by the caller to
+ * process the Tcl value absent some sideband testing that objPtr
+ * is "pure". Tcl offers no public interface to perform this test,
+ * so callers either break encapsulation or are unavoidably buggy. Tcl
+ * has defined a public interface that cannot be used correctly. The
+ * Tcl source code itself suffers the same problem, and has been buggy,
+ * but progressively less so as more and more portions of the code have
+ * been retrofitted with the required "purity testing". The set of values
+ * able to pass the purity test can be increased via the introduction of
+ * a "canonical" flag marker, but the only way the broken interface itself
+ * can be discarded is to start over and define the Tcl_ObjType properly.
+ * Bytearrays should simply be usable as bytearrays without a kabuki
+ * dance of testing.
+ *
+ * The Tcl_ObjType "properByteArrayType" is (nearly) a correct
+ * implementation of bytearrays. Any Tcl value with the type
+ * properByteArrayType can have its bytearray value fetched and
+ * used with confidence that acting on that value is equivalent to
+ * acting on the true Tcl string value. This still implies a side
+ * testing burden -- past mistakes will not let us avoid that
+ * immediately, but it is at least a conventional test of type, and
+ * can be implemented entirely by examining the objPtr fields, with
+ * no need to query the intrep, as a canonical flag would require.
+ *
+ * Until Tcl_GetByteArrayFromObj() and Tcl_SetByteArrayLength() can
+ * be revised to admit the possibility of returning NULL when the true
+ * value is not a valid bytearray, we need a mechanism to retain
+ * compatibility with the deployed callers of the broken interface.
+ * That's what the retained "tclByteArrayType" provides. In those
+ * unusual circumstances where we convert an invalid bytearray value
+ * to a bytearray type, it is to this legacy type. Essentially any
+ * time this legacy type gets used, it's a signal of a bug being ignored.
+ * A TIP should be drafted to remove this connection to the broken past
+ * so that Tcl 9 will no longer have any trace of it. Prescribing a
+ * migration path will be the key element of that work. The internal
+ * changes now in place are the limit of what can be done short of
+ * interface repair. They provide a great expansion of the histories
+ * over which bytearray values can be useful in the meanwhile.
*/
-const Tcl_ObjType tclByteArrayType = {
+static const Tcl_ObjType properByteArrayType = {
"bytearray",
FreeByteArrayInternalRep,
DupByteArrayInternalRep,
UpdateStringOfByteArray,
+ NULL
+};
+
+const Tcl_ObjType tclByteArrayType = {
+ "bytearray",
+ FreeByteArrayInternalRep,
+ DupByteArrayInternalRep,
+ NULL,
SetByteArrayFromAny
};
@@ -211,6 +284,12 @@ typedef struct ByteArray {
#define SET_BYTEARRAY(objPtr, baPtr) \
(objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (baPtr)
+int
+TclIsPureByteArray(
+ Tcl_Obj * objPtr)
+{
+ return (objPtr->typePtr == &properByteArrayType);
+}
/*
*----------------------------------------------------------------------
@@ -341,7 +420,7 @@ Tcl_SetByteArrayObj(
if ((bytes != NULL) && (length > 0)) {
memcpy(byteArrayPtr->bytes, bytes, (size_t) length);
}
- objPtr->typePtr = &tclByteArrayType;
+ objPtr->typePtr = &properByteArrayType;
SET_BYTEARRAY(objPtr, byteArrayPtr);
}
@@ -371,7 +450,8 @@ Tcl_GetByteArrayFromObj(
{
ByteArray *baPtr;
- if (objPtr->typePtr != &tclByteArrayType) {
+ if ((objPtr->typePtr != &properByteArrayType)
+ && (objPtr->typePtr != &tclByteArrayType)) {
SetByteArrayFromAny(NULL, objPtr);
}
baPtr = GET_BYTEARRAY(objPtr);
@@ -414,7 +494,8 @@ Tcl_SetByteArrayLength(
if (Tcl_IsShared(objPtr)) {
Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayLength");
}
- if (objPtr->typePtr != &tclByteArrayType) {
+ if ((objPtr->typePtr != &properByteArrayType)
+ && (objPtr->typePtr != &tclByteArrayType)) {
SetByteArrayFromAny(NULL, objPtr);
}
@@ -450,29 +531,37 @@ SetByteArrayFromAny(
Tcl_Interp *interp, /* Not used. */
Tcl_Obj *objPtr) /* The object to convert to type ByteArray. */
{
- int length;
+ size_t length;
+ int improper = 0;
const char *src, *srcEnd;
unsigned char *dst;
ByteArray *byteArrayPtr;
Tcl_UniChar ch;
- if (objPtr->typePtr != &tclByteArrayType) {
- src = TclGetStringFromObj(objPtr, &length);
- srcEnd = src + length;
-
- byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length));
- for (dst = byteArrayPtr->bytes; src < srcEnd; ) {
- src += Tcl_UtfToUniChar(src, &ch);
- *dst++ = UCHAR(ch);
- }
+ if (objPtr->typePtr == &properByteArrayType) {
+ return TCL_OK;
+ }
+ if (objPtr->typePtr == &tclByteArrayType) {
+ return TCL_OK;
+ }
- byteArrayPtr->used = dst - byteArrayPtr->bytes;
- byteArrayPtr->allocated = length;
+ src = TclGetString(objPtr);
+ length = objPtr->length;
+ srcEnd = src + length;
- TclFreeIntRep(objPtr);
- objPtr->typePtr = &tclByteArrayType;
- SET_BYTEARRAY(objPtr, byteArrayPtr);
+ byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length));
+ for (dst = byteArrayPtr->bytes; src < srcEnd; ) {
+ src += Tcl_UtfToUniChar(src, &ch);
+ improper = improper || (ch > 255);
+ *dst++ = UCHAR(ch);
}
+
+ byteArrayPtr->used = dst - byteArrayPtr->bytes;
+ byteArrayPtr->allocated = length;
+
+ TclFreeIntRep(objPtr);
+ objPtr->typePtr = improper ? &tclByteArrayType : &properByteArrayType;
+ SET_BYTEARRAY(objPtr, byteArrayPtr);
return TCL_OK;
}
@@ -535,7 +624,7 @@ DupByteArrayInternalRep(
memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, (size_t) length);
SET_BYTEARRAY(copyPtr, copyArrayPtr);
- copyPtr->typePtr = &tclByteArrayType;
+ copyPtr->typePtr = srcPtr->typePtr;
}
/*
@@ -642,7 +731,8 @@ TclAppendBytesToByteArray(
/* Append zero bytes is a no-op. */
return;
}
- if (objPtr->typePtr != &tclByteArrayType) {
+ if ((objPtr->typePtr != &properByteArrayType)
+ && (objPtr->typePtr != &tclByteArrayType)) {
SetByteArrayFromAny(NULL, objPtr);
}
byteArrayPtr = GET_BYTEARRAY(objPtr);
diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c
index 70e64f0..123d872 100644
--- a/generic/tclCkalloc.c
+++ b/generic/tclCkalloc.c
@@ -34,14 +34,14 @@
*/
typedef struct MemTag {
- int refCount; /* Number of mem_headers referencing this
+ size_t refCount; /* Number of mem_headers referencing this
* tag. */
char string[1]; /* Actual size of string will be as large as
* needed for actual tag. This must be the
* last field in the structure. */
} MemTag;
-#define TAG_SIZE(bytesInString) ((unsigned) ((TclOffset(MemTag, string) + 1) + bytesInString))
+#define TAG_SIZE(bytesInString) ((TclOffset(MemTag, string) + 1) + bytesInString)
static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers (set
* by "memory tag" command). */
@@ -52,14 +52,14 @@ static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers (set
* to help detect chunk under-runs.
*/
-#define LOW_GUARD_SIZE (8 + (32 - (sizeof(long) + sizeof(int)))%8)
+#define LOW_GUARD_SIZE (8 + (32 - (sizeof(size_t) + sizeof(int)))%8)
struct mem_header {
struct mem_header *flink;
struct mem_header *blink;
MemTag *tagPtr; /* Tag from "memory tag" command; may be
* NULL. */
const char *file;
- long length;
+ size_t length;
int line;
unsigned char low_guard[LOW_GUARD_SIZE];
/* Aligns body on 8-byte boundary, plus
@@ -89,14 +89,14 @@ static struct mem_header *allocHead = NULL; /* List of allocated structures */
#define BODY_OFFSET \
((size_t) (&((struct mem_header *) 0)->body))
-static int total_mallocs = 0;
-static int total_frees = 0;
+static unsigned int total_mallocs = 0;
+static unsigned int total_frees = 0;
static size_t current_bytes_malloced = 0;
static size_t maximum_bytes_malloced = 0;
-static int current_malloc_packets = 0;
-static int maximum_malloc_packets = 0;
-static int break_on_malloc = 0;
-static int trace_on_at_malloc = 0;
+static unsigned int current_malloc_packets = 0;
+static unsigned int maximum_malloc_packets = 0;
+static unsigned int break_on_malloc = 0;
+static unsigned int trace_on_at_malloc = 0;
static int alloc_tracing = FALSE;
static int init_malloced_bodies = TRUE;
#ifdef MEM_VALIDATE
@@ -184,18 +184,18 @@ TclDumpMemoryInfo(
return 0;
}
sprintf(buf,
- "total mallocs %10d\n"
- "total frees %10d\n"
- "current packets allocated %10d\n"
- "current bytes allocated %10lu\n"
- "maximum packets allocated %10d\n"
- "maximum bytes allocated %10lu\n",
+ "total mallocs %10u\n"
+ "total frees %10u\n"
+ "current packets allocated %10u\n"
+ "current bytes allocated %10" TCL_LL_MODIFIER "u\n"
+ "maximum packets allocated %10u\n"
+ "maximum bytes allocated %10" TCL_LL_MODIFIER "u\n",
total_mallocs,
total_frees,
current_malloc_packets,
- (unsigned long)current_bytes_malloced,
+ (Tcl_WideInt)current_bytes_malloced,
maximum_malloc_packets,
- (unsigned long)maximum_bytes_malloced);
+ (Tcl_WideInt)maximum_bytes_malloced);
if (flags == 0) {
fprintf((FILE *)clientData, "%s", buf);
} else {
@@ -251,10 +251,10 @@ ValidateMemory(
}
if (guard_failed) {
TclDumpMemoryInfo((ClientData) stderr, 0);
- fprintf(stderr, "low guard failed at %lx, %s %d\n",
- (long unsigned) memHeaderP->body, file, line);
+ fprintf(stderr, "low guard failed at %p, %s %d\n",
+ memHeaderP->body, file, line);
fflush(stderr); /* In case name pointer is bad. */
- fprintf(stderr, "%ld bytes allocated at (%s %d)\n", memHeaderP->length,
+ fprintf(stderr, "%" TCL_LL_MODIFIER "d bytes allocated at (%s %d)\n", (Tcl_WideInt) memHeaderP->length,
memHeaderP->file, memHeaderP->line);
Tcl_Panic("Memory validation failure");
}
@@ -273,11 +273,11 @@ ValidateMemory(
if (guard_failed) {
TclDumpMemoryInfo((ClientData) stderr, 0);
- fprintf(stderr, "high guard failed at %lx, %s %d\n",
- (long unsigned) memHeaderP->body, file, line);
+ fprintf(stderr, "high guard failed at %p, %s %d\n",
+ memHeaderP->body, file, line);
fflush(stderr); /* In case name pointer is bad. */
- fprintf(stderr, "%ld bytes allocated at (%s %d)\n",
- memHeaderP->length, memHeaderP->file,
+ fprintf(stderr, "%" TCL_LL_MODIFIER "d bytes allocated at (%s %d)\n",
+ (Tcl_WideInt)memHeaderP->length, memHeaderP->file,
memHeaderP->line);
Tcl_Panic("Memory validation failure");
}
@@ -359,10 +359,9 @@ Tcl_DumpActiveMemory(
Tcl_MutexLock(ckallocMutexPtr);
for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) {
address = &memScanP->body[0];
- fprintf(fileP, "%8lx - %8lx %7ld @ %s %d %s",
- (long unsigned) address,
- (long unsigned) address + memScanP->length - 1,
- memScanP->length, memScanP->file, memScanP->line,
+ fprintf(fileP, "%p - %p %" TCL_LL_MODIFIER "d @ %s %d %s",
+ address, address + memScanP->length - 1,
+ (Tcl_WideInt)memScanP->length, memScanP->file, memScanP->line,
(memScanP->tagPtr == NULL) ? "" : memScanP->tagPtr->string);
(void) fputc('\n', fileP);
}
@@ -450,7 +449,7 @@ Tcl_DbCkalloc(
total_mallocs++;
if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) {
(void) fflush(stdout);
- fprintf(stderr, "reached malloc trace enable point (%d)\n",
+ fprintf(stderr, "reached malloc trace enable point (%u)\n",
total_mallocs);
fflush(stderr);
alloc_tracing = TRUE;
@@ -458,14 +457,14 @@ Tcl_DbCkalloc(
}
if (alloc_tracing) {
- fprintf(stderr,"ckalloc %lx %u %s %d\n",
- (long unsigned int) result->body, size, file, line);
+ fprintf(stderr,"ckalloc %p %u %s %d\n",
+ result->body, size, file, line);
}
if (break_on_malloc && (total_mallocs >= break_on_malloc)) {
break_on_malloc = 0;
(void) fflush(stdout);
- Tcl_Panic("reached malloc break limit (%d)", total_mallocs);
+ Tcl_Panic("reached malloc break limit (%u)", total_mallocs);
}
current_malloc_packets++;
@@ -547,8 +546,8 @@ Tcl_AttemptDbCkalloc(
}
if (alloc_tracing) {
- fprintf(stderr,"ckalloc %lx %u %s %d\n",
- (long unsigned int) result->body, size, file, line);
+ fprintf(stderr,"ckalloc %p %u %s %d\n",
+ result->body, size, file, line);
}
if (break_on_malloc && (total_mallocs >= break_on_malloc)) {
@@ -612,8 +611,8 @@ Tcl_DbCkfree(
memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET);
if (alloc_tracing) {
- fprintf(stderr, "ckfree %lx %ld %s %d\n",
- (long unsigned int) memp->body, memp->length, file, line);
+ fprintf(stderr, "ckfree %p %" TCL_LL_MODIFIER "d %s %d\n",
+ memp->body, (Tcl_WideInt) memp->length, file, line);
}
if (validate_memory) {
@@ -623,7 +622,7 @@ Tcl_DbCkfree(
Tcl_MutexLock(ckallocMutexPtr);
ValidateMemory(memp, file, line, TRUE);
if (init_malloced_bodies) {
- memset(ptr, GUARD_VALUE, (size_t) memp->length);
+ memset(ptr, GUARD_VALUE, memp->length);
}
total_frees++;
@@ -631,8 +630,7 @@ Tcl_DbCkfree(
current_bytes_malloced -= memp->length;
if (memp->tagPtr != NULL) {
- memp->tagPtr->refCount--;
- if ((memp->tagPtr->refCount == 0) && (curTagPtr != memp->tagPtr)) {
+ if ((memp->tagPtr->refCount-- <= 1) && (curTagPtr != memp->tagPtr)) {
TclpFree((char *) memp->tagPtr);
}
}
@@ -675,7 +673,7 @@ Tcl_DbCkrealloc(
int line)
{
char *newPtr;
- unsigned int copySize;
+ size_t copySize;
struct mem_header *memp;
if (ptr == NULL) {
@@ -689,7 +687,7 @@ Tcl_DbCkrealloc(
memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET);
copySize = size;
- if (copySize > (unsigned int) memp->length) {
+ if (copySize > memp->length) {
copySize = memp->length;
}
newPtr = Tcl_DbCkalloc(size, file, line);
@@ -706,7 +704,7 @@ Tcl_AttemptDbCkrealloc(
int line)
{
char *newPtr;
- unsigned int copySize;
+ size_t copySize;
struct mem_header *memp;
if (ptr == NULL) {
@@ -720,7 +718,7 @@ Tcl_AttemptDbCkrealloc(
memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET);
copySize = size;
- if (copySize > (unsigned int) memp->length) {
+ if (copySize > memp->length) {
copySize = memp->length;
}
newPtr = Tcl_AttemptDbCkalloc(size, file, line);
@@ -849,22 +847,24 @@ MemoryCmd(
return TCL_OK;
}
if (strcmp(argv[1],"break_on_malloc") == 0) {
+ int value;
if (argc != 3) {
goto argError;
}
- if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK) {
+ if (Tcl_GetInt(interp, argv[2], &value) != TCL_OK) {
return TCL_ERROR;
}
+ break_on_malloc = (unsigned int) value;
return TCL_OK;
}
if (strcmp(argv[1],"info") == 0) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10lu\n%-25s %10d\n%-25s %10lu\n",
+ "%-25s %10u\n%-25s %10u\n%-25s %10u\n%-25s %10" TCL_LL_MODIFIER"d\n%-25s %10u\n%-25s %10" TCL_LL_MODIFIER "d\n",
"total mallocs", total_mallocs, "total frees", total_frees,
"current packets allocated", current_malloc_packets,
- "current bytes allocated", (unsigned long)current_bytes_malloced,
+ "current bytes allocated", (Tcl_WideInt)current_bytes_malloced,
"maximum packets allocated", maximum_malloc_packets,
- "maximum bytes allocated", (unsigned long)maximum_bytes_malloced));
+ "maximum bytes allocated", (Tcl_WideInt)maximum_bytes_malloced));
return TCL_OK;
}
if (strcmp(argv[1], "init") == 0) {
@@ -935,12 +935,14 @@ MemoryCmd(
}
if (strcmp(argv[1],"trace_on_at_malloc") == 0) {
+ int value;
if (argc != 3) {
goto argError;
}
- if (Tcl_GetInt(interp, argv[2], &trace_on_at_malloc) != TCL_OK) {
+ if (Tcl_GetInt(interp, argv[2], &value) != TCL_OK) {
return TCL_ERROR;
}
+ trace_on_at_malloc = value;
return TCL_OK;
}
if (strcmp(argv[1],"validate") == 0) {
diff --git a/generic/tclClock.c b/generic/tclClock.c
index c3b29e9..d44e9dc 100644
--- a/generic/tclClock.c
+++ b/generic/tclClock.c
@@ -92,7 +92,7 @@ static const char *const literals[] = {
*/
typedef struct ClockClientData {
- int refCount; /* Number of live references. */
+ size_t refCount; /* Number of live references. */
Tcl_Obj **literals; /* Pool of object literals. */
} ClockClientData;
@@ -208,11 +208,7 @@ struct ClockCommand {
};
static const struct ClockCommand clockCommands[] = {
- { "clicks", ClockClicksObjCmd },
{ "getenv", ClockGetenvObjCmd },
- { "microseconds", ClockMicrosecondsObjCmd },
- { "milliseconds", ClockMillisecondsObjCmd },
- { "seconds", ClockSecondsObjCmd },
{ "Oldscan", TclClockOldscanObjCmd },
{ "ConvertLocalToUTC", ClockConvertlocaltoutcObjCmd },
{ "GetDateFields", ClockGetdatefieldsObjCmd },
@@ -253,6 +249,19 @@ TclClockInit(
ClockClientData *data;
int i;
+ /* Structure of the 'clock' ensemble */
+
+ static const EnsembleImplMap clockImplMap[] = {
+ {"add", NULL, TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
+ {"clicks", ClockClicksObjCmd, TclCompileClockClicksCmd, NULL, NULL, 0},
+ {"format", NULL, TclCompileBasicMin1ArgCmd, NULL, NULL, 0},
+ {"microseconds", ClockMicrosecondsObjCmd, TclCompileClockReadingCmd, NULL, INT2PTR(1), 0},
+ {"milliseconds", ClockMillisecondsObjCmd, TclCompileClockReadingCmd, NULL, INT2PTR(2), 0},
+ {"scan", NULL, TclCompileBasicMin1ArgCmd, NULL, NULL , 0},
+ {"seconds", ClockSecondsObjCmd, TclCompileClockReadingCmd, NULL, INT2PTR(3), 0},
+ {NULL, NULL, NULL, NULL, NULL, 0}
+ };
+
/*
* Safe interps get [::clock] as alias to a master, so do not need their
* own copies of the support routines.
@@ -276,6 +285,7 @@ TclClockInit(
/*
* Install the commands.
+ * TODO - Let Tcl_MakeEnsemble do this?
*/
#define TCL_CLOCK_PREFIX_LEN 14 /* == strlen("::tcl::clock::") */
@@ -286,6 +296,10 @@ TclClockInit(
Tcl_CreateObjCommand(interp, cmdName, clockCmdPtr->objCmdProc, data,
ClockDeleteCmdProc);
}
+
+ /* Make the clock ensemble */
+
+ TclMakeEnsemble(interp, "clock", clockImplMap);
}
/*
@@ -1680,7 +1694,7 @@ ThreadSafeLocalTime(
* Get a thread-local buffer to hold the returned time.
*/
- struct tm *tmPtr = Tcl_GetThreadData(&tmKey, (int) sizeof(struct tm));
+ struct tm *tmPtr = Tcl_GetThreadData(&tmKey, sizeof(struct tm));
#ifdef HAVE_LOCALTIME_R
localtime_r(timePtr, tmPtr);
#else
@@ -2060,8 +2074,7 @@ ClockDeleteCmdProc(
ClockClientData *data = clientData;
int i;
- data->refCount--;
- if (data->refCount == 0) {
+ if (data->refCount-- <= 1) {
for (i = 0; i < LIT__END; ++i) {
Tcl_DecrRefCount(data->literals[i]);
}
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 4c299f8..807a1ac 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -46,9 +46,24 @@ struct ForeachState {
static int CheckAccess(Tcl_Interp *interp, Tcl_Obj *pathPtr,
int mode);
+static int BadEncodingSubcommand(ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+static int EncodingConvertfromObjCmd(ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+static int EncodingConverttoObjCmd(ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
static int EncodingDirsObjCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
+static int EncodingNamesObjCmd(ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+static int EncodingSystemObjCmd(ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
static inline int ForeachAssignments(Tcl_Interp *interp,
struct ForeachState *statePtr);
static inline void ForeachCleanup(Tcl_Interp *interp,
@@ -149,7 +164,7 @@ Tcl_BreakObjCmd(
*
*----------------------------------------------------------------------
*/
-
+#ifndef TCL_NO_DEPRECATED
/* ARGSUSED */
int
Tcl_CaseObjCmd(
@@ -267,6 +282,7 @@ Tcl_CaseObjCmd(
return TCL_OK;
}
+#endif /* !TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -541,79 +557,280 @@ Tcl_EncodingObjCmd(
switch ((enum options) index) {
case ENC_CONVERTTO:
- case ENC_CONVERTFROM: {
- Tcl_Obj *data;
- Tcl_DString ds;
- Tcl_Encoding encoding;
- int length;
- const char *stringPtr;
-
- if (objc == 3) {
- encoding = Tcl_GetEncoding(interp, NULL);
- data = objv[2];
- } else if (objc == 4) {
- if (Tcl_GetEncodingFromObj(interp, objv[2], &encoding) != TCL_OK) {
- return TCL_ERROR;
- }
- data = objv[3];
- } else {
- Tcl_WrongNumArgs(interp, 2, objv, "?encoding? data");
- return TCL_ERROR;
- }
+ return EncodingConverttoObjCmd(dummy, interp, objc, objv);
+ case ENC_CONVERTFROM:
+ return EncodingConvertfromObjCmd(dummy, interp, objc, objv);
+ case ENC_DIRS:
+ return EncodingDirsObjCmd(dummy, interp, objc, objv);
+ case ENC_NAMES:
+ return EncodingNamesObjCmd(dummy, interp, objc, objv);
+ case ENC_SYSTEM:
+ return EncodingSystemObjCmd(dummy, interp, objc, objv);
+ }
+ return TCL_OK;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * TclInitEncodingCmd --
+ *
+ * This function creates the 'encoding' ensemble.
+ *
+ * Results:
+ * Returns the Tcl_Command so created.
+ *
+ * Side effects:
+ * The ensemble is initialized.
+ *
+ * This command is hidden in a safe interpreter.
+ */
- if ((enum options) index == ENC_CONVERTFROM) {
- /*
- * Treat the string as binary data.
- */
+Tcl_Command
+TclInitEncodingCmd(
+ Tcl_Interp* interp) /* Tcl interpreter */
+{
+ static const EnsembleImplMap encodingImplMap[] = {
+ {"convertfrom", EncodingConvertfromObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
+ {"convertto", EncodingConverttoObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0},
+ {"dirs", EncodingDirsObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {"names", EncodingNamesObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0},
+ {"system", EncodingSystemObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0},
+ {NULL, NULL, NULL, NULL, NULL, 0}
+ };
- stringPtr = (char *) Tcl_GetByteArrayFromObj(data, &length);
- Tcl_ExternalToUtfDString(encoding, stringPtr, length, &ds);
+ return TclMakeEnsemble(interp, "encoding", encodingImplMap);
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * TclMakeEncodingCommandSafe --
+ *
+ * This function hides the unsafe 'dirs' and 'system' subcommands of
+ * the "encoding" Tcl command ensemble. It must be called only from
+ * TclHideUnsafeCommands.
+ *
+ * Results:
+ * A standard Tcl result
+ *
+ * Side effects:
+ * Adds commands to the table of hidden commands.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+int
+TclMakeEncodingCommandSafe(
+ Tcl_Interp* interp) /* Tcl interpreter */
+{
+ static const struct {
+ const char *cmdName;
+ int unsafe;
+ } unsafeInfo[] = {
+ {"convertfrom", 0},
+ {"convertto", 0},
+ {"dirs", 1},
+ {"names", 0},
+ {"system", 0},
+ {NULL, 0}
+ };
- /*
- * Note that we cannot use Tcl_DStringResult here because it will
- * truncate the string at the first null byte.
- */
+ int i;
+ Tcl_DString oldBuf, newBuf;
- Tcl_SetObjResult(interp, TclDStringToObj(&ds));
- } else {
- /*
- * Store the result as binary data.
- */
-
- stringPtr = TclGetStringFromObj(data, &length);
- Tcl_UtfToExternalDString(encoding, stringPtr, length, &ds);
- Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(
- (unsigned char *) Tcl_DStringValue(&ds),
- Tcl_DStringLength(&ds)));
- Tcl_DStringFree(&ds);
+ Tcl_DStringInit(&oldBuf);
+ TclDStringAppendLiteral(&oldBuf, "::tcl::encoding::");
+ Tcl_DStringInit(&newBuf);
+ TclDStringAppendLiteral(&newBuf, "tcl:encoding:");
+ for (i=0 ; unsafeInfo[i].cmdName != NULL ; i++) {
+ if (unsafeInfo[i].unsafe) {
+ const char *oldName, *newName;
+
+ Tcl_DStringSetLength(&oldBuf, 17);
+ oldName = Tcl_DStringAppend(&oldBuf, unsafeInfo[i].cmdName, -1);
+ Tcl_DStringSetLength(&newBuf, 13);
+ newName = Tcl_DStringAppend(&newBuf, unsafeInfo[i].cmdName, -1);
+ if (TclRenameCommand(interp, oldName, "___tmp") != TCL_OK
+ || Tcl_HideCommand(interp, "___tmp", newName) != TCL_OK) {
+ Tcl_Panic("problem making 'encoding %s' safe: %s",
+ unsafeInfo[i].cmdName,
+ Tcl_GetString(Tcl_GetObjResult(interp)));
+ }
+ Tcl_CreateObjCommand(interp, oldName, BadEncodingSubcommand,
+ (ClientData) unsafeInfo[i].cmdName, NULL);
}
+ }
+ Tcl_DStringFree(&oldBuf);
+ Tcl_DStringFree(&newBuf);
- Tcl_FreeEncoding(encoding);
- break;
+ /*
+ * Ugh. The [encoding] command is now actually safe, but it is assumed by
+ * scripts that it is not, which messes up security policies.
+ */
+
+ if (Tcl_HideCommand(interp, "encoding", "encoding") != TCL_OK) {
+ Tcl_Panic("problem making 'encoding' safe: %s",
+ Tcl_GetString(Tcl_GetObjResult(interp)));
}
- case ENC_DIRS:
- return EncodingDirsObjCmd(dummy, interp, objc, objv);
- case ENC_NAMES:
- if (objc > 2) {
- Tcl_WrongNumArgs(interp, 2, objv, NULL);
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * BadEncodingSubcommand --
+ *
+ * Command used to act as a backstop implementation when subcommands of
+ * "encoding" are unsafe (the real implementations of the subcommands are
+ * hidden). The clientData is always the full official subcommand name.
+ *
+ * Results:
+ * A standard Tcl result (always a TCL_ERROR).
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+BadEncodingSubcommand(
+ ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ const char *subcommandName = (const char *) clientData;
+
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "not allowed to invoke subcommand %s of encoding", subcommandName));
+ Tcl_SetErrorCode(interp, "TCL", "SAFE", "SUBCOMMAND", NULL);
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * EncodingConvertfromObjCmd --
+ *
+ * This command converts a byte array in an external encoding into a
+ * Tcl string
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+EncodingConvertfromObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ Tcl_Obj *data; /* Byte array to convert */
+ Tcl_DString ds; /* Buffer to hold the string */
+ Tcl_Encoding encoding; /* Encoding to use */
+ int length; /* Length of the byte array being converted */
+ const char *bytesPtr; /* Pointer to the first byte of the array */
+
+ if (objc == 2) {
+ encoding = Tcl_GetEncoding(interp, NULL);
+ data = objv[1];
+ } else if (objc == 3) {
+ if (Tcl_GetEncodingFromObj(interp, objv[1], &encoding) != TCL_OK) {
return TCL_ERROR;
}
- Tcl_GetEncodingNames(interp);
- break;
- case ENC_SYSTEM:
- if (objc > 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "?encoding?");
+ data = objv[2];
+ } else {
+ Tcl_WrongNumArgs(interp, 1, objv, "?encoding? data");
+ return TCL_ERROR;
+ }
+
+ /*
+ * Convert the string into a byte array in 'ds'
+ */
+ bytesPtr = (char *) Tcl_GetByteArrayFromObj(data, &length);
+ Tcl_ExternalToUtfDString(encoding, bytesPtr, length, &ds);
+
+ /*
+ * Note that we cannot use Tcl_DStringResult here because it will
+ * truncate the string at the first null byte.
+ */
+
+ Tcl_SetObjResult(interp, TclDStringToObj(&ds));
+
+ /*
+ * We're done with the encoding
+ */
+
+ Tcl_FreeEncoding(encoding);
+ return TCL_OK;
+
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * EncodingConverttoObjCmd --
+ *
+ * This command converts a Tcl string into a byte array that
+ * encodes the string according to some encoding.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+EncodingConverttoObjCmd(
+ ClientData dummy, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ Tcl_Obj *data; /* String to convert */
+ Tcl_DString ds; /* Buffer to hold the byte array */
+ Tcl_Encoding encoding; /* Encoding to use */
+ int length; /* Length of the string being converted */
+ const char *stringPtr; /* Pointer to the first byte of the string */
+
+ /* TODO - ADJUST OBJ INDICES WHEN ENSEMBLIFYING THIS */
+
+ if (objc == 2) {
+ encoding = Tcl_GetEncoding(interp, NULL);
+ data = objv[1];
+ } else if (objc == 3) {
+ if (Tcl_GetEncodingFromObj(interp, objv[1], &encoding) != TCL_OK) {
return TCL_ERROR;
}
- if (objc == 2) {
- Tcl_SetObjResult(interp, Tcl_NewStringObj(
- Tcl_GetEncodingName(NULL), -1));
- } else {
- return Tcl_SetSystemEncoding(interp, TclGetString(objv[2]));
- }
- break;
+ data = objv[2];
+ } else {
+ Tcl_WrongNumArgs(interp, 1, objv, "?encoding? data");
+ return TCL_ERROR;
}
+
+ /*
+ * Convert the string to a byte array in 'ds'
+ */
+
+ stringPtr = TclGetStringFromObj(data, &length);
+ Tcl_UtfToExternalDString(encoding, stringPtr, length, &ds);
+ Tcl_SetObjResult(interp,
+ Tcl_NewByteArrayObj((unsigned char*) Tcl_DStringValue(&ds),
+ Tcl_DStringLength(&ds)));
+ Tcl_DStringFree(&ds);
+
+ /*
+ * We're done with the encoding
+ */
+
+ Tcl_FreeEncoding(encoding);
return TCL_OK;
+
}
/*
@@ -641,16 +858,16 @@ EncodingDirsObjCmd(
{
Tcl_Obj *dirListObj;
- if (objc > 3) {
- Tcl_WrongNumArgs(interp, 2, objv, "?dirList?");
+ if (objc > 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?dirList?");
return TCL_ERROR;
}
- if (objc == 2) {
+ if (objc == 1) {
Tcl_SetObjResult(interp, Tcl_GetEncodingSearchPath());
return TCL_OK;
}
- dirListObj = objv[2];
+ dirListObj = objv[1];
if (Tcl_SetEncodingSearchPath(dirListObj) == TCL_ERROR) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected directory list but got \"%s\"",
@@ -664,6 +881,68 @@ EncodingDirsObjCmd(
}
/*
+ *-----------------------------------------------------------------------------
+ *
+ * EncodingNamesObjCmd --
+ *
+ * This command returns a list of the available encoding names
+ *
+ * Results:
+ * Returns a standard Tcl result
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+int
+EncodingNamesObjCmd(ClientData dummy, /* Unused */
+ Tcl_Interp* interp, /* Tcl interpreter */
+ int objc, /* Number of command line args */
+ Tcl_Obj* const objv[]) /* Vector of command line args */
+{
+ if (objc > 1) {
+ Tcl_WrongNumArgs(interp, 1, objv, NULL);
+ return TCL_ERROR;
+ }
+ Tcl_GetEncodingNames(interp);
+ return TCL_OK;
+}
+
+/*
+ *-----------------------------------------------------------------------------
+ *
+ * EncodingSystemObjCmd --
+ *
+ * This command retrieves or changes the system encoding
+ *
+ * Results:
+ * Returns a standard Tcl result
+ *
+ * Side effects:
+ * May change the system encoding.
+ *
+ *-----------------------------------------------------------------------------
+ */
+
+int
+EncodingSystemObjCmd(ClientData dummy, /* Unused */
+ Tcl_Interp* interp, /* Tcl interpreter */
+ int objc, /* Number of command line args */
+ Tcl_Obj* const objv[]) /* Vector of command line args */
+{
+ if (objc > 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?encoding?");
+ return TCL_ERROR;
+ }
+ if (objc == 1) {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj(Tcl_GetEncodingName(NULL), -1));
+ } else {
+ return Tcl_SetSystemEncoding(interp, TclGetString(objv[1]));
+ }
+ return TCL_OK;
+}
+
+/*
*----------------------------------------------------------------------
*
* Tcl_ErrorObjCmd --
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 7420538..a7a5f43 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -1717,19 +1717,24 @@ InfoLoadedCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- const char *interpName;
+ const char *interpName, *packageName;
- if ((objc != 1) && (objc != 2)) {
- Tcl_WrongNumArgs(interp, 1, objv, "?interp?");
+ if (objc > 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "?interp? ?packageName?");
return TCL_ERROR;
}
- if (objc == 1) { /* Get loaded pkgs in all interpreters. */
+ if (objc < 2) { /* Get loaded pkgs in all interpreters. */
interpName = NULL;
} else { /* Get pkgs just in specified interp. */
interpName = TclGetString(objv[1]);
}
- return TclGetLoadedPackages(interp, interpName);
+ if (objc < 3) { /* Get loaded files in all packages. */
+ packageName = NULL;
+ } else { /* Get pkgs just in specified interp. */
+ packageName = TclGetString(objv[2]);
+ }
+ return TclGetLoadedPackagesEx(interp, interpName, packageName);
}
/*
@@ -2155,8 +2160,8 @@ Tcl_JoinObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* The argument objects. */
{
- int listLen, i;
- Tcl_Obj *resObjPtr, *joinObjPtr, **elemPtrs;
+ int listLen;
+ Tcl_Obj *resObjPtr = NULL, *joinObjPtr, **elemPtrs;
if ((objc < 2) || (objc > 3)) {
Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?");
@@ -2173,19 +2178,47 @@ Tcl_JoinObjCmd(
return TCL_ERROR;
}
+ if (listLen == 0) {
+ /* No elements to join; default empty result is correct. */
+ return TCL_OK;
+ }
+ if (listLen == 1) {
+ /* One element; return it */
+ Tcl_SetObjResult(interp, elemPtrs[0]);
+ return TCL_OK;
+ }
+
joinObjPtr = (objc == 2) ? Tcl_NewStringObj(" ", 1) : objv[2];
Tcl_IncrRefCount(joinObjPtr);
- resObjPtr = Tcl_NewObj();
- for (i = 0; i < listLen; i++) {
- if (i > 0) {
- Tcl_AppendObjToObj(resObjPtr, joinObjPtr);
+ if (Tcl_GetCharLength(joinObjPtr) == 0) {
+ TclStringCatObjv(interp, /* inPlace */ 0, listLen, elemPtrs,
+ &resObjPtr);
+ } else {
+ int i;
+
+ resObjPtr = Tcl_NewObj();
+ for (i = 0; i < listLen; i++) {
+ if (i > 0) {
+
+ /*
+ * NOTE: This code is relying on Tcl_AppendObjToObj() **NOT**
+ * to shimmer joinObjPtr. If it did, then the case where
+ * objv[1] and objv[2] are the same value would not be safe.
+ * Accessing elemPtrs would crash.
+ */
+
+ Tcl_AppendObjToObj(resObjPtr, joinObjPtr);
+ }
+ Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]);
}
- Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]);
}
Tcl_DecrRefCount(joinObjPtr);
- Tcl_SetObjResult(interp, resObjPtr);
- return TCL_OK;
+ if (resObjPtr) {
+ Tcl_SetObjResult(interp, resObjPtr);
+ return TCL_OK;
+ }
+ return TCL_ERROR;
}
/*
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index cf7c686..ddb57b0 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -323,7 +323,7 @@ Tcl_RegexpObjCmd(
if (match == 0) {
/*
- * We want to set the value of the intepreter result only when
+ * We want to set the value of the interpreter result only when
* this is the first time through the loop.
*/
@@ -989,8 +989,11 @@ TclNRSourceObjCmd(
{
const char *encodingName = NULL;
Tcl_Obj *fileName;
+ int result;
+ void **pkgFiles = NULL;
+ void *names = NULL;
- if (objc != 2 && objc !=4) {
+ if (objc < 2 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv, "?-encoding name? fileName");
return TCL_ERROR;
}
@@ -1008,9 +1011,30 @@ TclNRSourceObjCmd(
return TCL_ERROR;
}
encodingName = TclGetString(objv[2]);
- }
+ } else if (objc == 3) {
+ /* Handle undocumented -nopkg option. This should only be
+ * used by the internal ::tcl::Pkg::source utility function. */
+ static const char *const nopkgoptions[] = {
+ "-nopkg", NULL
+ };
+ int index;
- return TclNREvalFile(interp, fileName, encodingName);
+ if (TCL_ERROR == Tcl_GetIndexFromObj(interp, objv[1], nopkgoptions,
+ "option", TCL_EXACT, &index)) {
+ return TCL_ERROR;
+ }
+ pkgFiles = Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
+ /* Make sure that during the following TclNREvalFile no filenames
+ * are recorded for inclusion in the "package files" command */
+ names = *pkgFiles;
+ *pkgFiles = NULL;
+ }
+ result = TclNREvalFile(interp, fileName, encodingName);
+ if (pkgFiles) {
+ /* restore "tclPkgFiles" assocdata to how it was. */
+ *pkgFiles = names;
+ }
+ return result;
}
/*
@@ -1176,8 +1200,7 @@ StringFirstCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- Tcl_UniChar *needleStr, *haystackStr;
- int match, start, needleLen, haystackLen;
+ int start = 0;
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv,
@@ -1185,82 +1208,23 @@ StringFirstCmd(
return TCL_ERROR;
}
- /*
- * We are searching haystackStr for the sequence needleStr.
- */
-
- match = -1;
- start = 0;
- haystackLen = -1;
-
- needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen);
- haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen);
-
if (objc == 4) {
- /*
- * If a startIndex is specified, we will need to fast forward to that
- * point in the string before we think about a match.
- */
+ int size = Tcl_GetCharLength(objv[2]);
- if (TclGetIntForIndexM(interp, objv[3], haystackLen-1,
- &start) != TCL_OK){
+ if (TCL_OK != TclGetIntForIndexM(interp, objv[3], size - 1, &start)) {
return TCL_ERROR;
}
- /*
- * Reread to prevent shimmering problems.
- */
-
- needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen);
- haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen);
-
- if (start >= haystackLen) {
- goto str_first_done;
- } else if (start > 0) {
- haystackStr += start;
- haystackLen -= start;
- } else if (start < 0) {
- /*
- * Invalid start index mapped to string start; Bug #423581
- */
-
+ if (start < 0) {
start = 0;
}
- }
-
- /*
- * If the length of the needle is more than the length of the haystack, it
- * cannot be contained in there so we can avoid searching. [Bug 2960021]
- */
-
- if (needleLen > 0 && needleLen <= haystackLen) {
- register Tcl_UniChar *p, *end;
-
- end = haystackStr + haystackLen - needleLen + 1;
- for (p = haystackStr; p < end; p++) {
- /*
- * Scan forward to find the first character.
- */
-
- if ((*p == *needleStr) && (TclUniCharNcmp(needleStr, p,
- (unsigned long) needleLen) == 0)) {
- match = p - haystackStr;
- break;
- }
+ if (start >= size) {
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(-1));
+ return TCL_OK;
}
}
-
- /*
- * Compute the character index of the matching string by counting the
- * number of characters before the match.
- */
-
- if ((match != -1) && (objc == 4)) {
- match += start;
- }
-
- str_first_done:
- Tcl_SetObjResult(interp, Tcl_NewIntObj(match));
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(TclStringFind(objv[1],
+ objv[2], start)));
return TCL_OK;
}
@@ -1289,76 +1253,31 @@ StringLastCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- Tcl_UniChar *needleStr, *haystackStr, *p;
- int match, start, needleLen, haystackLen;
+ int last = INT_MAX - 1;
if (objc < 3 || objc > 4) {
Tcl_WrongNumArgs(interp, 1, objv,
- "needleString haystackString ?startIndex?");
+ "needleString haystackString ?lastIndex?");
return TCL_ERROR;
}
- /*
- * We are searching haystackString for the sequence needleString.
- */
-
- match = -1;
- start = 0;
- haystackLen = -1;
-
- needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen);
- haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen);
-
if (objc == 4) {
- /*
- * If a startIndex is specified, we will need to restrict the string
- * range to that char index in the string
- */
+ int size = Tcl_GetCharLength(objv[2]);
- if (TclGetIntForIndexM(interp, objv[3], haystackLen-1,
- &start) != TCL_OK){
+ if (TCL_OK != TclGetIntForIndexM(interp, objv[3], size - 1, &last)) {
return TCL_ERROR;
}
- /*
- * Reread to prevent shimmering problems.
- */
-
- needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen);
- haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen);
-
- if (start < 0) {
- goto str_last_done;
- } else if (start < haystackLen) {
- p = haystackStr + start + 1 - needleLen;
- } else {
- p = haystackStr + haystackLen - needleLen;
+ if (last < 0) {
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(-1));
+ return TCL_OK;
}
- } else {
- p = haystackStr + haystackLen - needleLen;
- }
-
- /*
- * If the length of the needle is more than the length of the haystack, it
- * cannot be contained in there so we can avoid searching. [Bug 2960021]
- */
-
- if (needleLen > 0 && needleLen <= haystackLen) {
- for (; p >= haystackStr; p--) {
- /*
- * Scan backwards to find the first character.
- */
-
- if ((*p == *needleStr) && !memcmp(needleStr, p,
- sizeof(Tcl_UniChar) * (size_t)needleLen)) {
- match = p - haystackStr;
- break;
- }
+ if (last >= size) {
+ last = size - 1;
}
}
-
- str_last_done:
- Tcl_SetObjResult(interp, Tcl_NewIntObj(match));
+ Tcl_SetObjResult(interp, Tcl_NewIntObj(TclStringLast(objv[1],
+ objv[2], last)));
return TCL_OK;
}
@@ -1873,7 +1792,7 @@ StringMapCmd(
/*
* This test is tricky, but has to be that way or you get other strange
- * inconsistencies (see test string-10.20 for illustration why!)
+ * inconsistencies (see test string-10.20.1 for illustration why!)
*/
if (objv[objc-2]->typePtr == &tclDictType && objv[objc-2]->bytes == NULL){
@@ -2223,9 +2142,7 @@ StringReptCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- const char *string1;
- char *string2;
- int count, index, length1, length2;
+ int count;
Tcl_Obj *resultPtr;
if (objc != 3) {
@@ -2243,70 +2160,15 @@ StringReptCmd(
if (count == 1) {
Tcl_SetObjResult(interp, objv[1]);
- goto done;
+ return TCL_OK;
} else if (count < 1) {
- goto done;
- }
- string1 = TclGetStringFromObj(objv[1], &length1);
- if (length1 <= 0) {
- goto done;
- }
-
- /*
- * Only build up a string that has data. Instead of building it up with
- * repeated appends, we just allocate the necessary space once and copy
- * the string value in.
- *
- * We have to worry about overflow [Bugs 714106, 2561746].
- * At this point we know 1 <= length1 <= INT_MAX and 2 <= count <= INT_MAX.
- * We need to keep 2 <= length2 <= INT_MAX.
- */
-
- if (count > INT_MAX/length1) {
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "result exceeds max size for a Tcl value (%d bytes)",
- INT_MAX));
- Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
- return TCL_ERROR;
+ return TCL_OK;
}
- length2 = length1 * count;
- /*
- * Include space for the NUL.
- */
-
- string2 = attemptckalloc((unsigned) length2 + 1);
- if (string2 == NULL) {
- /*
- * Alloc failed. Note that in this case we try to do an error message
- * since this is a case that's most likely when the alloc is large and
- * that's easy to do with this API. Note that if we fail allocating a
- * short string, this will likely keel over too (and fatally).
- */
-
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "string size overflow, out of memory allocating %u bytes",
- length2 + 1));
- Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ if (TCL_OK != TclStringRepeat(interp, objv[1], count, &resultPtr)) {
return TCL_ERROR;
}
- for (index = 0; index < count; index++) {
- memcpy(string2 + (length1 * index), string1, (size_t) length1);
- }
- string2[length2] = '\0';
-
- /*
- * We have to directly assign this instead of using Tcl_SetStringObj (and
- * indirectly TclInitStringRep) because that makes another copy of the
- * data.
- */
-
- TclNewObj(resultPtr);
- resultPtr->bytes = string2;
- resultPtr->length = length2;
Tcl_SetObjResult(interp, resultPtr);
-
- done:
return TCL_OK;
}
@@ -2855,7 +2717,7 @@ StringCatCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
- int i;
+ int code;
Tcl_Obj *objResultPtr;
if (objc < 2) {
@@ -2872,16 +2734,16 @@ StringCatCmd(
Tcl_SetObjResult(interp, objv[1]);
return TCL_OK;
}
- objResultPtr = objv[1];
- if (Tcl_IsShared(objResultPtr)) {
- objResultPtr = Tcl_DuplicateObj(objResultPtr);
- }
- for(i = 2;i < objc;i++) {
- Tcl_AppendObjToObj(objResultPtr, objv[i]);
+
+ code = TclStringCatObjv(interp, /* inPlace */ 1, objc-1, objv+1,
+ &objResultPtr);
+
+ if (code == TCL_OK) {
+ Tcl_SetObjResult(interp, objResultPtr);
+ return TCL_OK;
}
- Tcl_SetObjResult(interp, objResultPtr);
- return TCL_OK;
+ return code;
}
/*
@@ -4319,7 +4181,7 @@ TclNRTryObjCmd(
}
info[0] = objv[i]; /* type */
- TclNewIntObj(info[1], code); /* returnCode */
+ TclNewLongObj(info[1], code); /* returnCode */
if (info[2] == NULL) { /* errorCodePrefix */
TclNewObj(info[2]);
}
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index bce17dc..b9bc228 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -734,6 +734,105 @@ TclCompileCatchCmd(
return TCL_OK;
}
+/*----------------------------------------------------------------------
+ *
+ * TclCompileClockClicksCmd --
+ *
+ * Procedure called to compile the "tcl::clock::clicks" command.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to run time.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "clock clicks"
+ * command at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileClockClicksCmd(
+ Tcl_Interp* interp, /* Tcl interpreter */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ Tcl_Token* tokenPtr;
+
+ switch (parsePtr->numWords) {
+ case 1:
+ /*
+ * No args
+ */
+ TclEmitInstInt1(INST_CLOCK_READ, 0, envPtr);
+ break;
+ case 2:
+ /*
+ * -milliseconds or -microseconds
+ */
+ tokenPtr = TokenAfter(parsePtr->tokenPtr);
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD
+ || tokenPtr[1].size < 4
+ || tokenPtr[1].size > 13) {
+ return TCL_ERROR;
+ } else if (!strncmp(tokenPtr[1].start, "-microseconds",
+ tokenPtr[1].size)) {
+ TclEmitInstInt1(INST_CLOCK_READ, 1, envPtr);
+ break;
+ } else if (!strncmp(tokenPtr[1].start, "-milliseconds",
+ tokenPtr[1].size)) {
+ TclEmitInstInt1(INST_CLOCK_READ, 2, envPtr);
+ break;
+ } else {
+ return TCL_ERROR;
+ }
+ default:
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+
+
+/*----------------------------------------------------------------------
+ *
+ * TclCompileClockReadingCmd --
+ *
+ * Procedure called to compile the "tcl::clock::microseconds",
+ * "tcl::clock::milliseconds" and "tcl::clock::seconds" commands.
+ *
+ * Results:
+ * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
+ * evaluation to run time.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the "clock clicks"
+ * command at runtime.
+ *
+ * Client data is 1 for microseconds, 2 for milliseconds, 3 for seconds.
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileClockReadingCmd(
+ Tcl_Interp* interp, /* Tcl interpreter */
+ Tcl_Parse *parsePtr, /* Points to a parse structure for the command
+ * created by Tcl_ParseCommand. */
+ Command *cmdPtr, /* Points to defintion of command being
+ * compiled. */
+ CompileEnv *envPtr) /* Holds resulting instructions. */
+{
+ if (parsePtr->numWords != 1) {
+ return TCL_ERROR;
+ }
+
+ TclEmitInstInt1(INST_CLOCK_READ, PTR2INT(cmdPtr->objClientData), envPtr);
+
+ return TCL_OK;
+}
+
/*
*----------------------------------------------------------------------
*
@@ -3206,17 +3305,6 @@ TclCompileFormatCmd(
*/
TclEmitInstInt1(INST_STR_CONCAT1, i, envPtr);
- } else {
- /*
- * EVIL HACK! Force there to be a string representation in the case
- * where there's just a "%s" in the format; case covered by the test
- * format-20.1 (and it is horrible...)
- */
-
- TclEmitOpcode(INST_DUP, envPtr);
- PushStringLiteral(envPtr, "");
- TclEmitOpcode(INST_STR_EQ, envPtr);
- TclEmitOpcode(INST_POP, envPtr);
}
return TCL_OK;
}
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 10b3cc8..25d10d6 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -1902,10 +1902,10 @@ TclCompileSwitchCmd(
}
if (numWords % 2) {
abort:
- ckfree((char *) bodyToken);
- ckfree((char *) bodyTokenArray);
- ckfree((char *) bodyLines);
- ckfree((char *) bodyContLines);
+ ckfree(bodyToken);
+ ckfree(bodyTokenArray);
+ ckfree(bodyLines);
+ ckfree(bodyContLines);
return TCL_ERROR;
}
} else if (numWords % 2 || numWords == 0) {
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index c588731..b5de230 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -654,6 +654,11 @@ InstructionDesc const tclInstructionTable[] = {
/* Lappend list to general variable.
* Stack: ... varName list => ... listVarContents */
+ {"clockRead", 2, +1, 1, {OPERAND_UINT1}},
+ /* Read clock out to the stack. Operand is which clock to read
+ * 0=clicks, 1=microseconds, 2=milliseconds, 3=seconds.
+ * Stack: ... => ... time */
+
{NULL, 0, 0, 0, {OPERAND_NONE}}
};
@@ -765,7 +770,8 @@ TclSetByteCodeFromAny(
Interp *iPtr = (Interp *) interp;
CompileEnv compEnv; /* Compilation environment structure allocated
* in frame. */
- int length, result = TCL_OK;
+ size_t length;
+ int result = TCL_OK;
const char *stringPtr;
Proc *procPtr = iPtr->compiledProcPtr;
ContLineLoc *clLocPtr;
@@ -780,7 +786,8 @@ TclSetByteCodeFromAny(
}
#endif
- stringPtr = TclGetStringFromObj(objPtr, &length);
+ stringPtr = TclGetString(objPtr);
+ length = objPtr->length;
/*
* TIP #280: Pick up the CmdFrame in which the BC compiler was invoked and
@@ -1002,7 +1009,7 @@ void
TclReleaseByteCode(
register ByteCode *codePtr)
{
- if (--codePtr->refCount) {
+ if (codePtr->refCount-- > 1) {
return;
}
@@ -1380,14 +1387,14 @@ ReleaseCmdWordData(
Tcl_DecrRefCount(eclPtr->path);
}
for (i=0 ; i<eclPtr->nuloc ; i++) {
- ckfree((char *) eclPtr->loc[i].line);
+ ckfree(eclPtr->loc[i].line);
}
if (eclPtr->loc != NULL) {
- ckfree((char *) eclPtr->loc);
+ ckfree(eclPtr->loc);
}
- ckfree((char *) eclPtr);
+ ckfree(eclPtr);
}
/*
@@ -1801,7 +1808,7 @@ CompileCmdLiteral(
extraLiteralFlags |= LITERAL_UNSHARED;
}
- bytes = Tcl_GetStringFromObj(cmdObj, &numBytes);
+ bytes = TclGetStringFromObj(cmdObj, &numBytes);
cmdLitIdx = TclRegisterLiteral(envPtr, bytes, numBytes, extraLiteralFlags);
if (cmdPtr) {
@@ -2976,7 +2983,8 @@ TclFindCompiledLocal(
varNamePtr = &cachePtr->varName0;
for (i=0; i < cachePtr->numVars; varNamePtr++, i++) {
if (*varNamePtr) {
- localName = TclGetStringFromObj(*varNamePtr, &len);
+ localName = TclGetString(*varNamePtr);
+ len = (*varNamePtr)->length;
if ((len == nameBytes) && !strncmp(name, localName, len)) {
return i;
}
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 89cdc59..46e447f 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -417,7 +417,7 @@ typedef struct ByteCode {
* procs are specific to an interpreter so the
* code emitted will depend on the
* interpreter. */
- int compileEpoch; /* Value of iPtr->compileEpoch when this
+ unsigned int compileEpoch; /* Value of iPtr->compileEpoch when this
* ByteCode was compiled. Used to invalidate
* code when, e.g., commands with compile
* procs are redefined. */
@@ -425,7 +425,7 @@ typedef struct ByteCode {
* compiled. If the code is executed if a
* different namespace, it must be
* recompiled. */
- int nsEpoch; /* Value of nsPtr->resolverEpoch when this
+ size_t nsEpoch; /* Value of nsPtr->resolverEpoch when this
* ByteCode was compiled. Used to invalidate
* code when new namespace resolution rules
* are put into effect. */
@@ -821,8 +821,10 @@ typedef struct ByteCode {
#define INST_LAPPEND_LIST_ARRAY_STK 187
#define INST_LAPPEND_LIST_STK 188
+#define INST_CLOCK_READ 189
+
/* The last opcode */
-#define LAST_INST_OPCODE 188
+#define LAST_INST_OPCODE 189
/*
* Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclConfig.c b/generic/tclConfig.c
index 2fb3e92..eb6807c 100644
--- a/generic/tclConfig.c
+++ b/generic/tclConfig.c
@@ -232,7 +232,7 @@ QueryConfigObjCmd(
Tcl_SetObjResult(interp, Tcl_NewStringObj("package not known", -1));
Tcl_SetErrorCode(interp, "TCL", "FATAL", "PKGCFG_BASE",
- Tcl_GetString(pkgName), NULL);
+ TclGetString(pkgName), NULL);
return TCL_ERROR;
}
@@ -247,7 +247,7 @@ QueryConfigObjCmd(
|| val == NULL) {
Tcl_SetObjResult(interp, Tcl_NewStringObj("key not known", -1));
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONFIG",
- Tcl_GetString(objv[2]), NULL);
+ TclGetString(objv[2]), NULL);
return TCL_ERROR;
}
@@ -333,9 +333,9 @@ QueryConfigDelete(
Tcl_DictObjRemove(NULL, pDB, pkgName);
Tcl_DecrRefCount(pkgName);
if (cdPtr->encoding) {
- ckfree((char *)cdPtr->encoding);
+ ckfree(cdPtr->encoding);
}
- ckfree((char *)cdPtr);
+ ckfree(cdPtr);
}
/*
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index b022d3c..d543238 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -878,7 +878,7 @@ EXTERN int Tcl_EvalObjv(Tcl_Interp *interp, int objc,
EXTERN int Tcl_EvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr,
int flags);
/* 294 */
-EXTERN void Tcl_ExitThread(int status);
+EXTERN TCL_NORETURN void Tcl_ExitThread(int status);
/* 295 */
EXTERN int Tcl_ExternalToUtf(Tcl_Interp *interp,
Tcl_Encoding encoding, const char *src,
@@ -1816,6 +1816,12 @@ EXTERN int Tcl_FSUnloadFile(Tcl_Interp *interp,
EXTERN void Tcl_ZlibStreamSetCompressionDictionary(
Tcl_ZlibStream zhandle,
Tcl_Obj *compressionDictionaryObj);
+/* 631 */
+EXTERN Tcl_Channel Tcl_OpenTcpServerEx(Tcl_Interp *interp,
+ const char *service, const char *host,
+ unsigned int flags,
+ Tcl_TcpAcceptProc *acceptProc,
+ ClientData callbackData);
typedef struct {
const struct TclPlatStubs *tclPlatStubs;
@@ -2145,7 +2151,7 @@ typedef struct TclStubs {
int (*tcl_EvalEx) (Tcl_Interp *interp, const char *script, int numBytes, int flags); /* 291 */
int (*tcl_EvalObjv) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); /* 292 */
int (*tcl_EvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 293 */
- void (*tcl_ExitThread) (int status); /* 294 */
+ TCL_NORETURN1 void (*tcl_ExitThread) (int status); /* 294 */
int (*tcl_ExternalToUtf) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 295 */
char * (*tcl_ExternalToUtfDString) (Tcl_Encoding encoding, const char *src, int srcLen, Tcl_DString *dsPtr); /* 296 */
void (*tcl_FinalizeThread) (void); /* 297 */
@@ -2482,6 +2488,7 @@ typedef struct TclStubs {
void * (*tcl_FindSymbol) (Tcl_Interp *interp, Tcl_LoadHandle handle, const char *symbol); /* 628 */
int (*tcl_FSUnloadFile) (Tcl_Interp *interp, Tcl_LoadHandle handlePtr); /* 629 */
void (*tcl_ZlibStreamSetCompressionDictionary) (Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj); /* 630 */
+ Tcl_Channel (*tcl_OpenTcpServerEx) (Tcl_Interp *interp, const char *service, const char *host, unsigned int flags, Tcl_TcpAcceptProc *acceptProc, ClientData callbackData); /* 631 */
} TclStubs;
extern const TclStubs *tclStubsPtr;
@@ -3774,6 +3781,8 @@ extern const TclStubs *tclStubsPtr;
(tclStubsPtr->tcl_FSUnloadFile) /* 629 */
#define Tcl_ZlibStreamSetCompressionDictionary \
(tclStubsPtr->tcl_ZlibStreamSetCompressionDictionary) /* 630 */
+#define Tcl_OpenTcpServerEx \
+ (tclStubsPtr->tcl_OpenTcpServerEx) /* 631 */
#endif /* defined(USE_TCL_STUBS) */
@@ -3788,7 +3797,6 @@ extern const TclStubs *tclStubsPtr;
# undef Tcl_SetVar
# undef Tcl_ObjSetVar2
# undef Tcl_StaticPackage
-# undef TclFSGetNativePath
# define Tcl_CreateInterp() (tclStubsPtr->tcl_CreateInterp())
# define Tcl_GetStringResult(interp) (tclStubsPtr->tcl_GetStringResult(interp))
# define Tcl_Init(interp) (tclStubsPtr->tcl_Init(interp))
@@ -3827,13 +3835,13 @@ extern const TclStubs *tclStubsPtr;
sizeof(char *), msg, flags, indexPtr)
#undef Tcl_NewBooleanObj
#define Tcl_NewBooleanObj(boolValue) \
- Tcl_NewIntObj((boolValue)!=0)
+ Tcl_NewLongObj((boolValue)!=0)
#undef Tcl_DbNewBooleanObj
#define Tcl_DbNewBooleanObj(boolValue, file, line) \
Tcl_DbNewLongObj((boolValue)!=0, file, line)
#undef Tcl_SetBooleanObj
#define Tcl_SetBooleanObj(objPtr, boolValue) \
- Tcl_SetIntObj((objPtr), (boolValue)!=0)
+ Tcl_SetLongObj(objPtr, (boolValue)!=0)
#undef Tcl_SetVar
#define Tcl_SetVar(interp, varName, newValue, flags) \
Tcl_SetVar2(interp, varName, NULL, newValue, flags)
@@ -3855,6 +3863,51 @@ extern const TclStubs *tclStubsPtr;
#undef Tcl_UpVar
#define Tcl_UpVar(interp, frameName, varName, localName, flags) \
Tcl_UpVar2(interp, frameName, varName, NULL, localName, flags)
+#undef Tcl_AddErrorInfo
+#define Tcl_AddErrorInfo(interp, message) \
+ Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, -1))
+#undef Tcl_AddObjErrorInfo
+#define Tcl_AddObjErrorInfo(interp, message, length) \
+ Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, length))
+#ifdef TCL_NO_DEPRECATED
+#undef Tcl_Eval
+#define Tcl_Eval(interp, objPtr) \
+ Tcl_EvalEx(interp, objPtr, -1, 0)
+#undef Tcl_GlobalEval
+#define Tcl_GlobalEval(interp, objPtr) \
+ Tcl_EvalEx(interp, objPtr, -1, TCL_EVAL_GLOBAL)
+#undef Tcl_SaveResult
+#define Tcl_SaveResult(interp, statePtr) \
+ do { \
+ (statePtr)->objResultPtr = Tcl_GetObjResult(interp); \
+ Tcl_IncrRefCount((statePtr)->objResultPtr); \
+ Tcl_SetObjResult(interp, Tcl_NewObj()); \
+ } while(0)
+#undef Tcl_RestoreResult
+#define Tcl_RestoreResult(interp, statePtr) \
+ do { \
+ Tcl_ResetResult(interp); \
+ Tcl_SetObjResult(interp, (statePtr)->objResultPtr); \
+ Tcl_DecrRefCount((statePtr)->objResultPtr); \
+ } while(0)
+#undef Tcl_DiscardResult
+#define Tcl_DiscardResult(statePtr) \
+ Tcl_DecrRefCount((statePtr)->objResultPtr)
+#undef Tcl_SetResult
+#define Tcl_SetResult(interp, result, freeProc) \
+ do { \
+ char *__result = result; \
+ Tcl_FreeProc *__freeProc = freeProc; \
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(__result, -1)); \
+ if (__result != NULL && __freeProc != NULL && __freeProc != TCL_VOLATILE) { \
+ if (__freeProc == TCL_DYNAMIC) { \
+ ckfree(__result); \
+ } else { \
+ (*__freeProc)(__result); \
+ } \
+ } \
+ } while(0)
+#endif /* TCL_NO_DEPRECATED */
#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
# if defined(__CYGWIN__) && defined(TCL_WIDE_INT_IS_LONG)
@@ -3909,10 +3962,10 @@ extern const TclStubs *tclStubsPtr;
*/
#undef Tcl_EvalObj
-#define Tcl_EvalObj(interp,objPtr) \
- Tcl_EvalObjEx((interp),(objPtr),0)
+#define Tcl_EvalObj(interp, objPtr) \
+ Tcl_EvalObjEx(interp, objPtr, 0)
#undef Tcl_GlobalEvalObj
-#define Tcl_GlobalEvalObj(interp,objPtr) \
- Tcl_EvalObjEx((interp),(objPtr),TCL_EVAL_GLOBAL)
+#define Tcl_GlobalEvalObj(interp, objPtr) \
+ Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL)
#endif /* _TCLDECLS */
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index 428173d..970978f 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -142,7 +142,7 @@ typedef struct Dict {
* the entries in the order that they are
* created. */
int epoch; /* Epoch counter */
- int refcount; /* Reference counter (see above) */
+ size_t refCount; /* Reference counter (see above) */
Tcl_Obj *chain; /* Linked list used for invalidating the
* string representations of updated nested
* dictionaries. */
@@ -392,7 +392,7 @@ DupDictInternalRep(
newDict->epoch = 0;
newDict->chain = NULL;
- newDict->refcount = 1;
+ newDict->refCount = 1;
/*
* Store in the object.
@@ -427,8 +427,7 @@ FreeDictInternalRep(
{
Dict *dict = DICT(dictPtr);
- dict->refcount--;
- if (dict->refcount <= 0) {
+ if (dict->refCount-- <= 1) {
DeleteDict(dict);
}
dictPtr->typePtr = NULL;
@@ -507,7 +506,7 @@ UpdateStringOfDict(
/* Handle empty list case first, simplifies what follows */
if (numElems == 0) {
- dictPtr->bytes = tclEmptyStringRep;
+ dictPtr->bytes = &tclEmptyString;
dictPtr->length = 0;
return;
}
@@ -713,7 +712,7 @@ SetDictFromAny(
TclFreeIntRep(objPtr);
dict->epoch = 0;
dict->chain = NULL;
- dict->refcount = 1;
+ dict->refCount = 1;
DICT(objPtr) = dict;
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = &tclDictType;
@@ -1117,7 +1116,7 @@ Tcl_DictObjFirst(
searchPtr->dictionaryPtr = (Tcl_Dict) dict;
searchPtr->epoch = dict->epoch;
searchPtr->next = cPtr->nextPtr;
- dict->refcount++;
+ dict->refCount++;
if (keyPtrPtr != NULL) {
*keyPtrPtr = Tcl_GetHashKey(&dict->table, &cPtr->entry);
}
@@ -1231,8 +1230,7 @@ Tcl_DictObjDone(
if (searchPtr->epoch != -1) {
searchPtr->epoch = -1;
dict = (Dict *) searchPtr->dictionaryPtr;
- dict->refcount--;
- if (dict->refcount <= 0) {
+ if (dict->refCount-- <= 1) {
DeleteDict(dict);
}
}
@@ -1384,7 +1382,7 @@ Tcl_NewDictObj(void)
InitChainTable(dict);
dict->epoch = 0;
dict->chain = NULL;
- dict->refcount = 1;
+ dict->refCount = 1;
DICT(dictPtr) = dict;
dictPtr->internalRep.twoPtrValue.ptr2 = NULL;
dictPtr->typePtr = &tclDictType;
@@ -1434,7 +1432,7 @@ Tcl_DbNewDictObj(
InitChainTable(dict);
dict->epoch = 0;
dict->chain = NULL;
- dict->refcount = 1;
+ dict->refCount = 1;
DICT(dictPtr) = dict;
dictPtr->internalRep.twoPtrValue.ptr2 = NULL;
dictPtr->typePtr = &tclDictType;
@@ -2282,7 +2280,7 @@ DictAppendCmd(
Tcl_Obj *const *objv)
{
Tcl_Obj *dictPtr, *valuePtr, *resultPtr;
- int i, allocatedDict = 0;
+ int allocatedDict = 0;
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?value ...?");
@@ -2305,17 +2303,44 @@ DictAppendCmd(
return TCL_ERROR;
}
- if (valuePtr == NULL) {
- TclNewObj(valuePtr);
- } else if (Tcl_IsShared(valuePtr)) {
- valuePtr = Tcl_DuplicateObj(valuePtr);
- }
+ if ((objc > 3) || (valuePtr == NULL)) {
+ /* Only go through append activites when something will change. */
+ Tcl_Obj *appendObjPtr = NULL;
- for (i=3 ; i<objc ; i++) {
- Tcl_AppendObjToObj(valuePtr, objv[i]);
+ if (objc > 3) {
+ /* Something to append */
+
+ if (objc == 4) {
+ appendObjPtr = objv[3];
+ } else if (TCL_OK != TclStringCatObjv(interp, /* inPlace */ 1,
+ objc-3, objv+3, &appendObjPtr)) {
+ return TCL_ERROR;
+ }
+ }
+
+ if (appendObjPtr == NULL) {
+ /* => (objc == 3) => (valuePtr == NULL) */
+ TclNewObj(valuePtr);
+ } else if (valuePtr == NULL) {
+ valuePtr = appendObjPtr;
+ appendObjPtr = NULL;
+ }
+
+ if (appendObjPtr) {
+ if (Tcl_IsShared(valuePtr)) {
+ valuePtr = Tcl_DuplicateObj(valuePtr);
+ }
+
+ Tcl_AppendObjToObj(valuePtr, appendObjPtr);
+ }
+
+ Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr);
}
- Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr);
+ /*
+ * Even if nothing changed, we still overwrite so that variable
+ * trace expectations are met.
+ */
resultPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr,
TCL_LEAVE_ERR_MSG);
diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c
index 0d6da8e..5e977e6 100644
--- a/generic/tclDisassemble.c
+++ b/generic/tclDisassemble.c
@@ -254,7 +254,6 @@ DisassembleByteCodeObj(
int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i, line;
Interp *iPtr = (Interp *) *codePtr->interpHandle;
Tcl_Obj *bufferObj, *fileObj;
- char ptrBuf1[20], ptrBuf2[20];
TclNewObj(bufferObj);
if (codePtr->refCount <= 0) {
@@ -269,11 +268,9 @@ DisassembleByteCodeObj(
* Print header lines describing the ByteCode.
*/
- 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,
+ "ByteCode %p, refCt %u, epoch %u, interp %p (epoch %u)\n",
+ codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr,
iPtr->compileEpoch);
Tcl_AppendToObj(bufferObj, " Source ", -1);
PrintSourceToObj(bufferObj, codePtr->source,
@@ -316,10 +313,9 @@ DisassembleByteCodeObj(
Proc *procPtr = codePtr->procPtr;
int numCompiledLocals = procPtr->numCompiledLocals;
- sprintf(ptrBuf1, "%p", procPtr);
Tcl_AppendPrintfToObj(bufferObj,
- " Proc 0x%s, refCt %d, args %d, compiled locals %d\n",
- ptrBuf1, procPtr->refCount, procPtr->numArgs,
+ " Proc %p, refCt %d, args %d, compiled locals %d\n",
+ procPtr, procPtr->refCount, procPtr->numArgs,
numCompiledLocals);
if (numCompiledLocals > 0) {
CompiledLocal *localPtr = procPtr->firstLocalPtr;
diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c
index 99cb315..91c2278 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.c
@@ -46,7 +46,7 @@ typedef struct Encoding {
* nullSize is 2, this is a function that
* returns the number of bytes in a 0x0000
* terminated string. */
- int refCount; /* Number of uses of this structure. */
+ size_t refCount; /* Number of uses of this structure. */
Tcl_HashEntry *hPtr; /* Hash table entry that owns this encoding. */
} Encoding;
@@ -305,7 +305,7 @@ Tcl_GetEncodingFromObj(
Tcl_Obj *objPtr,
Tcl_Encoding *encodingPtr)
{
- const char *name = Tcl_GetString(objPtr);
+ const char *name = TclGetString(objPtr);
if (objPtr->typePtr != &encodingType) {
Tcl_Encoding encoding = Tcl_GetEncoding(interp, name);
@@ -705,7 +705,7 @@ Tcl_GetDefaultEncodingDir(void)
}
Tcl_ListObjIndex(NULL, searchPath, 0, &first);
- return Tcl_GetString(first);
+ return TclGetString(first);
}
/*
@@ -844,11 +844,7 @@ FreeEncoding(
if (encodingPtr == NULL) {
return;
}
- if (encodingPtr->refCount<=0) {
- Tcl_Panic("FreeEncoding: refcount problem !!!");
- }
- encodingPtr->refCount--;
- if (encodingPtr->refCount == 0) {
+ if (encodingPtr->refCount-- <= 1) {
if (encodingPtr->freeProc != NULL) {
encodingPtr->freeProc(encodingPtr->clientData);
}
@@ -977,7 +973,7 @@ Tcl_GetEncodingNames(
* Side effects:
* The reference count of the new system encoding is incremented. The
* reference count of the old system encoding is decremented and it may
- * be freed.
+ * be freed. All VFS cached information is invalidated.
*
*------------------------------------------------------------------------
*/
@@ -1008,6 +1004,7 @@ Tcl_SetSystemEncoding(
FreeEncoding(systemEncoding);
systemEncoding = encoding;
Tcl_MutexUnlock(&encodingMutex);
+ Tcl_FSMountsChanged(NULL);
return TCL_OK;
}
@@ -1518,10 +1515,10 @@ OpenEncodingFileChannel(
}
}
if (!verified) {
- const char *dirString = Tcl_GetString(directory);
+ const char *dirString = TclGetString(directory);
for (i=0; i<numDirs && !verified; i++) {
- if (strcmp(dirString, Tcl_GetString(dir[i])) == 0) {
+ if (strcmp(dirString, TclGetString(dir[i])) == 0) {
verified = 1;
}
}
@@ -1762,7 +1759,7 @@ LoadTableEncoding(
const char *p;
Tcl_ReadChars(chan, objPtr, 3 + 16 * (16 * 4 + 1), 0);
- p = Tcl_GetString(objPtr);
+ p = TclGetString(objPtr);
hi = (staticHex[UCHAR(p[0])] << 4) + staticHex[UCHAR(p[1])];
dataPtr->toUnicode[hi] = pageMemPtr;
p += 2;
@@ -3599,11 +3596,11 @@ unilen(
static void
InitializeEncodingSearchPath(
char **valuePtr,
- int *lengthPtr,
+ size_t *lengthPtr,
Tcl_Encoding *encodingPtr)
{
const char *bytes;
- int i, numDirs, numBytes;
+ int i, numDirs;
Tcl_Obj *libPathObj, *encodingObj, *searchPathObj;
TclNewLiteralStringObj(encodingObj, "encoding");
@@ -3633,11 +3630,11 @@ InitializeEncodingSearchPath(
if (*encodingPtr) {
((Encoding *)(*encodingPtr))->refCount++;
}
- bytes = TclGetStringFromObj(searchPathObj, &numBytes);
+ bytes = TclGetString(searchPathObj);
- *lengthPtr = numBytes;
- *valuePtr = ckalloc(numBytes + 1);
- memcpy(*valuePtr, bytes, (size_t) numBytes + 1);
+ *lengthPtr = searchPathObj->length;
+ *valuePtr = ckalloc(*lengthPtr + 1);
+ memcpy(*valuePtr, bytes, *lengthPtr + 1);
Tcl_DecrRefCount(searchPathObj);
}
diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
index 43813f1..f3e8187 100644
--- a/generic/tclEnsemble.c
+++ b/generic/tclEnsemble.c
@@ -92,7 +92,7 @@ static const Tcl_ObjType ensembleCmdType = {
*/
typedef struct {
- int epoch; /* Used to confirm when the data in this
+ size_t epoch; /* Used to confirm when the data in this
* really structure matches up with the
* ensemble. */
Command *token; /* Reference to the command for which this
@@ -1605,7 +1605,7 @@ TclMakeEnsemble(
Tcl_DStringFree(&buf);
Tcl_DStringFree(&hiddenBuf);
if (nameParts != NULL) {
- ckfree((char *) nameParts);
+ ckfree(nameParts);
}
return ensemble;
}
@@ -3135,7 +3135,7 @@ TclCompileEnsemble(
* any extra elements that might have been appended by failing
* pathways above.
*/
- (void) Tcl_ListObjReplace(NULL, replaced, depth-1, INT_MAX, 0, NULL);
+ (void) Tcl_ListObjReplace(NULL, replaced, depth-1, LIST_MAX, 0, NULL);
/*
* TODO: Reconsider whether we ought to call CompileToInvokedCommand()
@@ -3306,7 +3306,7 @@ CompileToInvokedCommand(
Tcl_Token *tokPtr;
Tcl_Obj *objPtr, **words;
char *bytes;
- int length, i, numWords, cmdLit, extraLiteralFlags = LITERAL_CMD_NAME;
+ int i, numWords, cmdLit, extraLiteralFlags = LITERAL_CMD_NAME;
DefineLineInformation;
/*
@@ -3319,8 +3319,8 @@ CompileToInvokedCommand(
for (i = 0, tokPtr = parsePtr->tokenPtr; i < parsePtr->numWords;
i++, tokPtr = TokenAfter(tokPtr)) {
if (i > 0 && i < numWords+1) {
- bytes = TclGetStringFromObj(words[i-1], &length);
- PushLiteral(envPtr, bytes, length);
+ bytes = TclGetString(words[i-1]);
+ PushLiteral(envPtr, bytes, words[i-1]->length);
continue;
}
@@ -3348,11 +3348,11 @@ CompileToInvokedCommand(
objPtr = Tcl_NewObj();
Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr);
- bytes = Tcl_GetStringFromObj(objPtr, &length);
+ bytes = TclGetString(objPtr);
if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) {
extraLiteralFlags |= LITERAL_UNSHARED;
}
- cmdLit = TclRegisterLiteral(envPtr, bytes, length, extraLiteralFlags);
+ cmdLit = TclRegisterLiteral(envPtr, bytes, objPtr->length, extraLiteralFlags);
TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLit), cmdPtr);
TclEmitPush(cmdLit, envPtr);
TclDecrRefCount(objPtr);
diff --git a/generic/tclEvent.c b/generic/tclEvent.c
index 0eabc13..49fd2ae 100644
--- a/generic/tclEvent.c
+++ b/generic/tclEvent.c
@@ -37,7 +37,7 @@ typedef struct BgError {
* pending background errors for the interpreter.
*/
-typedef struct ErrAssocData {
+typedef struct {
Tcl_Interp *interp; /* Interpreter in which error occurred. */
Tcl_Obj *cmdPrefix; /* First word(s) of the handler command */
BgError *firstBgPtr; /* First in list of all background errors
@@ -1044,7 +1044,7 @@ TclInitSubsystems(void)
TclInitAlloc(); /* Process wide mutex init */
#endif
#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
- TclpInitAllocCache();
+ TclInitThreadAlloc(); /* Setup thread allocator caches */
#endif
#ifdef TCL_MEM_DEBUG
TclInitDbCkalloc(); /* Process wide mutex init */
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index df36958..ad80b28 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -19,7 +19,6 @@
#include "tclCompile.h"
#include "tclOOInt.h"
#include "tommath.h"
-#include "tclStringRep.h"
#include <math.h>
#include <assert.h>
@@ -326,7 +325,7 @@ VarHashCreateVar(
NEXT_INST_F(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \
default: \
if ((condition) < 0) { \
- TclNewIntObj(objResultPtr, -1); \
+ TclNewLongObj(objResultPtr, -1); \
} else { \
objResultPtr = TCONST((condition) > 0); \
} \
@@ -347,7 +346,7 @@ VarHashCreateVar(
NEXT_INST_V(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \
default: \
if ((condition) < 0) { \
- TclNewIntObj(objResultPtr, -1); \
+ TclNewLongObj(objResultPtr, -1); \
} else { \
objResultPtr = TCONST((condition) > 0); \
} \
@@ -358,7 +357,7 @@ VarHashCreateVar(
#define JUMP_PEEPHOLE_F(condition, pcAdjustment, cleanup) \
do{ \
if ((condition) < 0) { \
- TclNewIntObj(objResultPtr, -1); \
+ TclNewLongObj(objResultPtr, -1); \
} else { \
objResultPtr = TCONST((condition) > 0); \
} \
@@ -367,7 +366,7 @@ VarHashCreateVar(
#define JUMP_PEEPHOLE_V(condition, pcAdjustment, cleanup) \
do{ \
if ((condition) < 0) { \
- TclNewIntObj(objResultPtr, -1); \
+ TclNewLongObj(objResultPtr, -1); \
} else { \
objResultPtr = TCONST((condition) > 0); \
} \
@@ -513,7 +512,7 @@ VarHashCreateVar(
(&((objPtr)->internalRep.doubleValue)), TCL_OK) : \
((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \
(((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \
- ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \
+ ? TCL_ERROR : \
TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr)))
#else /* !TCL_WIDE_INT_IS_LONG */
#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \
@@ -533,7 +532,7 @@ VarHashCreateVar(
(&((objPtr)->internalRep.doubleValue)), TCL_OK) : \
((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \
(((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \
- ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \
+ ? TCL_ERROR : \
TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr)))
#endif /* TCL_WIDE_INT_IS_LONG */
@@ -911,9 +910,9 @@ TclCreateExecEnv(
+ (size_t) (size-1) * sizeof(Tcl_Obj *));
eePtr->execStackPtr = esPtr;
- TclNewBooleanObj(eePtr->constants[0], 0);
+ TclNewLongObj(eePtr->constants[0], 0);
Tcl_IncrRefCount(eePtr->constants[0]);
- TclNewBooleanObj(eePtr->constants[1], 1);
+ TclNewLongObj(eePtr->constants[1], 1);
Tcl_IncrRefCount(eePtr->constants[1]);
eePtr->interp = interp;
eePtr->callbackPtr = NULL;
@@ -1275,7 +1274,7 @@ TclStackFree(
Tcl_Obj **markerPtr, *marker;
if (iPtr == NULL || iPtr->execEnvPtr == NULL) {
- ckfree((char *) freePtr);
+ ckfree(freePtr);
return;
}
@@ -1542,11 +1541,10 @@ CompileExprObj(
* TIP #280: No invoker (yet) - Expression compilation.
*/
- int length;
- const char *string = TclGetStringFromObj(objPtr, &length);
+ const char *string = TclGetString(objPtr);
- TclInitCompileEnv(interp, &compEnv, string, length, NULL, 0);
- TclCompileExpr(interp, string, length, &compEnv, 0);
+ TclInitCompileEnv(interp, &compEnv, string, objPtr->length, NULL, 0);
+ TclCompileExpr(interp, string, objPtr->length, &compEnv, 0);
/*
* Successful compilation. If the expression yielded no instructions,
@@ -2538,7 +2536,7 @@ TEBCresume(
/* FIXME: What is the right thing to trace? */
fprintf(stdout, "%d: (%u) yielding to [%.30s]\n",
iPtr->numLevels, (unsigned)(pc - codePtr->codeStart),
- Tcl_GetString(valuePtr));
+ TclGetString(valuePtr));
}
fflush(stdout);
}
@@ -2685,154 +2683,18 @@ TEBCresume(
NEXT_INST_F(5, 0, 0);
}
- case INST_STR_CONCAT1: {
- int appendLen = 0;
- char *bytes, *p;
- Tcl_Obj **currPtr;
- int onlyb = 1;
+ case INST_STR_CONCAT1:
opnd = TclGetUInt1AtPtr(pc+1);
- /*
- * Detect only-bytearray-or-null case.
- */
-
- for (currPtr=&OBJ_AT_DEPTH(opnd-1); currPtr<=&OBJ_AT_TOS; currPtr++) {
- if (((*currPtr)->typePtr != &tclByteArrayType)
- && ((*currPtr)->bytes != tclEmptyStringRep)) {
- onlyb = 0;
- break;
- } else if (((*currPtr)->typePtr == &tclByteArrayType) &&
- ((*currPtr)->bytes != NULL)) {
- onlyb = 0;
- break;
- }
- }
-
- /*
- * Compute the length to be appended.
- */
-
- if (onlyb) {
- for (currPtr = &OBJ_AT_DEPTH(opnd-2);
- appendLen >= 0 && currPtr <= &OBJ_AT_TOS; currPtr++) {
- if ((*currPtr)->bytes != tclEmptyStringRep) {
- Tcl_GetByteArrayFromObj(*currPtr, &length);
- appendLen += length;
- }
- }
- } else {
- for (currPtr = &OBJ_AT_DEPTH(opnd-2);
- appendLen >= 0 && currPtr <= &OBJ_AT_TOS; currPtr++) {
- bytes = TclGetStringFromObj(*currPtr, &length);
- if (bytes != NULL) {
- appendLen += length;
- }
- }
- }
-
- if (appendLen < 0) {
- /* TODO: convert panic to error ? */
- Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
- }
-
- /*
- * If nothing is to be appended, just return the first object by
- * dropping all the others from the stack; this saves both the
- * computation and copy of the string rep of the first object,
- * enabling the fast '$x[set x {}]' idiom for 'K $x [set x {}]'.
- */
-
- if (appendLen == 0) {
- TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
- NEXT_INST_V(2, (opnd-1), 0);
- }
-
- /*
- * If the first object is shared, we need a new obj for the result;
- * otherwise, we can reuse the first object. In any case, make sure it
- * has enough room to accomodate all the concatenated bytes. Note that
- * if it is unshared its bytes are copied by ckrealloc, so that we set
- * the loop parameters to avoid copying them again: p points to the
- * end of the already copied bytes, currPtr to the second object.
- */
-
- objResultPtr = OBJ_AT_DEPTH(opnd-1);
- if (!onlyb) {
- bytes = TclGetStringFromObj(objResultPtr, &length);
- if (length + appendLen < 0) {
- /* TODO: convert panic to error ? */
- Tcl_Panic("max size for a Tcl value (%d bytes) exceeded",
- INT_MAX);
- }
-#ifndef TCL_COMPILE_DEBUG
- if (bytes != tclEmptyStringRep && !Tcl_IsShared(objResultPtr)) {
- TclFreeIntRep(objResultPtr);
- objResultPtr->bytes = ckrealloc(bytes, length+appendLen+1);
- objResultPtr->length = length + appendLen;
- p = TclGetString(objResultPtr) + length;
- currPtr = &OBJ_AT_DEPTH(opnd - 2);
- } else
-#endif
- {
- p = ckalloc(length + appendLen + 1);
- TclNewObj(objResultPtr);
- objResultPtr->bytes = p;
- objResultPtr->length = length + appendLen;
- currPtr = &OBJ_AT_DEPTH(opnd - 1);
- }
-
- /*
- * Append the remaining characters.
- */
-
- for (; currPtr <= &OBJ_AT_TOS; currPtr++) {
- bytes = TclGetStringFromObj(*currPtr, &length);
- if (bytes != NULL) {
- memcpy(p, bytes, (size_t) length);
- p += length;
- }
- }
- *p = '\0';
- } else {
- bytes = (char *) Tcl_GetByteArrayFromObj(objResultPtr, &length);
- if (length + appendLen < 0) {
- /* TODO: convert panic to error ? */
- Tcl_Panic("max size for a Tcl value (%d bytes) exceeded",
- INT_MAX);
- }
-#ifndef TCL_COMPILE_DEBUG
- if (!Tcl_IsShared(objResultPtr)) {
- bytes = (char *) Tcl_SetByteArrayLength(objResultPtr,
- length + appendLen);
- p = bytes + length;
- currPtr = &OBJ_AT_DEPTH(opnd - 2);
- } else
-#endif
- {
- TclNewObj(objResultPtr);
- bytes = (char *) Tcl_SetByteArrayLength(objResultPtr,
- length + appendLen);
- p = bytes;
- currPtr = &OBJ_AT_DEPTH(opnd - 1);
- }
-
- /*
- * Append the remaining characters.
- */
-
- for (; currPtr <= &OBJ_AT_TOS; currPtr++) {
- if ((*currPtr)->bytes != tclEmptyStringRep) {
- bytes = (char *) Tcl_GetByteArrayFromObj(*currPtr,&length);
- memcpy(p, bytes, (size_t) length);
- p += length;
- }
- }
+ if (TCL_OK != TclStringCatObjv(interp, /* inPlace */ 1,
+ opnd, &OBJ_AT_DEPTH(opnd-1), &objResultPtr)) {
+ TRACE_ERROR(interp);
+ goto gotError;
}
TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
NEXT_INST_V(2, opnd, 1);
- }
case INST_CONCAT_STK:
/*
@@ -4666,7 +4528,7 @@ TEBCresume(
NEXT_INST_F(1, 0, 1);
}
case INST_INFO_LEVEL_NUM:
- TclNewIntObj(objResultPtr, iPtr->varFramePtr->level);
+ TclNewLongObj(objResultPtr, iPtr->varFramePtr->level);
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(1, 0, 1);
case INST_INFO_LEVEL_ARGS: {
@@ -5035,7 +4897,7 @@ TEBCresume(
TRACE_ERROR(interp);
goto gotError;
}
- TclNewIntObj(objResultPtr, length);
+ TclNewLongObj(objResultPtr, length);
TRACE_APPEND(("%d\n", length));
NEXT_INST_F(1, 1, 1);
@@ -5506,7 +5368,7 @@ TEBCresume(
case INST_STR_LEN:
valuePtr = OBJ_AT_TOS;
length = Tcl_GetCharLength(valuePtr);
- TclNewIntObj(objResultPtr, length);
+ TclNewLongObj(objResultPtr, length);
TRACE(("\"%.20s\" => %d\n", O2S(valuePtr), length));
NEXT_INST_F(1, 1, 1);
@@ -5712,17 +5574,6 @@ TEBCresume(
length3 = Tcl_GetCharLength(value3Ptr);
/*
- * Remove substring. In-place.
- */
-
- if (length3 == 0 && !Tcl_IsShared(valuePtr) && toIdx == length) {
- TclDecrRefCount(value3Ptr);
- Tcl_SetObjLength(valuePtr, fromIdx);
- TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr)));
- NEXT_INST_F(1, 0, 0);
- }
-
- /*
* See if we can splice in place. This happens when the number of
* characters being replaced is the same as the number of characters
* in the string to be inserted.
@@ -5731,51 +5582,29 @@ TEBCresume(
if (length3 - 1 == toIdx - fromIdx) {
unsigned char *bytes1, *bytes2;
- /*
- * Flush the info in the string internal rep that refers to the
- * about-to-be-invalidated UTF-8 rep. This indicates that a new
- * buffer needs to be allocated, and assumes that the value is
- * already of tclStringTypePtr type, which should be true provided
- * we call it after Tcl_GetUnicodeFromObj.
- */
-#define MarkStringInternalRepForFlush(objPtr) \
- (GET_STRING(objPtr)->allocated = 0)
-
if (Tcl_IsShared(valuePtr)) {
objResultPtr = Tcl_DuplicateObj(valuePtr);
- if (TclIsPureByteArray(objResultPtr)
- && TclIsPureByteArray(value3Ptr)) {
- bytes1 = Tcl_GetByteArrayFromObj(objResultPtr, NULL);
- bytes2 = Tcl_GetByteArrayFromObj(value3Ptr, NULL);
- memcpy(bytes1 + fromIdx, bytes2, length3);
- } else {
- ustring1 = Tcl_GetUnicodeFromObj(objResultPtr, NULL);
- ustring2 = Tcl_GetUnicodeFromObj(value3Ptr, NULL);
- memcpy(ustring1 + fromIdx, ustring2,
- length3 * sizeof(Tcl_UniChar));
- MarkStringInternalRepForFlush(objResultPtr);
- }
- Tcl_InvalidateStringRep(objResultPtr);
- TclDecrRefCount(value3Ptr);
- TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 1, 1);
} else {
- if (TclIsPureByteArray(valuePtr)
- && TclIsPureByteArray(value3Ptr)) {
- bytes1 = Tcl_GetByteArrayFromObj(valuePtr, NULL);
- bytes2 = Tcl_GetByteArrayFromObj(value3Ptr, NULL);
- memcpy(bytes1 + fromIdx, bytes2, length3);
- } else {
- ustring1 = Tcl_GetUnicodeFromObj(valuePtr, NULL);
- ustring2 = Tcl_GetUnicodeFromObj(value3Ptr, NULL);
- memcpy(ustring1 + fromIdx, ustring2,
- length3 * sizeof(Tcl_UniChar));
- MarkStringInternalRepForFlush(valuePtr);
- }
- Tcl_InvalidateStringRep(valuePtr);
- TclDecrRefCount(value3Ptr);
- TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr)));
+ objResultPtr = valuePtr;
+ }
+ if (TclIsPureByteArray(objResultPtr)
+ && TclIsPureByteArray(value3Ptr)) {
+ bytes1 = Tcl_GetByteArrayFromObj(objResultPtr, NULL);
+ bytes2 = Tcl_GetByteArrayFromObj(value3Ptr, NULL);
+ memcpy(bytes1 + fromIdx, bytes2, length3);
+ } else {
+ ustring1 = Tcl_GetUnicodeFromObj(objResultPtr, NULL);
+ ustring2 = Tcl_GetUnicodeFromObj(value3Ptr, NULL);
+ memcpy(ustring1 + fromIdx, ustring2,
+ length3 * sizeof(Tcl_UniChar));
+ }
+ Tcl_InvalidateStringRep(objResultPtr);
+ TclDecrRefCount(value3Ptr);
+ TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
+ if (objResultPtr == valuePtr) {
NEXT_INST_F(1, 0, 0);
+ } else {
+ NEXT_INST_F(1, 1, 1);
}
}
@@ -5791,54 +5620,38 @@ TEBCresume(
* Remove substring using copying.
*/
- if (length3 == 0) {
- if (fromIdx > 0) {
- objResultPtr = Tcl_NewUnicodeObj(ustring1, fromIdx);
- if (toIdx < length) {
- Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1,
- length - toIdx);
- }
- } else {
- objResultPtr = Tcl_NewUnicodeObj(ustring1 + toIdx + 1,
- length - toIdx);
- }
- TclDecrRefCount(value3Ptr);
- TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
- NEXT_INST_F(1, 1, 1);
- }
-
- /*
- * Splice string pieces by full copying.
- */
-
+ objResultPtr = NULL;
if (fromIdx > 0) {
objResultPtr = Tcl_NewUnicodeObj(ustring1, fromIdx);
- Tcl_AppendObjToObj(objResultPtr, value3Ptr);
- if (toIdx < length) {
- Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1,
- length - toIdx);
+ }
+ if (length3 > 0) {
+ if (objResultPtr) {
+ Tcl_AppendObjToObj(objResultPtr, value3Ptr);
+ } else if (Tcl_IsShared(value3Ptr)) {
+ objResultPtr = Tcl_DuplicateObj(value3Ptr);
+ } else {
+ objResultPtr = value3Ptr;
}
- } else if (Tcl_IsShared(value3Ptr)) {
- objResultPtr = Tcl_DuplicateObj(value3Ptr);
- if (toIdx < length) {
+ }
+ if (toIdx < length) {
+ if (objResultPtr) {
Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1,
length - toIdx);
- }
- } else {
- /*
- * Be careful with splicing the stack in this case; we have a
- * refCount:1 object in value3Ptr and we want to append to it and
- * make it be the refCount:1 object at the top of the stack
- * afterwards. [Bug 82e7f67325]
- */
-
- if (toIdx < length) {
- Tcl_AppendUnicodeToObj(value3Ptr, ustring1 + toIdx + 1,
+ } else {
+ objResultPtr = Tcl_NewUnicodeObj(ustring1 + toIdx + 1,
length - toIdx);
}
+ }
+ if (objResultPtr == NULL) {
+ /* This has to be the case [string replace $s 0 end {}] */
+ /* which has result {} which is same as value3Ptr. */
+ objResultPtr = value3Ptr;
+ }
+ if (objResultPtr == value3Ptr) {
+ /* See [Bug 82e7f67325] */
+ TclDecrRefCount(OBJ_AT_TOS);
+ OBJ_AT_TOS = value3Ptr;
TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr)));
- TclDecrRefCount(valuePtr);
- OBJ_AT_TOS = value3Ptr; /* Tricky! */
NEXT_INST_F(1, 0, 0);
}
TclDecrRefCount(value3Ptr);
@@ -5906,45 +5719,19 @@ TEBCresume(
NEXT_INST_V(1, 3, 1);
case INST_STR_FIND:
- ustring1 = Tcl_GetUnicodeFromObj(OBJ_AT_TOS, &length); /* Haystack */
- ustring2 = Tcl_GetUnicodeFromObj(OBJ_UNDER_TOS, &length2);/* Needle */
-
- match = -1;
- if (length2 > 0 && length2 <= length) {
- end = ustring1 + length - length2 + 1;
- for (p=ustring1 ; p<end ; p++) {
- if ((*p == *ustring2) &&
- memcmp(ustring2,p,sizeof(Tcl_UniChar)*length2) == 0) {
- match = p - ustring1;
- break;
- }
- }
- }
+ match = TclStringFind(OBJ_UNDER_TOS, OBJ_AT_TOS, 0);
TRACE(("%.20s %.20s => %d\n",
O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match));
- TclNewIntObj(objResultPtr, match);
+ TclNewLongObj(objResultPtr, match);
NEXT_INST_F(1, 2, 1);
case INST_STR_FIND_LAST:
- ustring1 = Tcl_GetUnicodeFromObj(OBJ_AT_TOS, &length); /* Haystack */
- ustring2 = Tcl_GetUnicodeFromObj(OBJ_UNDER_TOS, &length2);/* Needle */
-
- match = -1;
- if (length2 > 0 && length2 <= length) {
- for (p=ustring1+length-length2 ; p>=ustring1 ; p--) {
- if ((*p == *ustring2) &&
- memcmp(ustring2,p,sizeof(Tcl_UniChar)*length2) == 0) {
- match = p - ustring1;
- break;
- }
- }
- }
+ match = TclStringLast(OBJ_UNDER_TOS, OBJ_AT_TOS, INT_MAX - 1);
TRACE(("%.20s %.20s => %d\n",
O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match));
-
- TclNewIntObj(objResultPtr, match);
+ TclNewLongObj(objResultPtr, match);
NEXT_INST_F(1, 2, 1);
case INST_STR_CLASS:
@@ -6148,7 +5935,7 @@ TEBCresume(
type1 = TCL_NUMBER_WIDE;
}
}
- TclNewIntObj(objResultPtr, type1);
+ TclNewLongObj(objResultPtr, type1);
TRACE(("\"%.20s\" => %d\n", O2S(OBJ_AT_TOS), type1));
NEXT_INST_F(1, 1, 1);
@@ -6163,16 +5950,17 @@ TEBCresume(
value2Ptr = OBJ_AT_TOS;
valuePtr = OBJ_UNDER_TOS;
- if (GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) {
+ if (GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK
+ || GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK) {
/*
* At least one non-numeric argument - compare as strings.
*/
goto stringCompare;
}
- if (type1 == TCL_NUMBER_NAN) {
+ if (type1 == TCL_NUMBER_NAN || type2 == TCL_NUMBER_NAN) {
/*
- * NaN first arg: NaN != to everything, other compares are false.
+ * NaN arg: NaN != to everything, other compares are false.
*/
iResult = (*pc == INST_NEQ);
@@ -6182,21 +5970,6 @@ TEBCresume(
compare = MP_EQ;
goto convertComparison;
}
- if (GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK) {
- /*
- * At least one non-numeric argument - compare as strings.
- */
-
- goto stringCompare;
- }
- if (type2 == TCL_NUMBER_NAN) {
- /*
- * NaN 2nd arg: NaN != to everything, other compares are false.
- */
-
- iResult = (*pc == INST_NEQ);
- goto foundResult;
- }
if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) {
l1 = *((const long *)ptr1);
l2 = *((const long *)ptr2);
@@ -6355,7 +6128,7 @@ TEBCresume(
if (l1 > 0L) {
objResultPtr = TCONST(0);
} else {
- TclNewIntObj(objResultPtr, -1);
+ TclNewLongObj(objResultPtr, -1);
}
TRACE(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
@@ -7255,7 +7028,7 @@ TEBCresume(
NEXT_INST_F(1, 0, -1);
case INST_PUSH_RETURN_CODE:
- TclNewIntObj(objResultPtr, result);
+ TclNewLongObj(objResultPtr, result);
TRACE(("=> %u\n", result));
NEXT_INST_F(1, 0, 1);
@@ -7891,6 +7664,39 @@ TEBCresume(
* -----------------------------------------------------------------
*/
+ case INST_CLOCK_READ:
+ { /* Read the wall clock */
+ Tcl_WideInt wval;
+ Tcl_Time now;
+ switch(TclGetUInt1AtPtr(pc+1)) {
+ case 0: /* clicks */
+#ifdef TCL_WIDE_CLICKS
+ wval = TclpGetWideClicks();
+#else
+ wval = (Tcl_WideInt) TclpGetClicks();
+#endif
+ break;
+ case 1: /* microseconds */
+ Tcl_GetTime(&now);
+ wval = (Tcl_WideInt) now.sec * 1000000 + now.usec;
+ break;
+ case 2: /* milliseconds */
+ Tcl_GetTime(&now);
+ wval = (Tcl_WideInt) now.sec * 1000 + now.usec / 1000;
+ break;
+ case 3: /* seconds */
+ Tcl_GetTime(&now);
+ wval = (Tcl_WideInt) now.sec;
+ break;
+ default:
+ Tcl_Panic("clockRead instruction with unknown clock#");
+ }
+ /* TclNewWideObj(objResultPtr, wval); doesn't exist */
+ objResultPtr = Tcl_NewWideIntObj(wval);
+ TRACE_WITH_OBJ(("=> "), objResultPtr);
+ NEXT_INST_F(2, 0, 1);
+ }
+
default:
Tcl_Panic("TclNRExecuteByteCode: unrecognized opCode %u", *pc);
} /* end of switch on opCode */
@@ -9147,7 +8953,7 @@ ExecuteExtendedBinaryMathOp(
}
Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
mp_init(&bigResult);
- mp_expt_d(&big1, big2.dp[0], &bigResult);
+ mp_expt_d_ex(&big1, big2.dp[0], &bigResult, 1);
mp_clear(&big1);
mp_clear(&big2);
BIG_RESULT(&bigResult);
@@ -9671,9 +9477,9 @@ PrintByteCodeInfo(
Proc *procPtr = codePtr->procPtr;
Interp *iPtr = (Interp *) *codePtr->interpHandle;
- fprintf(stdout, "\nExecuting ByteCode 0x%p, refCt %u, epoch %u, interp 0x%p (epoch %u)\n",
- codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr,
- iPtr->compileEpoch);
+ fprintf(stdout, "\nExecuting ByteCode 0x%p, refCt %" TCL_LL_MODIFIER "u, epoch %" TCL_LL_MODIFIER "u, interp 0x%p (epoch %" TCL_LL_MODIFIER "u)\n",
+ codePtr, (Tcl_WideInt)codePtr->refCount, (Tcl_WideInt)codePtr->compileEpoch, iPtr,
+ (Tcl_WideInt)iPtr->compileEpoch);
fprintf(stdout, " Source: ");
TclPrintSource(stdout, codePtr->source, 60);
@@ -9770,7 +9576,7 @@ ValidatePcAndStackTop(
TclNewLiteralStringObj(message, "\n executing ");
Tcl_IncrRefCount(message);
Tcl_AppendLimitedToObj(message, cmd, numChars, 100, NULL);
- fprintf(stderr,"%s\n", Tcl_GetString(message));
+ fprintf(stderr,"%s\n", TclGetString(message));
Tcl_DecrRefCount(message);
} else {
fprintf(stderr, "\n");
@@ -10233,7 +10039,7 @@ TclExprFloatError(
"unknown floating-point error, errno = %d", errno);
Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN",
- Tcl_GetString(objPtr), NULL);
+ TclGetString(objPtr), NULL);
Tcl_SetObjResult(interp, objPtr);
}
}
diff --git a/generic/tclHash.c b/generic/tclHash.c
index ac9d40e..78ad514 100644
--- a/generic/tclHash.c
+++ b/generic/tclHash.c
@@ -924,7 +924,7 @@ HashStringKey(
*
* BogusFind --
*
- * This function is invoked when an Tcl_FindHashEntry is called on a
+ * This function is invoked when Tcl_FindHashEntry is called on a
* table that has been deleted.
*
* Results:
@@ -951,7 +951,7 @@ BogusFind(
*
* BogusCreate --
*
- * This function is invoked when an Tcl_CreateHashEntry is called on a
+ * This function is invoked when Tcl_CreateHashEntry is called on a
* table that has been deleted.
*
* Results:
diff --git a/generic/tclHistory.c b/generic/tclHistory.c
index b08e352..47806d4 100644
--- a/generic/tclHistory.c
+++ b/generic/tclHistory.c
@@ -62,15 +62,14 @@ Tcl_RecordAndEval(
* instead of Tcl_Eval. */
{
register Tcl_Obj *cmdPtr;
- int length = strlen(cmd);
int result;
- if (length > 0) {
+ if (cmd[0]) {
/*
* Call Tcl_RecordAndEvalObj to do the actual work.
*/
- cmdPtr = Tcl_NewStringObj(cmd, length);
+ cmdPtr = Tcl_NewStringObj(cmd, -1);
Tcl_IncrRefCount(cmdPtr);
result = Tcl_RecordAndEvalObj(interp, cmdPtr, flags);
diff --git a/generic/tclIO.c b/generic/tclIO.c
index 80f6fa4..1460392 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -116,7 +116,7 @@ typedef struct CopyState {
* The structure defined below is used in this file only.
*/
-typedef struct ThreadSpecificData {
+typedef struct {
NextChannelHandler *nestedHandlerPtr;
/* This variable holds the list of nested
* Tcl_NotifyChannel invocations. */
@@ -321,9 +321,9 @@ static int WillRead(Channel *chanPtr);
typedef struct ResolvedChanName {
ChannelState *statePtr; /* The saved lookup result */
Tcl_Interp *interp; /* The interp in which the lookup was done. */
- int epoch; /* The epoch of the channel when the lookup
+ size_t epoch; /* The epoch of the channel when the lookup
* was done. Use to verify validity. */
- int refCount; /* Share this struct among many Tcl_Obj. */
+ size_t refCount; /* Share this struct among many Tcl_Obj. */
} ResolvedChanName;
static void DupChannelIntRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);
@@ -381,20 +381,20 @@ ChanCloseHalf(
*
* ChanRead --
*
- * Read up to dstSize bytes using the inputProc of chanPtr, store
- * them at dst, and return the number of bytes stored.
+ * Read up to dstSize bytes using the inputProc of chanPtr, store them at
+ * dst, and return the number of bytes stored.
*
* Results:
* The return value of the driver inputProc,
* - number of bytes stored at dst, ot
- * - -1 on error, with a Posix error code available to the
- * caller by calling Tcl_GetErrno().
+ * - -1 on error, with a Posix error code available to the caller by
+ * calling Tcl_GetErrno().
*
* Side effects:
- * The CHANNEL_BLOCKED and CHANNEL_EOF flags of the channel state are
- * set as appropriate.
- * On EOF, the inputEncodingFlags are set to perform ending operations
- * on decoding.
+ * The CHANNEL_BLOCKED and CHANNEL_EOF flags of the channel state are set
+ * as appropriate. On EOF, the inputEncodingFlags are set to perform
+ * ending operations on decoding.
+ *
* TODO - Is this really the right place for that?
*
*---------------------------------------------------------------------------
@@ -408,15 +408,17 @@ ChanRead(
int bytesRead, result;
/*
- * If the caller asked for zero bytes, we'd force the inputProc
- * to return zero bytes, and then misinterpret that as EOF.
+ * If the caller asked for zero bytes, we'd force the inputProc to return
+ * zero bytes, and then misinterpret that as EOF.
*/
+
assert(dstSize > 0);
/*
* Each read op must set the blocked and eof states anew, not let
* the effect of prior reads leak through.
*/
+
if (GotFlag(chanPtr->state, CHANNEL_EOF)) {
chanPtr->state->inputEncodingFlags |= TCL_ENCODING_START;
}
@@ -429,7 +431,10 @@ ChanRead(
bytesRead = chanPtr->typePtr->inputProc(chanPtr->instanceData,
dst, dstSize, &result);
- /* Stop any flag leakage through stacked channel levels */
+ /*
+ * Stop any flag leakage through stacked channel levels.
+ */
+
if (GotFlag(chanPtr->state, CHANNEL_EOF)) {
chanPtr->state->inputEncodingFlags |= TCL_ENCODING_START;
}
@@ -437,10 +442,10 @@ ChanRead(
chanPtr->state->inputEncodingFlags &= ~TCL_ENCODING_END;
if (bytesRead > 0) {
/*
- * If we get a short read, signal up that we may be BLOCKED.
- * We should avoid calling the driver because on some
- * platforms we will block in the low level reading code even
- * though the channel is set into nonblocking mode.
+ * If we get a short read, signal up that we may be BLOCKED. We should
+ * avoid calling the driver because on some platforms we will block in
+ * the low level reading code even though the channel is set into
+ * nonblocking mode.
*/
if (bytesRead < dstSize) {
@@ -574,7 +579,10 @@ TclFinalizeIOSubsystem(void)
int active = 1; /* Flag == 1 while there's still work to do */
int doflushnb;
- /* Fetch the pre-TIP#398 compatibility flag */
+ /*
+ * Fetch the pre-TIP#398 compatibility flag.
+ */
+
{
const char *s;
Tcl_DString ds;
@@ -619,18 +627,20 @@ TclFinalizeIOSubsystem(void)
*/
if (active) {
-
TclChannelPreserve((Tcl_Channel)chanPtr);
+
/*
- * TIP #398: by default, we no longer set the channel back into
- * blocking mode. To restore the old blocking behavior, the
- * environment variable TCL_FLUSH_NONBLOCKING_ON_EXIT must be set
+ * TIP #398: by default, we no longer set the channel back into
+ * blocking mode. To restore the old blocking behavior, the
+ * environment variable TCL_FLUSH_NONBLOCKING_ON_EXIT must be set
* and not be "0".
*/
+
if (doflushnb) {
- /* Set the channel back into blocking mode to ensure that we wait
- * for all data to flush out.
- */
+ /*
+ * Set the channel back into blocking mode to ensure that we
+ * wait for all data to flush out.
+ */
(void) Tcl_SetChannelOption(NULL, (Tcl_Channel) chanPtr,
"-blocking", "on");
@@ -1511,8 +1521,10 @@ TclGetChannelFromObj(
if ((resPtr->interp == interp) /* Same interp context */
/* No epoch change in channel since lookup */
&& (resPtr->epoch == statePtr->epoch)) {
+ /*
+ * Have a valid saved lookup. Jump to end to return it.
+ */
- /* Have a valid saved lookup. Jump to end to return it. */
goto valid;
}
}
@@ -1527,7 +1539,10 @@ TclGetChannelFromObj(
}
if (resPtr && resPtr->refCount == 1) {
- /* Re-use the ResolvedCmdName struct */
+ /*
+ * Re-use the ResolvedCmdName struct.
+ */
+
Tcl_Release((ClientData) resPtr->statePtr);
} else {
@@ -1671,7 +1686,7 @@ Tcl_CreateChannel(
* Set the channel up initially in AUTO input translation mode to accept
* "\n", "\r" and "\r\n". Output translation mode is set to a platform
* specific default value. The eofChar is set to 0 for both input and
- * output, so that Tcl does not look for an in-file EOF indicator (e.g.
+ * output, so that Tcl does not look for an in-file EOF indicator (e.g.,
* ^Z) and does not append an EOF indicator to files.
*/
@@ -1899,7 +1914,6 @@ Tcl_StackChannel(
*/
if (((mask & TCL_READABLE) != 0) && (statePtr->inQueueHead != NULL)) {
-
/*
* When statePtr->inQueueHead is not NULL, we know
* prevChanPtr->inQueueHead must be NULL.
@@ -2031,9 +2045,7 @@ Tcl_UnstackChannel(
* of registered channels we wind down the state of the
* transformation, and then restore the state of underlying channel
* into the old structure.
- */
-
- /*
+ *
* TODO: Figure out how to handle the situation where the chan
* operations called below by this unstacking operation cause
* another unstacking recursively. In that case the downChanPtr
@@ -2511,6 +2523,7 @@ RecycleBuffer(
/*
* Do we have to free the buffer to the OS?
*/
+
if (IsShared(bufPtr)) {
mustDiscard = 1;
}
@@ -2521,9 +2534,8 @@ RecycleBuffer(
}
/*
- * Only save buffers which have the requested buffersize for the
- * channel. This is to honor dynamic changes of the buffersize
- * made by the user.
+ * Only save buffers which have the requested buffersize for the channel.
+ * This is to honor dynamic changes of the buffersize made by the user.
*/
if ((bufPtr->bufLength - BUFFER_PADDING) != statePtr->bufSize) {
@@ -2693,14 +2705,18 @@ FlushChannel(
/*
* Should we shift the current output buffer over to the output queue?
* First check that there are bytes in it. If so then...
- * If the output queue is empty, then yes, trusting the caller called
- * us only when written bytes ought to be flushed.
- * If the current output buffer is full, then yes, so we can meet
- * the post-condition that on a successful return to caller we've
- * left space in the current output buffer for more writing (the flush
- * call was to make new room).
- * If the channel is blocking, then yes, so we guarantee that
- * blocking flushes actually flush all pending data.
+ *
+ * If the output queue is empty, then yes, trusting the caller called us
+ * only when written bytes ought to be flushed.
+ *
+ * If the current output buffer is full, then yes, so we can meet the
+ * post-condition that on a successful return to caller we've left space
+ * in the current output buffer for more writing (the flush call was to
+ * make new room).
+ *
+ * If the channel is blocking, then yes, so we guarantee that blocking
+ * flushes actually flush all pending data.
+ *
* Otherwise, no. Keep the current output buffer where it is so more
* can be written to it, possibly filling it, to promote more efficient
* buffer usage.
@@ -2794,8 +2810,8 @@ FlushChannel(
/*
* TIP #219, Tcl Channel Reflection API.
* When defering the error copy a message from the bypass into
- * the unreported area. Or discard it if the new error is to be
- * ignored in favor of an earlier defered error.
+ * the unreported area. Or discard it if the new error is to
+ * be ignored in favor of an earlier defered error.
*/
Tcl_Obj *msg = statePtr->chanMsg;
@@ -2847,8 +2863,11 @@ FlushChannel(
ReleaseChannelBuffer(bufPtr);
break;
} else {
- /* TODO: Consider detecting and reacting to short writes
- * on blocking channels. Ought not happen. See iocmd-24.2. */
+ /*
+ * TODO: Consider detecting and reacting to short writes on
+ * blocking channels. Ought not happen. See iocmd-24.2.
+ */
+
wroteSome = 1;
}
@@ -2882,7 +2901,6 @@ FlushChannel(
ResetFlag(statePtr, BG_FLUSH_SCHEDULED);
ChanWatch(chanPtr, statePtr->interestMask);
} else {
-
/*
* When we are calledFromAsyncFlush, that means a writable
* state on the channel triggered the call, so we should be
@@ -2927,7 +2945,8 @@ FlushChannel(
(statePtr->outQueueHead == NULL) &&
((statePtr->curOutPtr == NULL) ||
IsBufferEmpty(statePtr->curOutPtr))) {
- errorCode = CloseChannelPart(interp, chanPtr, errorCode, TCL_CLOSE_WRITE);
+ errorCode = CloseChannelPart(interp, chanPtr, errorCode,
+ TCL_CLOSE_WRITE);
goto done;
}
@@ -3398,7 +3417,6 @@ Tcl_Close(
if (GotFlag(statePtr, TCL_WRITABLE) && (statePtr->encoding != NULL)
&& !(statePtr->outputEncodingFlags & TCL_ENCODING_START)) {
-
int code = CheckChannelErrors(statePtr, TCL_WRITABLE);
if (code == 0) {
@@ -3488,12 +3506,14 @@ Tcl_Close(
}
return TCL_ERROR;
}
+
/*
* Bug 97069ea11a: set error message if a flush code is set and no error
* message set up to now.
*/
+
if (flushcode != 0 && interp != NULL
- && 0 == Tcl_GetCharLength(Tcl_GetObjResult(interp)) ) {
+ && 0 == Tcl_GetCharLength(Tcl_GetObjResult(interp))) {
Tcl_SetErrno(flushcode);
Tcl_SetObjResult(interp,
Tcl_NewStringObj(Tcl_PosixError(interp), -1));
@@ -3588,8 +3608,8 @@ Tcl_CloseEx(
}
/*
- * A user may try to call half-close from within a channel close
- * handler. That won't do.
+ * A user may try to call half-close from within a channel close handler.
+ * That won't do.
*/
if (statePtr->flags & CHANNEL_INCLOSE) {
@@ -3660,9 +3680,12 @@ CloseWrite(
* closed. May still be used by some
* interpreter */
{
- /* Notes: clear-channel-handlers - write side only ? or keep around, just
- * not called. */
- /* No close cllbacks are run - channel is still open (read side) */
+ /*
+ * Notes: clear-channel-handlers - write side only ? or keep around, just
+ * not called.
+ *
+ * No close callbacks are run - channel is still open (read side)
+ */
ChannelState *statePtr = chanPtr->state;
/* State of real IO channel. */
@@ -3687,9 +3710,9 @@ CloseWrite(
* Notes: Due to the assertion of CHANNEL_CLOSEDWRITE in the flags
* FlushChannel() has called CloseChannelPart(). While we can still access
* "chan" (no structures were freed), the only place which may still
- * contain a message is the interpreter itself, and "CloseChannelPart" made
- * sure to lift any channel message it generated into it. Hence the NULL
- * argument in the call below.
+ * contain a message is the interpreter itself, and "CloseChannelPart"
+ * made sure to lift any channel message it generated into it. Hence the
+ * NULL argument in the call below.
*/
if (TclChanCaughtErrorBypass(interp, NULL)) {
@@ -3913,10 +3936,10 @@ Tcl_ClearChannelHandlers(
StopCopy(statePtr->csPtrW);
/*
- * Must set the interest mask now to 0, otherwise infinite loops
- * will occur if Tcl_DoOneEvent is called before the channel is
- * finally deleted in FlushChannel. This can happen if the channel
- * has a background flush active.
+ * Must set the interest mask now to 0, otherwise infinite loops will
+ * occur if Tcl_DoOneEvent is called before the channel is finally deleted
+ * in FlushChannel. This can happen if the channel has a background flush
+ * active.
*/
statePtr->interestMask = 0;
@@ -4185,22 +4208,24 @@ WillRead(
Channel *chanPtr)
{
if (chanPtr->typePtr == NULL) {
- /* Prevent read attempts on a closed channel */
+ /*
+ * Prevent read attempts on a closed channel.
+ */
+
DiscardInputQueued(chanPtr->state, 0);
Tcl_SetErrno(EINVAL);
return -1;
}
if ((chanPtr->typePtr->seekProc != NULL)
&& (Tcl_OutputBuffered((Tcl_Channel) chanPtr) > 0)) {
-
/*
- * CAVEAT - The assumption here is that FlushChannel() will
- * push out the bytes of any writes that are in progress.
- * Since this is a seekable channel, we assume it is not one
- * that can block and force bg flushing. Channels we know that
- * can do that -- sockets, pipes -- are not seekable. If the
- * assumption is wrong, more drastic measures may be required here
- * like temporarily setting the channel into blocking mode.
+ * CAVEAT - The assumption here is that FlushChannel() will push out
+ * the bytes of any writes that are in progress. Since this is a
+ * seekable channel, we assume it is not one that can block and force
+ * bg flushing. Channels we know that can do that - sockets, pipes -
+ * are not seekable. If the assumption is wrong, more drastic measures
+ * may be required here like temporarily setting the channel into
+ * blocking mode.
*/
if (FlushChannel(NULL, chanPtr, 0) != 0) {
@@ -4292,11 +4317,17 @@ Write(
&statePtr->outputEncodingState, dst,
dstLen + BUFFER_PADDING, &srcRead, &dstWrote, NULL);
- /* See chan-io-1.[89]. Tcl Bug 506297. */
+ /*
+ * See chan-io-1.[89]. Tcl Bug 506297.
+ */
+
statePtr->outputEncodingFlags &= ~TCL_ENCODING_START;
if ((result != TCL_OK) && (srcRead + dstWrote == 0)) {
- /* We're reading from invalid/incomplete UTF-8 */
+ /*
+ * We're reading from invalid/incomplete UTF-8.
+ */
+
ReleaseChannelBuffer(bufPtr);
if (total == 0) {
Tcl_SetErrno(EINVAL);
@@ -4336,11 +4367,10 @@ Write(
}
result |= Tcl_UtfToExternal(NULL, encoding, nl, nlLen,
- statePtr->outputEncodingFlags,
- &statePtr->outputEncodingState, dst,
- dstLen + BUFFER_PADDING, &srcRead, &dstWrote, NULL);
-
- assert (srcRead == nlLen);
+ statePtr->outputEncodingFlags,
+ &statePtr->outputEncodingState, dst,
+ dstLen + BUFFER_PADDING, &srcRead, &dstWrote, NULL);
+ assert(srcRead == nlLen);
bufPtr->nextAdded += dstWrote;
src++;
@@ -4354,11 +4384,11 @@ Write(
if (IsBufferOverflowing(bufPtr)) {
/*
- * When translating from UTF-8 to external encoding, we
- * allowed the translation to produce a character that crossed
- * the end of the output buffer, so that we would get a
- * completely full buffer before flushing it. The extra bytes
- * will be moved to the beginning of the next buffer.
+ * When translating from UTF-8 to external encoding, we allowed
+ * the translation to produce a character that crossed the end of
+ * the output buffer, so that we would get a completely full
+ * buffer before flushing it. The extra bytes will be moved to the
+ * beginning of the next buffer.
*/
saved = -SpaceLeft(bufPtr);
@@ -4378,15 +4408,16 @@ Write(
flushed += statePtr->bufSize;
/*
- * We just flushed. So if we have needNlFlush set to record
- * that we need to flush because theres a (translated) newline
- * in the buffer, that's likely not true any more. But there
- * is a tricky exception. If we have saved bytes that did not
- * really get flushed and those bytes came from a translation
- * of a newline as the last thing taken from the src array,
- * then needNlFlush needs to remain set to flag that the
- * next buffer still needs a newline flush.
+ * We just flushed. So if we have needNlFlush set to record that
+ * we need to flush because theres a (translated) newline in the
+ * buffer, that's likely not true any more. But there is a tricky
+ * exception. If we have saved bytes that did not really get
+ * flushed and those bytes came from a translation of a newline as
+ * the last thing taken from the src array, then needNlFlush needs
+ * to remain set to flag that the next buffer still needs a
+ * newline flush.
*/
+
if (needNlFlush && (saved == 0 || src[-1] != '\n')) {
needNlFlush = 0;
}
@@ -4492,8 +4523,8 @@ Tcl_GetsObj(
if (GotFlag(statePtr, CHANNEL_STICKY_EOF)) {
SetFlag(statePtr, CHANNEL_EOF);
- assert( statePtr->inputEncodingFlags & TCL_ENCODING_END );
- assert( !GotFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR) );
+ assert(statePtr->inputEncodingFlags & TCL_ENCODING_END);
+ assert(!GotFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR));
/* TODO: Do we need this? */
UpdateInterest(chanPtr);
@@ -4833,17 +4864,17 @@ Tcl_GetsObj(
*/
done:
- assert(!GotFlag(statePtr, CHANNEL_EOF)
- || GotFlag(statePtr, CHANNEL_STICKY_EOF)
- || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0);
-
- assert( !(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED)
- == (CHANNEL_EOF|CHANNEL_BLOCKED)) );
+ assert(!GotFlag(statePtr, CHANNEL_EOF)
+ || GotFlag(statePtr, CHANNEL_STICKY_EOF)
+ || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0);
+ assert(!(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED)
+ == (CHANNEL_EOF|CHANNEL_BLOCKED)));
/*
* Regenerate the top channel, in case it was changed due to
* self-modifying reflected transforms.
*/
+
if (chanPtr != statePtr->topChanPtr) {
TclChannelRelease((Tcl_Channel)chanPtr);
chanPtr = statePtr->topChanPtr;
@@ -4863,10 +4894,9 @@ Tcl_GetsObj(
* end-of-line or end-of-file has been seen. Bytes read from the input
* channel return as a ByteArray obj.
*
- * WARNING! The notion of "binary" used here is different from
- * notions of "binary" used in other places. In particular, this
- * "binary" routine may be called when an -eofchar is set on the
- * channel.
+ * WARNING! The notion of "binary" used here is different from notions
+ * of "binary" used in other places. In particular, this "binary" routine
+ * may be called when an -eofchar is set on the channel.
*
* Results:
* Number of characters accumulated in the object or -1 if error,
@@ -4932,8 +4962,8 @@ TclGetsObjBinary(
ResetFlag(statePtr, CHANNEL_BLOCKED);
while (1) {
/*
- * Subtract the number of bytes that were removed from channel
- * buffer during last call.
+ * Subtract the number of bytes that were removed from channel buffer
+ * during last call.
*/
if (bufPtr != NULL) {
@@ -4945,10 +4975,11 @@ TclGetsObjBinary(
if ((bufPtr == NULL) || (bufPtr->nextAdded == BUFFER_PADDING)) {
/*
- * All channel buffers were exhausted and the caller still
- * hasn't seen EOL. Need to read more bytes from the channel
- * device. Side effect is to allocate another channel buffer.
+ * All channel buffers were exhausted and the caller still hasn't
+ * seen EOL. Need to read more bytes from the channel device. Side
+ * effect is to allocate another channel buffer.
*/
+
if (GetInput(chanPtr) != 0) {
goto restore;
}
@@ -4958,15 +4989,15 @@ TclGetsObjBinary(
}
} else {
/*
- * Incoming CHANNEL_STICKY_EOF is filtered out on entry.
- * A new CHANNEL_STICKY_EOF set in this routine leads to
- * return before coming back here. When we are not dealing
- * with CHANNEL_STICKY_EOF, a CHANNEL_EOF implies an
- * empty buffer. Here the buffer is non-empty so we know
- * we're a non-EOF */
+ * Incoming CHANNEL_STICKY_EOF is filtered out on entry. A new
+ * CHANNEL_STICKY_EOF set in this routine leads to return before
+ * coming back here. When we are not dealing with
+ * CHANNEL_STICKY_EOF, a CHANNEL_EOF implies an empty buffer.
+ * Here the buffer is non-empty so we know we're a non-EOF.
+ */
- assert ( !GotFlag(statePtr, CHANNEL_STICKY_EOF) );
- assert ( !GotFlag(statePtr, CHANNEL_EOF) );
+ assert(!GotFlag(statePtr, CHANNEL_STICKY_EOF));
+ assert(!GotFlag(statePtr, CHANNEL_EOF));
}
dst = (unsigned char *) RemovePoint(bufPtr);
@@ -5033,8 +5064,8 @@ TclGetsObjBinary(
}
/*
- * Copy bytes from the channel buffer to the ByteArray.
- * This may realloc space, so keep track of result.
+ * Copy bytes from the channel buffer to the ByteArray. This may
+ * realloc space, so keep track of result.
*/
rawLen = dstEnd - dst;
@@ -5118,11 +5149,11 @@ TclGetsObjBinary(
*/
done:
- assert(!GotFlag(statePtr, CHANNEL_EOF)
- || GotFlag(statePtr, CHANNEL_STICKY_EOF)
- || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0);
- assert( !(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED)
- == (CHANNEL_EOF|CHANNEL_BLOCKED)) );
+ assert(!GotFlag(statePtr, CHANNEL_EOF)
+ || GotFlag(statePtr, CHANNEL_STICKY_EOF)
+ || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0);
+ assert(!(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED)
+ == (CHANNEL_EOF|CHANNEL_BLOCKED)));
UpdateInterest(chanPtr);
TclChannelRelease((Tcl_Channel)chanPtr);
return copiedTotal;
@@ -5255,15 +5286,15 @@ FilterInputBytes(
}
} else {
/*
- * Incoming CHANNEL_STICKY_EOF is filtered out on entry.
- * A new CHANNEL_STICKY_EOF set in this routine leads to
- * return before coming back here. When we are not dealing
- * with CHANNEL_STICKY_EOF, a CHANNEL_EOF implies an
- * empty buffer. Here the buffer is non-empty so we know
- * we're a non-EOF */
+ * Incoming CHANNEL_STICKY_EOF is filtered out on entry. A new
+ * CHANNEL_STICKY_EOF set in this routine leads to return before
+ * coming back here. When we are not dealing with CHANNEL_STICKY_EOF,
+ * a CHANNEL_EOF implies an empty buffer. Here the buffer is
+ * non-empty so we know we're a non-EOF.
+ */
- assert ( !GotFlag(statePtr, CHANNEL_STICKY_EOF) );
- assert ( !GotFlag(statePtr, CHANNEL_EOF) );
+ assert(!GotFlag(statePtr, CHANNEL_STICKY_EOF));
+ assert(!GotFlag(statePtr, CHANNEL_EOF));
}
/*
@@ -5593,7 +5624,9 @@ Tcl_ReadRaw(
return -1;
}
- /* First read bytes from the push-back buffers. */
+ /*
+ * First read bytes from the push-back buffers.
+ */
while (chanPtr->inQueueHead && bytesToRead > 0) {
ChannelBuffer *bufPtr = chanPtr->inQueueHead;
@@ -5601,7 +5634,9 @@ Tcl_ReadRaw(
int toCopy = (bytesInBuffer < bytesToRead) ? bytesInBuffer
: bytesToRead;
- /* Copy the current chunk into the read buffer. */
+ /*
+ * Copy the current chunk into the read buffer.
+ */
memcpy(readBuf, RemovePoint(bufPtr), (size_t) toCopy);
bufPtr->nextRemoved += toCopy;
@@ -5609,7 +5644,9 @@ Tcl_ReadRaw(
readBuf += toCopy;
bytesToRead -= toCopy;
- /* If the current buffer is empty recycle it. */
+ /*
+ * If the current buffer is empty recycle it.
+ */
if (IsBufferEmpty(bufPtr)) {
chanPtr->inQueueHead = bufPtr->nextPtr;
@@ -5621,37 +5658,40 @@ Tcl_ReadRaw(
}
/*
- * Go to the driver only if we got nothing from pushback.
- * Have to do it this way to avoid EOF mis-timings when we
- * consider the ability that EOF may not be a permanent
- * condition in the driver, and in that case we have to
- * synchronize.
+ * Go to the driver only if we got nothing from pushback. Have to do it
+ * this way to avoid EOF mis-timings when we consider the ability that EOF
+ * may not be a permanent condition in the driver, and in that case we
+ * have to synchronize.
*/
if (copied) {
return copied;
}
- /* This test not needed. */
- if (bytesToRead > 0) {
+ /*
+ * This test not needed.
+ */
+ if (bytesToRead > 0) {
int nread = ChanRead(chanPtr, readBuf, bytesToRead);
if (nread > 0) {
- /* Successful read (short is OK) - add to bytes copied */
+ /*
+ * Successful read (short is OK) - add to bytes copied.
+ */
+
copied += nread;
} else if (nread < 0) {
/*
- * An error signaled. If CHANNEL_BLOCKED, then the error
- * is not real, but an indication of blocked state. In
- * that case, retain the flag and let caller receive the
- * short read of copied bytes from the pushback.
- * HOWEVER, if copied==0 bytes from pushback then repeat
- * signalling the blocked state as an error to caller so
- * there is no false report of an EOF.
- * When !CHANNEL_BLOCKED, the error is real and passes on
- * to caller.
+ * An error signaled. If CHANNEL_BLOCKED, then the error is not
+ * real, but an indication of blocked state. In that case, retain
+ * the flag and let caller receive the short read of copied bytes
+ * from the pushback. HOWEVER, if copied==0 bytes from pushback
+ * then repeat signalling the blocked state as an error to caller
+ * so there is no false report of an EOF. When !CHANNEL_BLOCKED,
+ * the error is real and passes on to caller.
*/
+
if (!GotFlag(statePtr, CHANNEL_BLOCKED) || copied == 0) {
copied = -1;
}
@@ -5788,21 +5828,23 @@ DoReadChars(
/*
* Early out when next read will see eofchar.
*
- * NOTE: See DoRead for argument that it's a bug (one we're keeping)
- * to have this escape before the one for zero-char read request.
+ * NOTE: See DoRead for argument that it's a bug (one we're keeping) to
+ * have this escape before the one for zero-char read request.
*/
if (GotFlag(statePtr, CHANNEL_STICKY_EOF)) {
SetFlag(statePtr, CHANNEL_EOF);
- assert( statePtr->inputEncodingFlags & TCL_ENCODING_END );
- assert( !GotFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR) );
+ assert(statePtr->inputEncodingFlags & TCL_ENCODING_END);
+ assert(!GotFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR));
/* TODO: We don't need this call? */
UpdateInterest(chanPtr);
return 0;
}
- /* Special handling for zero-char read request. */
+ /*
+ * Special handling for zero-char read request.
+ */
if (toRead == 0) {
if (GotFlag(statePtr, CHANNEL_EOF)) {
statePtr->inputEncodingFlags |= TCL_ENCODING_START;
@@ -5821,7 +5863,10 @@ DoReadChars(
chanPtr = statePtr->topChanPtr;
TclChannelPreserve((Tcl_Channel)chanPtr);
- /* Must clear the BLOCKED|EOF flags here since we check before reading */
+ /*
+ * Must clear the BLOCKED|EOF flags here since we check before reading.
+ */
+
if (GotFlag(statePtr, CHANNEL_EOF)) {
statePtr->inputEncodingFlags |= TCL_ENCODING_START;
}
@@ -5879,10 +5924,11 @@ DoReadChars(
}
/*
- * Failure to fill a channel buffer may have left channel reporting
- * a "blocked" state, but so long as we fulfilled the request here,
- * the caller does not consider us blocked.
+ * Failure to fill a channel buffer may have left channel reporting a
+ * "blocked" state, but so long as we fulfilled the request here, the
+ * caller does not consider us blocked.
*/
+
if (toRead == 0) {
ResetFlag(statePtr, CHANNEL_BLOCKED);
}
@@ -5891,6 +5937,7 @@ DoReadChars(
* Regenerate the top channel, in case it was changed due to
* self-modifying reflected transforms.
*/
+
if (chanPtr != statePtr->topChanPtr) {
TclChannelRelease((Tcl_Channel)chanPtr);
chanPtr = statePtr->topChanPtr;
@@ -5901,11 +5948,12 @@ DoReadChars(
* Update the notifier state so we don't block while there is still data
* in the buffers.
*/
- assert(!GotFlag(statePtr, CHANNEL_EOF)
- || GotFlag(statePtr, CHANNEL_STICKY_EOF)
- || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0);
- assert( !(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED)
- == (CHANNEL_EOF|CHANNEL_BLOCKED)) );
+
+ assert(!GotFlag(statePtr, CHANNEL_EOF)
+ || GotFlag(statePtr, CHANNEL_STICKY_EOF)
+ || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0);
+ assert(!(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED)
+ == (CHANNEL_EOF|CHANNEL_BLOCKED)));
UpdateInterest(chanPtr);
TclChannelRelease((Tcl_Channel)chanPtr);
return copied;
@@ -6022,11 +6070,10 @@ ReadChars(
int numBytes, srcLen = BytesLeft(bufPtr);
/*
- * One src byte can yield at most one character. So when the
- * number of src bytes we plan to read is less than the limit on
- * character count to be read, clearly we will remain within that
- * limit, and we can use the value of "srcLen" as a tighter limit
- * for sizing receiving buffers.
+ * One src byte can yield at most one character. So when the number of
+ * src bytes we plan to read is less than the limit on character count to
+ * be read, clearly we will remain within that limit, and we can use the
+ * value of "srcLen" as a tighter limit for sizing receiving buffers.
*/
int toRead = ((charsToRead<0)||(charsToRead > srcLen)) ? srcLen : charsToRead;
@@ -6044,6 +6091,7 @@ ReadChars(
Tcl_AppendToObj(objPtr, NULL, dstLimit);
if (toRead == srcLen) {
unsigned int size;
+
dst = TclGetStringStorage(objPtr, &size) + numBytes;
dstLimit = size - numBytes;
} else {
@@ -6051,19 +6099,18 @@ ReadChars(
}
/*
- * This routine is burdened with satisfying several constraints.
- * It cannot append more than 'charsToRead` chars onto objPtr.
- * This is measured after encoding and translation transformations
- * are completed. There is no precise number of src bytes that can
- * be associated with the limit. Yet, when we are done, we must know
- * precisely the number of src bytes that were consumed to produce
- * the appended chars, so that all subsequent bytes are left in
- * the buffers for future read operations.
+ * This routine is burdened with satisfying several constraints. It cannot
+ * append more than 'charsToRead` chars onto objPtr. This is measured
+ * after encoding and translation transformations are completed. There is
+ * no precise number of src bytes that can be associated with the limit.
+ * Yet, when we are done, we must know precisely the number of src bytes
+ * that were consumed to produce the appended chars, so that all
+ * subsequent bytes are left in the buffers for future read operations.
*
- * The consequence is that we have no choice but to implement a
- * "trial and error" approach, where in general we may need to
- * perform transformations and copies multiple times to achieve
- * a consistent set of results. This takes the shape of a loop.
+ * The consequence is that we have no choice but to implement a "trial and
+ * error" approach, where in general we may need to perform
+ * transformations and copies multiple times to achieve a consistent set
+ * of results. This takes the shape of a loop.
*/
while (1) {
@@ -6076,18 +6123,17 @@ ReadChars(
}
/*
- * Perform the encoding transformation. Read no more than
- * srcLen bytes, write no more than dstLimit bytes.
+ * Perform the encoding transformation. Read no more than srcLen
+ * bytes, write no more than dstLimit bytes.
*
- * Some trickiness with encoding flags here. We do not want
- * the end of a buffer to be treated as the end of all input
- * when the presence of bytes in a next buffer are already
- * known to exist. This is checked with an assert() because
- * so far no test case causing the assertion to be false has
- * been created. The normal operations of channel reading
- * appear to cause EOF and TCL_ENCODING_END setting to appear
- * only in situations where there are no further bytes in
- * any buffers.
+ * Some trickiness with encoding flags here. We do not want the end
+ * of a buffer to be treated as the end of all input when the presence
+ * of bytes in a next buffer are already known to exist. This is
+ * checked with an assert() because so far no test case causing the
+ * assertion to be false has been created. The normal operations of
+ * channel reading appear to cause EOF and TCL_ENCODING_END setting to
+ * appear only in situations where there are no further bytes in any
+ * buffers.
*/
assert(bufPtr->nextPtr == NULL || BytesLeft(bufPtr->nextPtr) == 0
@@ -6098,10 +6144,10 @@ ReadChars(
dst, dstLimit, &srcRead, &dstDecoded, &numChars);
/*
- * Perform the translation transformation in place. Read no more
- * than the dstDecoded bytes the encoding transformation actually
- * produced. Capture the number of bytes written in dstWrote.
- * Capture the number of bytes actually consumed in dstRead.
+ * Perform the translation transformation in place. Read no more than
+ * the dstDecoded bytes the encoding transformation actually produced.
+ * Capture the number of bytes written in dstWrote. Capture the number
+ * of bytes actually consumed in dstRead.
*/
dstWrote = dstLimit;
@@ -6109,11 +6155,9 @@ ReadChars(
TranslateInputEOL(statePtr, dst, dst, &dstWrote, &dstRead);
if (dstRead < dstDecoded) {
-
/*
- * The encoding transformation produced bytes that the
- * translation transformation did not consume. Why did
- * this happen?
+ * The encoding transformation produced bytes that the translation
+ * transformation did not consume. Why did this happen?
*/
if (statePtr->inEofChar && dst[dstRead] == statePtr->inEofChar) {
@@ -6122,40 +6166,38 @@ ReadChars(
* we saw it and stopped translating at that point.
*
* NOTE the bizarre spec of TranslateInputEOL in this case.
- * Clearly the eof char had to be read in order to account
- * for the stopping, but the value of dstRead does not
- * include it.
+ * Clearly the eof char had to be read in order to account for
+ * the stopping, but the value of dstRead does not include it.
*
- * Also rather bizarre, our caller can only notice an
- * EOF condition if we return the value -1 as the number
- * of chars read. This forces us to perform a 2-call
- * dance where the first call can read all the chars
- * up to the eof char, and the second call is solely
- * for consuming the encoded eof char then pointed at
- * by src so that we can return that magic -1 value.
- * This seems really wasteful, especially since
- * the first decoding pass of each call is likely to
- * decode many bytes beyond that eof char that's all we
- * care about.
+ * Also rather bizarre, our caller can only notice an EOF
+ * condition if we return the value -1 as the number of chars
+ * read. This forces us to perform a 2-call dance where the
+ * first call can read all the chars up to the eof char, and
+ * the second call is solely for consuming the encoded eof
+ * char then pointed at by src so that we can return that
+ * magic -1 value. This seems really wasteful, especially
+ * since the first decoding pass of each call is likely to
+ * decode many bytes beyond that eof char that's all we care
+ * about.
*/
if (dstRead == 0) {
/*
- * Curious choice in the eof char handling. We leave
- * the eof char in the buffer. So, no need to compute
- * a proper srcRead value. At this point, there
- * are no chars before the eof char in the buffer.
+ * Curious choice in the eof char handling. We leave the
+ * eof char in the buffer. So, no need to compute a proper
+ * srcRead value. At this point, there are no chars before
+ * the eof char in the buffer.
*/
+
Tcl_SetObjLength(objPtr, numBytes);
return -1;
}
{
/*
- * There are chars leading the buffer before the eof
- * char. Adjust the dstLimit so we go back and read
- * only those and do not encounter the eof char this
- * time.
+ * There are chars leading the buffer before the eof char.
+ * Adjust the dstLimit so we go back and read only those
+ * and do not encounter the eof char this time.
*/
dstLimit = dstRead - 1 + TCL_UTF_MAX;
@@ -6167,10 +6209,9 @@ ReadChars(
}
/*
- * 2) The other way to read fewer bytes than are decoded
- * is when the final byte is \r and we're in a CRLF
- * translation mode so we cannot decide whether to
- * record \r or \n yet.
+ * 2) The other way to read fewer bytes than are decoded is when
+ * the final byte is \r and we're in a CRLF translation mode so
+ * we cannot decide whether to record \r or \n yet.
*/
assert(dst[dstRead] == '\r');
@@ -6178,10 +6219,10 @@ ReadChars(
if (dstWrote > 0) {
/*
- * There are chars we can read before we hit the bare cr.
- * Go back with a smaller dstLimit so we get them in the
- * next pass, compute a matching srcRead, and don't end
- * up back here in this call.
+ * There are chars we can read before we hit the bare CR. Go
+ * back with a smaller dstLimit so we get them in the next
+ * pass, compute a matching srcRead, and don't end up back
+ * here in this call.
*/
dstLimit = dstRead - 1 + TCL_UTF_MAX;
@@ -6195,9 +6236,9 @@ ReadChars(
assert(dstRead == 0);
/*
- * We decoded only the bare cr, and we cannot read a
- * translated char from that alone. We have to know what's
- * next. So why do we only have the one decoded char?
+ * We decoded only the bare CR, and we cannot read a translated
+ * char from that alone. We have to know what's next. So why do
+ * we only have the one decoded char?
*/
if (code != TCL_OK) {
@@ -6238,10 +6279,9 @@ ReadChars(
}
} else if (statePtr->flags & CHANNEL_EOF) {
-
/*
- * The bare \r is the only char and we will never read
- * a subsequent char to make the determination.
+ * The bare \r is the only char and we will never read a
+ * subsequent char to make the determination.
*/
dst[0] = '\r';
@@ -6251,8 +6291,8 @@ ReadChars(
}
/*
- * Revise the dstRead value so that the numChars calc
- * below correctly computes zero characters read.
+ * Revise the dstRead value so that the numChars calc below
+ * correctly computes zero characters read.
*/
dstRead = numChars;
@@ -6261,9 +6301,9 @@ ReadChars(
}
/*
- * The translation transformation can only reduce the number
- * of chars when it converts \r\n into \n. The reduction in
- * the number of chars is the difference in bytes read and written.
+ * The translation transformation can only reduce the number of chars
+ * when it converts \r\n into \n. The reduction in the number of chars
+ * is the difference in bytes read and written.
*/
numChars -= (dstRead - dstWrote);
@@ -6273,10 +6313,9 @@ ReadChars(
/*
* TODO: This cannot happen anymore.
*
- * We read more chars than allowed. Reset limits to
- * prevent that and try again. Don't forget the extra
- * padding of TCL_UTF_MAX bytes demanded by the
- * Tcl_ExternalToUtf() call!
+ * We read more chars than allowed. Reset limits to prevent that
+ * and try again. Don't forget the extra padding of TCL_UTF_MAX
+ * bytes demanded by the Tcl_ExternalToUtf() call!
*/
dstLimit = Tcl_UtfAtIndex(dst, charsToRead) - 1 + TCL_UTF_MAX - dst;
@@ -6289,18 +6328,19 @@ ReadChars(
if (dstWrote == 0) {
ChannelBuffer *nextPtr;
- /* We were not able to read any chars. */
+ /*
+ * We were not able to read any chars.
+ */
- assert (numChars == 0);
+ assert(numChars == 0);
/*
- * There is one situation where this is the correct final
- * result. If the src buffer contains only a single \n
- * byte, and we are in TCL_TRANSLATE_AUTO mode, and
- * when the translation pass was made the INPUT_SAW_CR
- * flag was set on the channel. In that case, the
- * correct behavior is to consume that \n and produce the
- * empty string.
+ * There is one situation where this is the correct final result.
+ * If the src buffer contains only a single \n byte, and we are in
+ * TCL_TRANSLATE_AUTO mode, and when the translation pass was made
+ * the INPUT_SAW_CR flag was set on the channel. In that case, the
+ * correct behavior is to consume that \n and produce the empty
+ * string.
*/
if (dstRead == 1 && dst[0] == '\n') {
@@ -6309,12 +6349,13 @@ ReadChars(
goto consume;
}
- /* Otherwise, reading zero characters indicates there's
- * something incomplete at the end of the src buffer.
- * Maybe there were not enough src bytes to decode into
- * a char. Maybe a lone \r could not be translated (crlf
- * mode). Need to combine any unused src bytes we have
- * in the first buffer with subsequent bytes to try again.
+ /*
+ * Otherwise, reading zero characters indicates there's something
+ * incomplete at the end of the src buffer. Maybe there were not
+ * enough src bytes to decode into a char. Maybe a lone \r could
+ * not be translated (crlf mode). Need to combine any unused src
+ * bytes we have in the first buffer with subsequent bytes to try
+ * again.
*/
nextPtr = bufPtr->nextPtr;
@@ -6329,15 +6370,15 @@ ReadChars(
/*
* Space is made at the beginning of the buffer to copy the
- * previous unused bytes there. Check first if the buffer we
- * are using actually has enough space at its beginning for
- * the data we are copying. Because if not we will write over
- * the buffer management information, especially the 'nextPtr'.
+ * previous unused bytes there. Check first if the buffer we are
+ * using actually has enough space at its beginning for the data
+ * we are copying. Because if not we will write over the buffer
+ * management information, especially the 'nextPtr'.
*
- * Note that the BUFFER_PADDING (See AllocChannelBuffer) is
- * used to prevent exactly this situation. I.e. it should never
- * happen. Therefore it is ok to panic should it happen despite
- * the precautions.
+ * Note that the BUFFER_PADDING (See AllocChannelBuffer) is used
+ * to prevent exactly this situation. I.e. it should never happen.
+ * Therefore it is ok to panic should it happen despite the
+ * precautions.
*/
if (nextPtr->nextRemoved - srcLen < 0) {
@@ -6356,10 +6397,12 @@ ReadChars(
consume:
bufPtr->nextRemoved += srcRead;
+
/*
- * If this read contained multibyte characters, revise factorPtr
- * so the next read will allocate bigger buffers.
+ * If this read contained multibyte characters, revise factorPtr so
+ * the next read will allocate bigger buffers.
*/
+
if (numChars && numChars < srcRead) {
*factorPtr = srcRead * UTF_EXPANSION_FACTOR / numChars;
}
@@ -6407,22 +6450,27 @@ TranslateInputEOL(
int inEofChar = statePtr->inEofChar;
/*
- * Depending on the translation mode in use, there's no need
- * to scan more srcLen bytes at srcStart than can possibly transform
- * to dstLen bytes. This keeps the scan for eof char below from
- * being pointlessly long.
+ * Depending on the translation mode in use, there's no need to scan more
+ * srcLen bytes at srcStart than can possibly transform to dstLen bytes.
+ * This keeps the scan for eof char below from being pointlessly long.
*/
switch (statePtr->inputTranslation) {
case TCL_TRANSLATE_LF:
case TCL_TRANSLATE_CR:
if (srcLen > dstLen) {
- /* In these modes, each src byte become a dst byte. */
+ /*
+ * In these modes, each src byte become a dst byte.
+ */
+
srcLen = dstLen;
}
break;
default:
- /* In other modes, at most 2 src bytes become a dst byte. */
+ /*
+ * In other modes, at most 2 src bytes become a dst byte.
+ */
+
if (srcLen/2 > dstLen) {
srcLen = 2 * dstLen;
}
@@ -6755,7 +6803,7 @@ GetInput(
* eofchar.
*/
- assert( !GotFlag(statePtr, CHANNEL_STICKY_EOF) );
+ assert(!GotFlag(statePtr, CHANNEL_STICKY_EOF));
/*
* Prevent reading from a dead channel -- a channel that has been closed
@@ -6769,24 +6817,21 @@ GetInput(
}
/*
- * WARNING: There was once a comment here claiming that it was
- * a bad idea to make another call to the inputproc of a channel
- * driver when EOF has already been detected on the channel. Through
- * much of Tcl's history, this warning was then completely negated
- * by having all (most?) read paths clear the EOF setting before
- * reaching here. So we had a guard that was never triggered.
+ * WARNING: There was once a comment here claiming that it was a bad idea
+ * to make another call to the inputproc of a channel driver when EOF has
+ * already been detected on the channel. Through much of Tcl's history,
+ * this warning was then completely negated by having all (most?) read
+ * paths clear the EOF setting before reaching here. So we had a guard
+ * that was never triggered.
+ *
+ * Don't be tempted to restore the guard. Even if EOF is set on the
+ * channel, continue through and call the inputproc again. This is the
+ * way to enable the ability to [read] again beyond the EOF, which seems a
+ * strange thing to do, but for which use cases exist [Tcl Bug 5adc350683]
+ * and which may even be essential for channels representing things like
+ * ttys or other devices where the stream might take the logical form of a
+ * series of 'files' separated by an EOF condition.
*
- * Don't be tempted to restore the guard. Even if EOF is set on
- * the channel, continue through and call the inputproc again. This
- * is the way to enable the ability to [read] again beyond the EOF,
- * which seems a strange thing to do, but for which use cases exist
- * [Tcl Bug 5adc350683] and which may even be essential for channels
- * representing things like ttys or other devices where the stream
- * might take the logical form of a series of 'files' separated by
- * an EOF condition.
- */
-
- /*
* First check for more buffers in the pushback area of the topmost
* channel in the stack and use them. They can be the result of a
* transformation which went away without reading all the information
@@ -6794,7 +6839,6 @@ GetInput(
*/
if (chanPtr->inQueueHead != NULL) {
-
/* TODO: Tests to cover this. */
assert(statePtr->inQueueHead == NULL);
@@ -6824,8 +6868,9 @@ GetInput(
/*
* Check the actual buffersize against the requested buffersize.
- * Saved buffers of the wrong size are squashed. This is done
- * to honor dynamic changes of the buffersize made by the user.
+ * Saved buffers of the wrong size are squashed. This is done to honor
+ * dynamic changes of the buffersize made by the user.
+ *
* TODO: Tests to cover this.
*/
@@ -7127,53 +7172,12 @@ Tcl_Tell(
/*
*---------------------------------------------------------------------------
*
- * Tcl_SeekOld, Tcl_TellOld --
- *
- * Backward-compatability versions of the seek/tell interface that do not
- * support 64-bit offsets. This interface is not documented or expected
- * to be supported indefinitely.
- *
- * Results:
- * As for Tcl_Seek and Tcl_Tell respectively, except truncated to
- * whatever value will fit in an 'int'.
- *
- * Side effects:
- * As for Tcl_Seek and Tcl_Tell respectively.
- *
- *---------------------------------------------------------------------------
- */
-
-int
-Tcl_SeekOld(
- Tcl_Channel chan, /* The channel on which to seek. */
- int offset, /* Offset to seek to. */
- int mode) /* Relative to which location to seek? */
-{
- Tcl_WideInt wOffset, wResult;
-
- wOffset = Tcl_LongAsWide((long) offset);
- wResult = Tcl_Seek(chan, wOffset, mode);
- return (int) Tcl_WideAsLong(wResult);
-}
-
-int
-Tcl_TellOld(
- Tcl_Channel chan) /* The channel to return pos for. */
-{
- Tcl_WideInt wResult = Tcl_Tell(chan);
-
- return (int) Tcl_WideAsLong(wResult);
-}
-
-/*
- *---------------------------------------------------------------------------
- *
* Tcl_TruncateChannel --
*
* Truncate a channel to the given length.
*
* Results:
- * TCL_OK on success, TCL_ERROR if the operation failed (e.g. is not
+ * TCL_OK on success, TCL_ERROR if the operation failed (e.g., is not
* supported by the type of channel, or the underlying OS operation
* failed in some way).
*
@@ -9317,7 +9321,7 @@ MBWrite(
* then the calculations involving extra must be made wide too.
*
* Noted with Win32/MSVC debug build treating the warning (possible of
- * data in int64 to int conversion) as error.
+ * data in __int64 to int conversion) as error.
*/
bufPtr = AllocChannelBuffer(extra);
@@ -9533,7 +9537,10 @@ CopyData(
}
if (size == 0) {
if (!GotFlag(inStatePtr, CHANNEL_NONBLOCKING)) {
- /* We allowed a short read. Keep trying. */
+ /*
+ * We allowed a short read. Keep trying.
+ */
+
continue;
}
if (bufObj != NULL) {
@@ -9747,7 +9754,7 @@ DoRead(
ChannelState *statePtr = chanPtr->state;
char *p = dst;
- assert (bytesToRead >= 0);
+ assert(bytesToRead >= 0);
/*
* Early out when we know a read will get the eofchar.
@@ -9763,15 +9770,18 @@ DoRead(
if (GotFlag(statePtr, CHANNEL_STICKY_EOF)) {
SetFlag(statePtr, CHANNEL_EOF);
- assert( statePtr->inputEncodingFlags & TCL_ENCODING_END );
- assert( !GotFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR) );
+ assert(statePtr->inputEncodingFlags & TCL_ENCODING_END);
+ assert(!GotFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR));
/* TODO: Don't need this call */
UpdateInterest(chanPtr);
return 0;
}
- /* Special handling for zero-char read request. */
+ /*
+ * Special handling for zero-char read request.
+ */
+
if (bytesToRead == 0) {
if (GotFlag(statePtr, CHANNEL_EOF)) {
statePtr->inputEncodingFlags |= TCL_ENCODING_START;
@@ -9786,8 +9796,8 @@ DoRead(
TclChannelPreserve((Tcl_Channel)chanPtr);
while (bytesToRead) {
/*
- * Each pass through the loop is intended to process up to
- * one channel buffer.
+ * Each pass through the loop is intended to process up to one channel
+ * buffer.
*/
int bytesRead, bytesWritten;
@@ -9799,33 +9809,39 @@ DoRead(
while (!bufPtr || /* We got no buffer! OR */
(!IsBufferFull(bufPtr) && /* Our buffer has room AND */
- (BytesLeft(bufPtr) < bytesToRead) ) ) {
- /* Not enough bytes in it
- * yet to fill the dst */
+ (BytesLeft(bufPtr) < bytesToRead))) {
+ /* Not enough bytes in it yet
+ * to fill the dst */
int code;
moreData:
code = GetInput(chanPtr);
bufPtr = statePtr->inQueueHead;
- assert (bufPtr != NULL);
+ assert(bufPtr != NULL);
if (GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED)) {
- /* Further reads cannot do any more */
+ /*
+ * Further reads cannot do any more.
+ */
+
break;
}
if (code) {
- /* Read error */
+ /*
+ * Read error
+ */
+
UpdateInterest(chanPtr);
TclChannelRelease((Tcl_Channel)chanPtr);
return -1;
}
- assert (IsBufferFull(bufPtr));
+ assert(IsBufferFull(bufPtr));
}
- assert (bufPtr != NULL);
+ assert(bufPtr != NULL);
bytesRead = BytesLeft(bufPtr);
bytesWritten = bytesToRead;
@@ -9840,8 +9856,8 @@ DoRead(
/*
* Buffer is not empty. How can that be?
*
- * 0) We stopped early because we got all the bytes
- * we were seeking. That's fine.
+ * 0) We stopped early because we got all the bytes we were
+ * seeking. That's fine.
*/
if (bytesToRead == 0) {
@@ -9857,8 +9873,8 @@ DoRead(
}
/*
- * 2) The buffer holds a \r while in CRLF translation,
- * followed by the end of the buffer.
+ * 2) The buffer holds a \r while in CRLF translation, followed by
+ * the end of the buffer.
*/
assert(statePtr->inputTranslation == TCL_TRANSLATE_CRLF);
@@ -9866,26 +9882,38 @@ DoRead(
assert(BytesLeft(bufPtr) == 1);
if (bufPtr->nextPtr == NULL) {
- /* There's no more buffered data.... */
+ /*
+ * There's no more buffered data...
+ */
if (statePtr->flags & CHANNEL_EOF) {
- /* ...and there never will be. */
+ /*
+ * ...and there never will be.
+ */
*p++ = '\r';
bytesToRead--;
bufPtr->nextRemoved++;
} else if (statePtr->flags & CHANNEL_BLOCKED) {
- /* ...and we cannot get more now. */
+ /*
+ * ...and we cannot get more now.
+ */
+
SetFlag(statePtr, CHANNEL_NEED_MORE_DATA);
break;
} else {
- /* ... so we need to get some. */
+ /*
+ * ...so we need to get some.
+ */
+
goto moreData;
}
}
if (bufPtr->nextPtr) {
- /* There's a next buffer. Shift orphan \r to it. */
+ /*
+ * There's a next buffer. Shift orphan \r to it.
+ */
ChannelBuffer *nextPtr = bufPtr->nextPtr;
@@ -9910,8 +9938,8 @@ DoRead(
}
/*
- * When there's no buffered data to read, and we're at EOF,
- * escape to the caller.
+ * When there's no buffered data to read, and we're at EOF, escape to
+ * the caller.
*/
if (GotFlag(statePtr, CHANNEL_EOF)
@@ -9923,11 +9951,11 @@ DoRead(
ResetFlag(statePtr, CHANNEL_BLOCKED);
}
- assert(!GotFlag(statePtr, CHANNEL_EOF)
- || GotFlag(statePtr, CHANNEL_STICKY_EOF)
- || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0);
- assert( !(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED)
- == (CHANNEL_EOF|CHANNEL_BLOCKED)) );
+ assert(!GotFlag(statePtr, CHANNEL_EOF)
+ || GotFlag(statePtr, CHANNEL_STICKY_EOF)
+ || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0);
+ assert(!(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED)
+ == (CHANNEL_EOF|CHANNEL_BLOCKED)));
UpdateInterest(chanPtr);
TclChannelRelease((Tcl_Channel)chanPtr);
return (int)(p - dst);
@@ -11194,7 +11222,7 @@ FreeChannelIntRep(
ResolvedChanName *resPtr = objPtr->internalRep.twoPtrValue.ptr1;
objPtr->typePtr = NULL;
- if (--resPtr->refCount) {
+ if (resPtr->refCount-- > 1) {
return;
}
Tcl_Release(resPtr->statePtr);
diff --git a/generic/tclIO.h b/generic/tclIO.h
index ffbfa31..07c54fa 100644
--- a/generic/tclIO.h
+++ b/generic/tclIO.h
@@ -214,7 +214,7 @@ typedef struct ChannelState {
* because it happened in the background. The
* value is the chanMg, if any. #219's
* companion to 'unreportedError'. */
- int epoch; /* Used to test validity of stored channelname
+ size_t epoch; /* Used to test validity of stored channelname
* lookup results. */
} ChannelState;
diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c
index de65da5..6e8bd09 100644
--- a/generic/tclIOCmd.c
+++ b/generic/tclIOCmd.c
@@ -25,7 +25,7 @@ typedef struct AcceptCallback {
* It must be per-thread because of std channel limitations.
*/
-typedef struct ThreadSpecificData {
+typedef struct {
int initialized; /* Set to 1 when the module is initialized. */
Tcl_Obj *stdoutObjPtr; /* Cached stdout channel Tcl_Obj */
} ThreadSpecificData;
@@ -113,7 +113,6 @@ Tcl_PutsObjCmd(
int newline; /* Add a newline at end? */
int result; /* Result of puts operation. */
int mode; /* Mode in which channel is opened. */
- ThreadSpecificData *tsdPtr;
switch (objc) {
case 2: /* [puts $x] */
@@ -160,7 +159,7 @@ Tcl_PutsObjCmd(
}
if (chanObjPtr == NULL) {
- tsdPtr = TCL_TSD_INIT(&dataKey);
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (!tsdPtr->initialized) {
tsdPtr->initialized = 1;
@@ -1485,13 +1484,17 @@ Tcl_SocketObjCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
static const char *const socketOptions[] = {
- "-async", "-myaddr", "-myport", "-server", NULL
+ "-async", "-myaddr", "-myport", "-reuseaddr", "-reuseport", "-server",
+ NULL
};
enum socketOptions {
- SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER
+ SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_REUSEADDR, SKT_REUSEPORT,
+ SKT_SERVER
};
- int optionIndex, a, server = 0, port, myport = 0, async = 0;
- const char *host, *myaddr = NULL;
+ int optionIndex, a, server = 0, myport = 0, async = 0, reusep = -1,
+ reusea = -1;
+ unsigned int flags = 0;
+ const char *host, *port, *myaddr = NULL;
Tcl_Obj *script = NULL;
Tcl_Channel chan;
@@ -1557,6 +1560,28 @@ Tcl_SocketObjCmd(
}
script = objv[a];
break;
+ case SKT_REUSEADDR:
+ a++;
+ if (a >= objc) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "no argument given for -reuseaddr option", -1));
+ return TCL_ERROR;
+ }
+ if (Tcl_GetBooleanFromObj(interp, objv[a], &reusea) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ break;
+ case SKT_REUSEPORT:
+ a++;
+ if (a >= objc) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "no argument given for -reuseport option", -1));
+ return TCL_ERROR;
+ }
+ if (Tcl_GetBooleanFromObj(interp, objv[a], &reusep) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ break;
default:
Tcl_Panic("Tcl_SocketObjCmd: bad option index to SocketOptions");
}
@@ -1580,28 +1605,61 @@ Tcl_SocketObjCmd(
"?-myaddr addr? ?-myport myport? ?-async? host port");
iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS;
Tcl_WrongNumArgs(interp, 1, objv,
- "-server command ?-myaddr addr? port");
+ "-server command ?-reuseaddr boolean? ?-reuseport boolean? "
+ "?-myaddr addr? port");
return TCL_ERROR;
}
- if (a == objc-1) {
- if (TclSockGetPort(interp, TclGetString(objv[a]), "tcp",
- &port) != TCL_OK) {
- return TCL_ERROR;
- }
- } else {
+ if (!server && (reusea != -1 || reusep != -1)) {
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "options -reuseaddr and -reuseport are only valid for servers",
+ -1));
+ return TCL_ERROR;
+ }
+
+ /*
+ * Set the options to their default value if the user didn't override
+ * their value.
+ */
+
+ if (reusep == -1) {
+ reusep = 0;
+ }
+ if (reusea == -1) {
+ reusea = 1;
+ }
+
+ /*
+ * Build the bitset with the flags values.
+ */
+
+ if (reusea) {
+ flags |= TCL_TCPSERVER_REUSEADDR;
+ }
+ if (reusep) {
+ flags |= TCL_TCPSERVER_REUSEPORT;
+ }
+
+ /*
+ * All the arguments should have been parsed by now, 'a' points to the
+ * last one, the port number.
+ */
+
+ if (a != objc-1) {
goto wrongNumArgs;
}
+ port = TclGetString(objv[a]);
+
if (server) {
- AcceptCallback *acceptCallbackPtr =
- ckalloc(sizeof(AcceptCallback));
+ AcceptCallback *acceptCallbackPtr = ckalloc(sizeof(AcceptCallback));
Tcl_IncrRefCount(script);
acceptCallbackPtr->script = script;
acceptCallbackPtr->interp = interp;
- chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc,
- acceptCallbackPtr);
+
+ chan = Tcl_OpenTcpServerEx(interp, port, host, flags,
+ AcceptCallbackProc, acceptCallbackPtr);
if (chan == NULL) {
Tcl_DecrRefCount(script);
ckfree(acceptCallbackPtr);
@@ -1625,7 +1683,13 @@ Tcl_SocketObjCmd(
Tcl_CreateCloseHandler(chan, TcpServerCloseProc, acceptCallbackPtr);
} else {
- chan = Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async);
+ int portNum;
+
+ if (TclSockGetPort(interp, port, "tcp", &portNum) != TCL_OK) {
+ return TCL_ERROR;
+ }
+
+ chan = Tcl_OpenTcpClient(interp, portNum, host, myaddr, myport, async);
if (chan == NULL) {
return TCL_ERROR;
}
diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c
index 7f61def..c1e8c44 100644
--- a/generic/tclIOGT.c
+++ b/generic/tclIOGT.c
@@ -211,7 +211,7 @@ struct TransformChannelData {
* a transformation of incoming data. Also
* serves as buffer of all data not yet
* consumed by the reader. */
- int refCount;
+ size_t refCount;
};
static void
@@ -225,7 +225,7 @@ static void
ReleaseData(
TransformChannelData *dataPtr)
{
- if (--dataPtr->refCount) {
+ if (dataPtr->refCount-- > 1) {
return;
}
ResultClear(&dataPtr->result);
diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c
index 1089d2b..aefa104 100644
--- a/generic/tclIORChan.c
+++ b/generic/tclIORChan.c
@@ -234,7 +234,7 @@ typedef enum {
* sharing problems.
*/
-typedef struct ForwardParamBase {
+typedef struct {
int code; /* O: Ok/Fail of the cmd handler */
char *msgStr; /* O: Error message for handler failure */
int mustFree; /* O: True if msgStr is allocated, false if
@@ -309,7 +309,7 @@ typedef struct ForwardingResult ForwardingResult;
* General event structure, with reference to operation specific data.
*/
-typedef struct ForwardingEvent {
+typedef struct {
Tcl_Event event; /* Basic event data, has to be first item */
ForwardingResult *resultPtr;
ForwardedOperation op; /* Forwarded driver operation */
@@ -346,7 +346,7 @@ struct ForwardingResult {
* results. */
};
-typedef struct ThreadSpecificData {
+typedef struct {
/*
* Table of all reflected channels owned by this thread. This is the
* per-thread version of the per-interpreter map.
@@ -591,7 +591,7 @@ TclChanCreateObjCmd(
if (Tcl_ListObjGetElements(NULL, resObj, &listc, &listv) != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s initialize\" returned non-list: %s",
- Tcl_GetString(cmdObj), Tcl_GetString(resObj)));
+ TclGetString(cmdObj), TclGetString(resObj)));
Tcl_DecrRefCount(resObj);
goto error;
}
@@ -617,35 +617,35 @@ TclChanCreateObjCmd(
if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" does not support all required methods",
- Tcl_GetString(cmdObj)));
+ TclGetString(cmdObj)));
goto error;
}
if ((mode & TCL_READABLE) && !HAS(methods, METH_READ)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" lacks a \"read\" method",
- Tcl_GetString(cmdObj)));
+ TclGetString(cmdObj)));
goto error;
}
if ((mode & TCL_WRITABLE) && !HAS(methods, METH_WRITE)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" lacks a \"write\" method",
- Tcl_GetString(cmdObj)));
+ TclGetString(cmdObj)));
goto error;
}
if (!IMPLIES(HAS(methods, METH_CGET), HAS(methods, METH_CGETALL))) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" supports \"cget\" but not \"cgetall\"",
- Tcl_GetString(cmdObj)));
+ TclGetString(cmdObj)));
goto error;
}
if (!IMPLIES(HAS(methods, METH_CGETALL), HAS(methods, METH_CGET))) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" supports \"cgetall\" but not \"cget\"",
- Tcl_GetString(cmdObj)));
+ TclGetString(cmdObj)));
goto error;
}
@@ -723,7 +723,7 @@ TclChanCreateObjCmd(
Tcl_DecrRefCount(rcPtr->name);
Tcl_DecrRefCount(rcPtr->methods);
Tcl_DecrRefCount(rcPtr->cmd);
- ckfree((char*) rcPtr);
+ ckfree(rcPtr);
return TCL_ERROR;
#undef MODE
@@ -748,7 +748,7 @@ TclChanCreateObjCmd(
*----------------------------------------------------------------------
*/
-typedef struct ReflectEvent {
+typedef struct {
Tcl_Event header;
ReflectedChannel *rcPtr;
int events;
@@ -851,11 +851,12 @@ TclChanPostEventObjCmd(
}
/*
- * Note that the search above subsumes several of the older checks, namely:
+ * Note that the search above subsumes several of the older checks,
+ * namely:
*
- * (1) Does the channel handle refer to a reflected channel ?
+ * (1) Does the channel handle refer to a reflected channel?
* (2) Is the post event issued from the interpreter holding the handler
- * of the reflected channel ?
+ * of the reflected channel?
*
* A successful search answers yes to both. Because the map holds only
* handles of reflected channels, and only of such whose handler is
@@ -939,7 +940,8 @@ TclChanPostEventObjCmd(
(void) GetThreadReflectedChannelMap();
- /* XXX Race condition !!
+ /*
+ * XXX Race condition !!
* XXX The destination thread may not exist anymore already.
* XXX (Delayed postevent executed after channel got removed).
* XXX Can we detect this ? (check the validity of the owner threadid ?)
@@ -1152,7 +1154,7 @@ ReflectClose(
tctPtr = ((Channel *)rcPtr->chan)->typePtr;
if (tctPtr && tctPtr != &tclRChannelType) {
- ckfree((char *)tctPtr);
+ ckfree(tctPtr);
((Channel *)rcPtr->chan)->typePtr = NULL;
}
Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
@@ -1221,8 +1223,8 @@ ReflectClose(
#endif
tctPtr = ((Channel *)rcPtr->chan)->typePtr;
if (tctPtr && tctPtr != &tclRChannelType) {
- ckfree((char *)tctPtr);
- ((Channel *)rcPtr->chan)->typePtr = NULL;
+ ckfree(tctPtr);
+ ((Channel *)rcPtr->chan)->typePtr = NULL;
}
Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
return (result == TCL_OK) ? EOK : EINVAL;
@@ -1272,7 +1274,10 @@ ReflectInput(
if (p.base.code != TCL_OK) {
if (p.base.code < 0) {
- /* No error message, this is an errno signal. */
+ /*
+ * No error message, this is an errno signal.
+ */
+
*errorCodePtr = -p.base.code;
} else {
PassReceivedError(rcPtr->chan, &p);
@@ -1375,7 +1380,10 @@ ReflectOutput(
if (p.base.code != TCL_OK) {
if (p.base.code < 0) {
- /* No error message, this is an errno signal. */
+ /*
+ * No error message, this is an errno signal.
+ */
+
*errorCodePtr = -p.base.code;
} else {
PassReceivedError(rcPtr->chan, &p);
@@ -1426,8 +1434,8 @@ ReflectOutput(
if ((written == 0) && (toWrite > 0)) {
/*
- * The handler claims to have written nothing of what it was
- * given. That is bad.
+ * The handler claims to have written nothing of what it was given.
+ * That is bad.
*/
SetChannelErrorStr(rcPtr->chan, msg_write_nothing);
@@ -2373,8 +2381,8 @@ InvokeTclMethod(
* None.
*
* Users:
- * ReflectInput/Output(), to enable the signaling of EAGAIN
- * on 0-sized short reads/writes.
+ * ReflectInput/Output(), to enable the signaling of EAGAIN on 0-sized
+ * short reads/writes.
*
*----------------------------------------------------------------------
*/
@@ -2398,7 +2406,7 @@ ErrnoReturn(
if (((Tcl_GetIntFromObj(rcPtr->interp, resObj, &code) != TCL_OK)
|| (code >= 0))) {
- if (strcmp("EAGAIN", Tcl_GetString(resObj)) == 0) {
+ if (strcmp("EAGAIN", TclGetString(resObj)) == 0) {
code = -EAGAIN;
} else {
code = 0;
@@ -2560,7 +2568,10 @@ DeleteReflectedChannelMap(
evPtr = resultPtr->evPtr;
- /* Basic crash safety until this routine can get revised [3411310] */
+ /*
+ * Basic crash safety until this routine can get revised [3411310]
+ */
+
if (evPtr == NULL) {
continue;
}
@@ -2675,8 +2686,8 @@ DeleteThreadReflectedChannelMap(
/*
* Go through the list of pending results and cancel all whose events were
- * destined for this thread. While this is in progress we block any
- * other access to the list of pending results.
+ * destined for this thread. While this is in progress we block any other
+ * access to the list of pending results.
*/
Tcl_MutexLock(&rcForwardMutex);
@@ -2707,7 +2718,10 @@ DeleteThreadReflectedChannelMap(
evPtr = resultPtr->evPtr;
- /* Basic crash safety until this routine can get revised [3411310] */
+ /*
+ * Basic crash safety until this routine can get revised [3411310]
+ */
+
if (evPtr == NULL ) {
continue;
}
@@ -2761,8 +2775,8 @@ ForwardOpToHandlerThread(
const void *param) /* Arguments */
{
/*
- * Core of the communication from OWNER to HANDLER thread.
- * The receiver is ForwardProc() below.
+ * Core of the communication from OWNER to HANDLER thread. The receiver is
+ * ForwardProc() below.
*/
Tcl_ThreadId dst = rcPtr->thread;
@@ -2812,7 +2826,10 @@ ForwardOpToHandlerThread(
*/
TclSpliceIn(resultPtr, forwardList);
- /* Do not unlock here. That is done by the ConditionWait */
+
+ /*
+ * Do not unlock here. That is done by the ConditionWait.
+ */
/*
* Ensure cleanup of the event if the origin thread exits while this event
@@ -2888,7 +2905,7 @@ ForwardProc(
* Notes regarding access to the referenced data.
*
* In principle the data belongs to the originating thread (see
- * evPtr->src), however this thread is currently blocked at (*), i.e.
+ * evPtr->src), however this thread is currently blocked at (*), i.e.,
* quiescent. Because of this we can treat the data as belonging to us,
* without fear of race conditions. I.e. we can read and write as we like.
*
diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c
index 47e0bc8..f198c69 100644
--- a/generic/tclIORTrans.c
+++ b/generic/tclIORTrans.c
@@ -329,7 +329,7 @@ struct ForwardingResult {
* results. */
};
-typedef struct ThreadSpecificData {
+typedef struct {
/*
* Table of all reflected transformations owned by this thread.
*/
@@ -554,7 +554,7 @@ TclChanPushObjCmd(
*/
chanObj = objv[CHAN];
- parentChan = Tcl_GetChannel(interp, Tcl_GetString(chanObj), &mode);
+ parentChan = Tcl_GetChannel(interp, TclGetString(chanObj), &mode);
if (parentChan == NULL) {
return TCL_ERROR;
}
@@ -608,7 +608,7 @@ TclChanPushObjCmd(
if (Tcl_ListObjGetElements(NULL, resObj, &listc, &listv) != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s initialize\" returned non-list: %s",
- Tcl_GetString(cmdObj), Tcl_GetString(resObj)));
+ TclGetString(cmdObj), TclGetString(resObj)));
Tcl_DecrRefCount(resObj);
goto error;
}
@@ -619,7 +619,7 @@ TclChanPushObjCmd(
"method", TCL_EXACT, &methIndex) != TCL_OK) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s initialize\" returned %s",
- Tcl_GetString(cmdObj),
+ TclGetString(cmdObj),
Tcl_GetString(Tcl_GetObjResult(interp))));
Tcl_DecrRefCount(resObj);
goto error;
@@ -633,7 +633,7 @@ TclChanPushObjCmd(
if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" does not support all required methods",
- Tcl_GetString(cmdObj)));
+ TclGetString(cmdObj)));
goto error;
}
@@ -655,7 +655,7 @@ TclChanPushObjCmd(
if (!mode) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" makes the channel inaccessible",
- Tcl_GetString(cmdObj)));
+ TclGetString(cmdObj)));
goto error;
}
@@ -666,14 +666,14 @@ TclChanPushObjCmd(
if (!IMPLIES(HAS(methods, METH_DRAIN), HAS(methods, METH_READ))) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" supports \"drain\" but not \"read\"",
- Tcl_GetString(cmdObj)));
+ TclGetString(cmdObj)));
goto error;
}
if (!IMPLIES(HAS(methods, METH_FLUSH), HAS(methods, METH_WRITE))) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"chan handler \"%s\" supports \"flush\" but not \"write\"",
- Tcl_GetString(cmdObj)));
+ TclGetString(cmdObj)));
goto error;
}
@@ -694,14 +694,14 @@ TclChanPushObjCmd(
*/
rtmPtr = GetReflectedTransformMap(interp);
- hPtr = Tcl_CreateHashEntry(&rtmPtr->map, Tcl_GetString(rtId), &isNew);
+ hPtr = Tcl_CreateHashEntry(&rtmPtr->map, TclGetString(rtId), &isNew);
if (!isNew && rtPtr != Tcl_GetHashValue(hPtr)) {
Tcl_Panic("TclChanPushObjCmd: duplicate transformation handle");
}
Tcl_SetHashValue(hPtr, rtPtr);
#ifdef TCL_THREADS
rtmPtr = GetThreadReflectedTransformMap();
- hPtr = Tcl_CreateHashEntry(&rtmPtr->map, Tcl_GetString(rtId), &isNew);
+ hPtr = Tcl_CreateHashEntry(&rtmPtr->map, TclGetString(rtId), &isNew);
Tcl_SetHashValue(hPtr, rtPtr);
#endif /* TCL_THREADS */
@@ -1027,7 +1027,7 @@ ReflectClose(
#ifdef TCL_THREADS
rtmPtr = GetThreadReflectedTransformMap();
- hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle));
+ hPtr = Tcl_FindHashEntry(&rtmPtr->map, TclGetString(rtPtr->handle));
if (hPtr) {
Tcl_DeleteHashEntry(hPtr);
}
@@ -2568,7 +2568,7 @@ ForwardProc(
*/
rtmPtr = GetReflectedTransformMap(interp);
- hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle));
+ hPtr = Tcl_FindHashEntry(&rtmPtr->map, TclGetString(rtPtr->handle));
Tcl_DeleteHashEntry(hPtr);
/*
@@ -2578,7 +2578,7 @@ ForwardProc(
*/
rtmPtr = GetThreadReflectedTransformMap();
- hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle));
+ hPtr = Tcl_FindHashEntry(&rtmPtr->map, TclGetString(rtPtr->handle));
Tcl_DeleteHashEntry(hPtr);
FreeReflectedTransformArgs(rtPtr);
@@ -2955,7 +2955,7 @@ ResultClear(
return;
}
- ckfree((char *) rPtr->buf);
+ ckfree(rPtr->buf);
rPtr->buf = NULL;
rPtr->allocated = 0;
}
diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c
index f61073b..6abfa60 100644
--- a/generic/tclIOSock.c
+++ b/generic/tclIOSock.c
@@ -12,16 +12,21 @@
#include "tclInt.h"
#if defined(_WIN32) && defined(UNICODE)
-/* On Windows, we need to do proper Unicode->UTF-8 conversion. */
+/*
+ * On Windows, we need to do proper Unicode->UTF-8 conversion.
+ */
-typedef struct ThreadSpecificData {
+typedef struct {
int initialized;
Tcl_DString errorMsg; /* UTF-8 encoded error-message */
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
#undef gai_strerror
-static const char *gai_strerror(int code) {
+static const char *
+gai_strerror(
+ int code)
+{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if (tsdPtr->initialized) {
@@ -56,8 +61,8 @@ static const char *gai_strerror(int code) {
int
TclSockGetPort(
Tcl_Interp *interp,
- const char *string, /* Integer or service name */
- const char *proto, /* "tcp" or "udp", typically */
+ const char *string, /* Integer or service name */
+ const char *proto, /* "tcp" or "udp", typically */
int *portPtr) /* Return port number */
{
struct servent *sp; /* Protocol info for named services */
@@ -126,7 +131,7 @@ TclSockMinimumBuffers(
}
len = sizeof(int);
getsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_RCVBUF,
- (char *) &current, &len);
+ (char *) &current, &len);
if (current < size) {
len = sizeof(int);
setsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_RCVBUF,
@@ -154,15 +159,15 @@ TclSockMinimumBuffers(
int
TclCreateSocketAddress(
- Tcl_Interp *interp, /* Interpreter for querying
- * the desired socket family */
- struct addrinfo **addrlist, /* Socket address list */
- const char *host, /* Host. NULL implies INADDR_ANY */
- int port, /* Port number */
- int willBind, /* Is this an address to bind() to or
- * to connect() to? */
- const char **errorMsgPtr) /* Place to store the error message
- * detail, if available. */
+ Tcl_Interp *interp, /* Interpreter for querying the desired socket
+ * family */
+ struct addrinfo **addrlist, /* Socket address list */
+ const char *host, /* Host. NULL implies INADDR_ANY */
+ int port, /* Port number */
+ int willBind, /* Is this an address to bind() to or to
+ * connect() to? */
+ const char **errorMsgPtr) /* Place to store the error message detail, if
+ * available. */
{
struct addrinfo hints;
struct addrinfo *p;
@@ -181,30 +186,31 @@ TclCreateSocketAddress(
* Workaround for OSX's apparent inability to resolve "localhost", "0"
* when the loopback device is the only available network interface.
*/
+
if (host != NULL && port == 0) {
- portstring = NULL;
+ portstring = NULL;
} else {
- TclFormatInt(portbuf, port);
- portstring = portbuf;
+ TclFormatInt(portbuf, port);
+ portstring = portbuf;
}
(void) memset(&hints, 0, sizeof(hints));
hints.ai_family = AF_UNSPEC;
/*
- * Magic variable to enforce a certain address family - to be superseded
- * by a TIP that adds explicit switches to [socket]
+ * Magic variable to enforce a certain address family; to be superseded
+ * by a TIP that adds explicit switches to [socket].
*/
if (interp != NULL) {
- family = Tcl_GetVar2(interp, "::tcl::unsupported::socketAF", NULL, 0);
- if (family != NULL) {
- if (strcmp(family, "inet") == 0) {
- hints.ai_family = AF_INET;
- } else if (strcmp(family, "inet6") == 0) {
- hints.ai_family = AF_INET6;
- }
- }
+ family = Tcl_GetVar2(interp, "::tcl::unsupported::socketAF", NULL, 0);
+ if (family != NULL) {
+ if (strcmp(family, "inet") == 0) {
+ hints.ai_family = AF_INET;
+ } else if (strcmp(family, "inet6") == 0) {
+ hints.ai_family = AF_INET6;
+ }
+ }
}
hints.ai_socktype = SOCK_STREAM;
@@ -214,7 +220,7 @@ TclCreateSocketAddress(
* We found some problems when using AI_ADDRCONFIG, e.g. on systems that
* have no networking besides the loopback interface and want to resolve
* localhost. See [Bugs 3385024, 3382419, 3382431]. As the advantage of
- * using AI_ADDRCONFIG in situations where it works, is probably low,
+ * using AI_ADDRCONFIG is probably low even in situations where it works,
* we'll leave it out for now. After all, it is just an optimisation.
*
* Missing on: OpenBSD, NetBSD.
@@ -251,6 +257,7 @@ TclCreateSocketAddress(
*
* There might be more elegant/efficient ways to do this.
*/
+
if (willBind) {
for (p = *addrlist; p != NULL; p = p->ai_next) {
if (p->ai_family == AF_INET) {
@@ -283,6 +290,38 @@ TclCreateSocketAddress(
}
/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_OpenTcpServer --
+ *
+ * Opens a TCP server socket and creates a channel around it.
+ *
+ * Results:
+ * The channel or NULL if failed. If an error occurred, an error message
+ * is left in the interp's result if interp is not NULL.
+ *
+ * Side effects:
+ * Opens a server socket and creates a new channel.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Channel
+Tcl_OpenTcpServer(
+ Tcl_Interp *interp,
+ int port,
+ const char *host,
+ Tcl_TcpAcceptProc *acceptProc,
+ ClientData callbackData)
+{
+ char portbuf[TCL_INTEGER_SPACE];
+
+ TclFormatInt(portbuf, port);
+ return Tcl_OpenTcpServerEx(interp, portbuf, host, TCL_TCPSERVER_REUSEADDR,
+ acceptProc, callbackData);
+}
+
+/*
* Local Variables:
* mode: c
* c-basic-offset: 4
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index 397c3b1..ea407ab 100644
--- a/generic/tclIOUtil.c
+++ b/generic/tclIOUtil.c
@@ -57,7 +57,7 @@ typedef struct FilesystemRecord {
* this information each time the corresponding epoch counter changes.
*/
-typedef struct ThreadSpecificData {
+typedef struct {
int initialized;
size_t cwdPathEpoch;
size_t filesystemEpoch;
@@ -611,6 +611,7 @@ FsRecacheFilesystemList(void)
while (toFree) {
FilesystemRecord *next = toFree->nextPtr;
+
toFree->fsPtr = NULL;
ckfree(toFree);
toFree = next;
@@ -638,8 +639,8 @@ FsGetFirstFilesystem(void)
}
/*
- * The epoch can be changed both by filesystems being added or removed and by
- * env(HOME) changing.
+ * The epoch can be changed by filesystems being added or removed, by changing
+ * the "system encoding" and by env(HOME) changing.
*/
int
@@ -672,7 +673,6 @@ TclFSEpoch(void)
return tsdPtr->filesystemEpoch;
}
-
/*
* If non-NULL, clientData is owned by us and must be freed later.
@@ -784,7 +784,9 @@ TclFinalizeFilesystem(void)
while (fsRecPtr != NULL) {
FilesystemRecord *tmpFsRecPtr = fsRecPtr->nextPtr;
- /* The native filesystem is static, so we don't free it. */
+ /*
+ * The native filesystem is static, so we don't free it.
+ */
if (fsRecPtr != &nativeFilesystemRecord) {
ckfree(fsRecPtr);
@@ -947,7 +949,7 @@ Tcl_FSRegister(
int
Tcl_FSUnregister(
- const Tcl_Filesystem *fsPtr) /* The filesystem record to remove. */
+ const Tcl_Filesystem *fsPtr)/* The filesystem record to remove. */
{
int retVal = TCL_ERROR;
FilesystemRecord *fsRecPtr;
@@ -1233,7 +1235,7 @@ FsAddMountsToGlobResult(
len--;
}
- len++; /* account for '/' in the mElt [Bug 1602539] */
+ len++; /* account for '/' in the mElt [Bug 1602539] */
mElt = TclNewFSPathObj(pathPtr, mount + len, mlen - len);
Tcl_ListObjAppendElement(NULL, resultPtr, mElt);
}
@@ -1403,7 +1405,7 @@ TclFSNormalizeToUniquePath(
* Call each of the "normalise path" functions in succession. This is a
* special case, in which if we have a native filesystem handler, we call
* it first. This is because the root of Tcl's filesystem is always a
- * native filesystem (i.e. '/' on unix is native).
+ * native filesystem (i.e., '/' on unix is native).
*/
firstFsRecPtr = FsGetFirstFilesystem();
@@ -1525,7 +1527,7 @@ TclGetOpenModeEx(
#define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR)
/*
- * Check for the simpler fopen-like access modes (e.g. "r"). They are
+ * Check for the simpler fopen-like access modes (e.g., "r"). They are
* distinguished from the POSIX access modes by the presence of a
* lower-case first letter.
*/
@@ -1890,6 +1892,7 @@ TclNREvalFile(
Tcl_GetString(pathPtr), Tcl_PosixError(interp)));
return TCL_ERROR;
}
+ TclPkgFileSeen(interp, Tcl_GetString(pathPtr));
/*
* The eofchar is \32 (^Z). This is the usual on Windows, but we effect
@@ -2670,6 +2673,7 @@ Tcl_FSGetCwd(
fsRecPtr = fsRecPtr->nextPtr) {
ClientData retCd;
TclFSGetCwdProc2 *proc2;
+
if (fsRecPtr->fsPtr->getCwdProc == NULL) {
continue;
}
@@ -3142,8 +3146,8 @@ Tcl_FSLoadFile(
* Workaround for issue with modern HPUX which do allow the unlink (no ETXTBSY
* error) yet somehow trash some internal data structures which prevents the
* second and further shared libraries from getting properly loaded. Only the
- * first is ok. We try to get around the issue by not unlinking,
- * i.e. emulating the behaviour of the older HPUX which denied removal.
+ * first is ok. We try to get around the issue by not unlinking, i.e.,
+ * emulating the behaviour of the older HPUX which denied removal.
*
* Doing the unlink is also an issue within docker containers, whose AUFS
* bungles this as well, see
@@ -3161,28 +3165,30 @@ Tcl_FSLoadFile(
*/
int
-TclSkipUnlink (Tcl_Obj* shlibFile)
+TclSkipUnlink(
+ Tcl_Obj *shlibFile)
{
- /* Order of testing:
+ /*
+ * Order of testing:
* 1. On hpux we generally want to skip unlink in general
*
* Outside of hpux then:
- * 2. For a general user request (TCL_TEMPLOAD_NO_UNLINK present, non-empty, => int)
+ * 2. For a general user request (TCL_TEMPLOAD_NO_UNLINK present,
+ * non-empty, => int)
* 3. For general AUFS environment (statfs, if available).
*
* Ad 2: This variable can disable/override the AUFS detection, i.e. for
- * testing if a newer AUFS does not have the bug any more.
+ * testing if a newer AUFS does not have the bug any more.
*
- * Ad 3: This is conditionally compiled in. Condition currently must be set manually.
- * This part needs proper tests in the configure(.in).
+ * Ad 3: This is conditionally compiled in. Condition currently must be
+ * set manually. This part needs proper tests in the configure(.in).
*/
#ifdef hpux
return 1;
#else
- char* skipstr;
+ char *skipstr = getenv("TCL_TEMPLOAD_NO_UNLINK");
- skipstr = getenv ("TCL_TEMPLOAD_NO_UNLINK");
if (skipstr && (skipstr[0] != '\0')) {
return atoi(skipstr);
}
@@ -3191,7 +3197,8 @@ TclSkipUnlink (Tcl_Obj* shlibFile)
#ifndef NO_FSTATFS
{
struct statfs fs;
- /* Have fstatfs. May not have the AUFS super magic ... Indeed our build
+ /*
+ * Have fstatfs. May not have the AUFS super magic ... Indeed our build
* box is too old to have it directly in the headers. Define taken from
* http://mooon.googlecode.com/svn/trunk/linux_include/linux/aufs_type.h
* http://aufs.sourceforge.net/
@@ -3208,8 +3215,10 @@ TclSkipUnlink (Tcl_Obj* shlibFile)
#endif /* ... NO_FSTATFS */
#endif /* ... TCL_TEMPLOAD_NO_UNLINK */
- /* Fallback: !hpux, no EV override, no AUFS (detection, nor detected):
- * Don't skip */
+ /*
+ * Fallback: !hpux, no EV override, no AUFS (detection, nor detected):
+ * Don't skip
+ */
return 0;
#endif /* hpux */
}
@@ -3414,9 +3423,8 @@ Tcl_LoadFile(
* avoids any worries about leaving the copy laying around on exit.
*/
- if (
- !TclSkipUnlink (copyToPtr) &&
- (Tcl_FSDeleteFile(copyToPtr) == TCL_OK)) {
+ if (!TclSkipUnlink(copyToPtr) &&
+ (Tcl_FSDeleteFile(copyToPtr) == TCL_OK)) {
Tcl_DecrRefCount(copyToPtr);
/*
diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c
index 6a3e4e3..9f38638 100644
--- a/generic/tclIndexObj.c
+++ b/generic/tclIndexObj.c
@@ -101,6 +101,7 @@ typedef struct {
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_GetIndexFromObj
int
Tcl_GetIndexFromObj(
@@ -137,6 +138,7 @@ Tcl_GetIndexFromObj(
return Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, sizeof(char *),
msg, flags, indexPtr);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index c00dff1..8314925 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -1246,7 +1246,7 @@ declare 19 macosx {
}
declare 29 {win unix} {
- int TclWinCPUID(unsigned int index, unsigned int *regs)
+ int TclWinCPUID(int index, int *regs)
}
# Added in 8.6; core of TclpOpenTemporaryFile
declare 30 {win unix} {
diff --git a/generic/tclInt.h b/generic/tclInt.h
index bb67ba0..f43de31 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -265,7 +265,7 @@ typedef struct Namespace {
* strings; values have type (Namespace *). If
* NULL, there are no children. */
#endif
- long nsId; /* Unique id for the namespace. */
+ size_t nsId; /* Unique id for the namespace. */
Tcl_Interp *interp; /* The interpreter containing this
* namespace. */
int flags; /* OR-ed combination of the namespace status
@@ -299,12 +299,12 @@ typedef struct Namespace {
* registered using "namespace export". */
int maxExportPatterns; /* Mumber of export patterns for which space
* is currently allocated. */
- int cmdRefEpoch; /* Incremented if a newly added command
+ size_t cmdRefEpoch; /* Incremented if a newly added command
* shadows a command for which this namespace
* has already cached a Command* pointer; this
* causes all its cached Command* pointers to
* be invalidated. */
- int resolverEpoch; /* Incremented whenever (a) the name
+ size_t resolverEpoch; /* Incremented whenever (a) the name
* resolution rules change for this namespace
* or (b) a newly added command shadows a
* command that is compiled to bytecodes. This
@@ -331,7 +331,7 @@ typedef struct Namespace {
* LookupCompiledLocal to resolve variable
* references within the namespace at compile
* time. */
- int exportLookupEpoch; /* Incremented whenever a command is added to
+ size_t exportLookupEpoch; /* Incremented whenever a command is added to
* a namespace, removed from a namespace or
* the exports of a namespace are changed.
* Allows TIP#112-driven command lists to be
@@ -432,7 +432,7 @@ typedef struct EnsembleConfig {
* if the command has been deleted (or never
* existed; the global namespace never has an
* ensemble command.) */
- int epoch; /* The epoch at which this ensemble's table of
+ size_t epoch; /* The epoch at which this ensemble's table of
* exported commands is valid. */
char **subcommandArrayPtr; /* Array of ensemble subcommand names. At all
* consistent points, this will have the same
@@ -1357,7 +1357,7 @@ MODULE_SCOPE void TclThreadDataKeySet(Tcl_ThreadDataKey *keyPtr,
*/
#define TCL_TSD_INIT(keyPtr) \
- (ThreadSpecificData *)Tcl_GetThreadData((keyPtr), sizeof(ThreadSpecificData))
+ Tcl_GetThreadData((keyPtr), sizeof(ThreadSpecificData))
/*
*----------------------------------------------------------------
@@ -1639,7 +1639,7 @@ typedef struct Command {
* representing a command's name in a ByteCode
* instruction sequence. This structure can be
* freed when refCount becomes zero. */
- int cmdEpoch; /* Incremented to invalidate any references
+ size_t cmdEpoch; /* Incremented to invalidate any references
* that point to this command when it is
* renamed, deleted, hidden, or exposed. */
CompileProc *compileProc; /* Procedure called to compile command. NULL
@@ -1862,6 +1862,7 @@ typedef struct Interp {
* See Tcl_AppendResult code for details.
*/
+#ifndef TCL_NO_DEPRECATED
char *appendResult; /* Storage space for results generated by
* Tcl_AppendResult. Ckalloc-ed. NULL means
* not yet allocated. */
@@ -1869,6 +1870,11 @@ typedef struct Interp {
* partialResult. */
int appendUsed; /* Number of non-null bytes currently stored
* at partialResult. */
+#else
+ char *appendResultDontUse;
+ int appendAvlDontUse;
+ int appendUsedDontUse;
+#endif
/*
* Information about packages. Used only in tclPkg.c.
@@ -1898,7 +1904,7 @@ typedef struct Interp {
* compiled by the interpreter. Indexed by the
* string representations of literals. Used to
* avoid creating duplicate objects. */
- int compileEpoch; /* Holds the current "compilation epoch" for
+ unsigned int compileEpoch; /* Holds the current "compilation epoch" for
* this interpreter. This is incremented to
* invalidate existing ByteCodes when, e.g., a
* command with a compile procedure is
@@ -1930,8 +1936,12 @@ typedef struct Interp {
* string. Returned by Tcl_ObjSetVar2 when
* variable traces change a variable in a
* gross way. */
+#ifndef TCL_NO_DEPRECATED
char resultSpace[TCL_RESULT_SIZE+1];
/* Static space holding small results. */
+#else
+ char resultSpaceDontUse[TCL_RESULT_SIZE+1];
+#endif
Tcl_Obj *objResultPtr; /* If the last command returned an object
* result, this points to it. Should not be
* accessed directly; see comment above. */
@@ -2608,7 +2618,7 @@ typedef Tcl_ObjCmdProc *TclObjCmdProcType;
*----------------------------------------------------------------
*/
-typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, int *lengthPtr,
+typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, size_t *lengthPtr,
Tcl_Encoding *encodingPtr);
/*
@@ -2620,9 +2630,9 @@ typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, int *lengthPtr,
*/
typedef struct ProcessGlobalValue {
- int epoch; /* Epoch counter to detect changes in the
+ size_t epoch; /* Epoch counter to detect changes in the
* master value. */
- int numBytes; /* Length of the master string. */
+ size_t numBytes; /* Length of the master string. */
char *value; /* The master string value. */
Tcl_Encoding encoding; /* system encoding when master string was
* initialized. */
@@ -2745,7 +2755,6 @@ MODULE_SCOPE long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS];
* shared by all new objects allocated by Tcl_NewObj.
*/
-MODULE_SCOPE char * tclEmptyStringRep;
MODULE_SCOPE char tclEmptyString;
/*
@@ -2945,6 +2954,7 @@ MODULE_SCOPE void TclFinalizeNotifier(void);
MODULE_SCOPE void TclFinalizeObjects(void);
MODULE_SCOPE void TclFinalizePreserve(void);
MODULE_SCOPE void TclFinalizeSynchronization(void);
+MODULE_SCOPE void TclInitThreadAlloc(void);
MODULE_SCOPE void TclFinalizeThreadAlloc(void);
MODULE_SCOPE void TclFinalizeThreadAllocThread(void);
MODULE_SCOPE void TclFinalizeThreadData(int quick);
@@ -2974,6 +2984,9 @@ MODULE_SCOPE Tcl_Obj * TclGetSourceFromFrame(CmdFrame *cfPtr, int objc,
Tcl_Obj *const objv[]);
MODULE_SCOPE char * TclGetStringStorage(Tcl_Obj *objPtr,
unsigned int *sizePtr);
+MODULE_SCOPE int TclGetLoadedPackagesEx(Tcl_Interp *interp,
+ const char *targetName,
+ const char *packageName);
MODULE_SCOPE int TclGlob(Tcl_Interp *interp, char *pattern,
Tcl_Obj *unquotedPrefix, int globFlags,
Tcl_GlobTypeData *types);
@@ -3072,7 +3085,7 @@ MODULE_SCOPE int TclpThreadCreate(Tcl_ThreadId *idPtr,
int stackSize, int flags);
MODULE_SCOPE int TclpFindVariable(const char *name, int *lengthPtr);
MODULE_SCOPE void TclpInitLibraryPath(char **valuePtr,
- int *lengthPtr, Tcl_Encoding *encodingPtr);
+ size_t *lengthPtr, Tcl_Encoding *encodingPtr);
MODULE_SCOPE void TclpInitLock(void);
MODULE_SCOPE void TclpInitPlatform(void);
MODULE_SCOPE void TclpInitUnlock(void);
@@ -3100,6 +3113,8 @@ MODULE_SCOPE int TclpObjChdir(Tcl_Obj *pathPtr);
MODULE_SCOPE Tcl_Channel TclpOpenTemporaryFile(Tcl_Obj *dirObj,
Tcl_Obj *basenameObj, Tcl_Obj *extensionObj,
Tcl_Obj *resultingNameObj);
+MODULE_SCOPE void TclPkgFileSeen(Tcl_Interp *interp, const char *fileName);
+MODULE_SCOPE void *TclInitPkgFiles(Tcl_Interp *interp);
MODULE_SCOPE Tcl_Obj * TclPathPart(Tcl_Interp *interp, Tcl_Obj *pathPtr,
Tcl_PathPart portion);
MODULE_SCOPE char * TclpReadlink(const char *fileName,
@@ -3109,7 +3124,7 @@ MODULE_SCOPE void TclpSetVariables(Tcl_Interp *interp);
MODULE_SCOPE void * TclThreadStorageKeyGet(Tcl_ThreadDataKey *keyPtr);
MODULE_SCOPE void TclThreadStorageKeySet(Tcl_ThreadDataKey *keyPtr,
void *data);
-MODULE_SCOPE void TclpThreadExit(int status);
+MODULE_SCOPE TCL_NORETURN void TclpThreadExit(int status);
MODULE_SCOPE void TclRememberCondition(Tcl_Condition *mutex);
MODULE_SCOPE void TclRememberJoinableThread(Tcl_ThreadId id);
MODULE_SCOPE void TclRememberMutex(Tcl_Mutex *mutex);
@@ -3135,11 +3150,20 @@ MODULE_SCOPE void TclSpellFix(Tcl_Interp *interp,
Tcl_Obj *bad, Tcl_Obj *fix);
MODULE_SCOPE void * TclStackRealloc(Tcl_Interp *interp, void *ptr,
int numBytes);
+MODULE_SCOPE int TclStringCatObjv(Tcl_Interp *interp, int inPlace,
+ int objc, Tcl_Obj *const objv[],
+ Tcl_Obj **objPtrPtr);
+MODULE_SCOPE int TclStringFind(Tcl_Obj *needle, Tcl_Obj *haystack,
+ int start);
+MODULE_SCOPE int TclStringLast(Tcl_Obj *needle, Tcl_Obj *haystack,
+ int last);
MODULE_SCOPE int TclStringMatch(const char *str, int strLen,
const char *pattern, int ptnLen, int flags);
MODULE_SCOPE int TclStringMatchObj(Tcl_Obj *stringObj,
Tcl_Obj *patternObj, int flags);
MODULE_SCOPE Tcl_Obj * TclStringObjReverse(Tcl_Obj *objPtr);
+MODULE_SCOPE int TclStringRepeat(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ int count, Tcl_Obj **objPtrPtr);
MODULE_SCOPE void TclSubstCompile(Tcl_Interp *interp, const char *bytes,
int numBytes, int flags, int line,
struct CompileEnv *envPtr);
@@ -3205,9 +3229,11 @@ MODULE_SCOPE Tcl_Command TclInitBinaryCmd(Tcl_Interp *interp);
MODULE_SCOPE int Tcl_BreakObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
+#ifndef TCL_NO_DEPRECATED
MODULE_SCOPE int Tcl_CaseObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
+#endif
MODULE_SCOPE int Tcl_CatchObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
@@ -3262,10 +3288,8 @@ MODULE_SCOPE int Tcl_AssembleObjCmd(ClientData clientData,
MODULE_SCOPE int TclNRAssembleObjCmd(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[]);
+MODULE_SCOPE Tcl_Command TclInitEncodingCmd(Tcl_Interp *interp);
+MODULE_SCOPE int TclMakeEncodingCommandSafe(Tcl_Interp *interp);
MODULE_SCOPE int Tcl_EofObjCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
@@ -3503,6 +3527,12 @@ MODULE_SCOPE int TclCompileBreakCmd(Tcl_Interp *interp,
MODULE_SCOPE int TclCompileCatchCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileClockClicksCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
+MODULE_SCOPE int TclCompileClockReadingCmd(Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, Command *cmdPtr,
+ struct CompileEnv *envPtr);
MODULE_SCOPE int TclCompileConcatCmd(Tcl_Interp *interp,
Tcl_Parse *parsePtr, Command *cmdPtr,
struct CompileEnv *envPtr);
@@ -4050,7 +4080,7 @@ typedef const char *TclDTraceStr;
TclIncrObjsAllocated(); \
TclAllocObjStorage(objPtr); \
(objPtr)->refCount = 0; \
- (objPtr)->bytes = tclEmptyStringRep; \
+ (objPtr)->bytes = &tclEmptyString; \
(objPtr)->length = 0; \
(objPtr)->typePtr = NULL; \
TCL_DTRACE_OBJ_CREATE(objPtr)
@@ -4067,8 +4097,8 @@ typedef const char *TclDTraceStr;
if (!(objPtr)->typePtr || !(objPtr)->typePtr->freeIntRepProc) { \
TCL_DTRACE_OBJ_FREE(objPtr); \
if ((objPtr)->bytes \
- && ((objPtr)->bytes != tclEmptyStringRep)) { \
- ckfree((char *) (objPtr)->bytes); \
+ && ((objPtr)->bytes != &tclEmptyString)) { \
+ ckfree((objPtr)->bytes); \
} \
(objPtr)->length = -1; \
TclFreeObjStorage(objPtr); \
@@ -4091,7 +4121,7 @@ typedef const char *TclDTraceStr;
(objPtr) = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj))
# define TclFreeObjStorageEx(interp, objPtr) \
- ckfree((char *) (objPtr))
+ ckfree(objPtr)
#undef USE_THREAD_ALLOC
#undef USE_TCLALLOC
@@ -4228,7 +4258,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
#define TclInitStringRep(objPtr, bytePtr, len) \
if ((len) == 0) { \
- (objPtr)->bytes = tclEmptyStringRep; \
+ (objPtr)->bytes = &tclEmptyString; \
(objPtr)->length = 0; \
} else { \
(objPtr)->bytes = (char *) ckalloc((unsigned) ((len) + 1)); \
@@ -4250,7 +4280,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
*/
#define TclGetString(objPtr) \
- ((objPtr)->bytes? (objPtr)->bytes : Tcl_GetString((objPtr)))
+ ((objPtr)->bytes? (objPtr)->bytes : Tcl_GetString(objPtr))
#define TclGetStringFromObj(objPtr, lenPtr) \
((objPtr)->bytes \
@@ -4285,11 +4315,11 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
*/
#define TclInvalidateStringRep(objPtr) \
- if (objPtr->bytes != NULL) { \
- if (objPtr->bytes != tclEmptyStringRep) { \
- ckfree((char *) objPtr->bytes); \
+ if ((objPtr)->bytes != NULL) { \
+ if ((objPtr)->bytes != &tclEmptyString) { \
+ ckfree((objPtr)->bytes); \
} \
- objPtr->bytes = NULL; \
+ (objPtr)->bytes = NULL; \
}
/*
@@ -4419,8 +4449,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
*----------------------------------------------------------------
*/
-#define TclIsPureByteArray(objPtr) \
- (((objPtr)->typePtr==&tclByteArrayType) && ((objPtr)->bytes==NULL))
+MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr);
/*
*----------------------------------------------------------------
@@ -4502,9 +4531,7 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
* core. They should only be called on unshared objects. The ANSI C
* "prototypes" for these macros are:
*
- * MODULE_SCOPE void TclSetIntObj(Tcl_Obj *objPtr, int intValue);
* MODULE_SCOPE void TclSetLongObj(Tcl_Obj *objPtr, long longValue);
- * MODULE_SCOPE void TclSetBooleanObj(Tcl_Obj *objPtr, long boolValue);
* MODULE_SCOPE void TclSetWideIntObj(Tcl_Obj *objPtr, Tcl_WideInt w);
* MODULE_SCOPE void TclSetDoubleObj(Tcl_Obj *objPtr, double d);
*----------------------------------------------------------------
@@ -4518,19 +4545,6 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
(objPtr)->typePtr = &tclIntType; \
} while (0)
-#define TclSetIntObj(objPtr, l) \
- TclSetLongObj(objPtr, l)
-
-/*
- * NOTE: There is to be no such thing as a "pure" boolean. Boolean values set
- * programmatically go straight to being "int" Tcl_Obj's, with value 0 or 1.
- * The only "boolean" Tcl_Obj's shall be those holding the cached boolean
- * value of strings like: "yes", "no", "true", "false", "on", "off".
- */
-
-#define TclSetBooleanObj(objPtr, b) \
- TclSetLongObj(objPtr, (b)!=0);
-
#ifndef TCL_WIDE_INT_IS_LONG
#define TclSetWideIntObj(objPtr, w) \
do { \
@@ -4555,13 +4569,11 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
* types, avoiding the corresponding function calls in time critical parts of
* the core. The ANSI C "prototypes" for these macros are:
*
- * MODULE_SCOPE void TclNewIntObj(Tcl_Obj *objPtr, int i);
* MODULE_SCOPE void TclNewLongObj(Tcl_Obj *objPtr, long l);
- * MODULE_SCOPE void TclNewBooleanObj(Tcl_Obj *objPtr, int b);
* MODULE_SCOPE void TclNewWideObj(Tcl_Obj *objPtr, Tcl_WideInt w);
* MODULE_SCOPE void TclNewDoubleObj(Tcl_Obj *objPtr, double d);
- * MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, char *s, int len);
- * MODULE_SCOPE void TclNewLiteralStringObj(Tcl_Obj*objPtr, char*sLiteral);
+ * MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, const char *s, int len);
+ * MODULE_SCOPE void TclNewLiteralStringObj(Tcl_Obj*objPtr, const char *sLiteral);
*
*----------------------------------------------------------------
*/
@@ -4578,16 +4590,6 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
TCL_DTRACE_OBJ_CREATE(objPtr); \
} while (0)
-#define TclNewIntObj(objPtr, l) \
- TclNewLongObj(objPtr, l)
-
-/*
- * NOTE: There is to be no such thing as a "pure" boolean.
- * See comment above TclSetBooleanObj macro above.
- */
-#define TclNewBooleanObj(objPtr, b) \
- TclNewLongObj((objPtr), (b)!=0)
-
#define TclNewDoubleObj(objPtr, d) \
do { \
TclIncrObjsAllocated(); \
@@ -4610,15 +4612,9 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
} while (0)
#else /* TCL_MEM_DEBUG */
-#define TclNewIntObj(objPtr, i) \
- (objPtr) = Tcl_NewIntObj(i)
-
#define TclNewLongObj(objPtr, l) \
(objPtr) = Tcl_NewLongObj(l)
-#define TclNewBooleanObj(objPtr, b) \
- (objPtr) = Tcl_NewBooleanObj(b)
-
#define TclNewDoubleObj(objPtr, d) \
(objPtr) = Tcl_NewDoubleObj(d)
@@ -4700,7 +4696,7 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
#define TclCleanupCommandMacro(cmdPtr) \
if ((cmdPtr)->refCount-- <= 1) { \
- ckfree((char *) (cmdPtr));\
+ ckfree(cmdPtr);\
}
/*
@@ -4858,7 +4854,7 @@ typedef struct NRE_callback {
#else
#define TCLNR_ALLOC(interp, ptr) \
(ptr = ((ClientData) ckalloc(sizeof(NRE_callback))))
-#define TCLNR_FREE(interp, ptr) ckfree((char *) (ptr))
+#define TCLNR_FREE(interp, ptr) ckfree(ptr)
#endif
#if NRE_ENABLE_ASSERTS
diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h
index ac06787..494d6f1 100644
--- a/generic/tclIntPlatDecls.h
+++ b/generic/tclIntPlatDecls.h
@@ -98,7 +98,7 @@ EXTERN int TclUnixCopyFile(const char *src, const char *dst,
/* Slot 27 is reserved */
/* Slot 28 is reserved */
/* 29 */
-EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs);
+EXTERN int TclWinCPUID(int index, int *regs);
/* 30 */
EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj,
Tcl_Obj *basenameObj, Tcl_Obj *extensionObj,
@@ -173,7 +173,7 @@ EXTERN void TclWinFlushDirtyChannels(void);
/* 28 */
EXTERN void TclWinResetInterfaces(void);
/* 29 */
-EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs);
+EXTERN int TclWinCPUID(int index, int *regs);
/* 30 */
EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj,
Tcl_Obj *basenameObj, Tcl_Obj *extensionObj,
@@ -247,7 +247,7 @@ EXTERN void TclMacOSXNotifierAddRunLoopMode(
/* Slot 27 is reserved */
/* Slot 28 is reserved */
/* 29 */
-EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs);
+EXTERN int TclWinCPUID(int index, int *regs);
/* 30 */
EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj,
Tcl_Obj *basenameObj, Tcl_Obj *extensionObj,
@@ -288,7 +288,7 @@ typedef struct TclIntPlatStubs {
void (*reserved26)(void);
void (*reserved27)(void);
void (*reserved28)(void);
- int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */
+ int (*tclWinCPUID) (int index, int *regs); /* 29 */
int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */
#endif /* UNIX */
#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */
@@ -321,7 +321,7 @@ typedef struct TclIntPlatStubs {
void (*tclWinSetInterfaces) (int wide); /* 26 */
void (*tclWinFlushDirtyChannels) (void); /* 27 */
void (*tclWinResetInterfaces) (void); /* 28 */
- int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */
+ int (*tclWinCPUID) (int index, int *regs); /* 29 */
int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */
#endif /* WIN */
#ifdef MAC_OSX_TCL /* MACOSX */
@@ -354,7 +354,7 @@ typedef struct TclIntPlatStubs {
void (*reserved26)(void);
void (*reserved27)(void);
void (*reserved28)(void);
- int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */
+ int (*tclWinCPUID) (int index, int *regs); /* 29 */
int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */
#endif /* MACOSX */
} TclIntPlatStubs;
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 6c7ab64..1bf3cf9 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -331,13 +331,24 @@ TclSetPreInitScript(
*----------------------------------------------------------------------
*/
+typedef struct PkgName {
+ struct PkgName *nextPtr; /* Next in list of package names being initialized. */
+ char name[4];
+} PkgName;
+
int
Tcl_Init(
Tcl_Interp *interp) /* Interpreter to initialize. */
{
+ PkgName pkgName = {NULL, "Tcl"};
+ PkgName **names = TclInitPkgFiles(interp);
+ int result = TCL_ERROR;
+
+ pkgName.nextPtr = *names;
+ *names = &pkgName;
if (tclPreInitScript != NULL) {
if (Tcl_EvalEx(interp, tclPreInitScript, -1, 0) == TCL_ERROR) {
- return TCL_ERROR;
+ goto end;
}
}
@@ -382,7 +393,7 @@ Tcl_Init(
* alternate tclInit command before calling Tcl_Init().
*/
- return Tcl_EvalEx(interp,
+ result = Tcl_EvalEx(interp,
"if {[namespace which -command tclInit] eq \"\"} {\n"
" proc tclInit {} {\n"
" global tcl_libPath tcl_library env tclDefaultLibrary\n"
@@ -410,6 +421,7 @@ Tcl_Init(
" {file join $grandParentDir lib tcl[info tclversion]} \\\n"
" {file join $parentDir library} \\\n"
" {file join $grandParentDir library} \\\n"
+" {file join $grandParentDir tcl[info tclversion] library} \\\n"
" {file join $grandParentDir tcl[info patchlevel] library} \\\n"
" {\n"
"file join [file dirname $grandParentDir] tcl[info patchlevel] library}\n"
@@ -445,6 +457,10 @@ Tcl_Init(
" }\n"
"}\n"
"tclInit", -1, 0);
+
+end:
+ *names = (*names)->nextPtr;
+ return result;
}
/*
@@ -660,14 +676,9 @@ NRInterpCmd(
if (masterInterp == NULL) {
return TCL_ERROR;
}
- if (TclGetString(objv[5])[0] == '\0') {
- if (objc == 6) {
- return AliasDelete(interp, slaveInterp, objv[3]);
- }
- } else {
- return AliasCreate(interp, slaveInterp, masterInterp, objv[3],
- objv[5], objc - 6, objv + 6);
- }
+
+ return AliasCreate(interp, slaveInterp, masterInterp, objv[3],
+ objv[5], objc - 6, objv + 6);
}
goto aliasArgs;
}
@@ -3522,9 +3533,6 @@ Tcl_LimitAddHandler(
if (deleteProc == (Tcl_LimitHandlerDeleteProc *) TCL_DYNAMIC) {
deleteProc = (Tcl_LimitHandlerDeleteProc *) Tcl_Free;
}
- if (deleteProc == (Tcl_LimitHandlerDeleteProc *) TCL_STATIC) {
- deleteProc = NULL;
- }
/*
* Allocate a handler record.
diff --git a/generic/tclLink.c b/generic/tclLink.c
index e6dc657..a39dfcd 100644
--- a/generic/tclLink.c
+++ b/generic/tclLink.c
@@ -36,8 +36,10 @@ typedef struct Link {
unsigned int ui;
short s;
unsigned short us;
+#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__)
long l;
unsigned long ul;
+#endif
Tcl_WideInt w;
Tcl_WideUInt uw;
float f;
@@ -67,6 +69,9 @@ typedef struct Link {
static char * LinkTraceProc(ClientData clientData,Tcl_Interp *interp,
const char *name1, const char *name2, int flags);
static Tcl_Obj * ObjValue(Link *linkPtr);
+static int GetInvalidIntFromObj(Tcl_Obj *objPtr, int *intPtr);
+static int GetInvalidWideFromObj(Tcl_Obj *objPtr, Tcl_WideInt *widePtr);
+static int GetInvalidDoubleFromObj(Tcl_Obj *objPtr, double *doublePtr);
/*
* Convenience macro for accessing the value of the C variable pointed to by a
@@ -126,6 +131,14 @@ Tcl_LinkVar(
Tcl_IncrRefCount(linkPtr->varName);
linkPtr->addr = addr;
linkPtr->type = type & ~TCL_LINK_READ_ONLY;
+#if !defined(TCL_NO_DEPRECATED) && (defined(TCL_WIDE_INT_IS_LONG) \
+ || defined(_WIN32) || defined(__CYGWIN__))
+ if (linkPtr->type == 11 /* legacy TCL_LINK_LONG */) {
+ linkPtr->type = TCL_LINK_LONG;
+ } else if (linkPtr->type == 12 /* legacy TCL_LINK_ULONG */) {
+ linkPtr->type = TCL_LINK_ULONG;
+ }
+#endif
if (type & TCL_LINK_READ_ONLY) {
linkPtr->flags = LINK_READ_ONLY;
} else {
@@ -259,7 +272,8 @@ LinkTraceProc(
int flags) /* Miscellaneous additional information. */
{
Link *linkPtr = clientData;
- int changed, valueLength;
+ int changed;
+ size_t valueLength;
const char *value;
char **pp;
Tcl_Obj *valueObj;
@@ -331,12 +345,14 @@ LinkTraceProc(
case TCL_LINK_UINT:
changed = (LinkedVar(unsigned int) != linkPtr->lastValue.ui);
break;
+#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__)
case TCL_LINK_LONG:
changed = (LinkedVar(long) != linkPtr->lastValue.l);
break;
case TCL_LINK_ULONG:
changed = (LinkedVar(unsigned long) != linkPtr->lastValue.ul);
break;
+#endif
case TCL_LINK_FLOAT:
changed = (LinkedVar(float) != linkPtr->lastValue.f);
break;
@@ -378,8 +394,8 @@ LinkTraceProc(
switch (linkPtr->type) {
case TCL_LINK_INT:
- if (Tcl_GetIntFromObj(NULL, valueObj, &linkPtr->lastValue.i)
- != TCL_OK) {
+ if (Tcl_GetIntFromObj(NULL, valueObj, &linkPtr->lastValue.i) != TCL_OK
+ && GetInvalidIntFromObj(valueObj, &linkPtr->lastValue.i) != TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return (char *) "variable must have integer value";
@@ -388,8 +404,8 @@ LinkTraceProc(
break;
case TCL_LINK_WIDE_INT:
- if (Tcl_GetWideIntFromObj(NULL, valueObj, &linkPtr->lastValue.w)
- != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(NULL, valueObj, &linkPtr->lastValue.w) != TCL_OK
+ && GetInvalidWideFromObj(valueObj, &linkPtr->lastValue.w) != TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return (char *) "variable must have integer value";
@@ -398,14 +414,15 @@ LinkTraceProc(
break;
case TCL_LINK_DOUBLE:
- if (Tcl_GetDoubleFromObj(NULL, valueObj, &linkPtr->lastValue.d)
- != TCL_OK) {
+ if (Tcl_GetDoubleFromObj(NULL, valueObj, &linkPtr->lastValue.d) != TCL_OK) {
#ifdef ACCEPT_NAN
if (valueObj->typePtr != &tclDoubleType) {
#endif
- Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
- ObjValue(linkPtr), TCL_GLOBAL_ONLY);
- return (char *) "variable must have real value";
+ if (GetInvalidDoubleFromObj(valueObj, &linkPtr->lastValue.d) != TCL_OK) {
+ Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
+ TCL_GLOBAL_ONLY);
+ return (char *) "variable must have real value";
+ }
#ifdef ACCEPT_NAN
}
linkPtr->lastValue.d = valueObj->internalRep.doubleValue;
@@ -415,8 +432,7 @@ LinkTraceProc(
break;
case TCL_LINK_BOOLEAN:
- if (Tcl_GetBooleanFromObj(NULL, valueObj, &linkPtr->lastValue.i)
- != TCL_OK) {
+ if (Tcl_GetBooleanFromObj(NULL, valueObj, &linkPtr->lastValue.i) != TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return (char *) "variable must have boolean value";
@@ -425,113 +441,115 @@ LinkTraceProc(
break;
case TCL_LINK_CHAR:
- if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK
+ if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
+ && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK)
|| valueInt < SCHAR_MIN || valueInt > SCHAR_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return (char *) "variable must have char value";
}
- linkPtr->lastValue.c = (char)valueInt;
- LinkedVar(char) = linkPtr->lastValue.c;
+ LinkedVar(char) = linkPtr->lastValue.c = (char)valueInt;
break;
case TCL_LINK_UCHAR:
- if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK
+ if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
+ && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK)
|| valueInt < 0 || valueInt > UCHAR_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return (char *) "variable must have unsigned char value";
}
- linkPtr->lastValue.uc = (unsigned char) valueInt;
- LinkedVar(unsigned char) = linkPtr->lastValue.uc;
+ LinkedVar(unsigned char) = linkPtr->lastValue.uc = (unsigned char) valueInt;
break;
case TCL_LINK_SHORT:
- if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK
+ if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
+ && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK)
|| valueInt < SHRT_MIN || valueInt > SHRT_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return (char *) "variable must have short value";
}
- linkPtr->lastValue.s = (short)valueInt;
- LinkedVar(short) = linkPtr->lastValue.s;
+ LinkedVar(short) = linkPtr->lastValue.s = (short)valueInt;
break;
case TCL_LINK_USHORT:
- if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK
+ if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK
+ && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK)
|| valueInt < 0 || valueInt > USHRT_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return (char *) "variable must have unsigned short value";
}
- linkPtr->lastValue.us = (unsigned short)valueInt;
- LinkedVar(unsigned short) = linkPtr->lastValue.us;
+ LinkedVar(unsigned short) = linkPtr->lastValue.us = (unsigned short)valueInt;
break;
case TCL_LINK_UINT:
- if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK
+ if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK
+ && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK)
|| valueWide < 0 || valueWide > UINT_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return (char *) "variable must have unsigned int value";
}
- linkPtr->lastValue.ui = (unsigned int)valueWide;
- LinkedVar(unsigned int) = linkPtr->lastValue.ui;
+ LinkedVar(unsigned int) = linkPtr->lastValue.ui = (unsigned int)valueWide;
break;
+#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__)
case TCL_LINK_LONG:
- if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK
+ if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK
+ && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK)
|| valueWide < LONG_MIN || valueWide > LONG_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return (char *) "variable must have long value";
}
- linkPtr->lastValue.l = (long)valueWide;
- LinkedVar(long) = linkPtr->lastValue.l;
+ LinkedVar(long) = linkPtr->lastValue.l = (long)valueWide;
break;
case TCL_LINK_ULONG:
- if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK
+ if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK
+ && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK)
|| valueWide < 0 || (Tcl_WideUInt) valueWide > ULONG_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return (char *) "variable must have unsigned long value";
}
- linkPtr->lastValue.ul = (unsigned long)valueWide;
- LinkedVar(unsigned long) = linkPtr->lastValue.ul;
+ LinkedVar(unsigned long) = linkPtr->lastValue.ul = (unsigned long)valueWide;
break;
+#endif
case TCL_LINK_WIDE_UINT:
/*
* FIXME: represent as a bignum.
*/
- if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK) {
+ if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK
+ && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return (char *) "variable must have unsigned wide int value";
}
- linkPtr->lastValue.uw = (Tcl_WideUInt)valueWide;
- LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw;
+ LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw = (Tcl_WideUInt)valueWide;
break;
case TCL_LINK_FLOAT:
- if (Tcl_GetDoubleFromObj(interp, valueObj, &valueDouble) != TCL_OK
+ if ((Tcl_GetDoubleFromObj(NULL, valueObj, &valueDouble) != TCL_OK
+ && GetInvalidDoubleFromObj(valueObj, &valueDouble) != TCL_OK)
|| valueDouble < -FLT_MAX || valueDouble > FLT_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return (char *) "variable must have float value";
}
- linkPtr->lastValue.f = (float)valueDouble;
- LinkedVar(float) = linkPtr->lastValue.f;
+ LinkedVar(float) = linkPtr->lastValue.f = (float)valueDouble;
break;
case TCL_LINK_STRING:
- value = TclGetStringFromObj(valueObj, &valueLength);
- valueLength++;
+ value = TclGetString(valueObj);
+ valueLength = valueObj->length + 1;
pp = (char **) linkPtr->addr;
*pp = ckrealloc(*pp, valueLength);
- memcpy(*pp, value, (unsigned) valueLength);
+ memcpy(*pp, value, valueLength);
break;
default:
@@ -577,7 +595,7 @@ ObjValue(
return Tcl_NewDoubleObj(linkPtr->lastValue.d);
case TCL_LINK_BOOLEAN:
linkPtr->lastValue.i = LinkedVar(int);
- return Tcl_NewBooleanObj(linkPtr->lastValue.i != 0);
+ return Tcl_NewBooleanObj(linkPtr->lastValue.i);
case TCL_LINK_CHAR:
linkPtr->lastValue.c = LinkedVar(char);
return Tcl_NewIntObj(linkPtr->lastValue.c);
@@ -593,12 +611,14 @@ ObjValue(
case TCL_LINK_UINT:
linkPtr->lastValue.ui = LinkedVar(unsigned int);
return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ui);
+#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__)
case TCL_LINK_LONG:
linkPtr->lastValue.l = LinkedVar(long);
return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.l);
case TCL_LINK_ULONG:
linkPtr->lastValue.ul = LinkedVar(unsigned long);
return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ul);
+#endif
case TCL_LINK_FLOAT:
linkPtr->lastValue.f = LinkedVar(float);
return Tcl_NewDoubleObj(linkPtr->lastValue.f);
@@ -626,6 +646,108 @@ ObjValue(
return resultObj;
}
}
+
+static int SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
+
+static Tcl_ObjType invalidRealType = {
+ "invalidReal", /* name */
+ NULL, /* freeIntRepProc */
+ NULL, /* dupIntRepProc */
+ NULL, /* updateStringProc */
+ SetInvalidRealFromAny /* setFromAnyProc */
+};
+
+static int
+SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr) {
+ const char *str;
+ const char *endPtr;
+
+ str = TclGetString(objPtr);
+ if ((objPtr->length == 1) && (str[0] == '.')){
+ objPtr->typePtr = &invalidRealType;
+ objPtr->internalRep.doubleValue = 0.0;
+ return TCL_OK;
+ }
+ if (TclParseNumber(NULL, objPtr, NULL, str, objPtr->length, &endPtr,
+ TCL_PARSE_DECIMAL_ONLY) == TCL_OK) {
+ /* If number is followed by [eE][+-]?, then it is an invalid
+ * double, but it could be the start of a valid double. */
+ if (*endPtr == 'e' || *endPtr == 'E') {
+ ++endPtr;
+ if (*endPtr == '+' || *endPtr == '-') ++endPtr;
+ if (*endPtr == 0) {
+ double doubleValue = 0.0;
+ Tcl_GetDoubleFromObj(NULL, objPtr, &doubleValue);
+ TclFreeIntRep(objPtr);
+ objPtr->typePtr = &invalidRealType;
+ objPtr->internalRep.doubleValue = doubleValue;
+ return TCL_OK;
+ }
+ }
+ }
+ return TCL_ERROR;
+}
+
+
+/*
+ * This function checks for integer representations, which are valid
+ * when linking with C variables, but which are invalid in other
+ * contexts in Tcl. Handled are "+", "-", "", "0x", "0b" and "0o"
+ * (upperand lowercase). See bug [39f6304c2e].
+ */
+int
+GetInvalidIntFromObj(Tcl_Obj *objPtr, int *intPtr)
+{
+ const char *str = TclGetString(objPtr);
+
+ if ((objPtr->length == 0) ||
+ ((objPtr->length == 2) && (str[0] == '0') && strchr("xXbBoO", str[1]))) {
+ *intPtr = 0;
+ return TCL_OK;
+ } else if ((objPtr->length == 1) && strchr("+-", str[0])) {
+ *intPtr = (str[0] == '+');
+ return TCL_OK;
+ }
+ return TCL_ERROR;
+}
+
+int
+GetInvalidWideFromObj(Tcl_Obj *objPtr, Tcl_WideInt *widePtr)
+{
+ int intValue;
+
+ if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ *widePtr = intValue;
+ return TCL_OK;
+}
+
+/*
+ * This function checks for double representations, which are valid
+ * when linking with C variables, but which are invalid in other
+ * contexts in Tcl. Handled are "+", "-", "", ".", "0x", "0b" and "0o"
+ * (upper- and lowercase) and sequences like "1e-". See bug [39f6304c2e].
+ */
+int
+GetInvalidDoubleFromObj(Tcl_Obj *objPtr, double *doublePtr)
+{
+ int intValue;
+
+ if (objPtr->typePtr == &invalidRealType) {
+ goto gotdouble;
+ }
+ if (GetInvalidIntFromObj(objPtr, &intValue) == TCL_OK) {
+ *doublePtr = (double) intValue;
+ return TCL_OK;
+ }
+ if (SetInvalidRealFromAny(NULL, objPtr) == TCL_OK) {
+ gotdouble:
+ *doublePtr = objPtr->internalRep.doubleValue;
+ return TCL_OK;
+ }
+ return TCL_ERROR;
+}
/*
* Local Variables:
diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index 14b8a14..11374cc 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -374,7 +374,7 @@ Tcl_SetListObj(
listRepPtr = NewListIntRep(objc, objv, 1);
ListSetIntRep(objPtr, listRepPtr);
} else {
- objPtr->bytes = tclEmptyStringRep;
+ objPtr->bytes = &tclEmptyString;
objPtr->length = 0;
}
}
@@ -465,7 +465,7 @@ Tcl_ListObjGetElements(
if (listPtr->typePtr != &tclListType) {
int result;
- if (listPtr->bytes == tclEmptyStringRep) {
+ if (listPtr->bytes == &tclEmptyString) {
*objcPtr = 0;
*objvPtr = NULL;
return TCL_OK;
@@ -575,7 +575,7 @@ Tcl_ListObjAppendElement(
if (listPtr->typePtr != &tclListType) {
int result;
- if (listPtr->bytes == tclEmptyStringRep) {
+ if (listPtr->bytes == &tclEmptyString) {
Tcl_SetListObj(listPtr, 1, &objPtr);
return TCL_OK;
}
@@ -739,7 +739,7 @@ Tcl_ListObjIndex(
if (listPtr->typePtr != &tclListType) {
int result;
- if (listPtr->bytes == tclEmptyStringRep) {
+ if (listPtr->bytes == &tclEmptyString) {
*objPtrPtr = NULL;
return TCL_OK;
}
@@ -792,7 +792,7 @@ Tcl_ListObjLength(
if (listPtr->typePtr != &tclListType) {
int result;
- if (listPtr->bytes == tclEmptyStringRep) {
+ if (listPtr->bytes == &tclEmptyString) {
*intPtr = 0;
return TCL_OK;
}
@@ -863,7 +863,7 @@ Tcl_ListObjReplace(
Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace");
}
if (listPtr->typePtr != &tclListType) {
- if (listPtr->bytes == tclEmptyStringRep) {
+ if (listPtr->bytes == &tclEmptyString) {
if (!objc) {
return TCL_OK;
}
@@ -897,18 +897,18 @@ Tcl_ListObjReplace(
}
if (count < 0) {
count = 0;
- } else if (numElems < first+count || first+count < 0) {
- /*
- * The 'first+count < 0' condition here guards agains integer
- * overflow in determining 'first+count'.
- */
+ } else if (first > INT_MAX - count /* Handle integer overflow */
+ || numElems < first+count) {
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));
+ if (interp != NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "max length of a Tcl list (%d elements) exceeded",
+ LIST_MAX));
+ }
return TCL_ERROR;
}
isShared = (listRepPtr->refCount > 1);
@@ -1650,7 +1650,7 @@ TclListObjSetElement(
if (listPtr->typePtr != &tclListType) {
int result;
- if (listPtr->bytes == tclEmptyStringRep) {
+ if (listPtr->bytes == &tclEmptyString) {
if (interp != NULL) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("list index out of range", -1));
@@ -1898,7 +1898,7 @@ SetListFromAny(
while (--elemPtrs >= &listRepPtr->elements) {
Tcl_DecrRefCount(*elemPtrs);
}
- ckfree((char *) listRepPtr);
+ ckfree(listRepPtr);
return TCL_ERROR;
}
if (elemStart == limit) {
@@ -1979,7 +1979,7 @@ UpdateStringOfList(
*/
if (numElems == 0) {
- listPtr->bytes = tclEmptyStringRep;
+ listPtr->bytes = &tclEmptyString;
listPtr->length = 0;
return;
}
diff --git a/generic/tclLoad.c b/generic/tclLoad.c
index 7c70e03..bcda420 100644
--- a/generic/tclLoad.c
+++ b/generic/tclLoad.c
@@ -998,7 +998,7 @@ Tcl_StaticPackage(
}
/*
- * Package isn't loade in the current interp yet. Mark it as now being
+ * Package isn't loaded in the current interp yet. Mark it as now being
* loaded.
*/
@@ -1012,10 +1012,10 @@ Tcl_StaticPackage(
/*
*----------------------------------------------------------------------
*
- * TclGetLoadedPackages --
+ * TclGetLoadedPackages, TclGetLoadedPackagesEx --
*
* This function returns information about all of the files that are
- * loaded (either in a particular intepreter, or for all interpreters).
+ * loaded (either in a particular interpreter, or for all interpreters).
*
* Results:
* The return value is a standard Tcl completion code. If successful, a
@@ -1039,16 +1039,27 @@ TclGetLoadedPackages(
* otherwise, just return info about this
* interpreter. */
{
+ return TclGetLoadedPackagesEx(interp, targetName, NULL);
+}
+
+int
+TclGetLoadedPackagesEx(
+ Tcl_Interp *interp, /* Interpreter in which to return information
+ * or error message. */
+ const char *targetName, /* Name of target interpreter or NULL. If
+ * NULL, return info about all interps;
+ * otherwise, just return info about this
+ * interpreter. */
+ const char *packageName) /* Package name or NULL. If NULL, return info
+ * for all packages.
+ */
+{
Tcl_Interp *target;
LoadedPackage *pkgPtr;
InterpPackage *ipPtr;
Tcl_Obj *resultObj, *pkgDesc[2];
if (targetName == NULL) {
- /*
- * Return information about all of the available packages.
- */
-
resultObj = Tcl_NewObj();
Tcl_MutexLock(&packageMutex);
for (pkgPtr = firstPackagePtr; pkgPtr != NULL;
@@ -1063,16 +1074,38 @@ TclGetLoadedPackages(
return TCL_OK;
}
- /*
- * Return information about only the packages that are loaded in a given
- * interpreter.
- */
-
target = Tcl_GetSlave(interp, targetName);
if (target == NULL) {
return TCL_ERROR;
}
ipPtr = Tcl_GetAssocData(target, "tclLoad", NULL);
+
+ /*
+ * Return information about all of the available packages.
+ */
+ if (packageName) {
+ resultObj = NULL;
+
+ for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
+ pkgPtr = ipPtr->pkgPtr;
+
+ if (!strcmp(packageName, pkgPtr->packageName)) {
+ resultObj = Tcl_NewStringObj(pkgPtr->fileName, -1);
+ break;
+ }
+ }
+
+ if (resultObj) {
+ Tcl_SetObjResult(interp, resultObj);
+ }
+ return TCL_OK;
+ }
+
+ /*
+ * Return information about only the packages that are loaded in a given
+ * interpreter.
+ */
+
resultObj = Tcl_NewObj();
for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
pkgPtr = ipPtr->pkgPtr;
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 7f6ecf5..e1bad0e 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -31,8 +31,8 @@
* limited to a single interpreter.
*/
-typedef struct ThreadSpecificData {
- long numNsCreated; /* Count of the number of namespaces created
+typedef struct {
+ size_t numNsCreated; /* Count of the number of namespaces created
* within the thread. This value is used as a
* unique id for each namespace. Cannot be
* per-interp because the nsId is used to
@@ -59,7 +59,7 @@ typedef struct ResolvedNsName {
* the name was resolved. NULL if the name is
* fully qualified and thus the resolution
* does not depend on the context. */
- int refCount; /* Reference count: 1 for each nsName object
+ size_t refCount; /* Reference count: 1 for each nsName object
* that has a pointer to this ResolvedNsName
* structure as its internal rep. This
* structure can be freed when refCount
@@ -1326,8 +1326,7 @@ void
TclNsDecrRefCount(
Namespace *nsPtr)
{
- nsPtr->refCount--;
- if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) {
+ if ((nsPtr->refCount-- <= 1) && (nsPtr->flags & NS_DEAD)) {
NamespaceFree(nsPtr);
}
}
@@ -4671,8 +4670,7 @@ FreeNsNameInternalRep(
* references, free it up.
*/
- resNamePtr->refCount--;
- if (resNamePtr->refCount == 0) {
+ if (resNamePtr->refCount-- <= 1) {
/*
* Decrement the reference count for the cached namespace. If the
* namespace is dead, and there are no more references to it, free
diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c
index 1797760..ac0b94d 100644
--- a/generic/tclOOCall.c
+++ b/generic/tclOOCall.c
@@ -179,6 +179,7 @@ StashCallChain(
CallChain *callPtr)
{
callPtr->refCount++;
+ TclGetString(objPtr);
TclFreeIntRep(objPtr);
objPtr->typePtr = &methodNameType;
objPtr->internalRep.twoPtrValue.ptr1 = callPtr;
@@ -618,6 +619,7 @@ AddClassMethodNames(
int isWanted = (!(flags & PUBLIC_METHOD)
|| (mPtr->flags & PUBLIC_METHOD)) ? IN_LIST : 0;
+ isWanted |= (mPtr->typePtr == NULL ? NO_IMPLEMENTATION : 0);
Tcl_SetHashValue(hPtr, INT2PTR(isWanted));
} else if ((PTR2INT(Tcl_GetHashValue(hPtr)) & NO_IMPLEMENTATION)
&& mPtr->typePtr != NULL) {
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index 8c3f28c..5b0dfc3 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -2217,7 +2217,7 @@ ClassSuperSet(
"attempt to form circular dependency graph", -1));
Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", NULL);
failedAfterAlloc:
- ckfree((char *) superclasses);
+ ckfree(superclasses);
return TCL_ERROR;
}
}
@@ -2234,7 +2234,7 @@ ClassSuperSet(
FOREACH(superPtr, oPtr->classPtr->superclasses) {
TclOORemoveFromSubclasses(oPtr->classPtr, superPtr);
}
- ckfree((char *) oPtr->classPtr->superclasses.list);
+ ckfree(oPtr->classPtr->superclasses.list);
}
oPtr->classPtr->superclasses.list = superclasses;
oPtr->classPtr->superclasses.num = superc;
@@ -2323,7 +2323,7 @@ ClassVarsSet(
}
for (i=0 ; i<varc ; i++) {
- const char *varName = Tcl_GetString(varv[i]);
+ const char *varName = TclGetString(varv[i]);
if (strstr(varName, "::") != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
@@ -2349,7 +2349,7 @@ ClassVarsSet(
}
if (i != varc) {
if (varc == 0) {
- ckfree((char *) oPtr->classPtr->variables.list);
+ ckfree(oPtr->classPtr->variables.list);
} else if (i) {
oPtr->classPtr->variables.list = (Tcl_Obj **)
ckrealloc((char *) oPtr->classPtr->variables.list,
@@ -2604,7 +2604,7 @@ ObjVarsSet(
}
for (i=0 ; i<varc ; i++) {
- const char *varName = Tcl_GetString(varv[i]);
+ const char *varName = TclGetString(varv[i]);
if (strstr(varName, "::") != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
@@ -2630,7 +2630,7 @@ ObjVarsSet(
}
if (i != varc) {
if (varc == 0) {
- ckfree((char *) oPtr->variables.list);
+ ckfree(oPtr->variables.list);
} else if (i) {
oPtr->variables.list = (Tcl_Obj **)
ckrealloc((char *) oPtr->variables.list,
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index b75ffdb..ae24dee 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -592,7 +592,7 @@ MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr);
#define AddRef(ptr) ((ptr)->refCount++)
#define DelRef(ptr) do { \
if ((ptr)->refCount-- <= 1) { \
- ckfree((char *) (ptr)); \
+ ckfree(ptr); \
} \
} while(0)
diff --git a/generic/tclObj.c b/generic/tclObj.c
index d3f59ec..f4b81f2 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -49,7 +49,6 @@ Tcl_Mutex tclObjMutex;
*/
char tclEmptyString = '\0';
-char *tclEmptyStringRep = &tclEmptyString;
#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS)
/*
@@ -76,7 +75,7 @@ typedef struct ObjData {
* The structure defined below is used in this file only.
*/
-typedef struct ThreadSpecificData {
+typedef struct {
Tcl_HashTable *lineCLPtr; /* This table remembers for each Tcl_Obj
* generated by a call to the function
* TclSubstTokens() from a literal text
@@ -345,23 +344,23 @@ typedef struct ResolvedCmdName {
* reference (not the namespace that contains
* the referenced command). NULL if the name
* is fully qualified.*/
- long refNsId; /* refNsPtr's unique namespace id. Used to
+ size_t refNsId; /* refNsPtr's unique namespace id. Used to
* verify that refNsPtr is still valid (e.g.,
* it's possible that the cmd's containing
* namespace was deleted and a new one created
* at the same address). */
- int refNsCmdEpoch; /* Value of the referencing namespace's
+ size_t refNsCmdEpoch; /* Value of the referencing namespace's
* cmdRefEpoch when the pointer was cached.
* Before using the cached pointer, we check
* if the namespace's epoch was incremented;
* if so, this cached pointer is invalid. */
- int cmdEpoch; /* Value of the command's cmdEpoch when this
+ size_t cmdEpoch; /* Value of the command's cmdEpoch when this
* pointer was cached. Before using the cached
* pointer, we check if the cmd's epoch was
* incremented; if so, the cmd was renamed,
* deleted, hidden, or exposed, and so the
* pointer is invalid. */
- int refCount; /* Reference count: 1 for each cmdName object
+ size_t refCount; /* Reference count: 1 for each cmdName object
* that has a pointer to this ResolvedCmdName
* structure as its internal rep. This
* structure can be freed when refCount
@@ -1060,7 +1059,7 @@ TclDbInitNewObj(
* debugging. */
{
objPtr->refCount = 0;
- objPtr->bytes = tclEmptyStringRep;
+ objPtr->bytes = &tclEmptyString;
objPtr->length = 0;
objPtr->typePtr = NULL;
@@ -1733,7 +1732,7 @@ Tcl_InvalidateStringRep(
* is coerced to 1.
*
* When TCL_MEM_DEBUG is defined, this function just returns the result
- * of calling the debugging version Tcl_DbNewBooleanObj.
+ * of calling the debugging version Tcl_DbNewLongObj.
*
* Results:
* The newly created object is returned. This object will have an invalid
@@ -1752,7 +1751,7 @@ Tcl_Obj *
Tcl_NewBooleanObj(
register int boolValue) /* Boolean used to initialize new object. */
{
- return Tcl_DbNewBooleanObj(boolValue, "unknown", 0);
+ return Tcl_DbNewLongObj(boolValue!=0, "unknown", 0);
}
#else /* if not TCL_MEM_DEBUG */
@@ -1763,7 +1762,7 @@ Tcl_NewBooleanObj(
{
register Tcl_Obj *objPtr;
- TclNewBooleanObj(objPtr, boolValue);
+ TclNewLongObj(objPtr, boolValue!=0);
return objPtr;
}
#endif /* TCL_MEM_DEBUG */
@@ -1794,6 +1793,7 @@ Tcl_NewBooleanObj(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_DbNewBooleanObj
#ifdef TCL_MEM_DEBUG
@@ -1810,7 +1810,7 @@ Tcl_DbNewBooleanObj(
TclDbNewObj(objPtr, file, line);
objPtr->bytes = NULL;
- objPtr->internalRep.longValue = (boolValue? 1 : 0);
+ objPtr->internalRep.longValue = (boolValue != 0);
objPtr->typePtr = &tclIntType;
return objPtr;
}
@@ -1857,8 +1857,9 @@ Tcl_SetBooleanObj(
Tcl_Panic("%s called with shared object", "Tcl_SetBooleanObj");
}
- TclSetBooleanObj(objPtr, boolValue);
+ TclSetLongObj(objPtr, boolValue!=0);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -2004,9 +2005,10 @@ static int
ParseBoolean(
register Tcl_Obj *objPtr) /* The object to parse/convert. */
{
- int i, length, newBool;
+ int newBool;
char lowerCase[6];
- const char *str = TclGetStringFromObj(objPtr, &length);
+ const char *str = TclGetString(objPtr);
+ size_t i, length = objPtr->length;
if ((length == 0) || (length > 5)) {
/*
@@ -2058,25 +2060,25 @@ ParseBoolean(
/*
* Checking the 'y' is redundant, but makes the code clearer.
*/
- if (strncmp(lowerCase, "yes", (size_t) length) == 0) {
+ if (strncmp(lowerCase, "yes", length) == 0) {
newBool = 1;
goto goodBoolean;
}
return TCL_ERROR;
case 'n':
- if (strncmp(lowerCase, "no", (size_t) length) == 0) {
+ if (strncmp(lowerCase, "no", length) == 0) {
newBool = 0;
goto goodBoolean;
}
return TCL_ERROR;
case 't':
- if (strncmp(lowerCase, "true", (size_t) length) == 0) {
+ if (strncmp(lowerCase, "true", length) == 0) {
newBool = 1;
goto goodBoolean;
}
return TCL_ERROR;
case 'f':
- if (strncmp(lowerCase, "false", (size_t) length) == 0) {
+ if (strncmp(lowerCase, "false", length) == 0) {
newBool = 0;
goto goodBoolean;
}
@@ -2085,10 +2087,10 @@ ParseBoolean(
if (length < 2) {
return TCL_ERROR;
}
- if (strncmp(lowerCase, "on", (size_t) length) == 0) {
+ if (strncmp(lowerCase, "on", length) == 0) {
newBool = 1;
goto goodBoolean;
- } else if (strncmp(lowerCase, "off", (size_t) length) == 0) {
+ } else if (strncmp(lowerCase, "off", length) == 0) {
newBool = 0;
goto goodBoolean;
}
@@ -2425,7 +2427,7 @@ Tcl_NewIntObj(
{
register Tcl_Obj *objPtr;
- TclNewIntObj(objPtr, intValue);
+ TclNewLongObj(objPtr, intValue);
return objPtr;
}
#endif /* if TCL_MEM_DEBUG */
@@ -2458,7 +2460,7 @@ Tcl_SetIntObj(
Tcl_Panic("%s called with shared object", "Tcl_SetIntObj");
}
- TclSetIntObj(objPtr, intValue);
+ TclSetLongObj(objPtr, intValue);
}
/*
@@ -2784,7 +2786,7 @@ Tcl_GetLongFromObj(
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected integer but got \"%s\"",
- Tcl_GetString(objPtr)));
+ TclGetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL);
}
return TCL_ERROR;
@@ -3085,7 +3087,7 @@ Tcl_GetWideIntFromObj(
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected integer but got \"%s\"",
- Tcl_GetString(objPtr)));
+ TclGetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL);
}
return TCL_ERROR;
@@ -3252,13 +3254,11 @@ UpdateStringOfBignum(
if (status != MP_OKAY) {
Tcl_Panic("radix size failure in UpdateStringOfBignum");
}
- if (size == 3) {
+ if (size < 2) {
/*
- * mp_radix_size() returns 3 when more than INT_MAX bytes would be
+ * mp_radix_size() returns < 2 when more than INT_MAX bytes would be
* needed to hold the string rep (because mp_radix_size ignores
- * integer overflow issues). When we know the string rep will be more
- * than 3, we can conclude the string rep would overflow our string
- * length limits.
+ * integer overflow issues).
*
* Note that so long as we enforce our bignums to the size that fits
* in a packed bignum, this branch will never be taken.
@@ -3396,7 +3396,7 @@ GetBignumFromObj(
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = NULL;
if (objPtr->bytes == NULL) {
- TclInitStringRep(objPtr, tclEmptyStringRep, 0);
+ TclInitStringRep(objPtr, &tclEmptyString, 0);
}
}
return TCL_OK;
@@ -3416,7 +3416,7 @@ GetBignumFromObj(
if (interp != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected integer but got \"%s\"",
- Tcl_GetString(objPtr)));
+ TclGetString(objPtr)));
Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL);
}
return TCL_ERROR;
@@ -3966,7 +3966,7 @@ TclCompareObjKeys(
Tcl_Obj *objPtr1 = keyPtr;
Tcl_Obj *objPtr2 = (Tcl_Obj *) hPtr->key.oneWordValue;
register const char *p1, *p2;
- register int l1, l2;
+ register size_t l1, l2;
/*
* If the object pointers are the same then they match.
@@ -4309,7 +4309,7 @@ FreeCmdNameInternalRep(
* there are no more uses, free the ResolvedCmdName structure.
*/
- if (resPtr->refCount-- == 1) {
+ if (resPtr->refCount-- <= 1) {
/*
* Now free the cached command, unless it is still in its hash
* table or if there are other references to it from other cmdName
@@ -4421,7 +4421,7 @@ SetCmdNameFromAny(
Command *oldCmdPtr = resPtr->cmdPtr;
- if (--oldCmdPtr->refCount == 0) {
+ if (oldCmdPtr->refCount-- <= 1) {
TclCleanupCommandMacro(oldCmdPtr);
}
} else {
@@ -4455,7 +4455,6 @@ Tcl_RepresentationCmd(
int objc,
Tcl_Obj *const objv[])
{
- char ptrBuffer[2*TCL_INTEGER_SPACE+6];
Tcl_Obj *descObj;
if (objc != 2) {
@@ -4469,18 +4468,20 @@ Tcl_RepresentationCmd(
* "1872361827361287"
*/
- sprintf(ptrBuffer, "%p", (void *) objv[1]);
descObj = Tcl_ObjPrintf("value is a %s with a refcount of %d,"
- " object pointer at %s",
- objv[1]->typePtr ? objv[1]->typePtr->name : "pure string",
- objv[1]->refCount, ptrBuffer);
+ " object pointer at %p",
+ objv[1]->typePtr ? objv[1]->typePtr->name : "pure string",
+ objv[1]->refCount, objv[1]);
if (objv[1]->typePtr) {
- sprintf(ptrBuffer, "%p:%p",
- (void *) objv[1]->internalRep.twoPtrValue.ptr1,
- (void *) objv[1]->internalRep.twoPtrValue.ptr2);
- Tcl_AppendPrintfToObj(descObj, ", internal representation %s",
- ptrBuffer);
+ if (objv[1]->typePtr == &tclDoubleType) {
+ Tcl_AppendPrintfToObj(descObj, ", internal representation %g",
+ objv[1]->internalRep.doubleValue);
+ } else {
+ Tcl_AppendPrintfToObj(descObj, ", internal representation %p:%p",
+ (void *) objv[1]->internalRep.twoPtrValue.ptr1,
+ (void *) objv[1]->internalRep.twoPtrValue.ptr2);
+ }
}
if (objv[1]->bytes) {
diff --git a/generic/tclParse.c b/generic/tclParse.c
index 3a04df4..8a28bf2 100644
--- a/generic/tclParse.c
+++ b/generic/tclParse.c
@@ -1169,6 +1169,8 @@ ParseTokens(
numBytes--;
nestedPtr = TclStackAlloc(parsePtr->interp, sizeof(Tcl_Parse));
while (1) {
+ const char *curEnd;
+
if (Tcl_ParseCommand(parsePtr->interp, src, numBytes, 1,
nestedPtr) != TCL_OK) {
parsePtr->errorType = nestedPtr->errorType;
@@ -1177,8 +1179,9 @@ ParseTokens(
TclStackFree(parsePtr->interp, nestedPtr);
return TCL_ERROR;
}
+ curEnd = src + numBytes;
src = nestedPtr->commandStart + nestedPtr->commandSize;
- numBytes = parsePtr->end - src;
+ numBytes = curEnd - src;
Tcl_FreeParse(nestedPtr);
/*
diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c
index 68ec2c4..0053041 100644
--- a/generic/tclPathObj.c
+++ b/generic/tclPathObj.c
@@ -2608,7 +2608,7 @@ UpdateStringOfFsPath(
pathPtr->bytes = TclGetStringFromObj(copy, &cwdLen);
pathPtr->length = cwdLen;
- copy->bytes = tclEmptyStringRep;
+ copy->bytes = &tclEmptyString;
copy->length = 0;
TclDecrRefCount(copy);
}
diff --git a/generic/tclPipe.c b/generic/tclPipe.c
index 83fb818..d6cd188 100644
--- a/generic/tclPipe.c
+++ b/generic/tclPipe.c
@@ -60,7 +60,7 @@ static TclFile FileForRedirect(Tcl_Interp *interp, const char *spec,
static TclFile
FileForRedirect(
- Tcl_Interp *interp, /* Intepreter to use for error reporting. */
+ Tcl_Interp *interp, /* Interpreter to use for error reporting. */
const char *spec, /* Points to character just after redirection
* character. */
int atOK, /* Non-zero means that '@' notation can be
diff --git a/generic/tclPkg.c b/generic/tclPkg.c
index 244eb94..9ad3cb7 100644
--- a/generic/tclPkg.c
+++ b/generic/tclPkg.c
@@ -17,6 +17,10 @@
#include "tclInt.h"
+MODULE_SCOPE char *tclEmptyStringRep;
+
+char *tclEmptyStringRep = &tclEmptyString;
+
/*
* Each invocation of the "package ifneeded" command creates a structure of
* the following type, which is used to load the package into the interpreter
@@ -28,10 +32,22 @@ typedef struct PkgAvail {
char *script; /* Script to invoke to provide this version of
* the package. Malloc'ed and protected by
* Tcl_Preserve and Tcl_Release. */
+ char *pkgIndex; /* Full file name of pkgIndex file */
struct PkgAvail *nextPtr; /* Next in list of available versions of the
* same package. */
} PkgAvail;
+typedef struct PkgName {
+ struct PkgName *nextPtr; /* Next in list of package names being initialized. */
+ char name[1];
+} PkgName;
+
+typedef struct PkgFiles {
+ PkgName *names; /* Package names being initialized. Must be first field*/
+ Tcl_HashTable table; /* Table which contains files for each package */
+} PkgFiles;
+
+
/*
* For each package that is known in any way to an interpreter, there is one
* record of the following type. These records are stored in the
@@ -81,7 +97,7 @@ static const char * PkgRequireCore(Tcl_Interp *interp, const char *name,
((v) = ckalloc(len), memcpy((v),(s),(len)))
#define DupString(v,s) \
do { \
- unsigned local__len = (unsigned) (strlen(s) + 1); \
+ size_t local__len = strlen(s) + 1; \
DupBlock((v),(s),local__len); \
} while (0)
@@ -189,6 +205,62 @@ Tcl_PkgProvideEx(
*----------------------------------------------------------------------
*/
+static void PkgFilesCleanupProc(ClientData clientData,
+ Tcl_Interp *interp)
+{
+ PkgFiles *pkgFiles = (PkgFiles *) clientData;
+ Tcl_HashSearch search;
+ Tcl_HashEntry *entry;
+
+ while (pkgFiles->names) {
+ PkgName *name = pkgFiles->names;
+ pkgFiles->names = name->nextPtr;
+ ckfree(name);
+ }
+ entry = Tcl_FirstHashEntry(&pkgFiles->table, &search);
+ while (entry) {
+ Tcl_Obj *obj = (Tcl_Obj *)Tcl_GetHashValue(entry);
+ Tcl_DecrRefCount(obj);
+ entry = Tcl_NextHashEntry(&search);
+ }
+ Tcl_DeleteHashTable(&pkgFiles->table);
+ return;
+}
+
+void *TclInitPkgFiles(Tcl_Interp *interp)
+{
+ /* If assocdata "tclPkgFiles" doesn't exist yet, create it */
+ PkgFiles *pkgFiles = Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
+ if (!pkgFiles) {
+ pkgFiles = ckalloc(sizeof(PkgFiles));
+ pkgFiles->names = NULL;
+ Tcl_InitHashTable(&pkgFiles->table, TCL_STRING_KEYS);
+ Tcl_SetAssocData(interp, "tclPkgFiles", PkgFilesCleanupProc, pkgFiles);
+ }
+ return pkgFiles;
+}
+
+void TclPkgFileSeen(Tcl_Interp *interp, const char *fileName)
+{
+ PkgFiles *pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
+ if (pkgFiles && pkgFiles->names) {
+ const char *name = pkgFiles->names->name;
+ Tcl_HashTable *table = &pkgFiles->table;
+ int new;
+ Tcl_HashEntry *entry = Tcl_CreateHashEntry(table, name, &new);
+ Tcl_Obj *list;
+
+ if (new) {
+ list = Tcl_NewObj();
+ Tcl_SetHashValue(entry, list);
+ Tcl_IncrRefCount(list);
+ } else {
+ list = Tcl_GetHashValue(entry);
+ }
+ Tcl_ListObjAppendElement(interp, list, Tcl_NewStringObj(fileName, -1));
+ }
+}
+
#undef Tcl_PkgRequire
const char *
Tcl_PkgRequire(
@@ -489,12 +561,26 @@ PkgRequireCore(
*/
char *versionToProvide = bestPtr->version;
+ PkgFiles *pkgFiles;
+ PkgName *pkgName;
script = bestPtr->script;
pkgPtr->clientData = versionToProvide;
- Tcl_Preserve(script);
Tcl_Preserve(versionToProvide);
+ Tcl_Preserve(script);
+ pkgFiles = TclInitPkgFiles(interp);
+ /* Push "ifneeded" package name in "tclPkgFiles" assocdata. */
+ pkgName = ckalloc(sizeof(PkgName) + strlen(name));
+ pkgName->nextPtr = pkgFiles->names;
+ strcpy(pkgName->name, name);
+ pkgFiles->names = pkgName;
+ if (bestPtr->pkgIndex) {
+ TclPkgFileSeen(interp, bestPtr->pkgIndex);
+ }
code = Tcl_EvalEx(interp, script, -1, TCL_EVAL_GLOBAL);
+ /* Pop the "ifneeded" package name from "tclPkgFiles" assocdata*/
+ pkgFiles->names = pkgName->nextPtr;
+ ckfree(pkgName);
Tcl_Release(script);
pkgPtr = FindPackage(interp, name);
@@ -764,14 +850,14 @@ Tcl_PackageObjCmd(
Tcl_Obj *const objv[]) /* Argument objects. */
{
static const char *const pkgOptions[] = {
- "forget", "ifneeded", "names", "prefer", "present",
- "provide", "require", "unknown", "vcompare", "versions",
- "vsatisfies", NULL
+ "files", "forget", "ifneeded", "names", "prefer",
+ "present", "provide", "require", "unknown", "vcompare",
+ "versions", "vsatisfies", NULL
};
enum pkgOptions {
- PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, PKG_PREFER, PKG_PRESENT,
- PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE, PKG_VERSIONS,
- PKG_VSATISFIES
+ PKG_FILES, PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, PKG_PREFER,
+ PKG_PRESENT, PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE,
+ PKG_VERSIONS, PKG_VSATISFIES
};
Interp *iPtr = (Interp *) interp;
int optionIndex, exact, i, satisfies;
@@ -794,11 +880,37 @@ Tcl_PackageObjCmd(
return TCL_ERROR;
}
switch ((enum pkgOptions) optionIndex) {
+ case PKG_FILES: {
+ PkgFiles *pkgFiles;
+
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "package");
+ return TCL_ERROR;
+ }
+ pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
+ if (pkgFiles) {
+ Tcl_HashEntry *entry = Tcl_FindHashEntry(&pkgFiles->table, Tcl_GetString(objv[2]));
+ if (entry) {
+ Tcl_SetObjResult(interp, (Tcl_Obj *)Tcl_GetHashValue(entry));
+ }
+ }
+ break;
+ }
case PKG_FORGET: {
const char *keyString;
+ PkgFiles *pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL);
for (i = 2; i < objc; i++) {
keyString = TclGetString(objv[i]);
+ if (pkgFiles) {
+ hPtr = Tcl_FindHashEntry(&pkgFiles->table, keyString);
+ if (hPtr) {
+ Tcl_Obj *obj = Tcl_GetHashValue(hPtr);
+ Tcl_DeleteHashEntry(hPtr);
+ Tcl_DecrRefCount(obj);
+ }
+ }
+
hPtr = Tcl_FindHashEntry(&iPtr->packageTable, keyString);
if (hPtr == NULL) {
continue;
@@ -813,6 +925,9 @@ Tcl_PackageObjCmd(
pkgPtr->availPtr = availPtr->nextPtr;
Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC);
Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
+ if (availPtr->pkgIndex) {
+ Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC);
+ }
ckfree(availPtr);
}
ckfree(pkgPtr);
@@ -863,6 +978,9 @@ Tcl_PackageObjCmd(
return TCL_OK;
}
Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
+ if (availPtr->pkgIndex) {
+ Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC);
+ }
break;
}
}
@@ -873,6 +991,7 @@ Tcl_PackageObjCmd(
}
if (availPtr == NULL) {
availPtr = ckalloc(sizeof(PkgAvail));
+ availPtr->pkgIndex = 0;
DupBlock(availPtr->version, argv3, (unsigned) length + 1);
if (prevPtr == NULL) {
@@ -883,6 +1002,10 @@ Tcl_PackageObjCmd(
prevPtr->nextPtr = availPtr;
}
}
+ if (iPtr->scriptFile) {
+ argv4 = TclGetStringFromObj(iPtr->scriptFile, &length);
+ DupBlock(availPtr->pkgIndex, argv4, (unsigned) length + 1);
+ }
argv4 = TclGetStringFromObj(objv[4], &length);
DupBlock(availPtr->script, argv4, (unsigned) length + 1);
break;
@@ -1220,7 +1343,7 @@ FindPackage(
void
TclFreePackageInfo(
- Interp *iPtr) /* Interpereter that is being deleted. */
+ Interp *iPtr) /* Interpreter that is being deleted. */
{
Package *pkgPtr;
Tcl_HashSearch search;
@@ -1238,6 +1361,9 @@ TclFreePackageInfo(
pkgPtr->availPtr = availPtr->nextPtr;
Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC);
Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
+ if (availPtr->pkgIndex) {
+ Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC);
+ }
ckfree(availPtr);
}
ckfree(pkgPtr);
diff --git a/generic/tclPreserve.c b/generic/tclPreserve.c
index cca13e8..5c6097f 100644
--- a/generic/tclPreserve.c
+++ b/generic/tclPreserve.c
@@ -22,7 +22,7 @@
typedef struct {
ClientData clientData; /* Address of preserved block. */
- int refCount; /* Number of Tcl_Preserve calls in effect for
+ size_t refCount; /* Number of Tcl_Preserve calls in effect for
* block. */
int mustFree; /* Non-zero means Tcl_EventuallyFree was
* called while a Tcl_Preserve call was in
@@ -63,7 +63,7 @@ typedef struct HandleStruct {
* ensure that the contents of the handle are
* not changed by anyone else. */
#endif
- int refCount; /* Number of TclHandlePreserve() calls in
+ size_t refCount; /* Number of TclHandlePreserve() calls in
* effect on this handle. */
} HandleStruct;
@@ -155,7 +155,7 @@ Tcl_Preserve(
refPtr->clientData = clientData;
refPtr->refCount = 1;
refPtr->mustFree = 0;
- refPtr->freeProc = TCL_STATIC;
+ refPtr->freeProc = 0;
inUse += 1;
Tcl_MutexUnlock(&preserveMutex);
}
@@ -195,7 +195,7 @@ Tcl_Release(
continue;
}
- if (--refPtr->refCount != 0) {
+ if (refPtr->refCount-- > 1) {
Tcl_MutexUnlock(&preserveMutex);
return;
}
@@ -459,7 +459,7 @@ TclHandleRelease(
handlePtr, handlePtr->ptr2, handlePtr->ptr);
}
#endif
- if ((--handlePtr->refCount == 0) && (handlePtr->ptr == NULL)) {
+ if ((handlePtr->refCount-- <= 1) && (handlePtr->ptr == NULL)) {
ckfree(handlePtr);
}
}
diff --git a/generic/tclProc.c b/generic/tclProc.c
index bed520a..373192c 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -500,7 +500,8 @@ TclCreateProc(
}
for (i = 0; i < numArgs; i++) {
- int fieldCount, nameLength, valueLength;
+ int fieldCount, nameLength;
+ size_t valueLength;
const char **fieldValues;
/*
@@ -602,12 +603,11 @@ TclCreateProc(
*/
if (localPtr->defValuePtr != NULL) {
- int tmpLength;
- const char *tmpPtr = TclGetStringFromObj(localPtr->defValuePtr,
- &tmpLength);
+ const char *tmpPtr = TclGetString(localPtr->defValuePtr);
+ size_t tmpLength = localPtr->defValuePtr->length;
if ((valueLength != tmpLength) ||
- strncmp(fieldValues[1], tmpPtr, (size_t) tmpLength)) {
+ strncmp(fieldValues[1], tmpPtr, tmpLength)) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"procedure \"%s\": formal parameter \"%s\" has "
"default value inconsistent with precompiled body",
diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c
index ea25d4b..5f8dc20 100644
--- a/generic/tclRegexp.c
+++ b/generic/tclRegexp.c
@@ -64,7 +64,7 @@
#define NUM_REGEXPS 30
-typedef struct ThreadSpecificData {
+typedef struct {
int initialized; /* Set to 1 when the module is initialized. */
char *patterns[NUM_REGEXPS];/* Strings corresponding to compiled regular
* expression patterns. NULL means that this
@@ -502,9 +502,16 @@ Tcl_RegExpMatchObj(
{
Tcl_RegExp re;
- re = Tcl_GetRegExpFromObj(interp, patternObj,
- TCL_REG_ADVANCED | TCL_REG_NOSUB);
- if (re == NULL) {
+ /*
+ * For performance reasons, first try compiling the RE without support for
+ * subexpressions. On failure, try again without TCL_REG_NOSUB in case the
+ * RE has backreferences in it. Closely related to [Bug 1366683]. If this
+ * still fails, an error message will be left in the interpreter.
+ */
+
+ if (!(re = Tcl_GetRegExpFromObj(interp, patternObj,
+ TCL_REG_ADVANCED | TCL_REG_NOSUB))
+ && !(re = Tcl_GetRegExpFromObj(interp, patternObj, TCL_REG_ADVANCED))) {
return -1;
}
return Tcl_RegExpExecObj(interp, re, textObj, 0 /* offset */,
@@ -672,7 +679,7 @@ TclRegAbout(
resultObj = Tcl_NewObj();
Tcl_ListObjAppendElement(NULL, resultObj,
- Tcl_NewIntObj((int) regexpPtr->re.re_nsub));
+ Tcl_NewWideIntObj((Tcl_WideInt) regexpPtr->re.re_nsub));
/*
* Now append a list of all the bit-flags set for the RE.
diff --git a/generic/tclRegexp.h b/generic/tclRegexp.h
index 3b2433e..eac0aaa 100644
--- a/generic/tclRegexp.h
+++ b/generic/tclRegexp.h
@@ -37,7 +37,7 @@ typedef struct TclRegexp {
* of subexpressions. */
rm_detail_t details; /* Detailed information on match (currently
* used only for REG_EXPECT). */
- int refCount; /* Count of number of references to this
+ unsigned int refCount; /* Count of number of references to this
* compiled regexp. */
} TclRegexp;
diff --git a/generic/tclResult.c b/generic/tclResult.c
index 9d0714c..57a6de5 100644
--- a/generic/tclResult.c
+++ b/generic/tclResult.c
@@ -27,7 +27,9 @@ enum returnKeys {
static Tcl_Obj ** GetKeys(void);
static void ReleaseKeys(ClientData clientData);
static void ResetObjResult(Interp *iPtr);
+#ifndef TCL_NO_DEPRECATED
static void SetupAppendBuffer(Interp *iPtr, int newSpace);
+#endif /* !TCL_NO_DEPRECATED */
/*
* This structure is used to take a snapshot of the interpreter state in
@@ -35,7 +37,7 @@ static void SetupAppendBuffer(Interp *iPtr, int newSpace);
* then back up to the result or the error that was previously in progress.
*/
-typedef struct InterpState {
+typedef struct {
int status; /* return code status */
int flags; /* Each remaining field saves the */
int returnLevel; /* corresponding field of the Interp */
@@ -230,6 +232,7 @@ Tcl_DiscardInterpState(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_SaveResult
void
Tcl_SaveResult(
@@ -461,6 +464,7 @@ Tcl_SetResult(
ResetObjResult(iPtr);
}
+#endif /* !TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -483,18 +487,21 @@ const char *
Tcl_GetStringResult(
register Tcl_Interp *interp)/* Interpreter whose result to return. */
{
+ Interp *iPtr = (Interp *) interp;
+#ifdef TCL_NO_DEPRECATED
+ return Tcl_GetString(iPtr->objResultPtr);
+#else
/*
* If the string result is empty, move the object result to the string
* result, then reset the object result.
*/
- Interp *iPtr = (Interp *) interp;
-
if (*(iPtr->result) == 0) {
Tcl_SetResult(interp, TclGetString(Tcl_GetObjResult(interp)),
TCL_VOLATILE);
}
return iPtr->result;
+#endif
}
/*
@@ -536,6 +543,7 @@ Tcl_SetObjResult(
TclDecrRefCount(oldObjResult);
+#ifndef TCL_NO_DEPRECATED
/*
* Reset the string result since we just set the result object.
*/
@@ -550,6 +558,7 @@ Tcl_SetObjResult(
}
iPtr->result = iPtr->resultSpace;
iPtr->resultSpace[0] = 0;
+#endif
}
/*
@@ -578,6 +587,7 @@ Tcl_GetObjResult(
Tcl_Interp *interp) /* Interpreter whose result to return. */
{
register Interp *iPtr = (Interp *) interp;
+#ifndef TCL_NO_DEPRECATED
Tcl_Obj *objResultPtr;
int length;
@@ -604,6 +614,7 @@ Tcl_GetObjResult(
iPtr->result = iPtr->resultSpace;
iPtr->result[0] = 0;
}
+#endif /* !TCL_NO_DEPRECATED */
return iPtr->objResultPtr;
}
@@ -722,6 +733,21 @@ Tcl_AppendElement(
* to result. */
{
Interp *iPtr = (Interp *) interp;
+#ifdef TCL_NO_DEPRECATED
+ Tcl_Obj *elementPtr = Tcl_NewStringObj(element, -1);
+ Tcl_Obj *listPtr = Tcl_NewListObj(1, &elementPtr);
+ const char *bytes;
+
+ if (Tcl_IsShared(iPtr->objResultPtr)) {
+ Tcl_SetObjResult(interp, Tcl_DuplicateObj(iPtr->objResultPtr));
+ }
+ bytes = TclGetString(iPtr->objResultPtr);
+ if (TclNeedSpace(bytes, bytes+iPtr->objResultPtr->length)) {
+ Tcl_AppendToObj(iPtr->objResultPtr, " ", 1);
+ }
+ Tcl_AppendObjToObj(iPtr->objResultPtr, listPtr);
+ Tcl_DecrRefCount(listPtr);
+#else
char *dst;
int size;
int flags;
@@ -765,6 +791,7 @@ Tcl_AppendElement(
flags |= TCL_DONT_QUOTE_HASH;
}
iPtr->appendUsed += Tcl_ConvertElement(element, dst, flags);
+#endif /* !TCL_NO_DEPRECATED */
}
/*
@@ -786,6 +813,7 @@ Tcl_AppendElement(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
static void
SetupAppendBuffer(
Interp *iPtr, /* Interpreter whose result is being set up. */
@@ -846,6 +874,7 @@ SetupAppendBuffer(
Tcl_FreeResult((Tcl_Interp *) iPtr);
iPtr->result = iPtr->appendResult;
}
+#endif /* !TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -875,6 +904,7 @@ Tcl_FreeResult(
{
register Interp *iPtr = (Interp *) interp;
+#ifndef TCL_NO_DEPRECATED
if (iPtr->freeProc != NULL) {
if (iPtr->freeProc == TCL_DYNAMIC) {
ckfree(iPtr->result);
@@ -884,6 +914,7 @@ Tcl_FreeResult(
iPtr->freeProc = 0;
}
+#endif /* !TCL_NO_DEPRECATED */
ResetObjResult(iPtr);
}
@@ -913,6 +944,7 @@ Tcl_ResetResult(
register Interp *iPtr = (Interp *) interp;
ResetObjResult(iPtr);
+#ifndef TCL_NO_DEPRECATED
if (iPtr->freeProc != NULL) {
if (iPtr->freeProc == TCL_DYNAMIC) {
ckfree(iPtr->result);
@@ -923,6 +955,7 @@ Tcl_ResetResult(
}
iPtr->result = iPtr->resultSpace;
iPtr->resultSpace[0] = 0;
+#endif /* !TCL_NO_DEPRECATED */
if (iPtr->errorCode) {
/* Legacy support */
if (iPtr->flags & ERR_LEGACY_COPY) {
@@ -982,11 +1015,11 @@ ResetObjResult(
Tcl_IncrRefCount(objResultPtr);
iPtr->objResultPtr = objResultPtr;
} else {
- if (objResultPtr->bytes != tclEmptyStringRep) {
+ if (objResultPtr->bytes != &tclEmptyString) {
if (objResultPtr->bytes) {
ckfree(objResultPtr->bytes);
}
- objResultPtr->bytes = tclEmptyStringRep;
+ objResultPtr->bytes = &tclEmptyString;
objResultPtr->length = 0;
}
TclFreeIntRep(objResultPtr);
@@ -1276,10 +1309,8 @@ TclProcessReturn(
Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO],
&valuePtr);
if (valuePtr != NULL) {
- int infoLen;
-
- (void) TclGetStringFromObj(valuePtr, &infoLen);
- if (infoLen) {
+ (void) TclGetString(valuePtr);
+ if (valuePtr->length) {
iPtr->errorInfo = valuePtr;
Tcl_IncrRefCount(iPtr->errorInfo);
iPtr->flags |= ERR_ALREADY_LOGGED;
@@ -1382,13 +1413,11 @@ TclMergeReturnOptions(
Tcl_Obj **keys = GetKeys();
for (; objc > 1; objv += 2, objc -= 2) {
- int optLen;
- const char *opt = TclGetStringFromObj(objv[0], &optLen);
- int compareLen;
- const char *compare =
- TclGetStringFromObj(keys[KEY_OPTIONS], &compareLen);
+ const char *opt = TclGetString(objv[0]);
+ const char *compare = TclGetString(keys[KEY_OPTIONS]);
- if ((optLen == compareLen) && (memcmp(opt, compare, optLen) == 0)) {
+ if ((objv[0]->length == keys[KEY_OPTIONS]->length)
+ && (memcmp(opt, compare, objv[0]->length) == 0)) {
Tcl_DictSearch search;
int done = 0;
Tcl_Obj *keyPtr;
diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c
index f69f6b9..c7fdc5a 100644
--- a/generic/tclStrToD.c
+++ b/generic/tclStrToD.c
@@ -18,13 +18,6 @@
#include <math.h>
/*
- * Define KILL_OCTAL to suppress interpretation of numbers with leading zero
- * as octal. (Ceterum censeo: numeros octonarios delendos esse.)
- */
-
-#undef KILL_OCTAL
-
-/*
* This code supports (at least hypothetically), IBM, Cray, VAX and IEEE-754
* floating point; of these, only IEEE-754 can represent NaN. IEEE-754 can be
* uniquely determined by radix and by the widths of significand and exponent.
@@ -396,6 +389,9 @@ static Tcl_WideUInt Nokia770Twiddle(Tcl_WideUInt w);
* - TCL_PARSE_SCAN_PREFIXES: ignore the prefixes 0b and 0o that are
* not part of the [scan] command's vocabulary. Use only in
* combination with TCL_PARSE_INTEGER_ONLY.
+ * - TCL_PARSE_BINARY_ONLY: parse only in the binary format, whether
+ * or not a prefix is present that would lead to binary parsing.
+ * Use only in combination with TCL_PARSE_INTEGER_ONLY.
* - TCL_PARSE_OCTAL_ONLY: parse only in the octal format, whether
* or not a prefix is present that would lead to octal parsing.
* Use only in combination with TCL_PARSE_INTEGER_ONLY.
@@ -543,6 +539,20 @@ TclParseNumber(
*/
if (bytes == NULL) {
+ if (interp == NULL && endPtrPtr == NULL) {
+ if (objPtr->typePtr == &tclDictType) {
+ /* A dict can never be a (single) number */
+ return TCL_ERROR;
+ }
+ if (objPtr->typePtr == &tclListType) {
+ int length;
+ /* A list can only be a (single) number if its length == 1 */
+ TclListObjLength(NULL, objPtr, &length);
+ if (length != 1) {
+ return TCL_ERROR;
+ }
+ }
+ }
bytes = TclGetString(objPtr);
}
@@ -627,6 +637,9 @@ TclParseNumber(
acceptPoint = p;
acceptLen = len;
if (c == 'x' || c == 'X') {
+ if (flags & (TCL_PARSE_OCTAL_ONLY|TCL_PARSE_BINARY_ONLY)) {
+ goto endgame;
+ }
state = ZERO_X;
break;
}
@@ -637,6 +650,9 @@ TclParseNumber(
goto zeroo;
}
if (c == 'b' || c == 'B') {
+ if (flags & TCL_PARSE_OCTAL_ONLY) {
+ goto endgame;
+ }
state = ZERO_B;
break;
}
@@ -648,7 +664,7 @@ TclParseNumber(
state = ZERO_O;
break;
}
-#ifdef KILL_OCTAL
+#ifdef TCL_NO_DEPRECATED
goto decimal;
#endif
/* FALLTHROUGH */
@@ -731,7 +747,7 @@ TclParseNumber(
goto endgame;
}
-#ifndef KILL_OCTAL
+#ifndef TCL_NO_DEPRECATED
/*
* Scanned a number with a leading zero that contains an 8, 9,
@@ -870,7 +886,7 @@ TclParseNumber(
* digits.
*/
-#ifdef KILL_OCTAL
+#ifdef TCL_NO_DEPRECATED
decimal:
#endif
acceptState = state;
@@ -3789,7 +3805,7 @@ ShorteningBignumConversion(
--s5;
/*
- * IDEA: It might possibly be a win to fall back to int64
+ * IDEA: It might possibly be a win to fall back to int64_t
* arithmetic here if S < 2**64/10. But it's a win only for
* a fairly narrow range of magnitudes so perhaps not worth
* bothering. We already know that we shorten the
@@ -3954,7 +3970,7 @@ StrictBignumConversion(
* As with the shortening bignum conversion, it's possible at this
* point that we will have reduced the denominator to less than
* 2**64/10, at which point it would be possible to fall back to
- * to int64 arithmetic. But the potential payoff is tremendously
+ * to int64_t arithmetic. But the potential payoff is tremendously
* less - unless we're working in F format - because we know that
* three groups of digits will always suffice for %#.17e, the
* longest format that doesn't introduce empty precision.
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index e3cede6..7c898b7 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -136,7 +136,7 @@ GrowStringBuffer(
char *ptr = NULL;
int attempt;
- if (objPtr->bytes == tclEmptyStringRep) {
+ if (objPtr->bytes == &tclEmptyString) {
objPtr->bytes = NULL;
}
if (flag == 0 || stringPtr->allocated > 0) {
@@ -409,6 +409,15 @@ Tcl_GetCharLength(
int numChars;
/*
+ * Quick, no-shimmer return for short string reps.
+ */
+
+ if ((objPtr->bytes) && (objPtr->length < 2)) {
+ /* 0 bytes -> 0 chars; 1 byte -> 1 char */
+ return objPtr->length;
+ }
+
+ /*
* Optimize the case where we're really dealing with a bytearray object
* without string representation; we don't need to convert to a string to
* perform the get-length operation.
@@ -758,7 +767,7 @@ Tcl_SetObjLength(
/*
* Need to enlarge the buffer.
*/
- if (objPtr->bytes == tclEmptyStringRep) {
+ if (objPtr->bytes == &tclEmptyString) {
objPtr->bytes = ckalloc(length + 1);
} else {
objPtr->bytes = ckrealloc(objPtr->bytes, length + 1);
@@ -864,7 +873,7 @@ Tcl_AttemptSetObjLength(
char *newBytes;
- if (objPtr->bytes == tclEmptyStringRep) {
+ if (objPtr->bytes == &tclEmptyString) {
newBytes = attemptckalloc(length + 1);
} else {
newBytes = attemptckrealloc(objPtr->bytes, length + 1);
@@ -1173,6 +1182,8 @@ Tcl_AppendUnicodeToObj(
* Side effects:
* The string rep of appendObjPtr is appended to the string
* representation of objPtr.
+ * IMPORTANT: This routine does not and MUST NOT shimmer appendObjPtr.
+ * Callers are counting on that.
*
*----------------------------------------------------------------------
*/
@@ -1191,7 +1202,7 @@ Tcl_AppendObjToObj(
* that appending nothing to anything leaves that starting anything...
*/
- if (appendObjPtr->bytes == tclEmptyStringRep) {
+ if (appendObjPtr->bytes == &tclEmptyString) {
return;
}
@@ -1202,7 +1213,7 @@ Tcl_AppendObjToObj(
* information; this is a special-case optimization only.
*/
- if ((TclIsPureByteArray(objPtr) || objPtr->bytes == tclEmptyStringRep)
+ if ((TclIsPureByteArray(objPtr) || objPtr->bytes == &tclEmptyString)
&& TclIsPureByteArray(appendObjPtr)) {
/*
@@ -1659,8 +1670,11 @@ Tcl_AppendFormatToObj(
while (*format != '\0') {
char *end;
- int gotMinus, gotHash, gotZero, gotSpace, gotPlus, sawFlag;
- int width, gotPrecision, precision, useShort, useWide, useBig;
+ int gotMinus = 0, gotHash = 0, gotZero = 0, gotSpace = 0, gotPlus = 0;
+ int width, gotPrecision, precision, sawFlag, useShort = 0, useBig = 0;
+#ifndef TCL_WIDE_INT_IS_LONG
+ int useWide = 0;
+#endif
int newXpg, numChars, allocSegment = 0, segmentLimit, segmentNumBytes;
Tcl_Obj *segment;
Tcl_UniChar ch;
@@ -1736,7 +1750,6 @@ Tcl_AppendFormatToObj(
* Step 2. Set of flags.
*/
- gotMinus = gotHash = gotZero = gotSpace = gotPlus = 0;
sawFlag = 1;
do {
switch (ch) {
@@ -1837,7 +1850,6 @@ Tcl_AppendFormatToObj(
* Step 5. Length modifier.
*/
- useShort = useWide = useBig = 0;
if (ch == 'h') {
useShort = 1;
format += step;
@@ -1854,6 +1866,34 @@ Tcl_AppendFormatToObj(
useWide = 1;
#endif
}
+ } else if (ch == 'I') {
+ if ((format[1] == '6') && (format[2] == '4')) {
+ format += (step + 2);
+ step = Tcl_UtfToUniChar(format, &ch);
+#ifndef TCL_WIDE_INT_IS_LONG
+ useWide = 1;
+#endif
+ } else if ((format[1] == '3') && (format[2] == '2')) {
+ format += (step + 2);
+ step = Tcl_UtfToUniChar(format, &ch);
+ } else {
+ format += step;
+ step = Tcl_UtfToUniChar(format, &ch);
+ }
+ } else if ((ch == 't') || (ch == 'z')) {
+ format += step;
+ step = Tcl_UtfToUniChar(format, &ch);
+#ifndef TCL_WIDE_INT_IS_LONG
+ if (sizeof(size_t) > sizeof(int)) {
+ useWide = 1;
+ }
+#endif
+ } else if ((ch == 'q') ||(ch == 'j')) {
+ format += step;
+ step = Tcl_UtfToUniChar(format, &ch);
+#ifndef TCL_WIDE_INT_IS_LONG
+ useWide = 1;
+#endif
}
format += step;
@@ -1906,6 +1946,7 @@ Tcl_AppendFormatToObj(
}
case 'd':
case 'o':
+ case 'p':
case 'x':
case 'X':
case 'b': {
@@ -1916,11 +1957,17 @@ Tcl_AppendFormatToObj(
mp_int big;
int toAppend, isNegative = 0;
+#ifndef TCL_WIDE_INT_IS_LONG
+ if (ch == 'p') {
+ useWide = 1;
+ }
+#endif
if (useBig) {
if (Tcl_GetBignumFromObj(interp, segment, &big) != TCL_OK) {
goto error;
}
isNegative = (mp_cmp_d(&big, 0) == MP_LT);
+#ifndef TCL_WIDE_INT_IS_LONG
} else if (useWide) {
if (Tcl_GetWideIntFromObj(NULL, segment, &w) != TCL_OK) {
Tcl_Obj *objPtr;
@@ -1935,6 +1982,7 @@ Tcl_AppendFormatToObj(
Tcl_DecrRefCount(objPtr);
}
isNegative = (w < (Tcl_WideInt) 0);
+#endif
} else if (TclGetLongFromObj(NULL, segment, &l) != TCL_OK) {
if (Tcl_GetWideIntFromObj(NULL, segment, &w) != TCL_OK) {
Tcl_Obj *objPtr;
@@ -1974,13 +2022,14 @@ Tcl_AppendFormatToObj(
segmentLimit -= 1;
}
- if (gotHash) {
+ if (gotHash || (ch == 'p')) {
switch (ch) {
case 'o':
Tcl_AppendToObj(segment, "0", 1);
segmentLimit -= 1;
precision--;
break;
+ case 'p':
case 'x':
case 'X':
Tcl_AppendToObj(segment, "0x", 2);
@@ -2001,8 +2050,10 @@ Tcl_AppendFormatToObj(
if (useShort) {
pure = Tcl_NewIntObj((int) s);
+#ifndef TCL_WIDE_INT_IS_LONG
} else if (useWide) {
pure = Tcl_NewWideIntObj(w);
+#endif
} else if (useBig) {
pure = Tcl_NewBignumObj(&big);
} else {
@@ -2059,6 +2110,7 @@ Tcl_AppendFormatToObj(
case 'u':
case 'o':
+ case 'p':
case 'x':
case 'X':
case 'b': {
@@ -2085,6 +2137,7 @@ Tcl_AppendFormatToObj(
numDigits++;
us /= base;
}
+#ifndef TCL_WIDE_INT_IS_LONG
} else if (useWide) {
Tcl_WideUInt uw = (Tcl_WideUInt) w;
@@ -2093,6 +2146,7 @@ Tcl_AppendFormatToObj(
numDigits++;
uw /= base;
}
+#endif
} else if (useBig && big.used) {
int leftover = (big.used * DIGIT_BIT) % numBits;
mp_digit mask = (~(mp_digit)0) << (DIGIT_BIT-leftover);
@@ -2448,6 +2502,7 @@ AppendPrintfToObjVA(
case 'u':
case 'd':
case 'o':
+ case 'p':
case 'x':
case 'X':
seekingConversion = 0;
@@ -2461,6 +2516,10 @@ AppendPrintfToObjVA(
Tcl_ListObjAppendElement(NULL, list, Tcl_NewLongObj(
va_arg(argList, long)));
break;
+ case 2:
+ Tcl_ListObjAppendElement(NULL, list, Tcl_NewWideIntObj(
+ va_arg(argList, Tcl_WideInt)));
+ break;
}
break;
case 'e':
@@ -2489,9 +2548,32 @@ AppendPrintfToObjVA(
gotPrecision = 1;
p++;
break;
- /* TODO: support for wide (and bignum?) arguments */
+ /* TODO: support for bignum arguments */
case 'l':
- size = 1;
+ ++size;
+ p++;
+ break;
+ case 't':
+ case 'z':
+ if (sizeof(size_t) == sizeof(Tcl_WideInt)) {
+ size = 2;
+ }
+ p++;
+ break;
+ case 'j':
+ case 'q':
+ size = 2;
+ p++;
+ break;
+ case 'I':
+ if (p[1]=='6' && p[2]=='4') {
+ p += 2;
+ size = 2;
+ } else if (p[1]=='3' && p[2]=='2') {
+ p += 2;
+ } else if (sizeof(size_t) == sizeof(Tcl_WideInt)) {
+ size = 2;
+ }
p++;
break;
case 'h':
@@ -2598,6 +2680,616 @@ TclGetStringStorage(
*sizePtr = stringPtr->allocated;
return objPtr->bytes;
}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclStringRepeat --
+ *
+ * Performs the [string repeat] function.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Writes to *objPtrPtr the address of Tcl_Obj that is concatenation
+ * of count copies of the value in objPtr.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+TclStringRepeat(
+ Tcl_Interp *interp,
+ Tcl_Obj *objPtr,
+ int count,
+ Tcl_Obj **objPtrPtr)
+{
+ Tcl_Obj *objResultPtr;
+ int length = 0, unichar = 0, done = 1;
+ int binary = TclIsPureByteArray(objPtr);
+
+ /* assert (count >= 2) */
+
+ /*
+ * Analyze to determine what representation result should be.
+ * GOALS: Avoid shimmering & string rep generation.
+ * Produce pure bytearray when possible.
+ * Error on overflow.
+ */
+
+ if (!binary) {
+ if (objPtr->typePtr == &tclStringType) {
+ String *stringPtr = GET_STRING(objPtr);
+ if (stringPtr->hasUnicode) {
+ unichar = 1;
+ }
+ }
+ }
+
+ if (binary) {
+ /* Result will be pure byte array. Pre-size it */
+ Tcl_GetByteArrayFromObj(objPtr, &length);
+ } else if (unichar) {
+ /* Result will be pure Tcl_UniChar array. Pre-size it. */
+ Tcl_GetUnicodeFromObj(objPtr, &length);
+ } else {
+ /* Result will be concat of string reps. Pre-size it. */
+ Tcl_GetStringFromObj(objPtr, &length);
+ }
+
+ if (length == 0) {
+ /* Any repeats of empty is empty. */
+ *objPtrPtr = objPtr;
+ return TCL_OK;
+ }
+
+ if (count > INT_MAX/length) {
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "max size for a Tcl value (%d bytes) exceeded", INT_MAX));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ }
+ return TCL_ERROR;
+ }
+
+ if (binary) {
+ /* Efficiently produce a pure byte array result */
+ objResultPtr = Tcl_IsShared(objPtr) ? Tcl_DuplicateObj(objPtr)
+ : objPtr;
+
+ Tcl_SetByteArrayLength(objResultPtr, count*length); /* PANIC? */
+ Tcl_SetByteArrayLength(objResultPtr, length);
+ while (count - done > done) {
+ Tcl_AppendObjToObj(objResultPtr, objResultPtr);
+ done *= 2;
+ }
+ TclAppendBytesToByteArray(objResultPtr,
+ Tcl_GetByteArrayFromObj(objResultPtr, NULL),
+ (count - done) * length);
+ } else if (unichar) {
+ /* Efficiently produce a pure Tcl_UniChar array result */
+ if (Tcl_IsShared(objPtr)) {
+ objResultPtr = Tcl_NewUnicodeObj(Tcl_GetUnicode(objPtr), length);
+ } else {
+ TclInvalidateStringRep(objPtr);
+ objResultPtr = objPtr;
+ }
+
+ if (0 == Tcl_AttemptSetObjLength(objResultPtr, count*length)) {
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "string size overflow: unable to alloc %"
+ TCL_LL_MODIFIER "d bytes",
+ (Tcl_WideUInt)STRING_SIZE(count*length)));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ }
+ return TCL_ERROR;
+ }
+ Tcl_SetObjLength(objResultPtr, length);
+ while (count - done > done) {
+ Tcl_AppendObjToObj(objResultPtr, objResultPtr);
+ done *= 2;
+ }
+ Tcl_AppendUnicodeToObj(objResultPtr, Tcl_GetUnicode(objResultPtr),
+ (count - done) * length);
+ } else {
+ /* Efficiently concatenate string reps */
+ if (Tcl_IsShared(objPtr)) {
+ objResultPtr = Tcl_NewStringObj(Tcl_GetString(objPtr), length);
+ } else {
+ TclFreeIntRep(objPtr);
+ objResultPtr = objPtr;
+ }
+ if (0 == Tcl_AttemptSetObjLength(objResultPtr, count*length)) {
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "string size overflow: unable to alloc %u bytes",
+ count*length));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ }
+ return TCL_ERROR;
+ }
+ Tcl_SetObjLength(objResultPtr, length);
+ while (count - done > done) {
+ Tcl_AppendObjToObj(objResultPtr, objResultPtr);
+ done *= 2;
+ }
+ Tcl_AppendToObj(objResultPtr, Tcl_GetString(objResultPtr),
+ (count - done) * length);
+ }
+ *objPtrPtr = objResultPtr;
+ return TCL_OK;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclStringCatObjv --
+ *
+ * Performs the [string cat] function.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * Writes to *objPtrPtr the address of Tcl_Obj that is concatenation
+ * of all objc values in objv.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+TclStringCatObjv(
+ Tcl_Interp *interp,
+ int inPlace,
+ int objc,
+ Tcl_Obj * const objv[],
+ Tcl_Obj **objPtrPtr)
+{
+ Tcl_Obj *objPtr, *objResultPtr, * const *ov;
+ int oc, length = 0, binary = 1, first = 0;
+ int allowUniChar = 1, requestUniChar = 0;
+
+ /* assert (objc >= 2) */
+
+ /*
+ * Analyze to determine what representation result should be.
+ * GOALS: Avoid shimmering & string rep generation.
+ * Produce pure bytearray when possible.
+ * Error on overflow.
+ */
+
+ ov = objv, oc = objc;
+ while (oc-- && (binary || allowUniChar)) {
+ objPtr = *ov++;
+
+ if (objPtr->bytes) {
+ /* Value has a string rep. */
+ if (objPtr->length) {
+ /*
+ * Non-empty string rep. Not a pure bytearray, so we
+ * won't create a pure bytearray
+ */
+ binary = 0;
+ if ((objPtr->typePtr) && (objPtr->typePtr != &tclStringType)) {
+ /* Prevent shimmer of non-string types. */
+ allowUniChar = 0;
+ }
+ }
+ } else {
+ /* assert (objPtr->typePtr != NULL) -- stork! */
+ if (TclIsPureByteArray(objPtr)) {
+ allowUniChar = 0;
+ } else {
+ binary = 0;
+ if (objPtr->typePtr == &tclStringType) {
+ /* Have a pure Unicode value; ask to preserve it */
+ requestUniChar = 1;
+ } else {
+ /* Have another type; prevent shimmer */
+ allowUniChar = 0;
+ }
+ }
+ }
+ }
+
+ if (binary) {
+ /* Result will be pure byte array. Pre-size it */
+ ov = objv; oc = objc;
+ while (oc-- && (length >= 0)) {
+ objPtr = *ov++;
+
+ if (objPtr->bytes == NULL) {
+ int numBytes;
+
+ Tcl_GetByteArrayFromObj(objPtr, &numBytes); /* PANIC? */
+ if (length == 0) {
+ first = objc - oc - 1;
+ }
+ length += numBytes;
+ }
+ }
+ } else if (allowUniChar && requestUniChar) {
+ /* Result will be pure Tcl_UniChar array. Pre-size it. */
+ ov = objv; oc = objc;
+ while (oc-- && (length >= 0)) {
+ objPtr = *ov++;
+
+ if ((objPtr->bytes == NULL) || (objPtr->length)) {
+ int numChars;
+
+ Tcl_GetUnicodeFromObj(objPtr, &numChars); /* PANIC? */
+ if (length == 0) {
+ first = objc - oc - 1;
+ }
+ length += numChars;
+ }
+ }
+ } else {
+ /* Result will be concat of string reps. Pre-size it. */
+ ov = objv; oc = objc;
+ while (oc-- && (length >= 0)) {
+ int numBytes;
+
+ objPtr = *ov++;
+
+ Tcl_GetStringFromObj(objPtr, &numBytes); /* PANIC? */
+ if ((length == 0) && numBytes) {
+ first = objc - oc - 1;
+ }
+ length += numBytes;
+ }
+ }
+
+ if (length < 0) {
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "max size for a Tcl value (%d bytes) exceeded", INT_MAX));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ }
+ return TCL_ERROR;
+ }
+
+ if (length == 0) {
+ /* Total length of zero means every value has length zero */
+ *objPtrPtr = objv[0];
+ return TCL_OK;
+ }
+
+ objv += first; objc -= first;
+
+ if (binary) {
+ /* Efficiently produce a pure byte array result */
+ unsigned char *dst;
+
+ /*
+ * Broken interface! Byte array value routines offer no way
+ * to handle failure to allocate enough space. Following
+ * stanza may panic.
+ */
+ if (inPlace && !Tcl_IsShared(*objv)) {
+ int start;
+
+ objResultPtr = *objv++; objc--;
+ Tcl_GetByteArrayFromObj(objResultPtr, &start);
+ dst = Tcl_SetByteArrayLength(objResultPtr, length) + start;
+ } else {
+ objResultPtr = Tcl_NewByteArrayObj(NULL, length);
+ dst = Tcl_SetByteArrayLength(objResultPtr, length);
+ }
+ while (objc--) {
+ Tcl_Obj *objPtr = *objv++;
+
+ if (objPtr->bytes == NULL) {
+ int more;
+ unsigned char *src = Tcl_GetByteArrayFromObj(objPtr, &more);
+ memcpy(dst, src, (size_t) more);
+ dst += more;
+ }
+ }
+ } else if (allowUniChar && requestUniChar) {
+ /* Efficiently produce a pure Tcl_UniChar array result */
+ Tcl_UniChar *dst;
+
+ if (inPlace && !Tcl_IsShared(*objv)) {
+ int start;
+
+ objResultPtr = *objv++; objc--;
+
+ /* Ugly interface! Force resize of the unicode array. */
+ Tcl_GetUnicodeFromObj(objResultPtr, &start);
+ Tcl_InvalidateStringRep(objResultPtr);
+ if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) {
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "concatenation failed: unable to alloc %"
+ TCL_LL_MODIFIER "d bytes",
+ (Tcl_WideUInt)STRING_SIZE(length)));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ }
+ return TCL_ERROR;
+ }
+ dst = Tcl_GetUnicode(objResultPtr) + start;
+ } else {
+ Tcl_UniChar ch = 0;
+
+ /* Ugly interface! No scheme to init array size. */
+ objResultPtr = Tcl_NewUnicodeObj(&ch, 0); /* PANIC? */
+ if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) {
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "concatenation failed: unable to alloc %"
+ TCL_LL_MODIFIER "d bytes",
+ (Tcl_WideUInt)STRING_SIZE(length)));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ }
+ return TCL_ERROR;
+ }
+ dst = Tcl_GetUnicode(objResultPtr);
+ }
+ while (objc--) {
+ Tcl_Obj *objPtr = *objv++;
+
+ if ((objPtr->bytes == NULL) || (objPtr->length)) {
+ int more;
+ Tcl_UniChar *src = Tcl_GetUnicodeFromObj(objPtr, &more);
+ memcpy(dst, src, more * sizeof(Tcl_UniChar));
+ dst += more;
+ }
+ }
+ } else {
+ /* Efficiently concatenate string reps */
+ char *dst;
+
+ if (inPlace && !Tcl_IsShared(*objv)) {
+ int start;
+
+ objResultPtr = *objv++; objc--;
+
+ Tcl_GetStringFromObj(objResultPtr, &start);
+ if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) {
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "concatenation failed: unable to alloc %u bytes",
+ length));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ }
+ return TCL_ERROR;
+ }
+ dst = Tcl_GetString(objResultPtr) + start;
+ if (length > start) {
+ TclFreeIntRep(objResultPtr);
+ }
+ } else {
+ objResultPtr = Tcl_NewObj(); /* PANIC? */
+ if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) {
+ if (interp) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "concatenation failed: unable to alloc %u bytes",
+ length));
+ Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
+ }
+ return TCL_ERROR;
+ }
+ dst = Tcl_GetString(objResultPtr);
+ }
+ while (objc--) {
+ Tcl_Obj *objPtr = *objv++;
+
+ if ((objPtr->bytes == NULL) || (objPtr->length)) {
+ int more;
+ char *src = Tcl_GetStringFromObj(objPtr, &more);
+ memcpy(dst, src, (size_t) more);
+ dst += more;
+ }
+ }
+ }
+ *objPtrPtr = objResultPtr;
+ return TCL_OK;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclStringFind --
+ *
+ * Implements the [string first] operation.
+ *
+ * Results:
+ * If needle is found as a substring of haystack, the index of the
+ * first instance of such a find is returned. If needle is not present
+ * as a substring of haystack, -1 is returned.
+ *
+ * Side effects:
+ * needle and haystack may have their Tcl_ObjType changed.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+TclStringFind(
+ Tcl_Obj *needle,
+ Tcl_Obj *haystack,
+ int start)
+{
+ int lh, ln = Tcl_GetCharLength(needle);
+
+ if (ln == 0) {
+ /*
+ * We don't find empty substrings. Bizarre!
+ *
+ * TODO: When we one day make this a true substring
+ * finder, change this to "return 0"
+ */
+ return -1;
+ }
+
+ if (TclIsPureByteArray(needle) && TclIsPureByteArray(haystack)) {
+ unsigned char *end, *try, *bh;
+ unsigned char *bn = Tcl_GetByteArrayFromObj(needle, &ln);
+
+ bh = Tcl_GetByteArrayFromObj(haystack, &lh);
+ end = bh + lh;
+
+ try = bh + start;
+ while (try + ln <= end) {
+ try = memchr(try, bn[0], end - try);
+
+ if (try == NULL) {
+ return -1;
+ }
+ if (0 == memcmp(try+1, bn+1, ln-1)) {
+ return (try - bh);
+ }
+ try++;
+ }
+ return -1;
+ }
+
+ lh = Tcl_GetCharLength(haystack);
+ if (haystack->bytes && (lh == haystack->length)) {
+ /* haystack is all single-byte chars */
+
+ if (needle->bytes && (ln == needle->length)) {
+ /* needle is also all single-byte chars */
+ char *found = strstr(haystack->bytes + start, needle->bytes);
+
+ if (found) {
+ return (found - haystack->bytes);
+ } else {
+ return -1;
+ }
+ } else {
+ /*
+ * Cannot find substring with a multi-byte char inside
+ * a string with no multi-byte chars.
+ */
+ return -1;
+ }
+ } else {
+ Tcl_UniChar *try, *end, *uh;
+ Tcl_UniChar *un = Tcl_GetUnicodeFromObj(needle, &ln);
+
+ uh = Tcl_GetUnicodeFromObj(haystack, &lh);
+ end = uh + lh;
+
+ try = uh + start;
+ while (try + ln <= end) {
+ if ((*try == *un)
+ && (0 == memcmp(try+1, un+1, (ln-1)*sizeof(Tcl_UniChar)))) {
+ return (try - uh);
+ }
+ try++;
+ }
+ return -1;
+ }
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclStringLast --
+ *
+ * Implements the [string last] operation.
+ *
+ * Results:
+ * If needle is found as a substring of haystack, the index of the
+ * last instance of such a find is returned. If needle is not present
+ * as a substring of haystack, -1 is returned.
+ *
+ * Side effects:
+ * needle and haystack may have their Tcl_ObjType changed.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+TclStringLast(
+ Tcl_Obj *needle,
+ Tcl_Obj *haystack,
+ int last)
+{
+ int lh, ln = Tcl_GetCharLength(needle);
+
+ if (ln == 0) {
+ /*
+ * We don't find empty substrings. Bizarre!
+ *
+ * TODO: When we one day make this a true substring
+ * finder, change this to "return 0"
+ */
+ return -1;
+ }
+
+ if (ln > last + 1) {
+ return -1;
+ }
+
+ if (TclIsPureByteArray(needle) && TclIsPureByteArray(haystack)) {
+ unsigned char *try, *bh;
+ unsigned char *bn = Tcl_GetByteArrayFromObj(needle, &ln);
+
+ bh = Tcl_GetByteArrayFromObj(haystack, &lh);
+
+ if (last + 1 > lh) {
+ last = lh - 1;
+ }
+ try = bh + last + 1 - ln;
+ while (try >= bh) {
+ if ((*try == bn[0])
+ && (0 == memcmp(try+1, bn+1, ln-1))) {
+ return (try - bh);
+ }
+ try--;
+ }
+ return -1;
+ }
+
+ lh = Tcl_GetCharLength(haystack);
+ if (last + 1 > lh) {
+ last = lh - 1;
+ }
+ if (haystack->bytes && (lh == haystack->length)) {
+ /* haystack is all single-byte chars */
+
+ if (needle->bytes && (ln == needle->length)) {
+ /* needle is also all single-byte chars */
+
+ char *try = haystack->bytes + last + 1 - ln;
+ while (try >= haystack->bytes) {
+ if ((*try == needle->bytes[0])
+ && (0 == memcmp(try+1, needle->bytes + 1, ln - 1))) {
+ return (try - haystack->bytes);
+ }
+ try--;
+ }
+ return -1;
+ } else {
+ /*
+ * Cannot find substring with a multi-byte char inside
+ * a string with no multi-byte chars.
+ */
+ return -1;
+ }
+ } else {
+ Tcl_UniChar *try, *uh;
+ Tcl_UniChar *un = Tcl_GetUnicodeFromObj(needle, &ln);
+
+ uh = Tcl_GetUnicodeFromObj(haystack, &lh);
+
+ try = uh + last + 1 - ln;
+ while (try >= uh) {
+ if ((*try == un[0])
+ && (0 == memcmp(try+1, un+1, (ln-1)*sizeof(Tcl_UniChar)))) {
+ return (try - uh);
+ }
+ try--;
+ }
+ return -1;
+ }
+}
+
/*
*---------------------------------------------------------------------------
*
@@ -2948,8 +3640,18 @@ UpdateStringOfString(
{
String *stringPtr = GET_STRING(objPtr);
+ /*
+ * This routine is only called when we need to generate the
+ * string rep objPtr->bytes because it does not exist -- it is NULL.
+ * In that circumstance, any lingering claim about the size of
+ * memory pointed to by that NULL pointer is clearly bogus, and
+ * needs a reset.
+ */
+
+ stringPtr->allocated = 0;
+
if (stringPtr->numChars == 0) {
- TclInitStringRep(objPtr, tclEmptyStringRep, 0);
+ TclInitStringRep(objPtr, &tclEmptyString, 0);
} else {
(void) ExtendStringRepWithUnicode(objPtr, stringPtr->unicode,
stringPtr->numChars);
diff --git a/generic/tclStringRep.h b/generic/tclStringRep.h
index db6f7e4..1ef1957 100644
--- a/generic/tclStringRep.h
+++ b/generic/tclStringRep.h
@@ -72,17 +72,17 @@ typedef struct {
do { \
if ((numChars) < 0 || (numChars) > STRING_MAXCHARS) { \
Tcl_Panic("max length for a Tcl unicode value (%d chars) exceeded", \
- STRING_MAXCHARS); \
+ (int)STRING_MAXCHARS); \
} \
} while (0)
#define stringAttemptAlloc(numChars) \
- (String *) attemptckalloc((unsigned) STRING_SIZE(numChars))
+ (String *) attemptckalloc(STRING_SIZE(numChars))
#define stringAlloc(numChars) \
- (String *) ckalloc((unsigned) STRING_SIZE(numChars))
+ (String *) ckalloc(STRING_SIZE(numChars))
#define stringRealloc(ptr, numChars) \
- (String *) ckrealloc((ptr), (unsigned) STRING_SIZE(numChars))
+ (String *) ckrealloc((ptr), STRING_SIZE(numChars))
#define stringAttemptRealloc(ptr, numChars) \
- (String *) attemptckrealloc((ptr), (unsigned) STRING_SIZE(numChars))
+ (String *) attemptckrealloc((ptr), STRING_SIZE(numChars))
#define GET_STRING(objPtr) \
((String *) (objPtr)->internalRep.twoPtrValue.ptr1)
#define SET_STRING(objPtr, stringPtr) \
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 5b7a1cd..59325b7 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -41,15 +41,15 @@
#undef Tcl_FindExecutable
#undef TclpGetPid
#undef TclSockMinimumBuffers
-#define TclBackgroundException Tcl_BackgroundException
#undef Tcl_SetIntObj
#undef TclpInetNtoa
#undef TclWinGetServByName
#undef TclWinGetSockOpt
#undef TclWinSetSockOpt
+#undef TclWinNToHS
/* See bug 510001: TclSockMinimumBuffers needs plat imp */
-#ifdef _WIN64
+#if defined(_WIN64) || defined(TCL_NO_DEPRECATED)
# define TclSockMinimumBuffersOld 0
#else
#define TclSockMinimumBuffersOld sockMinimumBuffersOld
@@ -59,6 +59,17 @@ static int TclSockMinimumBuffersOld(int sock, int size)
}
#endif
+#if defined(TCL_NO_DEPRECATED)
+# define TclSetStartupScriptPath 0
+# define TclGetStartupScriptPath 0
+# define TclSetStartupScriptFileName 0
+# define TclGetStartupScriptFileName 0
+# define TclpInetNtoa 0
+# define TclWinGetServByName 0
+# define TclWinGetSockOpt 0
+# define TclWinSetSockOpt 0
+# define TclWinNToHS 0
+#else
#define TclSetStartupScriptPath setStartupScriptPath
static void TclSetStartupScriptPath(Tcl_Obj *path)
{
@@ -92,6 +103,7 @@ static unsigned short TclWinNToHS(unsigned short ns) {
return ntohs(ns);
}
#endif
+#endif /* TCL_NO_DEPRECATED */
#ifdef _WIN32
# define TclUnixWaitForFile 0
@@ -287,12 +299,102 @@ static int formatInt(char *buffer, int n){
}
#define TclFormatInt (int(*)(char *, long))formatInt
-#endif
+#endif /* TCL_WIDE_INT_IS_LONG */
+
+#endif /* __CYGWIN__ */
-#else /* UNIX and MAC */
+#ifdef TCL_NO_DEPRECATED
+# define Tcl_SeekOld 0
+# define Tcl_TellOld 0
+# undef Tcl_SetBooleanObj
+# define Tcl_SetBooleanObj 0
+# undef Tcl_PkgPresent
+# define Tcl_PkgPresent 0
+# undef Tcl_PkgProvide
+# define Tcl_PkgProvide 0
+# undef Tcl_PkgRequire
+# define Tcl_PkgRequire 0
+# undef Tcl_GetIndexFromObj
+# define Tcl_GetIndexFromObj 0
+# define Tcl_NewBooleanObj 0
+# undef Tcl_DbNewBooleanObj
+# define Tcl_DbNewBooleanObj 0
+# undef Tcl_SetBooleanObj
+# define Tcl_SetBooleanObj 0
+# undef Tcl_SetVar
+# define Tcl_SetVar 0
+# undef Tcl_UnsetVar
+# define Tcl_UnsetVar 0
+# undef Tcl_GetVar
+# define Tcl_GetVar 0
+# undef Tcl_TraceVar
+# define Tcl_TraceVar 0
+# undef Tcl_UntraceVar
+# define Tcl_UntraceVar 0
+# undef Tcl_VarTraceInfo
+# define Tcl_VarTraceInfo 0
+# undef Tcl_UpVar
+# define Tcl_UpVar 0
+# undef Tcl_AddErrorInfo
+# define Tcl_AddErrorInfo 0
+# undef Tcl_AddObjErrorInfo
+# define Tcl_AddObjErrorInfo 0
+# undef Tcl_Eval
+# define Tcl_Eval 0
+# undef Tcl_GlobalEval
+# define Tcl_GlobalEval 0
+# undef Tcl_SaveResult
+# define Tcl_SaveResult 0
+# undef Tcl_RestoreResult
+# define Tcl_RestoreResult 0
+# undef Tcl_DiscardResult
+# define Tcl_DiscardResult 0
+# undef Tcl_SetResult
+# define Tcl_SetResult 0
+# undef Tcl_EvalObj
+# define Tcl_EvalObj 0
+# undef Tcl_GlobalEvalObj
+# define Tcl_GlobalEvalObj 0
+# define TclBackgroundException 0
+# undef TclpReaddir
+# define TclpReaddir 0
+# undef TclpGetDate
+# define TclpGetDate 0
+# undef TclpLocaltime
+# define TclpLocaltime 0
+# undef TclpGmtime
+# define TclpGmtime 0
+# define TclpLocaltime_unix 0
+# define TclpGmtime_unix 0
+#else /* TCL_NO_DEPRECATED */
+# define Tcl_SeekOld seekOld
+# define Tcl_TellOld tellOld
+# define TclBackgroundException Tcl_BackgroundException
# define TclpLocaltime_unix TclpLocaltime
# define TclpGmtime_unix TclpGmtime
-#endif
+
+static int
+seekOld(
+ Tcl_Channel chan, /* The channel on which to seek. */
+ int offset, /* Offset to seek to. */
+ int mode) /* Relative to which location to seek? */
+{
+ Tcl_WideInt wOffset, wResult;
+
+ wOffset = Tcl_LongAsWide((long) offset);
+ wResult = Tcl_Seek(chan, wOffset, mode);
+ return (int) Tcl_WideAsLong(wResult);
+}
+
+static int
+tellOld(
+ Tcl_Channel chan) /* The channel to return pos for. */
+{
+ Tcl_WideInt wResult = Tcl_Tell(chan);
+
+ return (int) Tcl_WideAsLong(wResult);
+}
+#endif /* !TCL_NO_DEPRECATED */
/*
* WARNING: The contents of this file is automatically generated by the
@@ -749,6 +851,7 @@ const TclTomMathStubs tclTomMathStubs = {
TclBNInitBignumFromLong, /* 64 */
TclBNInitBignumFromWideInt, /* 65 */
TclBNInitBignumFromWideUInt, /* 66 */
+ TclBN_mp_expt_d_ex, /* 67 */
};
static const TclStubHooks tclStubHooks = {
@@ -1415,6 +1518,7 @@ const TclStubs tclStubs = {
Tcl_FindSymbol, /* 628 */
Tcl_FSUnloadFile, /* 629 */
Tcl_ZlibStreamSetCompressionDictionary, /* 630 */
+ Tcl_OpenTcpServerEx, /* 631 */
};
/* !END!: Do not edit above this line. */
diff --git a/generic/tclStubLib.c b/generic/tclStubLib.c
index afabdca..5261591 100644
--- a/generic/tclStubLib.c
+++ b/generic/tclStubLib.c
@@ -67,7 +67,7 @@ Tcl_InitStubs(
if (!stubsPtr || (stubsPtr->magic != (((exact&0xff00) >= 0x900) ? magic : TCL_STUB_MAGIC))) {
iPtr->result = (char *)"interpreter uses an incompatible stubs mechanism";
- iPtr->freeProc = TCL_STATIC;
+ iPtr->freeProc = 0;
return NULL;
}
@@ -101,12 +101,16 @@ Tcl_InitStubs(
}
}
}
- tclStubsPtr = (TclStubs *)pkgData;
+ if (((exact&0xff00) < 0x900)) {
+ /* We are running Tcl 8.x */
+ stubsPtr = (TclStubs *)pkgData;
+ }
+ tclStubsPtr = stubsPtr;
- if (tclStubsPtr->hooks) {
- tclPlatStubsPtr = tclStubsPtr->hooks->tclPlatStubs;
- tclIntStubsPtr = tclStubsPtr->hooks->tclIntStubs;
- tclIntPlatStubsPtr = tclStubsPtr->hooks->tclIntPlatStubs;
+ if (stubsPtr->hooks) {
+ tclPlatStubsPtr = stubsPtr->hooks->tclPlatStubs;
+ tclIntStubsPtr = stubsPtr->hooks->tclIntStubs;
+ tclIntPlatStubsPtr = stubsPtr->hooks->tclIntPlatStubs;
} else {
tclPlatStubsPtr = NULL;
tclIntStubsPtr = NULL;
diff --git a/generic/tclTest.c b/generic/tclTest.c
index 47d85e1..547dc9a 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -67,6 +67,18 @@ typedef struct TestAsyncHandler {
/* Next is list of handlers. */
} TestAsyncHandler;
+/*
+ * Start of the socket driver state structure to acces field testFlags
+ */
+
+typedef struct TcpState TcpState;
+
+struct TcpState {
+ Tcl_Channel channel; /* Channel associated with this socket. */
+ int testFlags; /* bit field for tests. Is set by testsocket
+ * test procedure */
+};
+
TCL_DECLARE_MUTEX(asyncTestMutex)
static TestAsyncHandler *firstHandler = NULL;
@@ -90,7 +102,7 @@ static Tcl_Trace cmdTrace;
* TestdelCmd:
*/
-typedef struct DelCmd {
+typedef struct {
Tcl_Interp *interp; /* Interpreter in which command exists. */
char *deleteCmd; /* Script to execute when command is deleted.
* Malloc'ed. */
@@ -101,7 +113,7 @@ typedef struct DelCmd {
* command.
*/
-typedef struct TclEncoding {
+typedef struct {
Tcl_Interp *interp;
char *toUtfCmd;
char *fromUtfCmd;
@@ -124,7 +136,7 @@ static int exitMainLoop = 0;
* Event structure used in testing the event queue management procedures.
*/
-typedef struct TestEvent {
+typedef struct {
Tcl_Event header; /* Header common to all events */
Tcl_Interp *interp; /* Interpreter that will handle the event */
Tcl_Obj *command; /* Command to evaluate when the event occurs */
@@ -290,12 +302,14 @@ static int TestlinkCmd(ClientData dummy,
static int TestlocaleCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
+#ifndef TCL_NO_DEPRECATED
static int TestMathFunc(ClientData clientData,
Tcl_Interp *interp, Tcl_Value *args,
Tcl_Value *resultPtr);
static int TestMathFunc2(ClientData clientData,
Tcl_Interp *interp, Tcl_Value *args,
Tcl_Value *resultPtr);
+#endif /* TCL_NO_DEPRECATED */
static int TestmainthreadCmd(ClientData dummy,
Tcl_Interp *interp, int argc, const char **argv);
static int TestsetmainloopCmd(ClientData dummy,
@@ -318,6 +332,9 @@ static int TestparsevarnameObjCmd(ClientData dummy,
static int TestpreferstableObjCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
+static int TestprintObjCmd(ClientData dummy,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
static int TestregexpObjCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
@@ -326,12 +343,10 @@ static int TestreturnObjCmd(ClientData dummy,
Tcl_Obj *const objv[]);
static void TestregexpXflags(const char *string,
int length, int *cflagsPtr, int *eflagsPtr);
-#ifndef TCL_NO_DEPRECATED
static int TestsaveresultCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static void TestsaveresultFree(char *blockPtr);
-#endif /* TCL_NO_DEPRECATED */
static int TestsetassocdataCmd(ClientData dummy,
Tcl_Interp *interp, int argc, const char **argv);
static int TestsetCmd(ClientData dummy,
@@ -361,6 +376,8 @@ static int TestChannelCmd(ClientData clientData,
Tcl_Interp *interp, int argc, const char **argv);
static int TestChannelEventCmd(ClientData clientData,
Tcl_Interp *interp, int argc, const char **argv);
+static int TestSocketCmd(ClientData clientData,
+ Tcl_Interp *interp, int argc, const char **argv);
static int TestFilesystemObjCmd(ClientData dummy,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
@@ -541,10 +558,10 @@ Tcltest_Init(
"-appinitprocclosestderr", "-appinitprocsetrcfile", NULL
};
- if (Tcl_InitStubs(interp, "8.5", 0) == NULL) {
+ if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
- if (Tcl_TomMath_InitStubs(interp, "8.5") == NULL) {
+ if (Tcl_TomMath_InitStubs(interp, "8.5-") == NULL) {
return TCL_ERROR;
}
if (Tcl_OOInitStubs(interp) == NULL) {
@@ -552,7 +569,7 @@ Tcltest_Init(
}
/* TIP #268: Full patchlevel instead of just major.minor */
- if (Tcl_PkgProvide(interp, "Tcltest", TCL_PATCH_LEVEL) == TCL_ERROR) {
+ if (Tcl_PkgProvideEx(interp, "Tcltest", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) {
return TCL_ERROR;
}
@@ -649,14 +666,14 @@ Tcltest_Init(
NULL, NULL);
Tcl_CreateObjCommand(interp, "testpreferstable", TestpreferstableObjCmd,
NULL, NULL);
+ Tcl_CreateObjCommand(interp, "testprint", TestprintObjCmd,
+ NULL, NULL);
Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd,
NULL, NULL);
Tcl_CreateObjCommand(interp, "testreturn", TestreturnObjCmd,
NULL, NULL);
-#ifndef TCL_NO_DEPRECATED
Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd,
NULL, NULL);
-#endif /* TCL_NO_DEPRECATED */
Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd,
@@ -673,6 +690,8 @@ Tcltest_Init(
TestNumUtfCharsCmd, NULL, NULL);
Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd,
NULL, NULL);
+ Tcl_CreateCommand(interp, "testsocket", TestSocketCmd,
+ NULL, NULL);
Tcl_CreateCommand(interp, "teststaticpkg", TeststaticpkgCmd,
NULL, NULL);
Tcl_CreateCommand(interp, "testtranslatefilename",
@@ -781,7 +800,7 @@ int
Tcltest_SafeInit(
Tcl_Interp *interp) /* Interpreter for application. */
{
- if (Tcl_InitStubs(interp, "8.5", 0) == NULL) {
+ if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) {
return TCL_ERROR;
}
return Procbodytest_SafeInit(interp);
@@ -818,7 +837,7 @@ TestasyncCmd(
if (argc < 2) {
wrongNumArgs:
- Tcl_SetResult(interp, "wrong # args", TCL_STATIC);
+ Tcl_AppendResult(interp, "wrong # args", NULL);
return TCL_ERROR;
}
if (strcmp(argv[1], "create") == 0) {
@@ -908,7 +927,7 @@ TestasyncCmd(
if (Tcl_CreateThread(&threadID, AsyncThreadProc,
INT2PTR(id), TCL_THREAD_STACK_DEFAULT,
TCL_THREAD_NOFLAGS) != TCL_OK) {
- Tcl_SetResult(interp, "can't create thread", TCL_STATIC);
+ Tcl_AppendResult(interp, "can't create thread", NULL);
Tcl_MutexUnlock(&asyncTestMutex);
return TCL_ERROR;
}
@@ -1055,7 +1074,7 @@ TestcmdinfoCmd(
Tcl_DStringResult(interp, &delString);
} else if (strcmp(argv[1], "get") == 0) {
if (Tcl_GetCommandInfo(interp, argv[2], &info) ==0) {
- Tcl_SetResult(interp, "??", TCL_STATIC);
+ Tcl_AppendResult(interp, "??", NULL);
return TCL_OK;
}
if (info.proc == CmdProc1) {
@@ -1182,7 +1201,7 @@ TestcmdtokenCmd(
token = Tcl_CreateCommand(interp, argv[2], CmdProc1,
(ClientData) "original", NULL);
sprintf(buf, "%p", (void *)token);
- Tcl_SetResult(interp, buf, TCL_VOLATILE);
+ Tcl_AppendResult(interp, buf, NULL);
} else if (strcmp(argv[1], "name") == 0) {
Tcl_Obj *objPtr;
@@ -1288,7 +1307,7 @@ TestcmdtraceCmd(
result = Tcl_EvalEx(interp, argv[2], -1, 0);
Tcl_DeleteTrace(interp, cmdTrace);
if (!deleteCalled) {
- Tcl_SetResult(interp, "Delete wasn't called", TCL_STATIC);
+ Tcl_AppendResult(interp, "Delete wasn't called", NULL);
return TCL_ERROR;
} else {
return result;
@@ -1588,7 +1607,7 @@ TestdelCmd(
Tcl_Interp *slave;
if (argc != 4) {
- Tcl_SetResult(interp, "wrong # args", TCL_STATIC);
+ Tcl_AppendResult(interp, "wrong # args", NULL);
return TCL_ERROR;
}
@@ -1793,7 +1812,7 @@ TestdstringCmd(
if (argc < 2) {
wrongNumArgs:
- Tcl_SetResult(interp, "wrong # args", TCL_STATIC);
+ Tcl_AppendResult(interp, "wrong # args", NULL);
return TCL_ERROR;
}
if (strcmp(argv[1], "append") == 0) {
@@ -1829,9 +1848,9 @@ TestdstringCmd(
goto wrongNumArgs;
}
if (strcmp(argv[2], "staticsmall") == 0) {
- Tcl_SetResult(interp, "short", TCL_STATIC);
+ Tcl_AppendResult(interp, "short", NULL);
} else if (strcmp(argv[2], "staticlarge") == 0) {
- Tcl_SetResult(interp, "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n", TCL_STATIC);
+ Tcl_AppendResult(interp, "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n", NULL);
} else if (strcmp(argv[2], "free") == 0) {
char *s = ckalloc(100);
strcpy(s, "This is a malloc-ed string");
@@ -1991,7 +2010,7 @@ EncodingToUtfProc(
TclEncoding *encodingPtr;
encodingPtr = (TclEncoding *) clientData;
- Tcl_EvalEx(encodingPtr->interp,encodingPtr->toUtfCmd,-1,TCL_EVAL_GLOBAL);
+ Tcl_EvalEx(encodingPtr->interp, encodingPtr->toUtfCmd, -1, TCL_EVAL_GLOBAL);
len = strlen(Tcl_GetStringResult(encodingPtr->interp));
if (len > dstLen) {
@@ -2023,7 +2042,7 @@ EncodingFromUtfProc(
TclEncoding *encodingPtr;
encodingPtr = (TclEncoding *) clientData;
- Tcl_EvalEx(encodingPtr->interp, encodingPtr->fromUtfCmd,-1,TCL_EVAL_GLOBAL);
+ Tcl_EvalEx(encodingPtr->interp, encodingPtr->fromUtfCmd, -1, TCL_EVAL_GLOBAL);
len = strlen(Tcl_GetStringResult(encodingPtr->interp));
if (len > dstLen) {
@@ -2431,7 +2450,7 @@ TestexprlongCmd(
" expression\"", NULL);
return TCL_ERROR;
}
- Tcl_SetResult(interp, "This is a result", TCL_STATIC);
+ Tcl_AppendResult(interp, "This is a result", NULL);
result = Tcl_ExprLong(interp, argv[1], &exprResult);
if (result != TCL_OK) {
return result;
@@ -2473,7 +2492,7 @@ TestexprlongobjCmd(
Tcl_WrongNumArgs(interp, 1, objv, "expression");
return TCL_ERROR;
}
- Tcl_SetResult(interp, "This is a result", TCL_STATIC);
+ Tcl_AppendResult(interp, "This is a result", NULL);
result = Tcl_ExprLongObj(interp, objv[1], &exprResult);
if (result != TCL_OK) {
return result;
@@ -2516,7 +2535,7 @@ TestexprdoubleCmd(
" expression\"", NULL);
return TCL_ERROR;
}
- Tcl_SetResult(interp, "This is a result", TCL_STATIC);
+ Tcl_AppendResult(interp, "This is a result", NULL);
result = Tcl_ExprDouble(interp, argv[1], &exprResult);
if (result != TCL_OK) {
return result;
@@ -2559,7 +2578,7 @@ TestexprdoubleobjCmd(
Tcl_WrongNumArgs(interp, 1, objv, "expression");
return TCL_ERROR;
}
- Tcl_SetResult(interp, "This is a result", TCL_STATIC);
+ Tcl_AppendResult(interp, "This is a result", NULL);
result = Tcl_ExprDoubleObj(interp, objv[1], &exprResult);
if (result != TCL_OK) {
return result;
@@ -3336,6 +3355,7 @@ TestlocaleCmd(
*/
/* ARGSUSED */
+#ifndef TCL_NO_DEPRECATED
static int
TestMathFunc(
ClientData clientData, /* Integer value to return. */
@@ -3401,7 +3421,7 @@ TestMathFunc2(
resultPtr->type = TCL_WIDE_INT;
resultPtr->wideValue = ((w0 > w1)? w0 : w1);
} else {
- Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC);
+ Tcl_AppendResult(interp, "T3: wrong type for arg 2", NULL);
result = TCL_ERROR;
}
} else if (args[0].type == TCL_DOUBLE) {
@@ -3423,7 +3443,7 @@ TestMathFunc2(
resultPtr->type = TCL_DOUBLE;
resultPtr->doubleValue = ((d0 > d1)? d0 : d1);
} else {
- Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC);
+ Tcl_AppendResult(interp, "T3: wrong type for arg 2", NULL);
result = TCL_ERROR;
}
} else if (args[0].type == TCL_WIDE_INT) {
@@ -3446,15 +3466,16 @@ TestMathFunc2(
resultPtr->type = TCL_WIDE_INT;
resultPtr->wideValue = ((w0 > w1)? w0 : w1);
} else {
- Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC);
+ Tcl_AppendResult(interp, "T3: wrong type for arg 2", NULL);
result = TCL_ERROR;
}
} else {
- Tcl_SetResult(interp, "T3: wrong type for arg 1", TCL_STATIC);
+ Tcl_AppendResult(interp, "T3: wrong type for arg 1", NULL);
result = TCL_ERROR;
}
return result;
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -3820,6 +3841,45 @@ TestpreferstableObjCmd(
/*
*----------------------------------------------------------------------
*
+ * TestprintObjCmd --
+ *
+ * This procedure implements the "testprint" command. It is
+ * used for being able to test the Tcl_ObjPrintf() function.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestprintObjCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Current interpreter. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* The argument objects. */
+{
+ Tcl_WideInt argv1 = 0;
+ size_t argv2;
+
+ if (objc < 2 || objc > 3) {
+ Tcl_WrongNumArgs(interp, 1, objv, "format wideint");
+ }
+
+ if (objc > 1) {
+ Tcl_GetWideIntFromObj(interp, objv[2], &argv1);
+ }
+ argv2 = (size_t)argv1;
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(Tcl_GetString(objv[1]), argv1, argv2, argv2));
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TestregexpObjCmd --
*
* This procedure implements the "testregexp" command. It is used to give
@@ -4444,7 +4504,7 @@ TestseterrorcodeCmd(
const char **argv) /* Argument strings. */
{
if (argc > 6) {
- Tcl_SetResult(interp, "too many args", TCL_STATIC);
+ Tcl_AppendResult(interp, "too many args", NULL);
return TCL_ERROR;
}
switch (argc) {
@@ -4597,7 +4657,7 @@ TestpanicCmd(
int argc, /* Number of arguments. */
const char **argv) /* Argument strings. */
{
- const char *argString;
+ char *argString;
/*
* Put the arguments into a var args structure
@@ -5048,7 +5108,7 @@ TestsetCmd(
const char *value;
if (argc == 2) {
- Tcl_SetResult(interp, "before get", TCL_STATIC);
+ Tcl_AppendResult(interp, "before get", NULL);
value = Tcl_GetVar2(interp, argv[1], NULL, flags);
if (value == NULL) {
return TCL_ERROR;
@@ -5056,7 +5116,7 @@ TestsetCmd(
Tcl_AppendElement(interp, value);
return TCL_OK;
} else if (argc == 3) {
- Tcl_SetResult(interp, "before set", TCL_STATIC);
+ Tcl_AppendResult(interp, "before set", NULL);
value = Tcl_SetVar2(interp, argv[1], NULL, argv[2], flags);
if (value == NULL) {
return TCL_ERROR;
@@ -5080,7 +5140,7 @@ Testset2Cmd(
const char *value;
if (argc == 3) {
- Tcl_SetResult(interp, "before get", TCL_STATIC);
+ Tcl_AppendResult(interp, "before get", NULL);
value = Tcl_GetVar2(interp, argv[1], argv[2], flags);
if (value == NULL) {
return TCL_ERROR;
@@ -5088,7 +5148,7 @@ Testset2Cmd(
Tcl_AppendElement(interp, value);
return TCL_OK;
} else if (argc == 4) {
- Tcl_SetResult(interp, "before set", TCL_STATIC);
+ Tcl_AppendResult(interp, "before set", NULL);
value = Tcl_SetVar2(interp, argv[1], argv[2], argv[3], flags);
if (value == NULL) {
return TCL_ERROR;
@@ -5102,7 +5162,6 @@ Testset2Cmd(
}
}
-#ifndef TCL_NO_DEPRECATED
/*
*----------------------------------------------------------------------
*
@@ -5155,10 +5214,11 @@ TestsaveresultCmd(
return TCL_ERROR;
}
+ freeCount = 0;
objPtr = NULL; /* Lint. */
switch ((enum options) index) {
case RESULT_SMALL:
- Tcl_SetResult(interp, "small result", TCL_VOLATILE);
+ Tcl_AppendResult(interp, "small result", NULL);
break;
case RESULT_APPEND:
Tcl_AppendResult(interp, "append result", NULL);
@@ -5179,7 +5239,6 @@ TestsaveresultCmd(
break;
}
- freeCount = 0;
Tcl_SaveResult(interp, &state);
if (((enum options) index) == RESULT_OBJECT) {
@@ -5197,11 +5256,9 @@ TestsaveresultCmd(
switch ((enum options) index) {
case RESULT_DYNAMIC: {
- int present = iPtr->freeProc == TestsaveresultFree;
- int called = freeCount;
+ int presentOrFreed = (iPtr->freeProc == TestsaveresultFree) ^ freeCount;
- Tcl_AppendElement(interp, called ? "called" : "notCalled");
- Tcl_AppendElement(interp, present ? "present" : "missing");
+ Tcl_AppendElement(interp, presentOrFreed ? "presentOrFreed" : "missingOrLeak");
break;
}
case RESULT_OBJECT:
@@ -5236,7 +5293,6 @@ TestsaveresultFree(
{
freeCount++;
}
-#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -5268,7 +5324,7 @@ TestmainthreadCmd(
Tcl_SetObjResult(interp, idObj);
return TCL_OK;
} else {
- Tcl_SetResult(interp, "wrong # args", TCL_STATIC);
+ Tcl_AppendResult(interp, "wrong # args", NULL);
return TCL_ERROR;
}
}
@@ -6041,6 +6097,75 @@ TestChannelEventCmd(
/*
*----------------------------------------------------------------------
*
+ * TestSocketCmd --
+ *
+ * Implements the Tcl "testsocket" debugging command and its
+ * subcommands. This is part of the testing environment.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+static int
+TestSocketCmd(
+ ClientData clientData, /* Not used. */
+ Tcl_Interp *interp, /* Interpreter for result. */
+ int argc, /* Count of additional args. */
+ const char **argv) /* Additional arg strings. */
+{
+ const char *cmdName; /* Sub command. */
+ size_t len; /* Length of subcommand string. */
+
+ if (argc < 2) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " subcommand ?additional args..?\"", NULL);
+ return TCL_ERROR;
+ }
+ cmdName = argv[1];
+ len = strlen(cmdName);
+
+ if ((cmdName[0] == 't') && (strncmp(cmdName, "testflags", len) == 0)) {
+ Tcl_Channel hChannel;
+ int modePtr;
+ TcpState *statePtr;
+ /* Set test value in the socket driver
+ */
+ /* Check for argument "channel name"
+ */
+ if (argc < 4) {
+ Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
+ " testflags channel flags\"", NULL);
+ return TCL_ERROR;
+ }
+ hChannel = Tcl_GetChannel(interp, argv[2], &modePtr);
+ if ( NULL == hChannel ) {
+ Tcl_AppendResult(interp, "unknown channel:", argv[2], NULL);
+ return TCL_ERROR;
+ }
+ statePtr = (TcpState *)Tcl_GetChannelInstanceData(hChannel);
+ if ( NULL == statePtr) {
+ Tcl_AppendResult(interp, "No channel instance data:", argv[2],
+ NULL);
+ return TCL_ERROR;
+ }
+ statePtr->testFlags = atoi(argv[3]);
+ return TCL_OK;
+ }
+
+ Tcl_AppendResult(interp, "bad option \"", cmdName, "\": should be "
+ "testflags", NULL);
+ return TCL_ERROR;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TestWrongNumArgsObjCmd --
*
* Test the Tcl_WrongNumArgs function.
@@ -6069,7 +6194,7 @@ TestWrongNumArgsObjCmd(
* Don't use Tcl_WrongNumArgs here, as that is the function
* we want to test!
*/
- Tcl_SetResult(interp, "insufficient arguments", TCL_STATIC);
+ Tcl_AppendResult(interp, "insufficient arguments", NULL);
return TCL_ERROR;
}
@@ -6086,7 +6211,7 @@ TestWrongNumArgsObjCmd(
/*
* Asked for more arguments than were given.
*/
- Tcl_SetResult(interp, "insufficient arguments", TCL_STATIC);
+ Tcl_AppendResult(interp, "insufficient arguments", NULL);
return TCL_ERROR;
}
@@ -6751,7 +6876,7 @@ TestcpuidCmd(
Tcl_Obj *const * objv) /* Parameter vector */
{
int status, index, i;
- unsigned int regs[4];
+ int regs[4];
Tcl_Obj *regsObjs[4];
if (objc != 2) {
@@ -6761,14 +6886,14 @@ TestcpuidCmd(
if (Tcl_GetIntFromObj(interp, objv[1], &index) != TCL_OK) {
return TCL_ERROR;
}
- status = TclWinCPUID((unsigned) index, regs);
+ status = TclWinCPUID(index, regs);
if (status != TCL_OK) {
Tcl_SetObjResult(interp,
Tcl_NewStringObj("operation not available", -1));
return status;
}
for (i=0 ; i<4 ; ++i) {
- regsObjs[i] = Tcl_NewIntObj((int) regs[i]);
+ regsObjs[i] = Tcl_NewIntObj(regs[i]);
}
Tcl_SetObjResult(interp, Tcl_NewListObj(4, regsObjs));
return TCL_OK;
@@ -6863,7 +6988,7 @@ TestgetintCmd(
const char **argv)
{
if (argc < 2) {
- Tcl_SetResult(interp, "wrong # args", TCL_STATIC);
+ Tcl_AppendResult(interp, "wrong # args", NULL);
return TCL_ERROR;
} else {
int val, i, total=0;
@@ -7387,7 +7512,7 @@ InterpCmdResolver(
*/
CallFrame *parentFramePtr = varFramePtr->callerPtr;
- char *context = parentFramePtr != NULL ? parentFramePtr->nsPtr->name : "(NULL)";
+ const char *context = parentFramePtr != NULL ? parentFramePtr->nsPtr->name : "(NULL)";
if (strcmp(context, "ctx1") == 0 && (name[0] == 'z') && (name[1] == '\0')) {
resolvedCmdPtr = Tcl_FindCommand(interp, "y", NULL, TCL_GLOBAL_ONLY);
diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c
index 6053ae3..5627608 100644
--- a/generic/tclTestObj.c
+++ b/generic/tclTestObj.c
@@ -152,10 +152,11 @@ TestbignumobjCmd(
Tcl_Obj *const objv[]) /* Argument vector */
{
const char *const subcmds[] = {
- "set", "get", "mult10", "div10", NULL
+ "set", "get", "mult10", "div10", "iseven", "radixsize", NULL
};
enum options {
- BIGNUM_SET, BIGNUM_GET, BIGNUM_MULT10, BIGNUM_DIV10
+ BIGNUM_SET, BIGNUM_GET, BIGNUM_MULT10, BIGNUM_DIV10, BIGNUM_ISEVEN,
+ BIGNUM_RADIXSIZE
};
int index, varIndex;
const char *string;
@@ -274,6 +275,50 @@ TestbignumobjCmd(
} else {
SetVarToObj(varPtr, varIndex, Tcl_NewBignumObj(&newValue));
}
+ break;
+
+ case BIGNUM_ISEVEN:
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
+ return TCL_ERROR;
+ }
+ if (CheckIfVarUnset(interp, varPtr,varIndex)) {
+ return TCL_ERROR;
+ }
+ if (Tcl_GetBignumFromObj(interp, varPtr[varIndex],
+ &bignumValue) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (!Tcl_IsShared(varPtr[varIndex])) {
+ Tcl_SetIntObj(varPtr[varIndex], mp_iseven(&bignumValue));
+ } else {
+ SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(mp_iseven(&bignumValue)));
+ }
+ mp_clear(&bignumValue);
+ break;
+
+ case BIGNUM_RADIXSIZE:
+ if (objc != 3) {
+ Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
+ return TCL_ERROR;
+ }
+ if (CheckIfVarUnset(interp, varPtr,varIndex)) {
+ return TCL_ERROR;
+ }
+ if (Tcl_GetBignumFromObj(interp, varPtr[varIndex],
+ &bignumValue) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (mp_radix_size(&bignumValue, 10, &index) != MP_OKAY) {
+ return TCL_ERROR;
+ }
+ if (!Tcl_IsShared(varPtr[varIndex])) {
+ Tcl_SetIntObj(varPtr[varIndex], index);
+ } else {
+ SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(index));
+ }
+ mp_clear(&bignumValue);
+ break;
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
@@ -1056,7 +1101,7 @@ TestobjCmd(
if (CheckIfVarUnset(interp, varPtr,varIndex)) {
return TCL_ERROR;
}
- Tcl_SetObjResult(interp, Tcl_NewIntObj(varPtr[varIndex]->refCount));
+ Tcl_SetObjResult(interp, Tcl_NewWideIntObj(varPtr[varIndex]->refCount));
} else if (strcmp(subCmd, "type") == 0) {
if (objc != 3) {
goto wrongNumArgs;
diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c
index 018f006..8077de4 100644
--- a/generic/tclThreadAlloc.c
+++ b/generic/tclThreadAlloc.c
@@ -196,20 +196,11 @@ GetCache(void)
if (listLockPtr == NULL) {
Tcl_Mutex *initLockPtr;
- unsigned int i;
initLockPtr = Tcl_GetAllocMutex();
Tcl_MutexLock(initLockPtr);
if (listLockPtr == NULL) {
- listLockPtr = TclpNewAllocMutex();
- objLockPtr = TclpNewAllocMutex();
- for (i = 0; i < NBUCKETS; ++i) {
- bucketInfo[i].blockSize = MINALLOC << i;
- bucketInfo[i].maxBlocks = 1 << (NBUCKETS - 1 - i);
- bucketInfo[i].numMove = i < NBUCKETS - 1 ?
- 1 << (NBUCKETS - 2 - i) : 1;
- bucketInfo[i].lockPtr = TclpNewAllocMutex();
- }
+ TclInitThreadAlloc();
}
Tcl_MutexUnlock(initLockPtr);
}
@@ -1064,6 +1055,40 @@ GetBlocks(
}
return 1;
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclInitThreadAlloc --
+ *
+ * Initializes the allocator cache-maintenance structures.
+ * It is done early and protected during the TclInitSubsystems().
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclInitThreadAlloc(void)
+{
+ unsigned int i;
+
+ listLockPtr = TclpNewAllocMutex();
+ objLockPtr = TclpNewAllocMutex();
+ for (i = 0; i < NBUCKETS; ++i) {
+ bucketInfo[i].blockSize = MINALLOC << i;
+ bucketInfo[i].maxBlocks = 1 << (NBUCKETS - 1 - i);
+ bucketInfo[i].numMove = i < NBUCKETS - 1 ?
+ 1 << (NBUCKETS - 2 - i) : 1;
+ bucketInfo[i].lockPtr = TclpNewAllocMutex();
+ }
+ TclpInitAllocCache();
+}
/*
*----------------------------------------------------------------------
@@ -1106,9 +1131,9 @@ TclFinalizeThreadAlloc(void)
*
* TclFinalizeThreadAllocThread --
*
- * This procedure is used to destroy single thread private resources used
- * in this file.
- * Called in TclpFinalizeThreadData when a thread exits (Tcl_FinalizeThread).
+ * This procedure is used to destroy single thread private resources
+ * defined in this file. Called either during Tcl_FinalizeThread() or
+ * Tcl_Finalize().
*
* Results:
* None.
diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c
index 1a05f80..9c5fecb 100644
--- a/generic/tclThreadTest.c
+++ b/generic/tclThreadTest.c
@@ -341,7 +341,7 @@ ThreadObjCmd(
} else if (objc == 3
&& strcmp("-main", Tcl_GetString(objv[2])) == 0) {
Tcl_MutexLock(&threadMutex);
- idObj = Tcl_NewLongObj((long)(size_t)mainThreadId);
+ idObj = Tcl_NewWideIntObj((Tcl_WideInt)(size_t)mainThreadId);
Tcl_MutexUnlock(&threadMutex);
} else {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
@@ -655,7 +655,7 @@ ThreadErrorProc(
char *script;
char buf[TCL_DOUBLE_SPACE+1];
- sprintf(buf, "%" TCL_LL_MODIFIER "d", (Tcl_WideInt)(size_t)Tcl_GetCurrentThread());
+ sprintf(buf, "%p", Tcl_GetCurrentThread());
errorInfo = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY);
if (errorProcString == NULL) {
diff --git a/generic/tclTimer.c b/generic/tclTimer.c
index adc36ce..16003b0 100644
--- a/generic/tclTimer.c
+++ b/generic/tclTimer.c
@@ -1053,11 +1053,17 @@ AfterDelay(
if (diff > TCL_TIME_MAXIMUM_SLICE) {
diff = TCL_TIME_MAXIMUM_SLICE;
}
- if (diff == 0 && TCL_TIME_BEFORE(now, endTime)) diff = 1;
+ if (diff == 0 && TCL_TIME_BEFORE(now, endTime)) {
+ diff = 1;
+ }
if (diff > 0) {
Tcl_Sleep((long) diff);
- if (diff < SLEEP_OFFLOAD_GETTIMEOFDAY) break;
- } else break;
+ if (diff < SLEEP_OFFLOAD_GETTIMEOFDAY) {
+ break;
+ }
+ } else {
+ break;
+ }
} else {
diff = TCL_TIME_DIFF_MS(iPtr->limit.time, now);
#ifndef TCL_WIDE_INT_IS_LONG
diff --git a/generic/tclTomMath.decls b/generic/tclTomMath.decls
index 610a031..74ccefc 100644
--- a/generic/tclTomMath.decls
+++ b/generic/tclTomMath.decls
@@ -90,7 +90,7 @@ declare 21 {
int TclBN_mp_init(mp_int *a)
}
declare 22 {
- int TclBN_mp_init_copy(mp_int *a, mp_int *b)
+ int TclBN_mp_init_copy(mp_int *a, const mp_int *b)
}
declare 23 {
int TclBN_mp_init_multi(mp_int *a, ...)
@@ -129,7 +129,7 @@ declare 34 {
int TclBN_mp_or(mp_int *a, mp_int *b, mp_int *c)
}
declare 35 {
- int TclBN_mp_radix_size(mp_int *a, int radix, int *size)
+ int TclBN_mp_radix_size(const mp_int *a, int radix, int *size)
}
declare 36 {
int TclBN_mp_read_radix(mp_int *a, const char *str, int radix)
@@ -233,6 +233,11 @@ declare 66 {
void TclBNInitBignumFromWideUInt(mp_int *bignum, Tcl_WideUInt initVal)
}
+# Added in libtommath 1.0
+declare 67 {
+ int TclBN_mp_expt_d_ex(mp_int *a, mp_digit b, mp_int *c, int fast)
+}
+
# Local Variables:
# mode: tcl
# End:
diff --git a/generic/tclTomMath.h b/generic/tclTomMath.h
index dd9edaf..001019c 100644
--- a/generic/tclTomMath.h
+++ b/generic/tclTomMath.h
@@ -10,7 +10,7 @@
* The library is free for all purposes without any express
* guarantee it works.
*
- * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com
+ * Tom St Denis, tstdenis82@gmail.com, http://math.libtomcrypt.com
*/
#ifndef BN_H_
#define BN_H_
@@ -22,33 +22,15 @@
-#ifndef MIN
-# define MIN(x,y) ((x)<(y)?(x):(y))
-#endif
-
-#ifndef MAX
-# define MAX(x,y) ((x)>(y)?(x):(y))
-#endif
-
#ifdef __cplusplus
extern "C" {
-
-/* C++ compilers don't like assigning void * to mp_digit * */
-#define OPT_CAST(x) (x *)
-
-#else
-
-/* C on the other hand doesn't care */
-#define OPT_CAST(x)
-
#endif
-
/* detect 64-bit mode if possible */
-#if defined(NEVER) /* 128-bit ints fail in too many places */
-# if !(defined(MP_64BIT) && defined(MP_16BIT) && defined(MP_8BIT))
-# define MP_64BIT
-# endif
+#if defined(NEVER) /* 128-bit ints fail in too many places */
+ #if !(defined(MP_32BIT) || defined(MP_16BIT) || defined(MP_8BIT))
+ #define MP_64BIT
+ #endif
#endif
/* some default configurations.
@@ -61,83 +43,89 @@ extern "C" {
*/
#ifdef MP_8BIT
#ifndef MP_DIGIT_DECLARED
- typedef unsigned char mp_digit;
+ typedef uint8_t mp_digit;
#define MP_DIGIT_DECLARED
#endif
- typedef unsigned short mp_word;
+ typedef uint16_t mp_word;
+#define MP_SIZEOF_MP_DIGIT 1
+#ifdef DIGIT_BIT
+#error You must not define DIGIT_BIT when using MP_8BIT
+#endif
#elif defined(MP_16BIT)
#ifndef MP_DIGIT_DECLARED
- typedef unsigned short mp_digit;
+ typedef uint16_t mp_digit;
#define MP_DIGIT_DECLARED
#endif
- typedef unsigned long mp_word;
+ typedef uint32_t mp_word;
+#define MP_SIZEOF_MP_DIGIT 2
+#ifdef DIGIT_BIT
+#error You must not define DIGIT_BIT when using MP_16BIT
+#endif
#elif defined(MP_64BIT)
/* for GCC only on supported platforms */
#ifndef CRYPT
- typedef unsigned long long ulong64;
- typedef signed long long long64;
+ typedef unsigned long long ulong64;
+ typedef signed long long long64;
#endif
#ifndef MP_DIGIT_DECLARED
- typedef unsigned long mp_digit;
+ typedef ulong64 mp_digit;
#define MP_DIGIT_DECLARED
#endif
- typedef unsigned long mp_word __attribute__ ((mode(TI)));
+#if defined(_WIN32)
+ typedef unsigned __int128 mp_word;
+#elif defined(__GNUC__)
+ typedef unsigned long mp_word __attribute__ ((mode(TI)));
+#else
+ /* it seems you have a problem
+ * but we assume you can somewhere define your own uint128_t */
+ typedef uint128_t mp_word;
+#endif
-# define DIGIT_BIT 60
+ #define DIGIT_BIT 60
#else
/* this is the default case, 28-bit digits */
-
+
/* this is to make porting into LibTomCrypt easier :-) */
#ifndef CRYPT
-# if defined(_MSC_VER) || defined(__BORLANDC__)
- typedef unsigned __int64 ulong64;
- typedef signed __int64 long64;
-# else
- typedef unsigned long long ulong64;
- typedef signed long long long64;
-# endif
+ typedef unsigned long long ulong64;
+ typedef signed long long long64;
#endif
#ifndef MP_DIGIT_DECLARED
- typedef unsigned int mp_digit;
+ typedef uint32_t mp_digit;
#define MP_DIGIT_DECLARED
#endif
- typedef ulong64 mp_word;
+ typedef ulong64 mp_word;
-#ifdef MP_31BIT
+#ifdef MP_31BIT
/* this is an extension that uses 31-bit digits */
-# define DIGIT_BIT 31
+ #define DIGIT_BIT 31
#else
/* default case is 28-bit digits, defines MP_28BIT as a handy macro to test */
-# define DIGIT_BIT 28
-# define MP_28BIT
-#endif
-#endif
-
-/* define heap macros */
-#if 0 /* these are macros in tclTomMathDecls.h */
-#ifndef CRYPT
- /* default to libc stuff */
-# ifndef XMALLOC
-# define XMALLOC malloc
-# define XFREE free
-# define XREALLOC realloc
-# define XCALLOC calloc
-# else
- /* prototypes for our heap functions */
- extern void *XMALLOC(size_t n);
- extern void *XREALLOC(void *p, size_t n);
- extern void *XCALLOC(size_t n, size_t s);
- extern void XFREE(void *p);
-# endif
+ #define DIGIT_BIT 28
+ #define MP_28BIT
#endif
#endif
-
/* otherwise the bits per digit is calculated automatically from the size of a mp_digit */
#ifndef DIGIT_BIT
-# define DIGIT_BIT ((int)((CHAR_BIT * sizeof(mp_digit) - 1))) /* bits per digit */
+ #define DIGIT_BIT (((CHAR_BIT * MP_SIZEOF_MP_DIGIT) - 1)) /* bits per digit */
+ typedef uint_least32_t mp_min_u32;
+#else
+ typedef mp_digit mp_min_u32;
+#endif
+
+/* platforms that can use a better rand function */
+#if defined(__FreeBSD__) || defined(__OpenBSD__) || defined(__NetBSD__) || defined(__DragonFly__)
+ #define MP_USE_ALT_RAND 1
+#endif
+
+/* use arc4random on platforms that support it */
+#ifdef MP_USE_ALT_RAND
+ #define MP_GEN_RANDOM() arc4random()
+#else
+ #define MP_GEN_RANDOM() rand()
#endif
#define MP_DIGIT_BIT DIGIT_BIT
@@ -180,15 +168,15 @@ MODULE_SCOPE int KARATSUBA_MUL_CUTOFF,
/* default precision */
#ifndef MP_PREC
-# ifndef MP_LOW_MEM
-# define MP_PREC 32 /* default digits of precision */
-# else
-# define MP_PREC 8 /* default digits of precision */
-# endif
+ #ifndef MP_LOW_MEM
+ #define MP_PREC 32 /* default digits of precision */
+ #else
+ #define MP_PREC 8 /* default digits of precision */
+ #endif
#endif
/* size of comba arrays, should be at least 2 * 2**(BITS_PER_WORD - BITS_PER_DIGIT*2) */
-#define MP_WARRAY (1 << (sizeof(mp_word) * CHAR_BIT - 2 * DIGIT_BIT + 1))
+#define MP_WARRAY (1 << (((sizeof(mp_word) * CHAR_BIT) - (2 * DIGIT_BIT)) + 1))
/* the infamous mp_int structure */
#ifndef MP_INT_DECLARED
@@ -209,9 +197,7 @@ typedef int ltm_prime_callback(unsigned char *dst, int len, void *dat);
#define SIGN(m) ((m)->sign)
/* error code to char* string */
-/*
-char *mp_error_to_string(int code);
-*/
+const char *mp_error_to_string(int code);
/* ---> init and deinit bignum functions <--- */
/* init a bignum */
@@ -256,8 +242,9 @@ int mp_init_size(mp_int *a, int size);
/* ---> Basic Manipulations <--- */
#define mp_iszero(a) (((a)->used == 0) ? MP_YES : MP_NO)
-#define mp_iseven(a) (((a)->used == 0 || (((a)->dp[0] & 1) == 0)) ? MP_YES : MP_NO)
-#define mp_isodd(a) (((a)->used > 0 && (((a)->dp[0] & 1) == 1)) ? MP_YES : MP_NO)
+#define mp_iseven(a) ((((a)->used == 0) || (((a)->dp[0] & 1u) == 0u)) ? MP_YES : MP_NO)
+#define mp_isodd(a) ((((a)->used > 0) && (((a)->dp[0] & 1u) == 1u)) ? MP_YES : MP_NO)
+#define mp_isneg(a) (((a)->sign != MP_ZPOS) ? MP_YES : MP_NO)
/* set to zero */
/*
@@ -274,9 +261,25 @@ void mp_set(mp_int *a, mp_digit b);
int mp_set_int(mp_int *a, unsigned long b);
*/
+/* set a platform dependent unsigned long value */
+/*
+int mp_set_long(mp_int *a, unsigned long b);
+*/
+
+/* set a platform dependent unsigned long long value */
+/*
+int mp_set_long_long(mp_int *a, unsigned long long b);
+*/
+
/* get a 32-bit value */
unsigned long mp_get_int(mp_int * a);
+/* get a platform dependent unsigned long value */
+unsigned long mp_get_long(mp_int * a);
+
+/* get a platform dependent unsigned long long value */
+unsigned long long mp_get_long_long(mp_int * a);
+
/* initialize and set a digit */
/*
int mp_init_set (mp_int * a, mp_digit b);
@@ -294,7 +297,7 @@ int mp_copy(const mp_int *a, mp_int *b);
/* inits and copies, a = b */
/*
-int mp_init_copy(mp_int *a, mp_int *b);
+int mp_init_copy(mp_int *a, const mp_int *b);
*/
/* trim unused digits */
@@ -302,6 +305,16 @@ int mp_init_copy(mp_int *a, mp_int *b);
void mp_clamp(mp_int *a);
*/
+/* import binary data */
+/*
+int mp_import(mp_int* rop, size_t count, int order, size_t size, int endian, size_t nails, const void* op);
+*/
+
+/* export binary data */
+/*
+int mp_export(void* rop, size_t* countp, int order, size_t size, int endian, size_t nails, mp_int* op);
+*/
+
/* ---> digit manipulation <--- */
/* right shift by "b" digits */
@@ -314,7 +327,7 @@ void mp_rshd(mp_int *a, int b);
int mp_lshd(mp_int *a, int b);
*/
-/* c = a / 2**b */
+/* c = a / 2**b, implemented as c = a >> b */
/*
int mp_div_2d(const mp_int *a, int b, mp_int *c, mp_int *d);
*/
@@ -324,7 +337,7 @@ int mp_div_2d(const mp_int *a, int b, mp_int *c, mp_int *d);
int mp_div_2(mp_int *a, mp_int *b);
*/
-/* c = a * 2**b */
+/* c = a * 2**b, implemented as c = a << b */
/*
int mp_mul_2d(const mp_int *a, int b, mp_int *c);
*/
@@ -334,7 +347,7 @@ int mp_mul_2d(const mp_int *a, int b, mp_int *c);
int mp_mul_2(mp_int *a, mp_int *b);
*/
-/* c = a mod 2**d */
+/* c = a mod 2**b */
/*
int mp_mod_2d(const mp_int *a, int b, mp_int *c);
*/
@@ -346,7 +359,7 @@ int mp_2expt(mp_int *a, int b);
/* Counts the number of lsbs which are zero before the first zero bit */
/*
-int mp_cnt_lsb(mp_int *a);
+int mp_cnt_lsb(const mp_int *a);
*/
/* I Love Earth! */
@@ -460,6 +473,9 @@ int mp_div_3(mp_int *a, mp_int *c, mp_digit *d);
/*
int mp_expt_d(mp_int *a, mp_digit b, mp_int *c);
*/
+/*
+int mp_expt_d_ex (mp_int * a, mp_digit b, mp_int * c, int fast);
+*/
/* c = a mod b, 0 <= c < b */
/*
@@ -515,12 +531,20 @@ int mp_lcm(mp_int *a, mp_int *b, mp_int *c);
/*
int mp_n_root(mp_int *a, mp_digit b, mp_int *c);
*/
+/*
+int mp_n_root_ex (mp_int * a, mp_digit b, mp_int * c, int fast);
+*/
/* special sqrt algo */
/*
int mp_sqrt(mp_int *arg, mp_int *ret);
*/
+/* special sqrt (mod prime) */
+/*
+int mp_sqrtmod_prime(mp_int *arg, mp_int *prime, mp_int *ret);
+*/
+
/* is number a square? */
/*
int mp_is_square(mp_int *arg, int *ret);
@@ -623,7 +647,7 @@ int mp_exptmod(mp_int *a, mp_int *b, mp_int *c, mp_int *d);
/* table of first PRIME_SIZE primes */
#if defined(BUILD_tcl) || !defined(_WIN32)
-MODULE_SCOPE const mp_digit ltm_prime_tab[];
+MODULE_SCOPE const mp_digit ltm_prime_tab[PRIME_SIZE];
#endif
/* result=1 if a is divisible by one of the first PRIME_SIZE primes */
@@ -646,7 +670,7 @@ int mp_prime_miller_rabin(mp_int *a, mp_int *b, int *result);
*/
/* This gives [for a given bit size] the number of trials required
- * such that Miller-Rabin gives a prob of failure lower than 2^-96
+ * such that Miller-Rabin gives a prob of failure lower than 2^-96
*/
/*
int mp_prime_rabin_miller_trials(int size);
@@ -673,7 +697,7 @@ int mp_prime_next_prime(mp_int *a, int t, int bbs_style);
*/
/* makes a truly random prime of a given size (bytes),
- * call with bbs = 1 if you want it to be congruent to 3 mod 4
+ * call with bbs = 1 if you want it to be congruent to 3 mod 4
*
* You have to supply a callback which fills in a buffer with random bytes. "dat" is a parameter you can
* have passed to the callback (e.g. a state or something). This function doesn't use "dat" itself
@@ -686,10 +710,9 @@ int mp_prime_next_prime(mp_int *a, int t, int bbs_style);
/* makes a truly random prime of a given size (bits),
*
* Flags are as follows:
- *
+ *
* LTM_PRIME_BBS - make prime congruent to 3 mod 4
* LTM_PRIME_SAFE - make sure (p-1)/2 is prime as well (implies LTM_PRIME_BBS)
- * LTM_PRIME_2MSB_OFF - make the 2nd highest bit zero
* LTM_PRIME_2MSB_ON - make the 2nd highest bit one
*
* You have to supply a callback which fills in a buffer with random bytes. "dat" is a parameter you can
@@ -742,15 +765,17 @@ int mp_toradix(mp_int *a, char *str, int radix);
int mp_toradix_n(mp_int * a, char *str, int radix, int maxlen);
*/
/*
-int mp_radix_size(mp_int *a, int radix, int *size);
+int mp_radix_size(const mp_int *a, int radix, int *size);
*/
+#ifndef LTM_NO_FILE
/*
int mp_fread(mp_int *a, int radix, FILE *stream);
*/
/*
int mp_fwrite(mp_int *a, int radix, FILE *stream);
*/
+#endif
#define mp_read_raw(mp, str, len) mp_read_signed_bin((mp), (str), (len))
#define mp_raw_size(mp) mp_signed_bin_size(mp)
@@ -764,69 +789,14 @@ int mp_fwrite(mp_int *a, int radix, FILE *stream);
#define mp_todecimal(M, S) mp_toradix((M), (S), 10)
#define mp_tohex(M, S) mp_toradix((M), (S), 16)
-/* lowlevel functions, do not call! */
-/*
-int s_mp_add(mp_int *a, mp_int *b, mp_int *c);
-*/
-/*
-int s_mp_sub(mp_int *a, mp_int *b, mp_int *c);
-*/
-#define s_mp_mul(a, b, c) s_mp_mul_digs(a, b, c, (a)->used + (b)->used + 1)
-/*
-int fast_s_mp_mul_digs(mp_int *a, mp_int *b, mp_int *c, int digs);
-*/
-/*
-int s_mp_mul_digs(mp_int *a, mp_int *b, mp_int *c, int digs);
-*/
-/*
-int fast_s_mp_mul_high_digs(mp_int *a, mp_int *b, mp_int *c, int digs);
-*/
-/*
-int s_mp_mul_high_digs(mp_int *a, mp_int *b, mp_int *c, int digs);
-*/
-/*
-int fast_s_mp_sqr(mp_int *a, mp_int *b);
-*/
-/*
-int s_mp_sqr(mp_int *a, mp_int *b);
-*/
-/*
-int mp_karatsuba_mul(mp_int *a, mp_int *b, mp_int *c);
-*/
-/*
-int mp_toom_mul(mp_int *a, mp_int *b, mp_int *c);
-*/
-/*
-int mp_karatsuba_sqr(mp_int *a, mp_int *b);
-*/
-/*
-int mp_toom_sqr(mp_int *a, mp_int *b);
-*/
-/*
-int fast_mp_invmod(mp_int *a, mp_int *b, mp_int *c);
-*/
-/*
-int mp_invmod_slow (mp_int * a, mp_int * b, mp_int * c);
-*/
-/*
-int fast_mp_montgomery_reduce(mp_int *a, mp_int *m, mp_digit mp);
-*/
-/*
-int mp_exptmod_fast(mp_int *G, mp_int *X, mp_int *P, mp_int *Y, int mode);
-*/
-/*
-int s_mp_exptmod (mp_int * G, mp_int * X, mp_int * P, mp_int * Y, int mode);
-*/
-/*
-void bn_reverse(unsigned char *s, int len);
-*/
-
-#if defined(BUILD_tcl) || !defined(_WIN32)
-MODULE_SCOPE const char *mp_s_rmap;
-#endif
-
#ifdef __cplusplus
-}
+ }
#endif
#endif
+
+
+/* $Source$ */
+/* $Revision$ */
+/* $Date$ */
+
diff --git a/generic/tclTomMathDecls.h b/generic/tclTomMathDecls.h
index 2ce9d5a..209c486 100644
--- a/generic/tclTomMathDecls.h
+++ b/generic/tclTomMathDecls.h
@@ -73,6 +73,7 @@
#define mp_div_d TclBN_mp_div_d
#define mp_exch TclBN_mp_exch
#define mp_expt_d TclBN_mp_expt_d
+#define mp_expt_d_ex TclBN_mp_expt_d_ex
#define mp_grow TclBN_mp_grow
#define mp_init TclBN_mp_init
#define mp_init_copy TclBN_mp_init_copy
@@ -190,7 +191,7 @@ EXTERN int TclBN_mp_grow(mp_int *a, int size);
/* 21 */
EXTERN int TclBN_mp_init(mp_int *a);
/* 22 */
-EXTERN int TclBN_mp_init_copy(mp_int *a, mp_int *b);
+EXTERN int TclBN_mp_init_copy(mp_int *a, const mp_int *b);
/* 23 */
EXTERN int TclBN_mp_init_multi(mp_int *a, ...);
/* 24 */
@@ -216,7 +217,8 @@ EXTERN int TclBN_mp_neg(const mp_int *a, mp_int *b);
/* 34 */
EXTERN int TclBN_mp_or(mp_int *a, mp_int *b, mp_int *c);
/* 35 */
-EXTERN int TclBN_mp_radix_size(mp_int *a, int radix, int *size);
+EXTERN int TclBN_mp_radix_size(const mp_int *a, int radix,
+ int *size);
/* 36 */
EXTERN int TclBN_mp_read_radix(mp_int *a, const char *str,
int radix);
@@ -287,6 +289,9 @@ EXTERN void TclBNInitBignumFromWideInt(mp_int *bignum,
/* 66 */
EXTERN void TclBNInitBignumFromWideUInt(mp_int *bignum,
Tcl_WideUInt initVal);
+/* 67 */
+EXTERN int TclBN_mp_expt_d_ex(mp_int *a, mp_digit b, mp_int *c,
+ int fast);
typedef struct TclTomMathStubs {
int magic;
@@ -314,7 +319,7 @@ typedef struct TclTomMathStubs {
int (*tclBN_mp_expt_d) (mp_int *a, mp_digit b, mp_int *c); /* 19 */
int (*tclBN_mp_grow) (mp_int *a, int size); /* 20 */
int (*tclBN_mp_init) (mp_int *a); /* 21 */
- int (*tclBN_mp_init_copy) (mp_int *a, mp_int *b); /* 22 */
+ int (*tclBN_mp_init_copy) (mp_int *a, const mp_int *b); /* 22 */
int (*tclBN_mp_init_multi) (mp_int *a, ...); /* 23 */
int (*tclBN_mp_init_set) (mp_int *a, mp_digit b); /* 24 */
int (*tclBN_mp_init_size) (mp_int *a, int size); /* 25 */
@@ -327,7 +332,7 @@ typedef struct TclTomMathStubs {
int (*tclBN_mp_mul_2d) (const mp_int *a, int d, mp_int *p); /* 32 */
int (*tclBN_mp_neg) (const mp_int *a, mp_int *b); /* 33 */
int (*tclBN_mp_or) (mp_int *a, mp_int *b, mp_int *c); /* 34 */
- int (*tclBN_mp_radix_size) (mp_int *a, int radix, int *size); /* 35 */
+ int (*tclBN_mp_radix_size) (const mp_int *a, int radix, int *size); /* 35 */
int (*tclBN_mp_read_radix) (mp_int *a, const char *str, int radix); /* 36 */
void (*tclBN_mp_rshd) (mp_int *a, int shift); /* 37 */
int (*tclBN_mp_shrink) (mp_int *a); /* 38 */
@@ -359,6 +364,7 @@ typedef struct TclTomMathStubs {
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 */
+ int (*tclBN_mp_expt_d_ex) (mp_int *a, mp_digit b, mp_int *c, int fast); /* 67 */
} TclTomMathStubs;
extern const TclTomMathStubs *tclTomMathStubsPtr;
@@ -507,6 +513,8 @@ extern const TclTomMathStubs *tclTomMathStubsPtr;
(tclTomMathStubsPtr->tclBNInitBignumFromWideInt) /* 65 */
#define TclBNInitBignumFromWideUInt \
(tclTomMathStubsPtr->tclBNInitBignumFromWideUInt) /* 66 */
+#define TclBN_mp_expt_d_ex \
+ (tclTomMathStubsPtr->tclBN_mp_expt_d_ex) /* 67 */
#endif /* defined(USE_TCL_STUBS) */
diff --git a/generic/tclTrace.c b/generic/tclTrace.c
index 0c73cba..f86f472 100644
--- a/generic/tclTrace.c
+++ b/generic/tclTrace.c
@@ -52,7 +52,7 @@ typedef struct {
* invoked step trace */
int curFlags; /* Trace flags for the current command */
int curCode; /* Return code for the current command */
- int refCount; /* Used to ensure this structure is not
+ size_t refCount; /* Used to ensure this structure is not
* deleted too early. Keeps track of how many
* pieces of code have a pointer to this
* structure. */
@@ -2819,6 +2819,7 @@ DisposeTraceResult(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_UntraceVar
void
Tcl_UntraceVar(
@@ -2834,6 +2835,7 @@ Tcl_UntraceVar(
{
Tcl_UntraceVar2(interp, varName, NULL, flags, proc, clientData);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -2988,6 +2990,7 @@ Tcl_UntraceVar2(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_VarTraceInfo
ClientData
Tcl_VarTraceInfo(
@@ -3005,6 +3008,7 @@ Tcl_VarTraceInfo(
return Tcl_VarTraceInfo2(interp, varName, NULL, flags, proc,
prevClientData);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -3097,6 +3101,7 @@ Tcl_VarTraceInfo2(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_TraceVar
int
Tcl_TraceVar(
@@ -3114,6 +3119,7 @@ Tcl_TraceVar(
{
return Tcl_TraceVar2(interp, varName, NULL, flags, proc, clientData);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index f0c7f77..91cc3b4 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -1384,7 +1384,7 @@ TclConvertElement(
*/
if ((src == NULL) || (length == 0) || (*src == '\0' && length == -1)) {
- src = tclEmptyStringRep;
+ src = &tclEmptyString;
length = 0;
conversion = CONVERT_BRACE;
}
@@ -2894,7 +2894,6 @@ Tcl_DStringResult(
Tcl_DString *dsPtr) /* Dynamic string that is to become the
* result of interp. */
{
- Tcl_ResetResult(interp);
Tcl_SetObjResult(interp, TclDStringToObj(dsPtr));
}
@@ -2924,6 +2923,14 @@ Tcl_DStringGetResult(
Tcl_DString *dsPtr) /* Dynamic string that is to become the result
* of interp. */
{
+#ifdef TCL_NO_DEPRECATED
+ Tcl_Obj *obj = Tcl_GetObjResult(interp);
+ const char *bytes = TclGetString(obj);
+
+ Tcl_DStringFree(dsPtr);
+ Tcl_DStringAppend(dsPtr, bytes, obj->length);
+ Tcl_ResetResult(interp);
+#else
Interp *iPtr = (Interp *) interp;
if (dsPtr->string != dsPtr->staticSpace) {
@@ -2932,7 +2939,7 @@ Tcl_DStringGetResult(
/*
* Do more efficient transfer when we know the result is a Tcl_Obj. When
- * there's no st`ring result, we only have to deal with two cases:
+ * there's no string result, we only have to deal with two cases:
*
* 1. When the string rep is the empty string, when we don't copy but
* instead use the staticSpace in the DString to hold an empty string.
@@ -2947,17 +2954,17 @@ Tcl_DStringGetResult(
if (!iPtr->result[0] && iPtr->objResultPtr
&& !Tcl_IsShared(iPtr->objResultPtr)) {
- if (iPtr->objResultPtr->bytes == tclEmptyStringRep) {
+ if (iPtr->objResultPtr->bytes == &tclEmptyString) {
dsPtr->string = dsPtr->staticSpace;
dsPtr->string[0] = 0;
dsPtr->length = 0;
dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
} else {
- dsPtr->string = Tcl_GetString(iPtr->objResultPtr);
+ dsPtr->string = TclGetString(iPtr->objResultPtr);
dsPtr->length = iPtr->objResultPtr->length;
dsPtr->spaceAvl = dsPtr->length + 1;
TclFreeIntRep(iPtr->objResultPtr);
- iPtr->objResultPtr->bytes = tclEmptyStringRep;
+ iPtr->objResultPtr->bytes = &tclEmptyString;
iPtr->objResultPtr->length = 0;
}
return;
@@ -2995,6 +3002,7 @@ Tcl_DStringGetResult(
iPtr->result = iPtr->resultSpace;
iPtr->resultSpace[0] = 0;
+#endif /* !TCL_NO_DEPRECATED */
}
/*
@@ -3145,7 +3153,7 @@ Tcl_PrintDouble(
int signum;
char *digits;
char *end;
- int *precisionPtr = Tcl_GetThreadData(&precisionKey, (int) sizeof(int));
+ int *precisionPtr = Tcl_GetThreadData(&precisionKey, sizeof(int));
/*
* Handle NaN.
@@ -3318,7 +3326,7 @@ TclPrecTraceProc(
{
Tcl_Obj *value;
int prec;
- int *precisionPtr = Tcl_GetThreadData(&precisionKey, (int) sizeof(int));
+ int *precisionPtr = Tcl_GetThreadData(&precisionKey, sizeof(int));
/*
* If the variable is unset, then recreate the trace.
@@ -3576,7 +3584,7 @@ TclGetIntForIndex(
int *indexPtr) /* Location filled in with an integer
* representing an index. */
{
- int length;
+ size_t length;
char *opPtr;
const char *bytes;
@@ -3594,7 +3602,8 @@ TclGetIntForIndex(
return TCL_OK;
}
- bytes = TclGetStringFromObj(objPtr, &length);
+ bytes = TclGetString(objPtr);
+ length = objPtr->length;
/*
* Leading whitespace is acceptable in an index.
@@ -3639,7 +3648,7 @@ TclGetIntForIndex(
parseError:
if (interp != NULL) {
- bytes = Tcl_GetString(objPtr);
+ bytes = TclGetString(objPtr);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad index \"%s\": must be integer?[+-]integer? or"
" end?[+-]integer?", bytes));
@@ -4000,9 +4009,10 @@ TclSetProcessGlobalValue(
} else {
Tcl_CreateExitHandler(FreeProcessGlobalValue, pgvPtr);
}
- bytes = TclGetStringFromObj(newValue, &pgvPtr->numBytes);
+ bytes = TclGetString(newValue);
+ pgvPtr->numBytes = newValue->length;
pgvPtr->value = ckalloc(pgvPtr->numBytes + 1);
- memcpy(pgvPtr->value, bytes, (unsigned) pgvPtr->numBytes + 1);
+ memcpy(pgvPtr->value, bytes, pgvPtr->numBytes + 1);
if (pgvPtr->encoding) {
Tcl_FreeEncoding(pgvPtr->encoding);
}
@@ -4017,7 +4027,7 @@ TclSetProcessGlobalValue(
Tcl_IncrRefCount(newValue);
cacheMap = GetThreadHash(&pgvPtr->key);
ClearHash(cacheMap);
- hPtr = Tcl_CreateHashEntry(cacheMap, INT2PTR(pgvPtr->epoch), &dummy);
+ hPtr = Tcl_CreateHashEntry(cacheMap, (void *)(pgvPtr->epoch), &dummy);
Tcl_SetHashValue(hPtr, newValue);
Tcl_MutexUnlock(&pgvPtr->mutex);
}
@@ -4043,7 +4053,7 @@ TclGetProcessGlobalValue(
Tcl_Obj *value = NULL;
Tcl_HashTable *cacheMap;
Tcl_HashEntry *hPtr;
- int epoch = pgvPtr->epoch;
+ size_t epoch = pgvPtr->epoch;
if (pgvPtr->encoding) {
Tcl_Encoding current = Tcl_GetEncoding(NULL, NULL);
@@ -4058,8 +4068,7 @@ TclGetProcessGlobalValue(
Tcl_DString native, newValue;
Tcl_MutexLock(&pgvPtr->mutex);
- pgvPtr->epoch++;
- epoch = pgvPtr->epoch;
+ epoch = ++pgvPtr->epoch;
Tcl_UtfToExternalDString(pgvPtr->encoding, pgvPtr->value,
pgvPtr->numBytes, &native);
Tcl_ExternalToUtfDString(current, Tcl_DStringValue(&native),
@@ -4078,7 +4087,7 @@ TclGetProcessGlobalValue(
}
}
cacheMap = GetThreadHash(&pgvPtr->key);
- hPtr = Tcl_FindHashEntry(cacheMap, (char *) INT2PTR(epoch));
+ hPtr = Tcl_FindHashEntry(cacheMap, (void *) (epoch));
if (NULL == hPtr) {
int dummy;
@@ -4111,7 +4120,7 @@ TclGetProcessGlobalValue(
value = Tcl_NewStringObj(pgvPtr->value, pgvPtr->numBytes);
hPtr = Tcl_CreateHashEntry(cacheMap,
- INT2PTR(pgvPtr->epoch), &dummy);
+ (void *)(pgvPtr->epoch), &dummy);
Tcl_MutexUnlock(&pgvPtr->mutex);
Tcl_SetHashValue(hPtr, value);
Tcl_IncrRefCount(value);
@@ -4194,11 +4203,10 @@ TclGetObjNameOfExecutable(void)
const char *
Tcl_GetNameOfExecutable(void)
{
- int numBytes;
- const char *bytes =
- Tcl_GetStringFromObj(TclGetObjNameOfExecutable(), &numBytes);
+ Tcl_Obj *obj = TclGetObjNameOfExecutable();
+ const char *bytes = TclGetString(obj);
- if (numBytes == 0) {
+ if (obj->length == 0) {
return NULL;
}
return bytes;
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 48e09f6..1947c8d 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -1067,6 +1067,7 @@ TclLookupArrayElement(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_GetVar
const char *
Tcl_GetVar(
@@ -1087,6 +1088,7 @@ Tcl_GetVar(
}
return TclGetString(resultPtr);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -1410,6 +1412,7 @@ Tcl_SetObjCmd(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_SetVar
const char *
Tcl_SetVar(
@@ -1422,18 +1425,15 @@ Tcl_SetVar(
* TCL_APPEND_VALUE, TCL_LIST_ELEMENT,
* TCL_LEAVE_ERR_MSG. */
{
- Tcl_Obj *varValuePtr, *varNamePtr = Tcl_NewStringObj(varName, -1);
-
- Tcl_IncrRefCount(varNamePtr);
- varValuePtr = Tcl_ObjSetVar2(interp, varNamePtr, NULL,
+ Tcl_Obj *varValuePtr = Tcl_SetVar2Ex(interp, varName, NULL,
Tcl_NewStringObj(newValue, -1), flags);
- Tcl_DecrRefCount(varNamePtr);
if (varValuePtr == NULL) {
return NULL;
}
return TclGetString(varValuePtr);
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -2005,6 +2005,7 @@ TclPtrIncrObjVar(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_UnsetVar
int
Tcl_UnsetVar(
@@ -2033,6 +2034,7 @@ Tcl_UnsetVar(
Tcl_DecrRefCount(varNamePtr);
return result;
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
@@ -2754,7 +2756,7 @@ TclArraySet(
} else {
/*
* Not a dictionary, so assume (and convert to, for backward-
- * -compatability reasons) a list.
+ * -compatibility reasons) a list.
*/
int elemLen;
@@ -4050,7 +4052,7 @@ TclInitArrayCmd(
*
* Results:
* A standard Tcl completion code. If an error occurs then an error
- * message is left in iPtr->result.
+ * message is left in interp.
*
* Side effects:
* The variable given by myName is linked to the variable in framePtr
@@ -4144,7 +4146,7 @@ ObjMakeUpvar(
*
* Results:
* A standard Tcl completion code. If an error occurs then an error
- * message is left in iPtr->result.
+ * message is left in interp.
*
* Side effects:
* The variable given by myName is linked to the variable in framePtr
@@ -4320,6 +4322,7 @@ TclPtrObjMakeUpvar(
*----------------------------------------------------------------------
*/
+#ifndef TCL_NO_DEPRECATED
#undef Tcl_UpVar
int
Tcl_UpVar(
@@ -4353,6 +4356,7 @@ Tcl_UpVar(
Tcl_DecrRefCount(localNamePtr);
return result;
}
+#endif /* TCL_NO_DEPRECATED */
/*
*----------------------------------------------------------------------
diff --git a/generic/tclZlib.c b/generic/tclZlib.c
index a7e8a8a..96b8318 100644
--- a/generic/tclZlib.c
+++ b/generic/tclZlib.c
@@ -177,6 +177,8 @@ static Tcl_ObjCmdProc ZlibStreamPutCmd;
static void ConvertError(Tcl_Interp *interp, int code,
uLong adler);
static Tcl_Obj * ConvertErrorToList(int code, uLong adler);
+static inline int Deflate(z_streamp strm, void *bufferPtr,
+ int bufferSize, int flush, int *writtenPtr);
static void ExtractHeader(gz_header *headerPtr, Tcl_Obj *dictObj);
static int GenerateHeader(Tcl_Interp *interp, Tcl_Obj *dictObj,
GzipHeader *headerPtr, int *extraSizePtr);
@@ -371,7 +373,7 @@ ConvertErrorToList(
default:
TclNewLiteralStringObj(objv[2], "UNKNOWN");
- TclNewIntObj(objv[3], code);
+ TclNewLongObj(objv[3], code);
return Tcl_NewListObj(4, objv);
}
}
@@ -578,6 +580,10 @@ ExtractHeader(
}
}
+/*
+ * Disentangle the worst of how the zlib API is used.
+ */
+
static int
SetInflateDictionary(
z_streamp strm,
@@ -605,6 +611,38 @@ SetDeflateDictionary(
}
return Z_OK;
}
+
+static inline int
+Deflate(
+ z_streamp strm,
+ void *bufferPtr,
+ int bufferSize,
+ int flush,
+ int *writtenPtr)
+{
+ int e;
+
+ strm->next_out = (Bytef *) bufferPtr;
+ strm->avail_out = (unsigned) bufferSize;
+ e = deflate(strm, flush);
+ if (writtenPtr != NULL) {
+ *writtenPtr = bufferSize - strm->avail_out;
+ }
+ return e;
+}
+
+static inline void
+AppendByteArray(
+ Tcl_Obj *listObj,
+ void *buffer,
+ int size)
+{
+ if (size > 0) {
+ Tcl_Obj *baObj = Tcl_NewByteArrayObj((unsigned char *) buffer, size);
+
+ Tcl_ListObjAppendElement(NULL, listObj, baObj);
+ }
+}
/*
*----------------------------------------------------------------------
@@ -1139,6 +1177,8 @@ Tcl_ZlibStreamSetCompressionDictionary(
*----------------------------------------------------------------------
*/
+#define BUFFER_SIZE_LIMIT 0xFFFF
+
int
Tcl_ZlibStreamPut(
Tcl_ZlibStream zshandle, /* As obtained from Tcl_ZlibStreamInit */
@@ -1148,8 +1188,7 @@ Tcl_ZlibStreamPut(
{
ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle;
char *dataTmp = NULL;
- int e, size, outSize;
- Tcl_Obj *obj;
+ int e, size, outSize, toStore;
if (zshPtr->streamEnd) {
if (zshPtr->interp) {
@@ -1165,36 +1204,55 @@ Tcl_ZlibStreamPut(
zshPtr->stream.avail_in = size;
/*
- * Must not do a zero-length compress. [Bug 25842c161]
+ * Must not do a zero-length compress unless finalizing. [Bug 25842c161]
*/
- if (size == 0) {
+ if (size == 0 && flush != Z_FINISH) {
return TCL_OK;
}
if (HaveDictToSet(zshPtr)) {
e = SetDeflateDictionary(&zshPtr->stream, zshPtr->compDictObj);
if (e != Z_OK) {
- if (zshPtr->interp) {
- ConvertError(zshPtr->interp, e, zshPtr->stream.adler);
- }
+ ConvertError(zshPtr->interp, e, zshPtr->stream.adler);
return TCL_ERROR;
}
DictWasSet(zshPtr);
}
/*
- * Deflatebound doesn't seem to take various header sizes into
- * account, so we add 100 extra bytes.
+ * deflateBound() doesn't seem to take various header sizes into
+ * account, so we add 100 extra bytes. However, we can also loop
+ * around again so we also set an upper bound on the output buffer
+ * size.
*/
- outSize = deflateBound(&zshPtr->stream, zshPtr->stream.avail_in)+100;
- zshPtr->stream.avail_out = outSize;
- dataTmp = ckalloc(zshPtr->stream.avail_out);
- zshPtr->stream.next_out = (Bytef *) dataTmp;
+ outSize = deflateBound(&zshPtr->stream, size) + 100;
+ if (outSize > BUFFER_SIZE_LIMIT) {
+ outSize = BUFFER_SIZE_LIMIT;
+ }
+ dataTmp = ckalloc(outSize);
+
+ while (1) {
+ e = Deflate(&zshPtr->stream, dataTmp, outSize, flush, &toStore);
+
+ /*
+ * Test if we've filled the buffer up and have to ask deflate() to
+ * give us some more. Note that the condition for needing to
+ * repeat a buffer transfer when the result is Z_OK is whether
+ * there is no more space in the buffer we provided; the zlib
+ * library does not necessarily return a different code in that
+ * case. [Bug b26e38a3e4] [Tk Bug 10f2e7872b]
+ */
+
+ if ((e != Z_BUF_ERROR) && (e != Z_OK || toStore < outSize)) {
+ if ((e == Z_OK) || (flush == Z_FINISH && e == Z_STREAM_END)) {
+ break;
+ }
+ ConvertError(zshPtr->interp, e, zshPtr->stream.adler);
+ return TCL_ERROR;
+ }
- e = deflate(&zshPtr->stream, flush);
- while (e == Z_BUF_ERROR || (flush == Z_FINISH && e == Z_OK)) {
/*
* Output buffer too small to hold the data being generated or we
* are doing the end-of-stream flush (which can spit out masses of
@@ -1202,45 +1260,21 @@ Tcl_ZlibStreamPut(
* saving the old generated data to the outData list.
*/
- obj = Tcl_NewByteArrayObj((unsigned char *) dataTmp, outSize);
- Tcl_ListObjAppendElement(NULL, zshPtr->outData, obj);
+ AppendByteArray(zshPtr->outData, dataTmp, outSize);
- if (outSize < 0xFFFF) {
- outSize = 0xFFFF; /* There may be *lots* of data left to
- * output... */
+ if (outSize < BUFFER_SIZE_LIMIT) {
+ outSize = BUFFER_SIZE_LIMIT;
+ /* There may be *lots* of data left to output... */
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);
- }
- return TCL_ERROR;
}
/*
- * And append the final data block.
+ * And append the final data block to the outData list.
*/
- if (outSize - zshPtr->stream.avail_out > 0) {
- obj = Tcl_NewByteArrayObj((unsigned char *) dataTmp,
- outSize - zshPtr->stream.avail_out);
-
- /*
- * Now append the compressed data to the outData list.
- */
-
- Tcl_ListObjAppendElement(NULL, zshPtr->outData, obj);
- }
-
- if (dataTmp) {
- ckfree(dataTmp);
- }
+ AppendByteArray(zshPtr->outData, dataTmp, toStore);
+ ckfree(dataTmp);
} else {
/*
* This is easy. Just append to the inData list.
@@ -1356,9 +1390,7 @@ Tcl_ZlibStreamGet(
if (IsRawStream(zshPtr) && HaveDictToSet(zshPtr)) {
e = SetInflateDictionary(&zshPtr->stream, zshPtr->compDictObj);
if (e != Z_OK) {
- if (zshPtr->interp) {
- ConvertError(zshPtr->interp, e, zshPtr->stream.adler);
- }
+ ConvertError(zshPtr->interp, e, zshPtr->stream.adler);
return TCL_ERROR;
}
DictWasSet(zshPtr);
@@ -2879,10 +2911,8 @@ ZlibTransformClose(
if (cd->mode == TCL_ZLIB_STREAM_DEFLATE) {
cd->outStream.avail_in = 0;
do {
- cd->outStream.next_out = (Bytef *) cd->outBuffer;
- cd->outStream.avail_out = (unsigned) cd->outAllocated;
- e = deflate(&cd->outStream, Z_FINISH);
- written = cd->outAllocated - cd->outStream.avail_out;
+ e = Deflate(&cd->outStream, cd->outBuffer, cd->outAllocated,
+ Z_FINISH, &written);
/*
* Can't be sure that deflate() won't declare the buffer to be
@@ -3086,17 +3116,15 @@ ZlibTransformOutput(
cd->outStream.next_in = (Bytef *) buf;
cd->outStream.avail_in = toWrite;
do {
- cd->outStream.next_out = (Bytef *) cd->outBuffer;
- cd->outStream.avail_out = cd->outAllocated;
-
- e = deflate(&cd->outStream, Z_NO_FLUSH);
- produced = cd->outAllocated - cd->outStream.avail_out;
+ e = Deflate(&cd->outStream, cd->outBuffer, cd->outAllocated,
+ Z_NO_FLUSH, &produced);
if ((e == Z_OK && produced > 0) || e == Z_BUF_ERROR) {
/*
* deflate() indicates that it is out of space by returning
- * Z_BUF_ERROR; in that case, we must write the whole buffer out
- * and retry to compress what is left.
+ * Z_BUF_ERROR *or* by simply returning Z_OK with no remaining
+ * space; in either case, we must write the whole buffer out and
+ * retry to compress what is left.
*/
if (e == Z_BUF_ERROR) {
@@ -3149,10 +3177,8 @@ ZlibTransformFlush(
* 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);
+ e = Deflate(&cd->outStream, cd->outBuffer, cd->outAllocated,
+ flushType, &len);
if (e != Z_OK && e != Z_BUF_ERROR) {
ConvertError(interp, e, cd->outStream.adler);
return TCL_ERROR;
@@ -3162,7 +3188,6 @@ ZlibTransformFlush(
* 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",