diff options
Diffstat (limited to 'generic')
95 files changed, 3202 insertions, 7393 deletions
diff --git a/generic/regc_lex.c b/generic/regc_lex.c index 4c8f15f..affcb48 100644 --- a/generic/regc_lex.c +++ b/generic/regc_lex.c @@ -457,7 +457,7 @@ next( if (ATEOS()) { FAILW(REG_EESCAPE); } - (void)lexescape(v); + (DISCARD)lexescape(v); switch (v->nexttype) { /* not all escapes okay here */ case PLAIN: return 1; @@ -716,7 +716,7 @@ next( } RETV(PLAIN, *v->now++); } - (void)lexescape(v); + (DISCARD)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(void); + ^ static chr newline(NOPARMS); */ static chr newline(void) diff --git a/generic/regc_locale.c b/generic/regc_locale.c index ab3b7f1..a6958fe 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((void*)(x), (void*)(y), len*sizeof(chr)); + return memcmp(VS(x), VS(y), len*sizeof(chr)); } /* diff --git a/generic/regc_nfa.c b/generic/regc_nfa.c index 240fcfe..088c6c0 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 58d55fb..211cd70 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(void); +static chr newline(NOPARMS); 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 = (void*)(&functions); + re->re_fns = VS(&functions); /* * More complex setup, malloced things. */ - re->re_guts = (void*)(MALLOC(sizeof(struct guts))); + re->re_guts = VS(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. */ - (void) optimize(v->nfa, debug); + (DISCARD) 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) { - (void) nfatree(v, t->left, f); + (DISCARD) nfatree(v, t->left, f); } if (t->right != NULL) { - (void) nfatree(v, t->right, f); + (DISCARD) nfatree(v, t->right, f); } return nfanode(v, t, f); diff --git a/generic/regcustom.h b/generic/regcustom.h index c4dbc73..681b97d 100644 --- a/generic/regcustom.h +++ b/generic/regcustom.h @@ -36,9 +36,10 @@ * Overrides for regguts.h definitions, if any. */ -#define MALLOC(n) (void*)(attemptckalloc(n)) -#define FREE(p) ckfree((void*)(p)) -#define REALLOC(p,n) (void*)(attemptckrealloc((void*)(p),n)) +#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)) /* * Do not insert extras between the "begin" and "end" lines - this chunk is diff --git a/generic/regexec.c b/generic/regexec.c index 128d439..6d12827 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((void*)(bv), (void*)((ss)->states), (nw)*sizeof(unsigned)) == 0)) + memcmp(VS(bv), VS((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((void*)(pmatch), (void*)(v->pmatch), n*sizeof(regmatch_t)); + memcpy(VS(pmatch), VS(v->pmatch), n*sizeof(regmatch_t)); } /* diff --git a/generic/regguts.h b/generic/regguts.h index ad9d5b9..1ac2465 100644 --- a/generic/regguts.h +++ b/generic/regguts.h @@ -49,15 +49,41 @@ #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(p, n) +#define REALLOC(p, n) realloc(VS(p), n) #endif #ifndef FREE -#define FREE(p) free(p) +#define FREE(p) free(VS(p)) #endif /* want size of a char in bits, and max value in bounded quantifiers */ @@ -382,7 +408,7 @@ struct subre { */ struct fns { - void (*free) (regex_t *); + void FUNCPTR(free, (regex_t *)); }; /* @@ -399,7 +425,7 @@ struct guts { struct cnfa search; /* for fast preliminary search */ int ntree; /* number of subre's, plus one */ struct colormap cmap; - int (*compare) (const chr *, const chr *, size_t); + int FUNCPTR(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 ba047a0..574b49b 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2326,17 +2326,6 @@ 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 d678229..759f824 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -38,10 +38,9 @@ extern "C" { * update the version numbers: * * library/init.tcl (1 LOC patch) - * unix/configure.ac (2 LOC Major, 2 LOC minor, 1 LOC patch) - * win/configure.ac (as above) + * unix/configure.in (2 LOC Major, 2 LOC minor, 1 LOC patch) + * win/configure.in (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 @@ -54,12 +53,12 @@ extern "C" { */ #define TCL_MAJOR_VERSION 8 -#define TCL_MINOR_VERSION 7 -#define TCL_RELEASE_LEVEL TCL_ALPHA_RELEASE -#define TCL_RELEASE_SERIAL 0 +#define TCL_MINOR_VERSION 6 +#define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE +#define TCL_RELEASE_SERIAL 6 -#define TCL_VERSION "8.7" -#define TCL_PATCH_LEVEL "8.7a0" +#define TCL_VERSION "8.6" +#define TCL_PATCH_LEVEL "8.6.6" /* *---------------------------------------------------------------------------- @@ -144,7 +143,6 @@ extern "C" { #if defined(__GNUC__) && (__GNUC__ > 2) # define TCL_FORMAT_PRINTF(a,b) __attribute__ ((__format__ (__printf__, a, b))) # define TCL_NORETURN __attribute__ ((noreturn)) -# define TCL_NOINLINE __attribute__ ((noinline)) # if defined(BUILD_tcl) || defined(BUILD_tk) # define TCL_NORETURN1 __attribute__ ((noreturn)) # else @@ -154,10 +152,8 @@ extern "C" { # define TCL_FORMAT_PRINTF(a,b) # if defined(_MSC_VER) && (_MSC_VER >= 1310) # define TCL_NORETURN _declspec(noreturn) -# define TCL_NOINLINE __declspec(noinline) # else # define TCL_NORETURN /* nothing */ -# define TCL_NOINLINE /* nothing */ # endif # define TCL_NORETURN1 /* nothing */ #endif @@ -376,8 +372,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. @@ -831,20 +827,19 @@ 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. - * Many uses in Tcl, including a bignum's + * the main use of which is 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; @@ -1147,13 +1142,8 @@ 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 @@ -1163,21 +1153,29 @@ typedef struct Tcl_DString { * Forward declarations of Tcl_HashTable and related types. */ -#ifndef TCL_HASH_TYPE -# define TCL_HASH_TYPE unsigned -#endif - typedef struct Tcl_HashKeyType Tcl_HashKeyType; typedef struct Tcl_HashTable Tcl_HashTable; typedef struct Tcl_HashEntry Tcl_HashEntry; -typedef TCL_HASH_TYPE (Tcl_HashKeyProc) (Tcl_HashTable *tablePtr, void *keyPtr); +typedef unsigned (Tcl_HashKeyProc) (Tcl_HashTable *tablePtr, void *keyPtr); typedef int (Tcl_CompareHashKeysProc) (void *keyPtr, Tcl_HashEntry *hPtr); typedef Tcl_HashEntry * (Tcl_AllocHashEntryProc) (Tcl_HashTable *tablePtr, void *keyPtr); typedef void (Tcl_FreeHashEntryProc) (Tcl_HashEntry *hPtr); /* + * This flag controls whether the hash table stores the hash of a key, or + * recalculates it. There should be no reason for turning this flag off as it + * is completely binary and source compatible unless you directly access the + * bucketPtr member of the Tcl_HashTableEntry structure. This member has been + * removed and the space used to store the hash value. + */ + +#ifndef TCL_HASH_KEY_STORE_HASH +# define TCL_HASH_KEY_STORE_HASH 1 +#endif + +/* * Structure definition for an entry in a hash table. No-one outside Tcl * should access any of these fields directly; use the macros defined below. */ @@ -1186,9 +1184,15 @@ struct Tcl_HashEntry { Tcl_HashEntry *nextPtr; /* Pointer to next entry in this hash bucket, * or NULL for end of chain. */ Tcl_HashTable *tablePtr; /* Pointer to table containing entry. */ +#if TCL_HASH_KEY_STORE_HASH void *hash; /* Hash value, stored as pointer to ensure * that the offsets of the fields in this * structure are not changed. */ +#else + Tcl_HashEntry **bucketPtr; /* Pointer to bucket that points to first + * entry in this entry's chain: used for + * deleting the entry. */ +#endif ClientData clientData; /* Application stores something here with * Tcl_SetHashValue. */ union { /* Key has one of these forms: */ @@ -2377,13 +2381,6 @@ 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. */ @@ -2394,6 +2391,9 @@ typedef int (Tcl_NRPostProc) (ClientData data[], Tcl_Interp *interp, *---------------------------------------------------------------------------- * The following constant is used to test for older versions of Tcl in the * stubs tables. + * + * Jan Nijtman's plus patch uses 0xFCA1BACF, so we need to pick a different + * value since the stubs tables don't match. */ #define TCL_STUB_MAGIC ((int) 0xFCA3BACF) @@ -2406,22 +2406,24 @@ typedef int (Tcl_NRPostProc) (ClientData data[], Tcl_Interp *interp, */ const char * Tcl_InitStubs(Tcl_Interp *interp, const char *version, - int exact, int magic); + int exact); const char * TclTomMathInitializeStubs(Tcl_Interp *interp, const char *version, int epoch, int revision); -#ifdef USE_TCL_STUBS -#define Tcl_InitStubs(interp, version, exact) \ - (Tcl_InitStubs)(interp, version, \ - (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \ - TCL_STUB_MAGIC) -#else +/* + * When not using stubs, make it a macro. + */ + +#ifndef USE_TCL_STUBS #define Tcl_InitStubs(interp, version, exact) \ - Tcl_PkgInitStubsCheck(interp, version, \ - (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16)) + Tcl_PkgInitStubsCheck(interp, version, exact) #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] */ diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c index 64df1a2..cda1f38 100644 --- a/generic/tclAlloc.c +++ b/generic/tclAlloc.c @@ -32,7 +32,7 @@ */ #if defined(_MSC_VER) || defined(__MSVCRT__) || defined(__BORLANDC__) -typedef size_t caddr_t; +typedef unsigned long caddr_t; #endif /* @@ -56,7 +56,7 @@ union overhead { unsigned char magic1; /* other magic number */ #ifndef NDEBUG unsigned short rmagic; /* range magic number */ - size_t size; /* actual block size */ + unsigned long 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 size_t numMallocs[NBUCKETS+1]; +static unsigned int numMallocs[NBUCKETS+1]; #endif #if !defined(NDEBUG) @@ -148,7 +148,7 @@ static size_t numMallocs[NBUCKETS+1]; * Prototypes for functions used only in this file. */ -static void MoreCore(size_t bucket); +static void MoreCore(int bucket); /* *------------------------------------------------------------------------- @@ -254,7 +254,7 @@ TclpAlloc( unsigned int numBytes) /* Number of bytes to allocate. */ { register union overhead *overPtr; - register size_t bucket; + register long bucket; register unsigned amount; struct block *bigBlockPtr = NULL; @@ -385,12 +385,12 @@ TclpAlloc( static void MoreCore( - size_t bucket) /* What bucket to allocate to. */ + int bucket) /* What bucket to allocat to. */ { register union overhead *overPtr; - register size_t size; /* size of desired block */ - size_t amount; /* amount to allocate */ - size_t numBlocks; /* how many blocks we get */ + register long size; /* size of desired block */ + long amount; /* amount to allocate */ + int numBlocks; /* how many blocks we get */ struct block *blockPtr; /* @@ -398,14 +398,14 @@ MoreCore( * VAX, I think) or for a negative arg. */ - size = ((size_t)1) << (bucket + 3); + size = 1 << (bucket + 3); ASSERT(size > 0); amount = MAXMALLOC; numBlocks = amount / size; ASSERT(numBlocks*size == amount); - blockPtr = (struct block *) TclpSysAlloc( + blockPtr = (struct block *) TclpSysAlloc((unsigned) (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 size_t size; + register long size; register union overhead *overPtr; struct block *bigBlockPtr; @@ -518,7 +518,7 @@ TclpRealloc( union overhead *overPtr; struct block *bigBlockPtr; int expensive; - size_t maxSize; + unsigned long maxSize; if (oldPtr == NULL) { return TclpAlloc(numBytes); @@ -645,30 +645,30 @@ void mstats( char *s) /* Where to write info. */ { - register unsigned int i, j; + register int i, j; register union overhead *overPtr; - size_t totalFree = 0, totalUsed = 0; + int 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, " %u", j); + fprintf(stderr, " %d", j); } - totalFree += ((size_t)j) * (1 << (i + 3)); + totalFree += j * (1 << (i + 3)); } fprintf(stderr, "\nused:\t"); for (i = 0; i < NBUCKETS; i++) { - fprintf(stderr, " %" TCL_LL_MODIFIER "d", (Tcl_WideInt)numMallocs[i]); + fprintf(stderr, " %d", numMallocs[i]); totalUsed += numMallocs[i] * (1 << (i + 3)); } - fprintf(stderr, "\n\tTotal small in use: %" TCL_LL_MODIFIER "d, total free: %" TCL_LL_MODIFIER "d\n", - (Tcl_WideInt)totalUsed, (Tcl_WideInt)totalFree); - fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %" TCL_LL_MODIFIER "d\n", - MAXMALLOC, (Tcl_WideInt)numMallocs[NBUCKETS]); + fprintf(stderr, "\n\tTotal small in use: %d, total free: %d\n", + totalUsed, totalFree); + fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %d\n", + MAXMALLOC, numMallocs[NBUCKETS]); Tcl_MutexUnlock(allocMutexPtr); } diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 2212d1c..120fd9a 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}, @@ -866,7 +869,7 @@ CompileAssembleObj( * Not valid, so free it and regenerate. */ - TclFreeIntRep(objPtr); + FreeAssembleCodeInternalRep(objPtr); } /* @@ -891,13 +894,15 @@ CompileAssembleObj( */ TclEmitOpcode(INST_DONE, &compEnv); - codePtr = TclInitByteCodeObj(objPtr, &assembleCodeType, &compEnv); + TclInitByteCodeObj(objPtr, &compEnv); + objPtr->typePtr = &assembleCodeType; TclFreeCompileEnv(&compEnv); /* * Record the local variable context to which the bytecode pertains */ + codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (iPtr->varFramePtr->localCachePtr) { codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; @@ -1299,8 +1304,8 @@ AssembleOneLine( if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) { goto cleanup; } - operand1 = TclGetStringFromObj(operand1Obj, &operand1Len); - litIndex = TclRegisterLiteral(envPtr, operand1, operand1Len, 0); + operand1 = Tcl_GetStringFromObj(operand1Obj, &operand1Len); + litIndex = TclRegisterNewLiteral(envPtr, operand1, operand1Len); BBEmitInst1or4(assemEnvPtr, tblIdx, litIndex, 0); break; @@ -1361,6 +1366,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"); @@ -1448,8 +1470,8 @@ AssembleOneLine( &operand1Obj) != TCL_OK) { goto cleanup; } else { - operand1 = TclGetStringFromObj(operand1Obj, &operand1Len); - litIndex = TclRegisterLiteral(envPtr, operand1, operand1Len, 0); + operand1 = Tcl_GetStringFromObj(operand1Obj, &operand1Len); + litIndex = TclRegisterNewLiteral(envPtr, operand1, operand1Len); /* * Assumes that PUSH is the first slot! @@ -1543,7 +1565,7 @@ AssembleOneLine( * Add the (label_name, address) pair to the hash table. */ - if (DefineLabel(assemEnvPtr, TclGetString(operand1Obj)) != TCL_OK) { + if (DefineLabel(assemEnvPtr, Tcl_GetString(operand1Obj)) != TCL_OK) { goto cleanup; } break; @@ -1722,7 +1744,7 @@ AssembleOneLine( default: Tcl_Panic("Instruction \"%s\" could not be found, can't happen\n", - TclGetString(instNameObj)); + Tcl_GetString(instNameObj)); } status = TCL_OK; @@ -1985,15 +2007,15 @@ CreateMirrorJumpTable( DEBUG_PRINT("jump table {\n"); for (i = 0; i < objc; i+=2) { - DEBUG_PRINT(" %s -> %s\n", TclGetString(objv[i]), - TclGetString(objv[i+1])); - hashEntry = Tcl_CreateHashEntry(jtHashPtr, TclGetString(objv[i]), + DEBUG_PRINT(" %s -> %s\n", Tcl_GetString(objv[i]), + Tcl_GetString(objv[i+1])); + hashEntry = Tcl_CreateHashEntry(jtHashPtr, Tcl_GetString(objv[i]), &isNew); if (!isNew) { if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "duplicate entry in jump table for \"%s\"", - TclGetString(objv[i]))); + Tcl_GetString(objv[i]))); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPJUMPTABLEENTRY"); DeleteMirrorJumpTable(jtPtr); return TCL_ERROR; @@ -2288,7 +2310,7 @@ FindLocalVar( if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &varNameObj) != TCL_OK) { return -1; } - varNameStr = TclGetStringFromObj(varNameObj, &varNameLen); + varNameStr = Tcl_GetStringFromObj(varNameObj, &varNameLen); if (CheckNamespaceQualifiers(interp, varNameStr, varNameLen)) { Tcl_DecrRefCount(varNameObj); return -1; @@ -2801,7 +2823,7 @@ CalculateJumpRelocations( if (bbPtr->jumpTarget != NULL) { entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - TclGetString(bbPtr->jumpTarget)); + Tcl_GetString(bbPtr->jumpTarget)); if (entry == NULL) { ReportUndefinedLabel(assemEnvPtr, bbPtr, bbPtr->jumpTarget); @@ -2882,10 +2904,10 @@ CheckJumpTableLabels( symEntryPtr = Tcl_NextHashEntry(&search)) { symbolObj = Tcl_GetHashValue(symEntryPtr); valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - TclGetString(symbolObj)); + Tcl_GetString(symbolObj)); DEBUG_PRINT(" %s -> %s (%d)\n", (char*) Tcl_GetHashKey(symHash, symEntryPtr), - TclGetString(symbolObj), (valEntryPtr != NULL)); + Tcl_GetString(symbolObj), (valEntryPtr != NULL)); if (valEntryPtr == NULL) { ReportUndefinedLabel(assemEnvPtr, bbPtr, symbolObj); return TCL_ERROR; @@ -2923,9 +2945,9 @@ ReportUndefinedLabel( if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "undefined label \"%s\"", TclGetString(jumpTarget))); + "undefined label \"%s\"", Tcl_GetString(jumpTarget))); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOLABEL", - TclGetString(jumpTarget), NULL); + Tcl_GetString(jumpTarget), NULL); Tcl_SetErrorLine(interp, bbPtr->jumpLine); } } @@ -3008,7 +3030,7 @@ FillInJumpOffsets( bbPtr = bbPtr->successor1) { if (bbPtr->jumpTarget != NULL) { entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - TclGetString(bbPtr->jumpTarget)); + Tcl_GetString(bbPtr->jumpTarget)); jumpTarget = Tcl_GetHashValue(entry); fromOffset = bbPtr->jumpOffset; targetOffset = jumpTarget->startOffset; @@ -3080,17 +3102,17 @@ ResolveJumpTableTargets( symEntryPtr != NULL; symEntryPtr = Tcl_NextHashEntry(&search)) { symbolObj = Tcl_GetHashValue(symEntryPtr); - DEBUG_PRINT(" symbol %s\n", TclGetString(symbolObj)); + DEBUG_PRINT(" symbol %s\n", Tcl_GetString(symbolObj)); valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - TclGetString(symbolObj)); + Tcl_GetString(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), - TclGetString(symbolObj), jumpTargetBBPtr, + Tcl_GetString(symbolObj), jumpTargetBBPtr, jumpTargetBBPtr->startOffset, realJumpEntryPtr); Tcl_SetHashValue(realJumpEntryPtr, @@ -3462,7 +3484,7 @@ StackCheckBasicBlock( if (result == TCL_OK && blockPtr->jumpTarget != NULL) { entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - TclGetString(blockPtr->jumpTarget)); + Tcl_GetString(blockPtr->jumpTarget)); jumpTarget = Tcl_GetHashValue(entry); result = StackCheckBasicBlock(assemEnvPtr, jumpTarget, blockPtr, stackDepth); @@ -3479,7 +3501,7 @@ StackCheckBasicBlock( jtEntry = Tcl_NextHashEntry(&jtSearch)) { targetLabel = Tcl_GetHashValue(jtEntry); entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - TclGetString(targetLabel)); + Tcl_GetString(targetLabel)); jumpTarget = Tcl_GetHashValue(entry); result = StackCheckBasicBlock(assemEnvPtr, jumpTarget, blockPtr, stackDepth); @@ -3541,7 +3563,7 @@ StackCheckExit( * Emit a 'push' of the empty literal. */ - litIndex = TclRegisterLiteral(envPtr, "", 0, 0); + litIndex = TclRegisterNewLiteral(envPtr, "", 0); /* * Assumes that 'push' is at slot 0 in TalInstructionTable. @@ -3784,7 +3806,7 @@ ProcessCatchesInBasicBlock( } if (result == TCL_OK && bbPtr->jumpTarget != NULL) { entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - TclGetString(bbPtr->jumpTarget)); + Tcl_GetString(bbPtr->jumpTarget)); jumpTarget = Tcl_GetHashValue(entry); result = ProcessCatchesInBasicBlock(assemEnvPtr, jumpTarget, jumpEnclosing, jumpState, catchDepth); @@ -3800,7 +3822,7 @@ ProcessCatchesInBasicBlock( jtEntry = Tcl_NextHashEntry(&jtSearch)) { targetLabel = Tcl_GetHashValue(jtEntry); entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - TclGetString(targetLabel)); + Tcl_GetString(targetLabel)); jumpTarget = Tcl_GetHashValue(entry); result = ProcessCatchesInBasicBlock(assemEnvPtr, jumpTarget, jumpEnclosing, jumpState, catchDepth); @@ -4104,7 +4126,7 @@ StackFreshCatches( range->codeOffset = bbPtr->startOffset; entryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - TclGetString(catch->jumpTarget)); + Tcl_GetString(catch->jumpTarget)); if (entryPtr == NULL) { Tcl_Panic("undefined label in tclAssembly.c:" "BuildExceptionRanges, can't happen"); @@ -4313,7 +4335,11 @@ FreeAssembleCodeInternalRep( { ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; - TclReleaseByteCode(codePtr); + codePtr->refCount--; + if (codePtr->refCount <= 0) { + TclCleanupByteCode(codePtr); + } + objPtr->typePtr = NULL; } /* diff --git a/generic/tclBasic.c b/generic/tclBasic.c index cd7bd73..4d392d0 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 TCL_NO_DEPRECATED +#ifndef EXCLUDE_OBSOLETE_COMMANDS {"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}, @@ -580,16 +579,15 @@ Tcl_CreateInterp(void) iPtr->packageUnknown = NULL; /* TIP #268 */ -#if (TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE) if (getenv("TCL_PKG_PREFER_LATEST") == NULL) { iPtr->packagePrefer = PKG_PREFER_STABLE; - } else -#endif + } else { iPtr->packagePrefer = PKG_PREFER_LATEST; + } iPtr->cmdCount = 0; TclInitLiteralTable(&iPtr->literalTable); - iPtr->compileEpoch = 1; + iPtr->compileEpoch = 0; iPtr->compiledProcPtr = NULL; iPtr->resolverPtr = NULL; iPtr->evalFlags = 0; @@ -791,16 +789,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); @@ -941,8 +940,8 @@ Tcl_CreateInterp(void) * Set up other variables such as tcl_version and tcl_library */ - Tcl_SetVar2(interp, "tcl_patchLevel", NULL, TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY); - Tcl_SetVar2(interp, "tcl_version", NULL, TCL_VERSION, TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "tcl_patchLevel", TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "tcl_version", TCL_VERSION, TCL_GLOBAL_ONLY); Tcl_TraceVar2(interp, "tcl_precision", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, TclPrecTraceProc, NULL); @@ -967,11 +966,11 @@ Tcl_CreateInterp(void) Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs); if (TclTommath_Init(interp) != TCL_OK) { - Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp))); + Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); } if (TclOOInit(interp) != TCL_OK) { - Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp))); + Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); } /* @@ -981,7 +980,7 @@ Tcl_CreateInterp(void) #ifdef HAVE_ZLIB if (TclZlibInit(interp) != TCL_OK) { - Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp))); + Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); } #endif @@ -1028,6 +1027,7 @@ TclHideUnsafeCommands( Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name); } } + TclMakeEncodingCommandSafe(interp); /* Ugh! */ TclMakeFileCommandSafe(interp); /* Ugh! */ return TCL_OK; } @@ -1636,7 +1636,7 @@ DeleteInterpProc( } Tcl_DeleteHashTable(iPtr->lineLAPtr); - ckfree(iPtr->lineLAPtr); + ckfree((char *) iPtr->lineLAPtr); iPtr->lineLAPtr = NULL; if (iPtr->lineLABCPtr->numEntries && !TclInExit()) { @@ -2404,7 +2404,7 @@ TclInvokeStringCommand( TclStackAlloc(interp, (unsigned)(objc + 1) * sizeof(char *)); for (i = 0; i < objc; i++) { - argv[i] = TclGetString(objv[i]); + argv[i] = Tcl_GetString(objv[i]); } argv[objc] = 0; @@ -2658,7 +2658,7 @@ TclRenameCommand( } Tcl_DStringAppend(&newFullName, newTail, -1); cmdPtr->refCount++; - CallCommandTraces(iPtr, cmdPtr, TclGetString(oldFullName), + CallCommandTraces(iPtr, cmdPtr, Tcl_GetString(oldFullName), Tcl_DStringValue(&newFullName), TCL_TRACE_RENAME); Tcl_DStringFree(&newFullName); @@ -3025,6 +3025,13 @@ 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 @@ -3046,14 +3053,6 @@ 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; } @@ -3156,13 +3155,6 @@ 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++; } /* @@ -3409,7 +3401,8 @@ TclCleanupCommand( register Command *cmdPtr) /* Points to the Command structure to * be freed. */ { - if (cmdPtr->refCount-- <= 1) { + cmdPtr->refCount--; + if (cmdPtr->refCount <= 0) { ckfree(cmdPtr); } } @@ -3531,7 +3524,7 @@ OldMathFuncProc( Tcl_SetObjResult(interp, Tcl_NewStringObj( "argument to math function didn't have numeric value", -1)); - TclCheckBadOctal(interp, TclGetString(valuePtr)); + TclCheckBadOctal(interp, Tcl_GetString(valuePtr)); ckfree(args); return TCL_ERROR; } @@ -3951,7 +3944,7 @@ Tcl_Canceled( */ if (iPtr->asyncCancelMsg != NULL) { - message = TclGetStringFromObj(iPtr->asyncCancelMsg, &length); + message = Tcl_GetStringFromObj(iPtr->asyncCancelMsg, &length); } else { length = 0; } @@ -4050,7 +4043,7 @@ Tcl_CancelEval( */ if (resultObjPtr != NULL) { - result = TclGetStringFromObj(resultObjPtr, &cancelInfo->length); + result = Tcl_GetStringFromObj(resultObjPtr, &cancelInfo->length); cancelInfo->result = ckrealloc(cancelInfo->result,cancelInfo->length); memcpy(cancelInfo->result, result, (size_t) cancelInfo->length); TclDecrRefCount(resultObjPtr); /* Discard their result object. */ @@ -4562,7 +4555,7 @@ TEOV_Error( */ listPtr = Tcl_NewListObj(objc, objv); - cmdString = TclGetStringFromObj(listPtr, &cmdLen); + cmdString = Tcl_GetStringFromObj(listPtr, &cmdLen); Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen); Tcl_DecrRefCount(listPtr); } @@ -4706,9 +4699,9 @@ TEOV_RunEnterTraces( { Interp *iPtr = (Interp *) interp; Command *cmdPtr = *cmdPtrPtr; - size_t newEpoch, cmdEpoch = cmdPtr->cmdEpoch; + int newEpoch, cmdEpoch = cmdPtr->cmdEpoch; int length, traceCode = TCL_OK; - const char *command = TclGetStringFromObj(commandPtr, &length); + const char *command = Tcl_GetStringFromObj(commandPtr, &length); /* * Call trace functions. @@ -4760,7 +4753,7 @@ TEOV_RunLeaveTraces( Command *cmdPtr = data[2]; Tcl_Obj **objv = data[3]; int length; - const char *command = TclGetStringFromObj(commandPtr, &length); + const char *command = Tcl_GetStringFromObj(commandPtr, &length); if (!(cmdPtr->flags & CMD_IS_DELETED)) { if (cmdPtr->flags & CMD_HAS_EXEC_TRACES){ @@ -5586,7 +5579,8 @@ TclArgumentRelease( } cfwPtr = Tcl_GetHashValue(hPtr); - if (cfwPtr->refCount-- > 1) { + cfwPtr->refCount--; + if (cfwPtr->refCount > 0) { continue; } @@ -6056,7 +6050,7 @@ TclNREvalObjEx( TclNRAddCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr, objPtr, NULL); - TclListObjGetElements(NULL, listPtr, &objc, &objv); + ListObjGetElements(listPtr, objc, objv); return TclNREvalObjv(interp, objc, objv, flags, NULL); } @@ -6124,7 +6118,7 @@ TclNREvalObjEx( Tcl_IncrRefCount(objPtr); - script = TclGetStringFromObj(objPtr, &numSrcBytes); + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); result = Tcl_EvalEx(interp, script, numSrcBytes, flags); TclDecrRefCount(objPtr); @@ -6155,7 +6149,7 @@ TEOEx_ByteCodeCallback( ProcessUnexpectedResult(interp, result); result = TCL_ERROR; - script = TclGetStringFromObj(objPtr, &numSrcBytes); + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); Tcl_LogCommandInfo(interp, script, script, numSrcBytes); } @@ -6703,10 +6697,11 @@ Tcl_AppendObjToErrorInfo( * pertains. */ Tcl_Obj *objPtr) /* Message to record. */ { - const char *message = TclGetString(objPtr); + int length; + const char *message = TclGetStringFromObj(objPtr, &length); Tcl_IncrRefCount(objPtr); - Tcl_AddObjErrorInfo(interp, message, objPtr->length); + Tcl_AddObjErrorInfo(interp, message, length); Tcl_DecrRefCount(objPtr); } @@ -6853,7 +6848,7 @@ Tcl_VarEvalVA( Tcl_DStringAppend(&buf, string, -1); } - result = Tcl_EvalEx(interp, Tcl_DStringValue(&buf), -1, 0); + result = Tcl_Eval(interp, Tcl_DStringValue(&buf)); Tcl_DStringFree(&buf); return result; } @@ -6923,7 +6918,7 @@ Tcl_GlobalEval( savedVarFramePtr = iPtr->varFramePtr; iPtr->varFramePtr = iPtr->rootFramePtr; - result = Tcl_EvalEx(interp, command, -1, 0); + result = Tcl_Eval(interp, command); iPtr->varFramePtr = savedVarFramePtr; return result; } @@ -7890,7 +7885,7 @@ MathFuncWrongNumArgs( int found, /* Actual parameter count. */ Tcl_Obj *const *objv) /* Actual parameter vector. */ { - const char *name = TclGetString(objv[0]); + const char *name = Tcl_GetString(objv[0]); const char *tail = name + strlen(name); while (tail > name+1) { @@ -8754,6 +8749,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. @@ -8805,7 +8829,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; @@ -8823,7 +8848,7 @@ TclNRInterpCoroutine( if (!COR_IS_SUSPENDED(corPtr)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "coroutine \"%s\" is already running", - TclGetString(objv[0]))); + Tcl_GetString(objv[0]))); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BUSY", NULL); return TCL_ERROR; } diff --git a/generic/tclBinary.c b/generic/tclBinary.c index a3e5071..2a4fd84 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -155,108 +155,35 @@ static const EnsembleImplMap decodeMap[] = { }; /* - * 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. + * 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. */ -static const Tcl_ObjType properByteArrayType = { - "bytearray", - FreeByteArrayInternalRep, - DupByteArrayInternalRep, - UpdateStringOfByteArray, - NULL -}; - const Tcl_ObjType tclByteArrayType = { "bytearray", FreeByteArrayInternalRep, DupByteArrayInternalRep, - NULL, + UpdateStringOfByteArray, SetByteArrayFromAny }; @@ -284,12 +211,6 @@ typedef struct ByteArray { #define SET_BYTEARRAY(objPtr, baPtr) \ (objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (baPtr) -int -TclIsPureByteArray( - Tcl_Obj * objPtr) -{ - return (objPtr->typePtr == &properByteArrayType); -} /* *---------------------------------------------------------------------- @@ -420,7 +341,7 @@ Tcl_SetByteArrayObj( if ((bytes != NULL) && (length > 0)) { memcpy(byteArrayPtr->bytes, bytes, (size_t) length); } - objPtr->typePtr = &properByteArrayType; + objPtr->typePtr = &tclByteArrayType; SET_BYTEARRAY(objPtr, byteArrayPtr); } @@ -450,8 +371,7 @@ Tcl_GetByteArrayFromObj( { ByteArray *baPtr; - if ((objPtr->typePtr != &properByteArrayType) - && (objPtr->typePtr != &tclByteArrayType)) { + if (objPtr->typePtr != &tclByteArrayType) { SetByteArrayFromAny(NULL, objPtr); } baPtr = GET_BYTEARRAY(objPtr); @@ -494,8 +414,7 @@ Tcl_SetByteArrayLength( if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayLength"); } - if ((objPtr->typePtr != &properByteArrayType) - && (objPtr->typePtr != &tclByteArrayType)) { + if (objPtr->typePtr != &tclByteArrayType) { SetByteArrayFromAny(NULL, objPtr); } @@ -531,37 +450,29 @@ SetByteArrayFromAny( Tcl_Interp *interp, /* Not used. */ Tcl_Obj *objPtr) /* The object to convert to type ByteArray. */ { - size_t length; - int improper = 0; + int length; const char *src, *srcEnd; unsigned char *dst; ByteArray *byteArrayPtr; Tcl_UniChar ch; - if (objPtr->typePtr == &properByteArrayType) { - return TCL_OK; - } - if (objPtr->typePtr == &tclByteArrayType) { - return TCL_OK; - } - - src = TclGetString(objPtr); - length = objPtr->length; - srcEnd = src + length; + 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); - improper = improper || (ch > 255); - *dst++ = UCHAR(ch); - } + byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length)); + for (dst = byteArrayPtr->bytes; src < srcEnd; ) { + src += Tcl_UtfToUniChar(src, &ch); + *dst++ = UCHAR(ch); + } - byteArrayPtr->used = dst - byteArrayPtr->bytes; - byteArrayPtr->allocated = length; + byteArrayPtr->used = dst - byteArrayPtr->bytes; + byteArrayPtr->allocated = length; - TclFreeIntRep(objPtr); - objPtr->typePtr = improper ? &tclByteArrayType : &properByteArrayType; - SET_BYTEARRAY(objPtr, byteArrayPtr); + TclFreeIntRep(objPtr); + objPtr->typePtr = &tclByteArrayType; + SET_BYTEARRAY(objPtr, byteArrayPtr); + } return TCL_OK; } @@ -624,7 +535,7 @@ DupByteArrayInternalRep( memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, (size_t) length); SET_BYTEARRAY(copyPtr, copyArrayPtr); - copyPtr->typePtr = srcPtr->typePtr; + copyPtr->typePtr = &tclByteArrayType; } /* @@ -731,8 +642,7 @@ TclAppendBytesToByteArray( /* Append zero bytes is a no-op. */ return; } - if ((objPtr->typePtr != &properByteArrayType) - && (objPtr->typePtr != &tclByteArrayType)) { + if (objPtr->typePtr != &tclByteArrayType) { SetByteArrayFromAny(NULL, objPtr); } byteArrayPtr = GET_BYTEARRAY(objPtr); @@ -1743,7 +1653,15 @@ GetFormatSpec( (*formatPtr)++; *countPtr = BINARY_ALL; } else if (isdigit(UCHAR(**formatPtr))) { /* INTL: digit */ - *countPtr = strtoul(*formatPtr, (char **) formatPtr, 10); + unsigned long int count; + + errno = 0; + count = strtoul(*formatPtr, (char **) formatPtr, 10); + if (errno || (count > (unsigned long) INT_MAX)) { + *countPtr = INT_MAX; + } else { + *countPtr = (int) count; + } } else { *countPtr = BINARY_NOCOUNT; } @@ -2590,7 +2508,7 @@ BinaryEncode64( } break; case OPT_WRAPCHAR: - wrapchar = TclGetStringFromObj(objv[i+1], &wrapcharlen); + wrapchar = Tcl_GetStringFromObj(objv[i+1], &wrapcharlen); if (wrapcharlen == 0) { maxlen = 0; } diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index d42536e..70e64f0 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -34,14 +34,14 @@ */ typedef struct MemTag { - size_t refCount; /* Number of mem_headers referencing this + int 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) ((TclOffset(MemTag, string) + 1) + bytesInString) +#define TAG_SIZE(bytesInString) ((unsigned) ((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(size_t) + sizeof(int)))%8) +#define LOW_GUARD_SIZE (8 + (32 - (sizeof(long) + 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; - size_t length; + long length; int line; unsigned char low_guard[LOW_GUARD_SIZE]; /* Aligns body on 8-byte boundary, plus @@ -251,10 +251,10 @@ ValidateMemory( } if (guard_failed) { TclDumpMemoryInfo((ClientData) stderr, 0); - fprintf(stderr, "low guard failed at %p, %s %d\n", - memHeaderP->body, file, line); + fprintf(stderr, "low guard failed at %lx, %s %d\n", + (long unsigned) memHeaderP->body, file, line); fflush(stderr); /* In case name pointer is bad. */ - fprintf(stderr, "%" TCL_LL_MODIFIER "d bytes allocated at (%s %d)\n", (Tcl_WideInt) memHeaderP->length, + fprintf(stderr, "%ld bytes allocated at (%s %d)\n", 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 %p, %s %d\n", - memHeaderP->body, file, line); + fprintf(stderr, "high guard failed at %lx, %s %d\n", + (long unsigned) memHeaderP->body, file, line); fflush(stderr); /* In case name pointer is bad. */ - fprintf(stderr, "%" TCL_LL_MODIFIER "d bytes allocated at (%s %d)\n", - (Tcl_WideInt)memHeaderP->length, memHeaderP->file, + fprintf(stderr, "%ld bytes allocated at (%s %d)\n", + memHeaderP->length, memHeaderP->file, memHeaderP->line); Tcl_Panic("Memory validation failure"); } @@ -359,10 +359,10 @@ Tcl_DumpActiveMemory( Tcl_MutexLock(ckallocMutexPtr); for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) { address = &memScanP->body[0]; - fprintf(fileP, "%8" TCL_LL_MODIFIER "x - %8" TCL_LL_MODIFIER "x %7" TCL_LL_MODIFIER "d @ %s %d %s", - (Tcl_WideInt)(size_t)address, - (Tcl_WideInt)((size_t)address + memScanP->length - 1), - (Tcl_WideInt)memScanP->length, memScanP->file, memScanP->line, + fprintf(fileP, "%8lx - %8lx %7ld @ %s %d %s", + (long unsigned) address, + (long unsigned) address + memScanP->length - 1, + memScanP->length, memScanP->file, memScanP->line, (memScanP->tagPtr == NULL) ? "" : memScanP->tagPtr->string); (void) fputc('\n', fileP); } @@ -458,8 +458,8 @@ Tcl_DbCkalloc( } if (alloc_tracing) { - fprintf(stderr,"ckalloc %p %u %s %d\n", - result->body, size, file, line); + fprintf(stderr,"ckalloc %lx %u %s %d\n", + (long unsigned int) result->body, size, file, line); } if (break_on_malloc && (total_mallocs >= break_on_malloc)) { @@ -547,8 +547,8 @@ Tcl_AttemptDbCkalloc( } if (alloc_tracing) { - fprintf(stderr,"ckalloc %p %u %s %d\n", - result->body, size, file, line); + fprintf(stderr,"ckalloc %lx %u %s %d\n", + (long unsigned int) result->body, size, file, line); } if (break_on_malloc && (total_mallocs >= break_on_malloc)) { @@ -612,8 +612,8 @@ Tcl_DbCkfree( memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET); if (alloc_tracing) { - fprintf(stderr, "ckfree %p %" TCL_LL_MODIFIER "d %s %d\n", - memp->body, (Tcl_WideInt) memp->length, file, line); + fprintf(stderr, "ckfree %lx %ld %s %d\n", + (long unsigned int) memp->body, memp->length, file, line); } if (validate_memory) { @@ -623,7 +623,7 @@ Tcl_DbCkfree( Tcl_MutexLock(ckallocMutexPtr); ValidateMemory(memp, file, line, TRUE); if (init_malloced_bodies) { - memset(ptr, GUARD_VALUE, memp->length); + memset(ptr, GUARD_VALUE, (size_t) memp->length); } total_frees++; @@ -631,7 +631,8 @@ Tcl_DbCkfree( current_bytes_malloced -= memp->length; if (memp->tagPtr != NULL) { - if ((memp->tagPtr->refCount-- <= 1) && (curTagPtr != memp->tagPtr)) { + memp->tagPtr->refCount--; + if ((memp->tagPtr->refCount == 0) && (curTagPtr != memp->tagPtr)) { TclpFree((char *) memp->tagPtr); } } @@ -674,7 +675,7 @@ Tcl_DbCkrealloc( int line) { char *newPtr; - size_t copySize; + unsigned int copySize; struct mem_header *memp; if (ptr == NULL) { @@ -688,7 +689,7 @@ Tcl_DbCkrealloc( memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET); copySize = size; - if (copySize > memp->length) { + if (copySize > (unsigned int) memp->length) { copySize = memp->length; } newPtr = Tcl_DbCkalloc(size, file, line); @@ -705,7 +706,7 @@ Tcl_AttemptDbCkrealloc( int line) { char *newPtr; - size_t copySize; + unsigned int copySize; struct mem_header *memp; if (ptr == NULL) { @@ -719,7 +720,7 @@ Tcl_AttemptDbCkrealloc( memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET); copySize = size; - if (copySize > memp->length) { + if (copySize > (unsigned int) memp->length) { copySize = memp->length; } newPtr = Tcl_AttemptDbCkalloc(size, file, line); diff --git a/generic/tclClock.c b/generic/tclClock.c index cf52673..8e176b6 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -149,18 +149,13 @@ struct ClockCommand { const char *name; /* The tail of the command name. The full name * is "::tcl::clock::<name>". When NULL marks * the end of the table. */ - Tcl_ObjCmdProc *objCmdProc; /* Function that implements the command. This + Tcl_ObjCmdProc *objCmdProc; /* Function that implements the command. This * will always have the ClockClientData sent * to it, but may well ignore this data. */ }; static const struct ClockCommand clockCommands[] = { - { "add", ClockAddObjCmd }, - { "clicks", ClockClicksObjCmd }, { "getenv", ClockGetenvObjCmd }, - { "microseconds", ClockMicrosecondsObjCmd }, - { "milliseconds", ClockMillisecondsObjCmd }, - { "seconds", ClockSecondsObjCmd }, { "format", ClockFormatObjCmd }, { "scan", ClockScanObjCmd }, { "configure", ClockConfigureObjCmd }, @@ -203,6 +198,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. @@ -250,6 +258,7 @@ TclClockInit( /* * Install the commands. + * TODO - Let Tcl_MakeEnsemble do this? */ #define TCL_CLOCK_PREFIX_LEN 14 /* == strlen("::tcl::clock::") */ @@ -260,6 +269,10 @@ TclClockInit( Tcl_CreateObjCommand(interp, cmdName, clockCmdPtr->objCmdProc, data, ClockDeleteCmdProc); } + + /* Make the clock ensemble */ + + TclMakeEnsemble(interp, "clock", clockImplMap); } /* @@ -1991,7 +2004,7 @@ ConvertUTCToLocal( if (ConvertUTCToLocalUsingTable(interp, fields, rowc, rowv, dataPtr->UTC2Local.rangesVal) != TCL_OK) { return TCL_ERROR; - } + } } /* Cache the last conversion */ @@ -2563,9 +2576,9 @@ GetJulianDayFromEraYearMonthDay( * See above bug for details. The casts are necessary. */ if (ym1 >= 0) - ym1o4 = ym1 / 4; + ym1o4 = ym1 / 4; else { - ym1o4 = - (int) (((unsigned int) -ym1) / 4); + ym1o4 = - (int) (((unsigned int) -ym1) / 4); } #endif if (ym1 % 4 < 0) { @@ -2982,7 +2995,7 @@ ClockParseFmtScnArgs( ClockFmtScnCmdArgs *opts, /* Result vector: format, locale, timezone... */ TclDateFields *date, /* Extracted date-time corresponding base * (by scan or add) resp. clockval (by format) */ - int objc, /* Parameter count */ + int objc, /* Parameter count */ Tcl_Obj *const objv[], /* Parameter vector */ int flags /* Flags, differentiates between format, scan, add */ ) { @@ -3018,7 +3031,7 @@ ClockParseFmtScnArgs( Tcl_WideInt num; if (TclGetWideIntFromObj(NULL, objv[i], &num) == TCL_OK) { continue; - } + } } /* get option */ if (Tcl_GetIndexFromObj(interp, objv[i], options, @@ -3054,10 +3067,10 @@ ClockParseFmtScnArgs( case CLC_ARGS_BASE: if ( !(flags & (CLC_SCN_ARGS)) ) { goto badOptionMsg; - } + } opts->baseObj = objv[i+1]; break; - } + } saw |= (1 << optionIndex); } @@ -3117,10 +3130,10 @@ ClockParseFmtScnArgs( i = 1; goto badOption; } - /* + /* * seconds could be an unsigned number that overflowed. Make sure * that it isn't. - */ + */ if (opts->baseObj->typePtr == &tclBignumType) { Tcl_SetObjResult(interp, dataPtr->literals[LIT_INTEGER_VALUE_TOO_LARGE]); @@ -4029,14 +4042,14 @@ ClockSecondsObjCmd( static unsigned long TzsetGetEpoch(void) { - static char* tzWas = INT2PTR(-1); /* Previous value of TZ, protected by - * clockMutex. */ + static char* tzWas = INT2PTR(-1); /* Previous value of TZ, protected by + * clockMutex. */ static long tzLastRefresh = 0; /* Used for latency before next refresh */ static unsigned long tzWasEpoch = 0; /* Epoch, signals that TZ changed */ static unsigned long tzEnvEpoch = 0; /* Last env epoch, for faster signaling, that TZ changed via TCL */ - const char *tzIsNow; /* Current value of TZ */ + const char *tzIsNow; /* Current value of TZ */ /* * Prevent performance regression on some platforms by resolving of system time zone: @@ -4055,7 +4068,7 @@ TzsetGetEpoch(void) Tcl_MutexLock(&clockMutex); tzIsNow = getenv("TCL_TZ"); if (tzIsNow == NULL) { - tzIsNow = getenv("TZ"); + tzIsNow = getenv("TZ"); } if (tzIsNow != NULL && (tzWas == NULL || tzWas == INT2PTR(-1) || strcmp(tzIsNow, tzWas) != 0)) { @@ -4076,8 +4089,7 @@ TzsetGetEpoch(void) return tzWasEpoch; } - -static void + static void TzsetIfNecessary(void) { TzsetGetEpoch(); diff --git a/generic/tclClockFmt.c b/generic/tclClockFmt.c deleted file mode 100644 index d875bd4..0000000 --- a/generic/tclClockFmt.c +++ /dev/null @@ -1,3135 +0,0 @@ -/* - * tclClockFmt.c -- - * - * Contains the date format (and scan) routines. This code is back-ported - * from the time and date facilities of tclSE engine, by Serg G. Brester. - * - * Copyright (c) 2015 by Sergey G. Brester aka sebres. All rights reserved. - * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -#include "tclInt.h" -#include "tclStrIdxTree.h" -#include "tclDate.h" - -/* - * Miscellaneous forward declarations and functions used within this file - */ - -static void -ClockFmtObj_DupInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); -static void -ClockFmtObj_FreeInternalRep(Tcl_Obj *objPtr); -static int -ClockFmtObj_SetFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); -static void -ClockFmtObj_UpdateString(Tcl_Obj *objPtr); - - -TCL_DECLARE_MUTEX(ClockFmtMutex); /* Serializes access to common format list. */ - -static void ClockFmtScnStorageDelete(ClockFmtScnStorage *fss); - -static void ClockFrmScnFinalize(ClientData clientData); - -/* Msgcat index literals prefixed with _IDX_, used for quick dictionary search */ -CLOCK_LOCALE_LITERAL_ARRAY(MsgCtLitIdxs, "_IDX_"); - -/* - * Clock scan and format facilities. - */ - -/* - *---------------------------------------------------------------------- - * - * _str2int -- , _str2wideInt -- - * - * Fast inline-convertion of string to signed int or wide int by given - * start/end. - * - * The given string should contain numbers chars only (because already - * pre-validated within parsing routines) - * - * Results: - * Returns a standard Tcl result. - * TCL_OK - by successful conversion, TCL_ERROR by (wide) int overflow - * - *---------------------------------------------------------------------- - */ - -static inline int -_str2int( - int *out, - register - const char *p, - const char *e, - int sign) -{ - register int val = 0, prev = 0; - if (sign >= 0) { - while (p < e) { - val = val * 10 + (*p++ - '0'); - if (val < prev) { - return TCL_ERROR; - } - prev = val; - } - } else { - while (p < e) { - val = val * 10 - (*p++ - '0'); - if (val > prev) { - return TCL_ERROR; - } - prev = val; - } - } - *out = val; - return TCL_OK; -} - -static inline int -_str2wideInt( - Tcl_WideInt *out, - register - const char *p, - const char *e, - int sign) -{ - register Tcl_WideInt val = 0, prev = 0; - if (sign >= 0) { - while (p < e) { - val = val * 10 + (*p++ - '0'); - if (val < prev) { - return TCL_ERROR; - } - prev = val; - } - } else { - while (p < e) { - val = val * 10 - (*p++ - '0'); - if (val > prev) { - return TCL_ERROR; - } - prev = val; - } - } - *out = val; - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * _itoaw -- , _witoaw -- - * - * Fast inline-convertion of signed int or wide int to string, using - * given padding with specified padchar and width (or without padding). - * - * This is a very fast replacement for sprintf("%02d"). - * - * Results: - * Returns position in buffer after end of conversion result. - * - *---------------------------------------------------------------------- - */ - -static inline char * -_itoaw( - char *buf, - register int val, - char padchar, - unsigned short int width) -{ - register char *p; - static int wrange[] = {1, 10, 100, 1000, 10000, 100000, 1000000, 10000000, 100000000, 1000000000}; - - /* positive integer */ - - if (val >= 0) - { - /* check resp. recalculate width */ - while (width <= 9 && val >= wrange[width]) { - width++; - } - /* number to string backwards */ - p = buf + width; - *p-- = '\0'; - do { - register char c = (val % 10); val /= 10; - *p-- = '0' + c; - } while (val > 0); - /* fulling with pad-char */ - while (p >= buf) { - *p-- = padchar; - } - - return buf + width; - } - /* negative integer */ - - if (!width) width++; - /* check resp. recalculate width (regarding sign) */ - width--; - while (width <= 9 && val <= -wrange[width]) { - width++; - } - width++; - /* number to string backwards */ - p = buf + width; - *p-- = '\0'; - /* differentiate platforms with -1 % 10 == 1 and -1 % 10 == -1 */ - if (-1 % 10 == -1) { - do { - register char c = (val % 10); val /= 10; - *p-- = '0' - c; - } while (val < 0); - } else { - do { - register char c = (val % 10); val /= 10; - *p-- = '0' + c; - } while (val < 0); - } - /* sign by 0 padding */ - if (padchar != '0') { *p-- = '-'; } - /* fulling with pad-char */ - while (p >= buf + 1) { - *p-- = padchar; - } - /* sign by non 0 padding */ - if (padchar == '0') { *p = '-'; } - - return buf + width; -} - -static inline char * -_witoaw( - char *buf, - register Tcl_WideInt val, - char padchar, - unsigned short int width) -{ - register char *p; - static int wrange[] = {1, 10, 100, 1000, 10000, 100000, 1000000, 10000000, 100000000, 1000000000}; - - /* positive integer */ - - if (val >= 0) - { - /* check resp. recalculate width */ - if (val >= 10000000000L) { - Tcl_WideInt val2; - val2 = val / 10000000000L; - while (width <= 9 && val2 >= wrange[width]) { - width++; - } - width += 10; - } else { - while (width <= 9 && val >= wrange[width]) { - width++; - } - } - /* number to string backwards */ - p = buf + width; - *p-- = '\0'; - do { - register char c = (val % 10); val /= 10; - *p-- = '0' + c; - } while (val > 0); - /* fulling with pad-char */ - while (p >= buf) { - *p-- = padchar; - } - - return buf + width; - } - - /* negative integer */ - - if (!width) width++; - /* check resp. recalculate width (regarding sign) */ - width--; - if (val <= 10000000000L) { - Tcl_WideInt val2; - val2 = val / 10000000000L; - while (width <= 9 && val2 <= -wrange[width]) { - width++; - } - width += 10; - } else { - while (width <= 9 && val <= -wrange[width]) { - width++; - } - } - width++; - /* number to string backwards */ - p = buf + width; - *p-- = '\0'; - /* differentiate platforms with -1 % 10 == 1 and -1 % 10 == -1 */ - if (-1 % 10 == -1) { - do { - register char c = (val % 10); val /= 10; - *p-- = '0' - c; - } while (val < 0); - } else { - do { - register char c = (val % 10); val /= 10; - *p-- = '0' + c; - } while (val < 0); - } - /* sign by 0 padding */ - if (padchar != '0') { *p-- = '-'; } - /* fulling with pad-char */ - while (p >= buf + 1) { - *p-- = padchar; - } - /* sign by non 0 padding */ - if (padchar == '0') { *p = '-'; } - - return buf + width; -} - -/* - * Global GC as LIFO for released scan/format object storages. - * - * Used to holds last released CLOCK_FMT_SCN_STORAGE_GC_SIZE formats - * (after last reference from Tcl-object will be removed). This is helpful - * to avoid continuous (re)creation and compiling by some dynamically resp. - * variable format objects, that could be often reused. - * - * As long as format storage is used resp. belongs to GC, it takes place in - * FmtScnHashTable also. - */ - -#if CLOCK_FMT_SCN_STORAGE_GC_SIZE > 0 - -static struct { - ClockFmtScnStorage *stackPtr; - ClockFmtScnStorage *stackBound; - unsigned int count; -} ClockFmtScnStorage_GC = {NULL, NULL, 0}; - -/* - *---------------------------------------------------------------------- - * - * ClockFmtScnStorageGC_In -- - * - * Adds an format storage object to GC. - * - * If current GC is full (size larger as CLOCK_FMT_SCN_STORAGE_GC_SIZE) - * this removes last unused storage at begin of GC stack (LIFO). - * - * Assumes caller holds the ClockFmtMutex. - * - * Results: - * None. - * - *---------------------------------------------------------------------- - */ - -static inline void -ClockFmtScnStorageGC_In(ClockFmtScnStorage *entry) -{ - /* add new entry */ - TclSpliceIn(entry, ClockFmtScnStorage_GC.stackPtr); - if (ClockFmtScnStorage_GC.stackBound == NULL) { - ClockFmtScnStorage_GC.stackBound = entry; - } - ClockFmtScnStorage_GC.count++; - - /* if GC ist full */ - if (ClockFmtScnStorage_GC.count > CLOCK_FMT_SCN_STORAGE_GC_SIZE) { - - /* GC stack is LIFO: delete first inserted entry */ - ClockFmtScnStorage *delEnt = ClockFmtScnStorage_GC.stackBound; - ClockFmtScnStorage_GC.stackBound = delEnt->prevPtr; - TclSpliceOut(delEnt, ClockFmtScnStorage_GC.stackPtr); - ClockFmtScnStorage_GC.count--; - delEnt->prevPtr = delEnt->nextPtr = NULL; - /* remove it now */ - ClockFmtScnStorageDelete(delEnt); - } -} - -/* - *---------------------------------------------------------------------- - * - * ClockFmtScnStorage_GC_Out -- - * - * Restores (for reusing) given format storage object from GC. - * - * Assumes caller holds the ClockFmtMutex. - * - * Results: - * None. - * - *---------------------------------------------------------------------- - */ - -static inline void -ClockFmtScnStorage_GC_Out(ClockFmtScnStorage *entry) -{ - TclSpliceOut(entry, ClockFmtScnStorage_GC.stackPtr); - ClockFmtScnStorage_GC.count--; - if (ClockFmtScnStorage_GC.stackBound == entry) { - ClockFmtScnStorage_GC.stackBound = entry->prevPtr; - } - entry->prevPtr = entry->nextPtr = NULL; -} - -#endif - - -/* - * Global format storage hash table of type ClockFmtScnStorageHashKeyType - * (contains list of scan/format object storages, shared across all threads). - * - * Used for fast searching by format string. - */ -static Tcl_HashTable FmtScnHashTable; -static int initialized = 0; - -/* - * Wrappers between pointers to hash entry and format storage object - */ -static inline Tcl_HashEntry * -HashEntry4FmtScn(ClockFmtScnStorage *fss) { - return (Tcl_HashEntry*)(fss + 1); -}; -static inline ClockFmtScnStorage * -FmtScn4HashEntry(Tcl_HashEntry *hKeyPtr) { - return (ClockFmtScnStorage*)(((char*)hKeyPtr) - sizeof(ClockFmtScnStorage)); -}; - -/* - *---------------------------------------------------------------------- - * - * ClockFmtScnStorageAllocProc -- - * - * Allocate space for a hash entry containing format storage together - * with the string key. - * - * Results: - * The return value is a pointer to the created entry. - * - *---------------------------------------------------------------------- - */ - -static Tcl_HashEntry * -ClockFmtScnStorageAllocProc( - Tcl_HashTable *tablePtr, /* Hash table. */ - void *keyPtr) /* Key to store in the hash table entry. */ -{ - ClockFmtScnStorage *fss; - - const char *string = (const char *) keyPtr; - Tcl_HashEntry *hPtr; - unsigned int size, - allocsize = sizeof(ClockFmtScnStorage) + sizeof(Tcl_HashEntry); - - allocsize += (size = strlen(string) + 1); - if (size > sizeof(hPtr->key)) { - allocsize -= sizeof(hPtr->key); - } - - fss = ckalloc(allocsize); - - /* initialize */ - memset(fss, 0, sizeof(*fss)); - - hPtr = HashEntry4FmtScn(fss); - memcpy(&hPtr->key.string, string, size); - hPtr->clientData = 0; /* currently unused */ - - return hPtr; -} - -/* - *---------------------------------------------------------------------- - * - * ClockFmtScnStorageFreeProc -- - * - * Free format storage object and space of given hash entry. - * - * Results: - * None. - * - *---------------------------------------------------------------------- - */ - -static void -ClockFmtScnStorageFreeProc( - Tcl_HashEntry *hPtr) -{ - ClockFmtScnStorage *fss = FmtScn4HashEntry(hPtr); - - if (fss->scnTok != NULL) { - ckfree(fss->scnTok); - fss->scnTok = NULL; - fss->scnTokC = 0; - } - if (fss->fmtTok != NULL) { - ckfree(fss->fmtTok); - fss->fmtTok = NULL; - fss->fmtTokC = 0; - } - - ckfree(fss); -} - -/* - *---------------------------------------------------------------------- - * - * ClockFmtScnStorageDelete -- - * - * Delete format storage object. - * - * Results: - * None. - * - *---------------------------------------------------------------------- - */ - -static void -ClockFmtScnStorageDelete(ClockFmtScnStorage *fss) { - Tcl_HashEntry *hPtr = HashEntry4FmtScn(fss); - /* - * This will delete a hash entry and call "ckfree" for storage self, if - * some additionally handling required, freeEntryProc can be used instead - */ - Tcl_DeleteHashEntry(hPtr); -} - - -/* - * Derivation of tclStringHashKeyType with another allocEntryProc - */ - -static Tcl_HashKeyType ClockFmtScnStorageHashKeyType; - - -/* - * Type definition of clock-format tcl object type. - */ - -Tcl_ObjType ClockFmtObjType = { - "clock-format", /* name */ - ClockFmtObj_FreeInternalRep, /* freeIntRepProc */ - ClockFmtObj_DupInternalRep, /* dupIntRepProc */ - ClockFmtObj_UpdateString, /* updateStringProc */ - ClockFmtObj_SetFromAny /* setFromAnyProc */ -}; - -#define ObjClockFmtScn(objPtr) \ - (*((ClockFmtScnStorage **)&(objPtr)->internalRep.twoPtrValue.ptr1)) - -#define ObjLocFmtKey(objPtr) \ - (*((Tcl_Obj **)&(objPtr)->internalRep.twoPtrValue.ptr2)) - -static void -ClockFmtObj_DupInternalRep(srcPtr, copyPtr) - Tcl_Obj *srcPtr; - Tcl_Obj *copyPtr; -{ - ClockFmtScnStorage *fss = ObjClockFmtScn(srcPtr); - - if (fss != NULL) { - Tcl_MutexLock(&ClockFmtMutex); - fss->objRefCount++; - Tcl_MutexUnlock(&ClockFmtMutex); - } - - ObjClockFmtScn(copyPtr) = fss; - /* regards special case - format not localizable */ - if (ObjLocFmtKey(srcPtr) != srcPtr) { - Tcl_InitObjRef(ObjLocFmtKey(copyPtr), ObjLocFmtKey(srcPtr)); - } else { - ObjLocFmtKey(copyPtr) = copyPtr; - } - copyPtr->typePtr = &ClockFmtObjType; - - - /* if no format representation, dup string representation */ - if (fss == NULL) { - copyPtr->bytes = ckalloc(srcPtr->length + 1); - memcpy(copyPtr->bytes, srcPtr->bytes, srcPtr->length + 1); - copyPtr->length = srcPtr->length; - } -} - -static void -ClockFmtObj_FreeInternalRep(objPtr) - Tcl_Obj *objPtr; -{ - ClockFmtScnStorage *fss = ObjClockFmtScn(objPtr); - if (fss != NULL) { - Tcl_MutexLock(&ClockFmtMutex); - /* decrement object reference count of format/scan storage */ - if (--fss->objRefCount <= 0) { - #if CLOCK_FMT_SCN_STORAGE_GC_SIZE > 0 - /* don't remove it right now (may be reusable), just add to GC */ - ClockFmtScnStorageGC_In(fss); - #else - /* remove storage (format representation) */ - ClockFmtScnStorageDelete(fss); - #endif - } - Tcl_MutexUnlock(&ClockFmtMutex); - } - ObjClockFmtScn(objPtr) = NULL; - if (ObjLocFmtKey(objPtr) != objPtr) { - Tcl_UnsetObjRef(ObjLocFmtKey(objPtr)); - } else { - ObjLocFmtKey(objPtr) = NULL; - } - objPtr->typePtr = NULL; -}; - -static int -ClockFmtObj_SetFromAny(interp, objPtr) - Tcl_Interp *interp; - Tcl_Obj *objPtr; -{ - /* validate string representation before free old internal represenation */ - (void)TclGetString(objPtr); - - /* free old internal represenation */ - if (objPtr->typePtr && objPtr->typePtr->freeIntRepProc) - objPtr->typePtr->freeIntRepProc(objPtr); - - /* initial state of format object */ - ObjClockFmtScn(objPtr) = NULL; - ObjLocFmtKey(objPtr) = NULL; - objPtr->typePtr = &ClockFmtObjType; - - return TCL_OK; -}; - -static void -ClockFmtObj_UpdateString(objPtr) - Tcl_Obj *objPtr; -{ - char *name = "UNKNOWN"; - int len; - ClockFmtScnStorage *fss = ObjClockFmtScn(objPtr); - - if (fss != NULL) { - Tcl_HashEntry *hPtr = HashEntry4FmtScn(fss); - name = hPtr->key.string; - } - len = strlen(name); - objPtr->length = len, - objPtr->bytes = ckalloc((size_t)++len); - if (objPtr->bytes) - memcpy(objPtr->bytes, name, len); -} - -/* - *---------------------------------------------------------------------- - * - * ClockFrmObjGetLocFmtKey -- - * - * Retrieves format key object used to search localized format. - * - * This is normally stored in second pointer of internal representation. - * If format object is not localizable, it is equal the given format - * pointer and the first pointer of internal representation may be NULL. - * - * Results: - * Returns tcl object with key or format object if not localizable. - * - * Side effects: - * Converts given format object to ClockFmtObjType on demand for caching - * the key inside its internal representation. - * - *---------------------------------------------------------------------- - */ - -MODULE_SCOPE Tcl_Obj* -ClockFrmObjGetLocFmtKey( - Tcl_Interp *interp, - Tcl_Obj *objPtr) -{ - Tcl_Obj *keyObj; - - if (objPtr->typePtr != &ClockFmtObjType) { - if (ClockFmtObj_SetFromAny(interp, objPtr) != TCL_OK) { - return NULL; - } - } - - keyObj = ObjLocFmtKey(objPtr); - if (keyObj) { - return keyObj; - } - - keyObj = Tcl_ObjPrintf("FMT_%s", TclGetString(objPtr)); - Tcl_InitObjRef(ObjLocFmtKey(objPtr), keyObj); - - return keyObj; -} - -/* - *---------------------------------------------------------------------- - * - * FindOrCreateFmtScnStorage -- - * - * Retrieves format storage for given string format. - * - * This will find the given format in the global storage hash table - * or create a format storage object on demaind and save the - * reference in the first pointer of internal representation of given - * object. - * - * Results: - * Returns scan/format storage pointer to ClockFmtScnStorage. - * - * Side effects: - * Converts given format object to ClockFmtObjType on demand for caching - * the format storage reference inside its internal representation. - * Increments objRefCount of the ClockFmtScnStorage reference. - * - *---------------------------------------------------------------------- - */ - -static ClockFmtScnStorage * -FindOrCreateFmtScnStorage( - Tcl_Interp *interp, - Tcl_Obj *objPtr) -{ - const char *strFmt = TclGetString(objPtr); - ClockFmtScnStorage *fss = NULL; - int new; - Tcl_HashEntry *hPtr; - - Tcl_MutexLock(&ClockFmtMutex); - - /* if not yet initialized */ - if (!initialized) { - /* initialize type */ - memcpy(&ClockFmtScnStorageHashKeyType, &tclStringHashKeyType, sizeof(tclStringHashKeyType)); - ClockFmtScnStorageHashKeyType.allocEntryProc = ClockFmtScnStorageAllocProc; - ClockFmtScnStorageHashKeyType.freeEntryProc = ClockFmtScnStorageFreeProc; - - /* initialize hash table */ - Tcl_InitCustomHashTable(&FmtScnHashTable, TCL_CUSTOM_TYPE_KEYS, - &ClockFmtScnStorageHashKeyType); - - initialized = 1; - Tcl_CreateExitHandler(ClockFrmScnFinalize, NULL); - } - - /* get or create entry (and alocate storage) */ - hPtr = Tcl_CreateHashEntry(&FmtScnHashTable, strFmt, &new); - if (hPtr != NULL) { - - fss = FmtScn4HashEntry(hPtr); - - #if CLOCK_FMT_SCN_STORAGE_GC_SIZE > 0 - /* unlink if it is currently in GC */ - if (new == 0 && fss->objRefCount == 0) { - ClockFmtScnStorage_GC_Out(fss); - } - #endif - - /* new reference, so increment in lock right now */ - fss->objRefCount++; - - ObjClockFmtScn(objPtr) = fss; - } - - Tcl_MutexUnlock(&ClockFmtMutex); - - if (fss == NULL && interp != NULL) { - Tcl_AppendResult(interp, "retrieve clock format failed \"", - strFmt ? strFmt : "", "\"", NULL); - Tcl_SetErrorCode(interp, "TCL", "EINVAL", NULL); - } - - return fss; -} - -/* - *---------------------------------------------------------------------- - * - * Tcl_GetClockFrmScnFromObj -- - * - * Returns a clock format/scan representation of (*objPtr), if possible. - * If something goes wrong, NULL is returned, and if interp is non-NULL, - * an error message is written there. - * - * Results: - * Valid representation of type ClockFmtScnStorage. - * - * Side effects: - * Caches the ClockFmtScnStorage reference as the internal rep of (*objPtr) - * and in global hash table, shared across all threads. - * - *---------------------------------------------------------------------- - */ - -ClockFmtScnStorage * -Tcl_GetClockFrmScnFromObj( - Tcl_Interp *interp, - Tcl_Obj *objPtr) -{ - ClockFmtScnStorage *fss; - - if (objPtr->typePtr != &ClockFmtObjType) { - if (ClockFmtObj_SetFromAny(interp, objPtr) != TCL_OK) { - return NULL; - } - } - - fss = ObjClockFmtScn(objPtr); - - if (fss == NULL) { - fss = FindOrCreateFmtScnStorage(interp, objPtr); - } - - return fss; -} -/* - *---------------------------------------------------------------------- - * - * ClockLocalizeFormat -- - * - * Wrap the format object in options to the localized format, - * corresponding given locale. - * - * This searches localized format in locale catalog, and if not yet - * exists, it executes ::tcl::clock::LocalizeFormat in given interpreter - * and caches its result in the locale catalog. - * - * Results: - * Localized format object. - * - * Side effects: - * Caches the localized format inside locale catalog. - * - *---------------------------------------------------------------------- - */ - -MODULE_SCOPE Tcl_Obj * -ClockLocalizeFormat( - ClockFmtScnCmdArgs *opts) -{ - ClockClientData *dataPtr = opts->clientData; - Tcl_Obj *valObj = NULL, *keyObj; - - keyObj = ClockFrmObjGetLocFmtKey(opts->interp, opts->formatObj); - - /* special case - format object is not localizable */ - if (keyObj == opts->formatObj) { - return opts->formatObj; - } - - if (opts->mcDictObj == NULL) { - ClockMCDict(opts); - if (opts->mcDictObj == NULL) - return NULL; - } - - /* try to find in cache within locale mc-catalog */ - if (Tcl_DictObjGet(NULL, opts->mcDictObj, - keyObj, &valObj) != TCL_OK) { - return NULL; - } - - /* call LocalizeFormat locale format fmtkey */ - if (valObj == NULL) { - Tcl_Obj *callargs[4]; - callargs[0] = dataPtr->literals[LIT_LOCALIZE_FORMAT]; - callargs[1] = opts->localeObj; - callargs[2] = opts->formatObj; - callargs[3] = keyObj; - Tcl_IncrRefCount(keyObj); - if (Tcl_EvalObjv(opts->interp, 4, callargs, 0) != TCL_OK - ) { - goto clean; - } - - valObj = Tcl_GetObjResult(opts->interp); - - /* cache it inside mc-dictionary (this incr. ref count of keyObj/valObj) */ - if (Tcl_DictObjPut(opts->interp, opts->mcDictObj, - keyObj, valObj) != TCL_OK - ) { - valObj = NULL; - goto clean; - } - - /* check special case - format object is not localizable */ - if (valObj == opts->formatObj) { - /* mark it as unlocalizable, by setting self as key (without refcount incr) */ - if (opts->formatObj->typePtr == &ClockFmtObjType) { - Tcl_UnsetObjRef(ObjLocFmtKey(opts->formatObj)); - ObjLocFmtKey(opts->formatObj) = opts->formatObj; - } - } -clean: - - Tcl_UnsetObjRef(keyObj); - if (valObj) { - Tcl_ResetResult(opts->interp); - } - } - - return (opts->formatObj = valObj); -} - -/* - *---------------------------------------------------------------------- - * - * FindTokenBegin -- - * - * Find begin of given scan token in string, corresponding token type. - * - * Results: - * Position of token inside string if found. Otherwise - end of string. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static const char * -FindTokenBegin( - register const char *p, - register const char *end, - ClockScanToken *tok) -{ - char c; - if (p < end) { - /* next token a known token type */ - switch (tok->map->type) { - case CTOKT_DIGIT: - /* should match at least one digit */ - while (!isdigit(UCHAR(*p)) && (p = TclUtfNext(p)) < end) {}; - return p; - break; - case CTOKT_WORD: - c = *(tok->tokWord.start); - /* should match at least to the first char of this word */ - while (*p != c && (p = TclUtfNext(p)) < end) {}; - return p; - break; - case CTOKT_SPACE: - while (!isspace(UCHAR(*p)) && (p = TclUtfNext(p)) < end) {}; - return p; - break; - case CTOKT_CHAR: - c = *((char *)tok->map->data); - while (*p != c && (p = TclUtfNext(p)) < end) {}; - return p; - break; - } - } - return p; -} - -/* - *---------------------------------------------------------------------- - * - * DetermineGreedySearchLen -- - * - * Determine min/max lengths as exact as possible (speed, greedy match). - * - * Results: - * None. Lengths are stored in *minLenPtr, *maxLenPtr. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static void -DetermineGreedySearchLen(ClockFmtScnCmdArgs *opts, - DateInfo *info, ClockScanToken *tok, - int *minLenPtr, int *maxLenPtr) -{ - register int minLen = tok->map->minSize; - register int maxLen; - register const char *p = yyInput + minLen, - *end = info->dateEnd; - - /* if still tokens available, try to correct minimum length */ - if ((tok+1)->map) { - end -= tok->endDistance + yySpaceCount; - /* find position of next known token */ - p = FindTokenBegin(p, end, tok+1); - if (p < end) { - minLen = p - yyInput; - } - } - - /* max length to the end regarding distance to end (min-width of following tokens) */ - maxLen = end - yyInput; - /* several amendments */ - if (maxLen > tok->map->maxSize) { - maxLen = tok->map->maxSize; - }; - if (minLen < tok->map->minSize) { - minLen = tok->map->minSize; - } - if (minLen > maxLen) { - maxLen = minLen; - } - if (maxLen > info->dateEnd - yyInput) { - maxLen = info->dateEnd - yyInput; - } - - /* check digits rigth now */ - if (tok->map->type == CTOKT_DIGIT) { - p = yyInput; - end = p + maxLen; - if (end > info->dateEnd) { end = info->dateEnd; }; - while (isdigit(UCHAR(*p)) && p < end) { p++; }; - maxLen = p - yyInput; - } - - /* try to get max length more precise for greedy match, - * check the next ahead token available there */ - if (minLen < maxLen && tok->lookAhTok) { - ClockScanToken *laTok = tok + tok->lookAhTok + 1; - p = yyInput + maxLen; - /* regards all possible spaces here (because they are optional) */ - end = p + tok->lookAhMax + yySpaceCount + 1; - if (end > info->dateEnd) { - end = info->dateEnd; - } - p += tok->lookAhMin; - if (laTok->map && p < end) { - const char *f; - /* try to find laTok between [lookAhMin, lookAhMax] */ - while (minLen < maxLen) { - f = FindTokenBegin(p, end, laTok); - /* if found (not below lookAhMax) */ - if (f < end) { - break; - } - /* try again with fewer length */ - maxLen--; - p--; - end--; - } - } else if (p > end) { - maxLen -= (p - end); - if (maxLen < minLen) { - maxLen = minLen; - } - } - } - - *minLenPtr = minLen; - *maxLenPtr = maxLen; -} - -/* - *---------------------------------------------------------------------- - * - * ObjListSearch -- - * - * Find largest part of the input string from start regarding min and - * max lengths in the given list (utf-8, case sensitive). - * - * Results: - * TCL_OK - match found, TCL_RETURN - not matched, TCL_ERROR in error case. - * - * Side effects: - * Input points to end of the found token in string. - * - *---------------------------------------------------------------------- - */ - -static inline int -ObjListSearch(ClockFmtScnCmdArgs *opts, - DateInfo *info, int *val, - Tcl_Obj **lstv, int lstc, - int minLen, int maxLen) -{ - int i, l, lf = -1; - const char *s, *f, *sf; - /* search in list */ - for (i = 0; i < lstc; i++) { - s = TclGetString(lstv[i]); - l = lstv[i]->length; - - if ( l >= minLen - && (f = TclUtfFindEqualNC(yyInput, yyInput + maxLen, s, s + l, &sf)) > yyInput - ) { - l = f - yyInput; - if (l < minLen) { - continue; - } - /* found, try to find longest value (greedy search) */ - if (l < maxLen && minLen != maxLen) { - lf = i; - minLen = l + 1; - continue; - } - /* max possible - end of search */ - *val = i; - yyInput += l; - break; - } - } - - /* if found */ - if (i < lstc) { - return TCL_OK; - } - if (lf >= 0) { - *val = lf; - yyInput += minLen - 1; - return TCL_OK; - } - return TCL_RETURN; -} -#if 0 -/* currently unused */ - -static int -LocaleListSearch(ClockFmtScnCmdArgs *opts, - DateInfo *info, int mcKey, int *val, - int minLen, int maxLen) -{ - Tcl_Obj **lstv; - int lstc; - Tcl_Obj *valObj; - - /* get msgcat value */ - valObj = ClockMCGet(opts, mcKey); - if (valObj == NULL) { - return TCL_ERROR; - } - - /* is a list */ - if (TclListObjGetElements(opts->interp, valObj, &lstc, &lstv) != TCL_OK) { - return TCL_ERROR; - } - - /* search in list */ - return ObjListSearch(opts, info, val, lstv, lstc, - minLen, maxLen); -} -#endif - -/* - *---------------------------------------------------------------------- - * - * ClockMCGetListIdxTree -- - * - * Retrieves localized string indexed tree in the locale catalog for - * given literal index mcKey (and builds it on demand). - * - * Searches localized index in locale catalog, and if not yet exists, - * creates string indexed tree and stores it in the locale catalog. - * - * Results: - * Localized string index tree. - * - * Side effects: - * Caches the localized string index tree inside locale catalog. - * - *---------------------------------------------------------------------- - */ - -static TclStrIdxTree * -ClockMCGetListIdxTree( - ClockFmtScnCmdArgs *opts, - int mcKey) -{ - TclStrIdxTree * idxTree; - Tcl_Obj *objPtr = ClockMCGetIdx(opts, mcKey); - if ( objPtr != NULL - && (idxTree = TclStrIdxTreeGetFromObj(objPtr)) != NULL - ) { - return idxTree; - - } else { - /* build new index */ - - Tcl_Obj **lstv; - int lstc; - Tcl_Obj *valObj; - - objPtr = TclStrIdxTreeNewObj(); - if ((idxTree = TclStrIdxTreeGetFromObj(objPtr)) == NULL) { - goto done; /* unexpected, but ...*/ - } - - valObj = ClockMCGet(opts, mcKey); - if (valObj == NULL) { - goto done; - } - - if (TclListObjGetElements(opts->interp, valObj, - &lstc, &lstv) != TCL_OK) { - goto done; - }; - - if (TclStrIdxTreeBuildFromList(idxTree, lstc, lstv) != TCL_OK) { - goto done; - } - - ClockMCSetIdx(opts, mcKey, objPtr); - objPtr = NULL; - }; - -done: - if (objPtr) { - Tcl_DecrRefCount(objPtr); - idxTree = NULL; - } - - return idxTree; -} - -/* - *---------------------------------------------------------------------- - * - * ClockMCGetMultiListIdxTree -- - * - * Retrieves localized string indexed tree in the locale catalog for - * multiple lists by literal indices mcKeys (and builds it on demand). - * - * Searches localized index in locale catalog for mcKey, and if not - * yet exists, creates string indexed tree and stores it in the - * locale catalog. - * - * Results: - * Localized string index tree. - * - * Side effects: - * Caches the localized string index tree inside locale catalog. - * - *---------------------------------------------------------------------- - */ - -static TclStrIdxTree * -ClockMCGetMultiListIdxTree( - ClockFmtScnCmdArgs *opts, - int mcKey, - int *mcKeys) -{ - TclStrIdxTree * idxTree; - Tcl_Obj *objPtr = ClockMCGetIdx(opts, mcKey); - if ( objPtr != NULL - && (idxTree = TclStrIdxTreeGetFromObj(objPtr)) != NULL - ) { - return idxTree; - - } else { - /* build new index */ - - Tcl_Obj **lstv; - int lstc; - Tcl_Obj *valObj; - - objPtr = TclStrIdxTreeNewObj(); - if ((idxTree = TclStrIdxTreeGetFromObj(objPtr)) == NULL) { - goto done; /* unexpected, but ...*/ - } - - while (*mcKeys) { - - valObj = ClockMCGet(opts, *mcKeys); - if (valObj == NULL) { - goto done; - } - - if (TclListObjGetElements(opts->interp, valObj, - &lstc, &lstv) != TCL_OK) { - goto done; - }; - - if (TclStrIdxTreeBuildFromList(idxTree, lstc, lstv) != TCL_OK) { - goto done; - } - mcKeys++; - } - - ClockMCSetIdx(opts, mcKey, objPtr); - objPtr = NULL; - }; - -done: - if (objPtr) { - Tcl_DecrRefCount(objPtr); - idxTree = NULL; - } - - return idxTree; -} - -/* - *---------------------------------------------------------------------- - * - * ClockStrIdxTreeSearch -- - * - * Find largest part of the input string from start regarding lengths - * in the given localized string indexed tree (utf-8, case sensitive). - * - * Results: - * TCL_OK - match found and the index stored in *val, - * TCL_RETURN - not matched or ambigous, - * TCL_ERROR - in error case. - * - * Side effects: - * Input points to end of the found token in string. - * - *---------------------------------------------------------------------- - */ - -static inline int -ClockStrIdxTreeSearch(ClockFmtScnCmdArgs *opts, - DateInfo *info, TclStrIdxTree *idxTree, int *val, - int minLen, int maxLen) -{ - const char *f; - TclStrIdx *foundItem; - f = TclStrIdxTreeSearch(NULL, &foundItem, idxTree, - yyInput, yyInput + maxLen); - - if (f <= yyInput || (f - yyInput) < minLen) { - /* not found */ - return TCL_RETURN; - } - if (foundItem->value == -1) { - /* ambigous */ - return TCL_RETURN; - } - - *val = foundItem->value; - - /* shift input pointer */ - yyInput = f; - - return TCL_OK; -} -#if 0 -/* currently unused */ - -static int -StaticListSearch(ClockFmtScnCmdArgs *opts, - DateInfo *info, const char **lst, int *val) -{ - int len; - const char **s = lst; - while (*s != NULL) { - len = strlen(*s); - if ( len <= info->dateEnd - yyInput - && strncasecmp(yyInput, *s, len) == 0 - ) { - *val = (s - lst); - yyInput += len; - break; - } - s++; - } - if (*s != NULL) { - return TCL_OK; - } - return TCL_RETURN; -} -#endif - -static inline const char * -FindWordEnd( - ClockScanToken *tok, - register const char * p, const char * end) -{ - register const char *x = tok->tokWord.start; - const char *pfnd = p; - if (x == tok->tokWord.end - 1) { /* fast phase-out for single char word */ - if (*p == *x) { - return ++p; - } - } - /* multi-char word */ - x = TclUtfFindEqualNC(x, tok->tokWord.end, p, end, &pfnd); - if (x < tok->tokWord.end) { - /* no match -> error */ - return NULL; - } - return pfnd; -} - -static int -ClockScnToken_Month_Proc(ClockFmtScnCmdArgs *opts, - DateInfo *info, ClockScanToken *tok) -{ -#if 0 -/* currently unused, test purposes only */ - static const char * months[] = { - /* full */ - "January", "February", "March", - "April", "May", "June", - "July", "August", "September", - "October", "November", "December", - /* abbr */ - "Jan", "Feb", "Mar", "Apr", "May", "Jun", - "Jul", "Aug", "Sep", "Oct", "Nov", "Dec", - NULL - }; - int val; - if (StaticListSearch(opts, info, months, &val) != TCL_OK) { - return TCL_RETURN; - } - yyMonth = (val % 12) + 1; - return TCL_OK; -#endif - - static int monthsKeys[] = {MCLIT_MONTHS_FULL, MCLIT_MONTHS_ABBREV, 0}; - - int ret, val; - int minLen, maxLen; - TclStrIdxTree *idxTree; - - DetermineGreedySearchLen(opts, info, tok, &minLen, &maxLen); - - /* get or create tree in msgcat dict */ - - idxTree = ClockMCGetMultiListIdxTree(opts, MCLIT_MONTHS_COMB, monthsKeys); - if (idxTree == NULL) { - return TCL_ERROR; - } - - ret = ClockStrIdxTreeSearch(opts, info, idxTree, &val, minLen, maxLen); - if (ret != TCL_OK) { - return ret; - } - - yyMonth = val + 1; - return TCL_OK; - -} - -static int -ClockScnToken_DayOfWeek_Proc(ClockFmtScnCmdArgs *opts, - DateInfo *info, ClockScanToken *tok) -{ - static int dowKeys[] = {MCLIT_DAYS_OF_WEEK_ABBREV, MCLIT_DAYS_OF_WEEK_FULL, 0}; - - int ret, val; - int minLen, maxLen; - char curTok = *tok->tokWord.start; - TclStrIdxTree *idxTree; - - DetermineGreedySearchLen(opts, info, tok, &minLen, &maxLen); - - /* %u %w %Ou %Ow */ - if ( curTok != 'a' && curTok != 'A' - && ((minLen <= 1 && maxLen >= 1) || PTR2INT(tok->map->data)) - ) { - - val = -1; - - if (PTR2INT(tok->map->data) == 0) { - if (*yyInput >= '0' && *yyInput <= '9') { - val = *yyInput - '0'; - } - } else { - idxTree = ClockMCGetListIdxTree(opts, PTR2INT(tok->map->data) /* mcKey */); - if (idxTree == NULL) { - return TCL_ERROR; - } - - ret = ClockStrIdxTreeSearch(opts, info, idxTree, &val, minLen, maxLen); - if (ret != TCL_OK) { - return ret; - } - } - - if (val != -1) { - if (val == 0) { - val = 7; - } - if (val > 7) { - Tcl_SetResult(opts->interp, "day of week is greater than 7", - TCL_STATIC); - Tcl_SetErrorCode(opts->interp, "CLOCK", "badDayOfWeek", NULL); - return TCL_ERROR; - } - info->date.dayOfWeek = val; - yyInput++; - return TCL_OK; - } - - - return TCL_RETURN; - } - - /* %a %A */ - idxTree = ClockMCGetMultiListIdxTree(opts, MCLIT_DAYS_OF_WEEK_COMB, dowKeys); - if (idxTree == NULL) { - return TCL_ERROR; - } - - ret = ClockStrIdxTreeSearch(opts, info, idxTree, &val, minLen, maxLen); - if (ret != TCL_OK) { - return ret; - } - - if (val == 0) { - val = 7; - } - info->date.dayOfWeek = val; - return TCL_OK; - -} - -static int -ClockScnToken_amPmInd_Proc(ClockFmtScnCmdArgs *opts, - DateInfo *info, ClockScanToken *tok) -{ - int ret, val; - int minLen, maxLen; - Tcl_Obj *amPmObj[2]; - - DetermineGreedySearchLen(opts, info, tok, &minLen, &maxLen); - - amPmObj[0] = ClockMCGet(opts, MCLIT_AM); - amPmObj[1] = ClockMCGet(opts, MCLIT_PM); - - if (amPmObj[0] == NULL || amPmObj[1] == NULL) { - return TCL_ERROR; - } - - ret = ObjListSearch(opts, info, &val, amPmObj, 2, - minLen, maxLen); - if (ret != TCL_OK) { - return ret; - } - - if (val == 0) { - yyMeridian = MERam; - } else { - yyMeridian = MERpm; - } - - return TCL_OK; -} - -static int -ClockScnToken_LocaleERA_Proc(ClockFmtScnCmdArgs *opts, - DateInfo *info, ClockScanToken *tok) -{ - ClockClientData *dataPtr = opts->clientData; - - int ret, val; - int minLen, maxLen; - Tcl_Obj *eraObj[6]; - - DetermineGreedySearchLen(opts, info, tok, &minLen, &maxLen); - - eraObj[0] = ClockMCGet(opts, MCLIT_BCE); - eraObj[1] = ClockMCGet(opts, MCLIT_CE); - eraObj[2] = dataPtr->mcLiterals[MCLIT_BCE2]; - eraObj[3] = dataPtr->mcLiterals[MCLIT_CE2]; - eraObj[4] = dataPtr->mcLiterals[MCLIT_BCE3]; - eraObj[5] = dataPtr->mcLiterals[MCLIT_CE3]; - - if (eraObj[0] == NULL || eraObj[1] == NULL) { - return TCL_ERROR; - } - - ret = ObjListSearch(opts, info, &val, eraObj, 6, - minLen, maxLen); - if (ret != TCL_OK) { - return ret; - } - - if (val & 1) { - yydate.era = CE; - } else { - yydate.era = BCE; - } - - return TCL_OK; -} - -static int -ClockScnToken_LocaleListMatcher_Proc(ClockFmtScnCmdArgs *opts, - DateInfo *info, ClockScanToken *tok) -{ - int ret, val; - int minLen, maxLen; - TclStrIdxTree *idxTree; - - DetermineGreedySearchLen(opts, info, tok, &minLen, &maxLen); - - /* get or create tree in msgcat dict */ - - idxTree = ClockMCGetListIdxTree(opts, PTR2INT(tok->map->data) /* mcKey */); - if (idxTree == NULL) { - return TCL_ERROR; - } - - ret = ClockStrIdxTreeSearch(opts, info, idxTree, &val, minLen, maxLen); - if (ret != TCL_OK) { - return ret; - } - - if (tok->map->offs > 0) { - *(int *)(((char *)info) + tok->map->offs) = val; - } - - return TCL_OK; -} - -static int -ClockScnToken_TimeZone_Proc(ClockFmtScnCmdArgs *opts, - DateInfo *info, ClockScanToken *tok) -{ - int minLen, maxLen; - int len = 0; - register const char *p = yyInput; - Tcl_Obj *tzObjStor = NULL; - - DetermineGreedySearchLen(opts, info, tok, &minLen, &maxLen); - - /* numeric timezone */ - if (*p == '+' || *p == '-') { - /* max chars in numeric zone = "+00:00:00" */ - #define MAX_ZONE_LEN 9 - char buf[MAX_ZONE_LEN + 1]; - char *bp = buf; - *bp++ = *p++; len++; - if (maxLen > MAX_ZONE_LEN) - maxLen = MAX_ZONE_LEN; - /* cumulate zone into buf without ':' */ - while (len + 1 < maxLen) { - if (!isdigit(UCHAR(*p))) break; - *bp++ = *p++; len++; - if (!isdigit(UCHAR(*p))) break; - *bp++ = *p++; len++; - if (len + 2 < maxLen) { - if (*p == ':') { - p++; len++; - } - } - } - *bp = '\0'; - - if (len < minLen) { - return TCL_RETURN; - } - #undef MAX_ZONE_LEN - - /* timezone */ - tzObjStor = Tcl_NewStringObj(buf, bp-buf); - } else { - /* legacy (alnum) timezone like CEST, etc. */ - if (maxLen > 4) - maxLen = 4; - while (len < maxLen) { - if ( (*p & 0x80) - || (!isalpha(UCHAR(*p)) && !isdigit(UCHAR(*p))) - ) { /* INTL: ISO only. */ - break; - } - p++; len++; - } - - if (len < minLen) { - return TCL_RETURN; - } - - /* timezone */ - tzObjStor = Tcl_NewStringObj(yyInput, p-yyInput); - - /* convert using dict */ - } - - /* try to apply new time zone */ - Tcl_IncrRefCount(tzObjStor); - - opts->timezoneObj = ClockSetupTimeZone(opts->clientData, opts->interp, - tzObjStor); - - Tcl_DecrRefCount(tzObjStor); - if (opts->timezoneObj == NULL) { - return TCL_ERROR; - } - - yyInput += len; - - return TCL_OK; -} - -static int -ClockScnToken_StarDate_Proc(ClockFmtScnCmdArgs *opts, - DateInfo *info, ClockScanToken *tok) -{ - int minLen, maxLen; - register const char *p = yyInput, *end; const char *s; - int year, fractYear, fractDayDiv, fractDay; - static const char *stardatePref = "stardate "; - - DetermineGreedySearchLen(opts, info, tok, &minLen, &maxLen); - - end = yyInput + maxLen; - - /* stardate string */ - p = TclUtfFindEqualNCInLwr(p, end, stardatePref, stardatePref + 9, &s); - if (p >= end || p - yyInput < 9) { - return TCL_RETURN; - } - /* bypass spaces */ - while (p < end && isspace(UCHAR(*p))) { - p++; - } - if (p >= end) { - return TCL_RETURN; - } - /* currently positive stardate only */ - if (*p == '+') { p++; }; - s = p; - while (p < end && isdigit(UCHAR(*p))) { - p++; - } - if (p >= end || p - s < 4) { - return TCL_RETURN; - } - if ( _str2int(&year, s, p-3, 1) != TCL_OK - || _str2int(&fractYear, p-3, p, 1) != TCL_OK) { - return TCL_RETURN; - }; - if (*p++ != '.') { - return TCL_RETURN; - } - s = p; - fractDayDiv = 1; - while (p < end && isdigit(UCHAR(*p))) { - fractDayDiv *= 10; - p++; - } - if ( _str2int(&fractDay, s, p, 1) != TCL_OK) { - return TCL_RETURN; - }; - yyInput = p; - - /* Build a date from year and fraction. */ - - yydate.year = year + RODDENBERRY; - yydate.era = CE; - yydate.gregorian = 1; - - if (IsGregorianLeapYear(&yydate)) { - fractYear *= 366; - } else { - fractYear *= 365; - } - yydate.dayOfYear = fractYear / 1000 + 1; - if (fractYear % 1000 >= 500) { - yydate.dayOfYear++; - } - - GetJulianDayFromEraYearDay(&yydate, GREGORIAN_CHANGE_DATE); - - yydate.localSeconds = - -210866803200L - + ( SECONDS_PER_DAY * (Tcl_WideInt)yydate.julianDay ) - + ( SECONDS_PER_DAY * fractDay / fractDayDiv ); - - return TCL_OK; -} - -static const char *ScnSTokenMapIndex = - "dmbyYHMSpJjCgGVazUsntQ"; -static ClockScanTokenMap ScnSTokenMap[] = { - /* %d %e */ - {CTOKT_DIGIT, CLF_DAYOFMONTH, 0, 1, 2, TclOffset(DateInfo, date.dayOfMonth), - NULL}, - /* %m %N */ - {CTOKT_DIGIT, CLF_MONTH, 0, 1, 2, TclOffset(DateInfo, date.month), - NULL}, - /* %b %B %h */ - {CTOKT_PARSER, CLF_MONTH, 0, 0, 0xffff, 0, - ClockScnToken_Month_Proc}, - /* %y */ - {CTOKT_DIGIT, CLF_YEAR, 0, 1, 2, TclOffset(DateInfo, date.year), - NULL}, - /* %Y */ - {CTOKT_DIGIT, CLF_YEAR | CLF_CENTURY, 0, 4, 4, TclOffset(DateInfo, date.year), - NULL}, - /* %H %k %I %l */ - {CTOKT_DIGIT, CLF_TIME, 0, 1, 2, TclOffset(DateInfo, date.hour), - NULL}, - /* %M */ - {CTOKT_DIGIT, CLF_TIME, 0, 1, 2, TclOffset(DateInfo, date.minutes), - NULL}, - /* %S */ - {CTOKT_DIGIT, CLF_TIME, 0, 1, 2, TclOffset(DateInfo, date.secondOfDay), - NULL}, - /* %p %P */ - {CTOKT_PARSER, CLF_ISO8601, 0, 0, 0xffff, 0, - ClockScnToken_amPmInd_Proc, NULL}, - /* %J */ - {CTOKT_DIGIT, CLF_JULIANDAY, 0, 1, 0xffff, TclOffset(DateInfo, date.julianDay), - NULL}, - /* %j */ - {CTOKT_DIGIT, CLF_DAYOFYEAR, 0, 1, 3, TclOffset(DateInfo, date.dayOfYear), - NULL}, - /* %C */ - {CTOKT_DIGIT, CLF_CENTURY|CLF_ISO8601CENTURY, 0, 1, 2, TclOffset(DateInfo, dateCentury), - NULL}, - /* %g */ - {CTOKT_DIGIT, CLF_ISO8601YEAR | CLF_ISO8601, 0, 2, 2, TclOffset(DateInfo, date.iso8601Year), - NULL}, - /* %G */ - {CTOKT_DIGIT, CLF_ISO8601YEAR | CLF_ISO8601 | CLF_ISO8601CENTURY, 0, 4, 4, TclOffset(DateInfo, date.iso8601Year), - NULL}, - /* %V */ - {CTOKT_DIGIT, CLF_ISO8601, 0, 1, 2, TclOffset(DateInfo, date.iso8601Week), - NULL}, - /* %a %A %u %w */ - {CTOKT_PARSER, CLF_ISO8601, 0, 0, 0xffff, 0, - ClockScnToken_DayOfWeek_Proc, NULL}, - /* %z %Z */ - {CTOKT_PARSER, CLF_OPTIONAL, 0, 0, 0xffff, 0, - ClockScnToken_TimeZone_Proc, NULL}, - /* %U %W */ - {CTOKT_DIGIT, CLF_OPTIONAL, 0, 1, 2, 0, /* currently no capture, parse only token */ - NULL}, - /* %s */ - {CTOKT_DIGIT, CLF_POSIXSEC | CLF_SIGNED, 0, 1, 0xffff, TclOffset(DateInfo, date.seconds), - NULL}, - /* %n */ - {CTOKT_CHAR, 0, 0, 1, 1, 0, NULL, "\n"}, - /* %t */ - {CTOKT_CHAR, 0, 0, 1, 1, 0, NULL, "\t"}, - /* %Q */ - {CTOKT_PARSER, CLF_LOCALSEC, 0, 16, 30, 0, - ClockScnToken_StarDate_Proc, NULL}, -}; -static const char *ScnSTokenMapAliasIndex[2] = { - "eNBhkIlPAuwZW", - "dmbbHHHpaaazU" -}; - -static const char *ScnETokenMapIndex = - "Eys"; -static ClockScanTokenMap ScnETokenMap[] = { - /* %EE */ - {CTOKT_PARSER, 0, 0, 0, 0xffff, TclOffset(DateInfo, date.year), - ClockScnToken_LocaleERA_Proc, (void *)MCLIT_LOCALE_NUMERALS}, - /* %Ey */ - {CTOKT_PARSER, 0, 0, 0, 0xffff, 0, /* currently no capture, parse only token */ - ClockScnToken_LocaleListMatcher_Proc, (void *)MCLIT_LOCALE_NUMERALS}, - /* %Es */ - {CTOKT_DIGIT, CLF_LOCALSEC | CLF_SIGNED, 0, 1, 0xffff, TclOffset(DateInfo, date.localSeconds), - NULL}, -}; -static const char *ScnETokenMapAliasIndex[2] = { - "", - "" -}; - -static const char *ScnOTokenMapIndex = - "dmyHMSu"; -static ClockScanTokenMap ScnOTokenMap[] = { - /* %Od %Oe */ - {CTOKT_PARSER, CLF_DAYOFMONTH, 0, 0, 0xffff, TclOffset(DateInfo, date.dayOfMonth), - ClockScnToken_LocaleListMatcher_Proc, (void *)MCLIT_LOCALE_NUMERALS}, - /* %Om */ - {CTOKT_PARSER, CLF_MONTH, 0, 0, 0xffff, TclOffset(DateInfo, date.month), - ClockScnToken_LocaleListMatcher_Proc, (void *)MCLIT_LOCALE_NUMERALS}, - /* %Oy */ - {CTOKT_PARSER, CLF_YEAR, 0, 0, 0xffff, TclOffset(DateInfo, date.year), - ClockScnToken_LocaleListMatcher_Proc, (void *)MCLIT_LOCALE_NUMERALS}, - /* %OH %Ok %OI %Ol */ - {CTOKT_PARSER, CLF_TIME, 0, 0, 0xffff, TclOffset(DateInfo, date.hour), - ClockScnToken_LocaleListMatcher_Proc, (void *)MCLIT_LOCALE_NUMERALS}, - /* %OM */ - {CTOKT_PARSER, CLF_TIME, 0, 0, 0xffff, TclOffset(DateInfo, date.minutes), - ClockScnToken_LocaleListMatcher_Proc, (void *)MCLIT_LOCALE_NUMERALS}, - /* %OS */ - {CTOKT_PARSER, CLF_TIME, 0, 0, 0xffff, TclOffset(DateInfo, date.secondOfDay), - ClockScnToken_LocaleListMatcher_Proc, (void *)MCLIT_LOCALE_NUMERALS}, - /* %Ou Ow */ - {CTOKT_PARSER, CLF_ISO8601, 0, 0, 0xffff, 0, - ClockScnToken_DayOfWeek_Proc, (void *)MCLIT_LOCALE_NUMERALS}, -}; -static const char *ScnOTokenMapAliasIndex[2] = { - "ekIlw", - "dHHHu" -}; - -static const char *ScnSpecTokenMapIndex = - " "; -static ClockScanTokenMap ScnSpecTokenMap[] = { - {CTOKT_SPACE, 0, 0, 1, 1, 0, - NULL}, -}; - -static ClockScanTokenMap ScnWordTokenMap = { - CTOKT_WORD, 0, 0, 1, 1, 0, - NULL -}; - - -static inline unsigned int -EstimateTokenCount( - register const char *fmt, - register const char *end) -{ - register const char *p = fmt; - unsigned int tokcnt; - /* estimate token count by % char and format length */ - tokcnt = 0; - while (p <= end) { - if (*p++ == '%') { - tokcnt++; - p++; - } - } - p = fmt + tokcnt * 2; - if (p < end) { - if ((unsigned int)(end - p) < tokcnt) { - tokcnt += (end - p); - } else { - tokcnt += tokcnt; - } - } - return ++tokcnt; -} - -#define AllocTokenInChain(tok, chain, tokCnt) \ - if (++(tok) >= (chain) + (tokCnt)) { \ - *((char **)&chain) = ckrealloc((char *)(chain), \ - (tokCnt + CLOCK_MIN_TOK_CHAIN_BLOCK_SIZE) * sizeof(*(tok))); \ - if ((chain) == NULL) { goto done; }; \ - (tok) = (chain) + (tokCnt); \ - (tokCnt) += CLOCK_MIN_TOK_CHAIN_BLOCK_SIZE; \ - } \ - memset(tok, 0, sizeof(*(tok))); - -/* - *---------------------------------------------------------------------- - */ -ClockFmtScnStorage * -ClockGetOrParseScanFormat( - Tcl_Interp *interp, /* Tcl interpreter */ - Tcl_Obj *formatObj) /* Format container */ -{ - ClockFmtScnStorage *fss; - ClockScanToken *tok; - - fss = Tcl_GetClockFrmScnFromObj(interp, formatObj); - if (fss == NULL) { - return NULL; - } - - /* if first time scanning - tokenize format */ - if (fss->scnTok == NULL) { - unsigned int tokCnt; - register const char *p, *e, *cp; - - e = p = HashEntry4FmtScn(fss)->key.string; - e += strlen(p); - - /* estimate token count by % char and format length */ - fss->scnTokC = EstimateTokenCount(p, e); - - fss->scnSpaceCount = 0; - - Tcl_MutexLock(&ClockFmtMutex); - - fss->scnTok = tok = ckalloc(sizeof(*tok) * fss->scnTokC); - memset(tok, 0, sizeof(*(tok))); - tokCnt = 1; - while (p < e) { - switch (*p) { - case '%': - if (1) { - ClockScanTokenMap * scnMap = ScnSTokenMap; - const char *mapIndex = ScnSTokenMapIndex, - **aliasIndex = ScnSTokenMapAliasIndex; - if (p+1 >= e) { - goto word_tok; - } - p++; - /* try to find modifier: */ - switch (*p) { - case '%': - /* begin new word token - don't join with previous word token, - * because current mapping should be "...%%..." -> "...%..." */ - tok->map = &ScnWordTokenMap; - tok->tokWord.start = p; - tok->tokWord.end = p+1; - AllocTokenInChain(tok, fss->scnTok, fss->scnTokC); tokCnt++; - p++; - continue; - break; - case 'E': - scnMap = ScnETokenMap, - mapIndex = ScnETokenMapIndex, - aliasIndex = ScnETokenMapAliasIndex; - p++; - break; - case 'O': - scnMap = ScnOTokenMap, - mapIndex = ScnOTokenMapIndex, - aliasIndex = ScnOTokenMapAliasIndex; - p++; - break; - } - /* search direct index */ - cp = strchr(mapIndex, *p); - if (!cp || *cp == '\0') { - /* search wrapper index (multiple chars for same token) */ - cp = strchr(aliasIndex[0], *p); - if (!cp || *cp == '\0') { - p--; if (scnMap != ScnSTokenMap) p--; - goto word_tok; - } - cp = strchr(mapIndex, aliasIndex[1][cp - aliasIndex[0]]); - if (!cp || *cp == '\0') { /* unexpected, but ... */ - #ifdef DEBUG - Tcl_Panic("token \"%c\" has no map in wrapper resolver", *p); - #endif - p--; if (scnMap != ScnSTokenMap) p--; - goto word_tok; - } - } - tok->map = &scnMap[cp - mapIndex]; - tok->tokWord.start = p; - - /* calculate look ahead value by standing together tokens */ - if (tok > fss->scnTok) { - ClockScanToken *prevTok = tok - 1; - - while (prevTok >= fss->scnTok) { - if (prevTok->map->type != tok->map->type) { - break; - } - prevTok->lookAhMin += tok->map->minSize; - prevTok->lookAhMax += tok->map->maxSize; - prevTok->lookAhTok++; - prevTok--; - } - } - - /* increase space count used in format */ - if ( tok->map->type == CTOKT_CHAR - && isspace(UCHAR(*((char *)tok->map->data))) - ) { - fss->scnSpaceCount++; - } - - /* next token */ - AllocTokenInChain(tok, fss->scnTok, fss->scnTokC); tokCnt++; - p++; - continue; - } - break; - case ' ': - cp = strchr(ScnSpecTokenMapIndex, *p); - if (!cp || *cp == '\0') { - p--; - goto word_tok; - } - tok->map = &ScnSpecTokenMap[cp - ScnSpecTokenMapIndex]; - /* increase space count used in format */ - fss->scnSpaceCount++; - /* next token */ - AllocTokenInChain(tok, fss->scnTok, fss->scnTokC); tokCnt++; - p++; - continue; - break; - default: -word_tok: - if (1) { - ClockScanToken *wordTok = tok; - if (tok > fss->scnTok && (tok-1)->map == &ScnWordTokenMap) { - wordTok = tok-1; - } - /* new word token */ - if (wordTok == tok) { - wordTok->tokWord.start = p; - wordTok->map = &ScnWordTokenMap; - AllocTokenInChain(tok, fss->scnTok, fss->scnTokC); tokCnt++; - } - if (isspace(UCHAR(*p))) { - fss->scnSpaceCount++; - } - p = TclUtfNext(p); - wordTok->tokWord.end = p; - } - break; - } - } - - /* calculate end distance value for each tokens */ - if (tok > fss->scnTok) { - unsigned int endDist = 0; - ClockScanToken *prevTok = tok-1; - - while (prevTok >= fss->scnTok) { - prevTok->endDistance = endDist; - if (prevTok->map->type != CTOKT_WORD) { - endDist += prevTok->map->minSize; - } else { - endDist += prevTok->tokWord.end - prevTok->tokWord.start; - } - prevTok--; - } - } - - /* correct count of real used tokens and free mem if desired - * (1 is acceptable delta to prevent memory fragmentation) */ - if (fss->scnTokC > tokCnt + (CLOCK_MIN_TOK_CHAIN_BLOCK_SIZE / 2)) { - if ( (tok = ckrealloc(fss->scnTok, tokCnt * sizeof(*tok))) != NULL ) { - fss->scnTok = tok; - } - } - fss->scnTokC = tokCnt; - -done: - Tcl_MutexUnlock(&ClockFmtMutex); - } - - return fss; -} - -/* - *---------------------------------------------------------------------- - */ -int -ClockScan( - register DateInfo *info, /* Date fields used for parsing & converting */ - Tcl_Obj *strObj, /* String containing the time to scan */ - ClockFmtScnCmdArgs *opts) /* Command options */ -{ - ClockClientData *dataPtr = opts->clientData; - ClockFmtScnStorage *fss; - ClockScanToken *tok; - ClockScanTokenMap *map; - register const char *p, *x, *end; - unsigned short int flags = 0; - int ret = TCL_ERROR; - - /* get localized format */ - if (ClockLocalizeFormat(opts) == NULL) { - return TCL_ERROR; - } - - if ( !(fss = ClockGetOrParseScanFormat(opts->interp, opts->formatObj)) - || !(tok = fss->scnTok) - ) { - return TCL_ERROR; - } - - /* prepare parsing */ - - yyMeridian = MER24; - - p = TclGetString(strObj); - end = p + strObj->length; - /* in strict mode - bypass spaces at begin / end only (not between tokens) */ - if (opts->flags & CLF_STRICT) { - while (p < end && isspace(UCHAR(*p))) { - p++; - } - } - yyInput = p; - /* look ahead to count spaces (bypass it by count length and distances) */ - x = end; - while (p < end) { - if (isspace(UCHAR(*p))) { - x = p++; - yySpaceCount++; - continue; - } - x = end; - p++; - } - /* ignore spaces at end */ - yySpaceCount -= (end - x); - end = x; - /* ignore mandatory spaces used in format */ - yySpaceCount -= fss->scnSpaceCount; - if (yySpaceCount < 0) { - yySpaceCount = 0; - } - info->dateStart = p = yyInput; - info->dateEnd = end; - - /* parse string */ - for (; tok->map != NULL; tok++) { - map = tok->map; - /* bypass spaces at begin of input before parsing each token */ - if ( !(opts->flags & CLF_STRICT) - && ( map->type != CTOKT_SPACE - && map->type != CTOKT_WORD - && map->type != CTOKT_CHAR ) - ) { - while (p < end && isspace(UCHAR(*p))) { - yySpaceCount--; - p++; - } - } - yyInput = p; - /* end of input string */ - if (p >= end) { - break; - } - switch (map->type) - { - case CTOKT_DIGIT: - if (1) { - int minLen, size; - int sign = 1; - if (map->flags & CLF_SIGNED) { - if (*p == '+') { yyInput = ++p; } - else - if (*p == '-') { yyInput = ++p; sign = -1; }; - } - - DetermineGreedySearchLen(opts, info, tok, &minLen, &size); - - if (size < map->minSize) { - /* missing input -> error */ - if ((map->flags & CLF_OPTIONAL)) { - continue; - } - goto not_match; - } - /* string 2 number, put number into info structure by offset */ - if (map->offs) { - p = yyInput; x = p + size; - if (!(map->flags & (CLF_LOCALSEC|CLF_POSIXSEC))) { - if (_str2int((int *)(((char *)info) + map->offs), - p, x, sign) != TCL_OK) { - goto overflow; - } - p = x; - } else { - if (_str2wideInt((Tcl_WideInt *)(((char *)info) + map->offs), - p, x, sign) != TCL_OK) { - goto overflow; - } - p = x; - } - flags = (flags & ~map->clearFlags) | map->flags; - } - } - break; - case CTOKT_PARSER: - switch (map->parser(opts, info, tok)) { - case TCL_OK: - break; - case TCL_RETURN: - if ((map->flags & CLF_OPTIONAL)) { - yyInput = p; - continue; - } - goto not_match; - break; - default: - goto done; - break; - }; - /* decrement count for possible spaces in match */ - while (p < yyInput) { - if (isspace(UCHAR(*p++))) { - yySpaceCount--; - } - } - p = yyInput; - flags = (flags & ~map->clearFlags) | map->flags; - break; - case CTOKT_SPACE: - /* at least one space */ - if (!isspace(UCHAR(*p))) { - /* unmatched -> error */ - goto not_match; - } - yySpaceCount--; - p++; - while (p < end && isspace(UCHAR(*p))) { - yySpaceCount--; - p++; - } - break; - case CTOKT_WORD: - x = FindWordEnd(tok, p, end); - if (!x) { - /* no match -> error */ - goto not_match; - } - p = x; - break; - case CTOKT_CHAR: - x = (char *)map->data; - if (*x != *p) { - /* no match -> error */ - goto not_match; - } - if (isspace(UCHAR(*x))) { - yySpaceCount--; - } - p++; - break; - } - } - /* check end was reached */ - if (p < end) { - /* something after last token - wrong format */ - goto not_match; - } - /* end of string, check only optional tokens at end, otherwise - not match */ - while (tok->map != NULL) { - if (!(opts->flags & CLF_STRICT) && (tok->map->type == CTOKT_SPACE)) { - tok++; - if (tok->map == NULL) break; - } - if (!(tok->map->flags & CLF_OPTIONAL)) { - goto not_match; - } - tok++; - } - - /* - * Invalidate result - */ - - /* seconds token (%s) take precedence over all other tokens */ - if ((opts->flags & CLF_EXTENDED) || !(flags & CLF_POSIXSEC)) { - if (flags & CLF_DATE) { - - if (!(flags & CLF_JULIANDAY)) { - info->flags |= CLF_ASSEMBLE_SECONDS|CLF_ASSEMBLE_JULIANDAY; - - /* dd precedence below ddd */ - switch (flags & (CLF_MONTH|CLF_DAYOFYEAR|CLF_DAYOFMONTH)) { - case (CLF_DAYOFYEAR|CLF_DAYOFMONTH): - /* miss month: ddd over dd (without month) */ - flags &= ~CLF_DAYOFMONTH; - case (CLF_DAYOFYEAR): - /* ddd over naked weekday */ - if (!(flags & CLF_ISO8601YEAR)) { - flags &= ~CLF_ISO8601; - } - break; - case (CLF_MONTH|CLF_DAYOFYEAR|CLF_DAYOFMONTH): - /* both available: mmdd over ddd */ - flags &= ~CLF_DAYOFYEAR; - case (CLF_MONTH|CLF_DAYOFMONTH): - case (CLF_DAYOFMONTH): - /* mmdd / dd over naked weekday */ - if (!(flags & CLF_ISO8601YEAR)) { - flags &= ~CLF_ISO8601; - } - break; - } - - /* YearWeekDay below YearMonthDay */ - if ( (flags & CLF_ISO8601) - && ( (flags & (CLF_YEAR|CLF_DAYOFYEAR)) == (CLF_YEAR|CLF_DAYOFYEAR) - || (flags & (CLF_YEAR|CLF_DAYOFMONTH|CLF_MONTH)) == (CLF_YEAR|CLF_DAYOFMONTH|CLF_MONTH) - ) - ) { - /* yy precedence below yyyy */ - if (!(flags & CLF_ISO8601CENTURY) && (flags & CLF_CENTURY)) { - /* normally precedence of ISO is higher, but no century - so put it down */ - flags &= ~CLF_ISO8601; - } - else - /* yymmdd or yyddd over naked weekday */ - if (!(flags & CLF_ISO8601YEAR)) { - flags &= ~CLF_ISO8601; - } - } - - if (!(flags & CLF_ISO8601)) { - if (yyYear < 100) { - if (!(flags & CLF_CENTURY)) { - if (yyYear >= dataPtr->yearOfCenturySwitch) { - yyYear -= 100; - } - yyYear += dataPtr->currentYearCentury; - } else { - yyYear += info->dateCentury * 100; - } - } - } else { - if (info->date.iso8601Year < 100) { - if (!(flags & CLF_ISO8601CENTURY)) { - if (info->date.iso8601Year >= dataPtr->yearOfCenturySwitch) { - info->date.iso8601Year -= 100; - } - info->date.iso8601Year += dataPtr->currentYearCentury; - } else { - info->date.iso8601Year += info->dateCentury * 100; - } - } - } - } - } - - /* if no time - reset time */ - if (!(flags & (CLF_TIME|CLF_LOCALSEC|CLF_POSIXSEC))) { - info->flags |= CLF_ASSEMBLE_SECONDS; - yydate.localSeconds = 0; - } - - if (flags & CLF_TIME) { - info->flags |= CLF_ASSEMBLE_SECONDS; - yySeconds = ToSeconds(yyHour, yyMinutes, - yySeconds, yyMeridian); - } else - if (!(flags & (CLF_LOCALSEC|CLF_POSIXSEC))) { - info->flags |= CLF_ASSEMBLE_SECONDS; - yySeconds = yydate.localSeconds % SECONDS_PER_DAY; - } - } - - /* tell caller which flags were set */ - info->flags |= flags; - - ret = TCL_OK; - goto done; - -overflow: - - Tcl_SetResult(opts->interp, "requested date too large to represent", - TCL_STATIC); - Tcl_SetErrorCode(opts->interp, "CLOCK", "dateTooLarge", NULL); - goto done; - -not_match: - - Tcl_SetResult(opts->interp, "input string does not match supplied format", - TCL_STATIC); - Tcl_SetErrorCode(opts->interp, "CLOCK", "badInputString", NULL); - -done: - - return ret; -} - -static inline int -FrmResultAllocate( - register DateFormat *dateFmt, - int len) -{ - int needed = dateFmt->output + len - dateFmt->resEnd; - if (needed >= 0) { /* >= 0 - regards NTS zero */ - int newsize = dateFmt->resEnd - dateFmt->resMem - + needed + MIN_FMT_RESULT_BLOCK_ALLOC; - char *newRes = ckrealloc(dateFmt->resMem, newsize); - if (newRes == NULL) { - return TCL_ERROR; - } - dateFmt->output = newRes + (dateFmt->output - dateFmt->resMem); - dateFmt->resMem = newRes; - dateFmt->resEnd = newRes + newsize; - } - return TCL_OK; -} - -static int -ClockFmtToken_HourAMPM_Proc( - ClockFmtScnCmdArgs *opts, - DateFormat *dateFmt, - ClockFormatToken *tok, - int *val) -{ - *val = ( ( ( *val % SECONDS_PER_DAY ) + SECONDS_PER_DAY - 3600 ) / 3600 ) % 12 + 1; - return TCL_OK; -} - -static int -ClockFmtToken_AMPM_Proc( - ClockFmtScnCmdArgs *opts, - DateFormat *dateFmt, - ClockFormatToken *tok, - int *val) -{ - Tcl_Obj *mcObj; - const char *s; - int len; - - if ((*val % SECONDS_PER_DAY) < (SECONDS_PER_DAY / 2)) { - mcObj = ClockMCGet(opts, MCLIT_AM); - } else { - mcObj = ClockMCGet(opts, MCLIT_PM); - } - if (mcObj == NULL) { - return TCL_ERROR; - } - s = TclGetString(mcObj); len = mcObj->length; - if (FrmResultAllocate(dateFmt, len) != TCL_OK) { return TCL_ERROR; }; - memcpy(dateFmt->output, s, len + 1); - if (*tok->tokWord.start == 'p') { - len = Tcl_UtfToUpper(dateFmt->output); - } - dateFmt->output += len; - - return TCL_OK; -} - -static int -ClockFmtToken_StarDate_Proc( - ClockFmtScnCmdArgs *opts, - DateFormat *dateFmt, - ClockFormatToken *tok, - int *val) - { - int fractYear; - /* Get day of year, zero based */ - int doy = dateFmt->date.dayOfYear - 1; - - /* Convert day of year to a fractional year */ - if (IsGregorianLeapYear(&dateFmt->date)) { - fractYear = 1000 * doy / 366; - } else { - fractYear = 1000 * doy / 365; - } - - /* Put together the StarDate as "Stardate %02d%03d.%1d" */ - if (FrmResultAllocate(dateFmt, 30) != TCL_OK) { return TCL_ERROR; }; - memcpy(dateFmt->output, "Stardate ", 9); - dateFmt->output += 9; - dateFmt->output = _itoaw(dateFmt->output, - dateFmt->date.year - RODDENBERRY, '0', 2); - dateFmt->output = _itoaw(dateFmt->output, - fractYear, '0', 3); - *dateFmt->output++ = '.'; - dateFmt->output = _itoaw(dateFmt->output, - dateFmt->date.localSeconds % SECONDS_PER_DAY / ( SECONDS_PER_DAY / 10 ), '0', 1); - - return TCL_OK; -} -static int -ClockFmtToken_WeekOfYear_Proc( - ClockFmtScnCmdArgs *opts, - DateFormat *dateFmt, - ClockFormatToken *tok, - int *val) -{ - int dow = dateFmt->date.dayOfWeek; - if (*tok->tokWord.start == 'U') { - if (dow == 7) { - dow = 0; - } - dow++; - } - *val = ( dateFmt->date.dayOfYear - dow + 7 ) / 7; - return TCL_OK; -} -static int -ClockFmtToken_TimeZone_Proc( - ClockFmtScnCmdArgs *opts, - DateFormat *dateFmt, - ClockFormatToken *tok, - int *val) -{ - if (*tok->tokWord.start == 'z') { - int z = dateFmt->date.tzOffset; - char sign = '+'; - if ( z < 0 ) { - z = -z; - sign = '-'; - } - if (FrmResultAllocate(dateFmt, 7) != TCL_OK) { return TCL_ERROR; }; - *dateFmt->output++ = sign; - dateFmt->output = _itoaw(dateFmt->output, z / 3600, '0', 2); - z %= 3600; - dateFmt->output = _itoaw(dateFmt->output, z / 60, '0', 2); - z %= 60; - if (z != 0) { - dateFmt->output = _itoaw(dateFmt->output, z, '0', 2); - } - } else { - Tcl_Obj * objPtr; - const char *s; int len; - /* convert seconds to local seconds to obtain tzName object */ - if (ConvertUTCToLocal(opts->clientData, opts->interp, - &dateFmt->date, opts->timezoneObj, - GREGORIAN_CHANGE_DATE) != TCL_OK) { - return TCL_ERROR; - }; - objPtr = dateFmt->date.tzName; - s = TclGetString(objPtr); - len = objPtr->length; - if (FrmResultAllocate(dateFmt, len) != TCL_OK) { return TCL_ERROR; }; - memcpy(dateFmt->output, s, len + 1); - dateFmt->output += len; - } - return TCL_OK; -} - -static int -ClockFmtToken_LocaleERA_Proc( - ClockFmtScnCmdArgs *opts, - DateFormat *dateFmt, - ClockFormatToken *tok, - int *val) -{ - Tcl_Obj *mcObj; - const char *s; - int len; - - if (dateFmt->date.era == BCE) { - mcObj = ClockMCGet(opts, MCLIT_BCE); - } else { - mcObj = ClockMCGet(opts, MCLIT_CE); - } - if (mcObj == NULL) { - return TCL_ERROR; - } - s = TclGetString(mcObj); len = mcObj->length; - if (FrmResultAllocate(dateFmt, len) != TCL_OK) { return TCL_ERROR; }; - memcpy(dateFmt->output, s, len + 1); - dateFmt->output += len; - - return TCL_OK; -} - -static int -ClockFmtToken_LocaleERAYear_Proc( - ClockFmtScnCmdArgs *opts, - DateFormat *dateFmt, - ClockFormatToken *tok, - int *val) -{ - int rowc; - Tcl_Obj **rowv; - - if (dateFmt->localeEra == NULL) { - Tcl_Obj *mcObj = ClockMCGet(opts, MCLIT_LOCALE_ERAS); - if (mcObj == NULL) { - return TCL_ERROR; - } - if (TclListObjGetElements(opts->interp, mcObj, &rowc, &rowv) != TCL_OK) { - return TCL_ERROR; - } - if (rowc != 0) { - dateFmt->localeEra = LookupLastTransition(opts->interp, - dateFmt->date.localSeconds, rowc, rowv, NULL); - } - if (dateFmt->localeEra == NULL) { - dateFmt->localeEra = (Tcl_Obj*)1; - } - } - - /* if no LOCALE_ERAS in catalog or era not found */ - if (dateFmt->localeEra == (Tcl_Obj*)1) { - if (FrmResultAllocate(dateFmt, 11) != TCL_OK) { return TCL_ERROR; }; - if (*tok->tokWord.start == 'C') { /* %EC */ - *val = dateFmt->date.year / 100; - dateFmt->output = _itoaw(dateFmt->output, - *val, '0', 2); - } else { /* %Ey */ - *val = dateFmt->date.year % 100; - dateFmt->output = _itoaw(dateFmt->output, - *val, '0', 2); - } - } else { - Tcl_Obj *objPtr; - const char *s; - int len; - if (*tok->tokWord.start == 'C') { /* %EC */ - if (Tcl_ListObjIndex(opts->interp, dateFmt->localeEra, 1, - &objPtr) != TCL_OK ) { - return TCL_ERROR; - } - } else { /* %Ey */ - if (Tcl_ListObjIndex(opts->interp, dateFmt->localeEra, 2, - &objPtr) != TCL_OK ) { - return TCL_ERROR; - } - if (Tcl_GetIntFromObj(opts->interp, objPtr, val) != TCL_OK) { - return TCL_ERROR; - } - *val = dateFmt->date.year - *val; - /* if year in locale numerals */ - if (*val >= 0 && *val < 100) { - /* year as integer */ - Tcl_Obj * mcObj = ClockMCGet(opts, MCLIT_LOCALE_NUMERALS); - if (mcObj == NULL) { - return TCL_ERROR; - } - if (Tcl_ListObjIndex(opts->interp, mcObj, *val, &objPtr) != TCL_OK) { - return TCL_ERROR; - } - } else { - /* year as integer */ - if (FrmResultAllocate(dateFmt, 11) != TCL_OK) { return TCL_ERROR; }; - dateFmt->output = _itoaw(dateFmt->output, - *val, '0', 2); - return TCL_OK; - } - } - s = TclGetString(objPtr); - len = objPtr->length; - if (FrmResultAllocate(dateFmt, len) != TCL_OK) { return TCL_ERROR; }; - memcpy(dateFmt->output, s, len + 1); - dateFmt->output += len; - } - return TCL_OK; -} - - -static const char *FmtSTokenMapIndex = - "demNbByYCHMSIklpaAuwUVzgGjJsntQ"; -static ClockFormatTokenMap FmtSTokenMap[] = { - /* %d */ - {CFMTT_INT, "0", 2, 0, 0, 0, TclOffset(DateFormat, date.dayOfMonth), NULL}, - /* %e */ - {CFMTT_INT, " ", 2, 0, 0, 0, TclOffset(DateFormat, date.dayOfMonth), NULL}, - /* %m */ - {CFMTT_INT, "0", 2, 0, 0, 0, TclOffset(DateFormat, date.month), NULL}, - /* %N */ - {CFMTT_INT, " ", 2, 0, 0, 0, TclOffset(DateFormat, date.month), NULL}, - /* %b %h */ - {CFMTT_INT, NULL, 0, CLFMT_LOCALE_INDX | CLFMT_DECR, 0, 12, TclOffset(DateFormat, date.month), - NULL, (void *)MCLIT_MONTHS_ABBREV}, - /* %B */ - {CFMTT_INT, NULL, 0, CLFMT_LOCALE_INDX | CLFMT_DECR, 0, 12, TclOffset(DateFormat, date.month), - NULL, (void *)MCLIT_MONTHS_FULL}, - /* %y */ - {CFMTT_INT, "0", 2, 0, 0, 100, TclOffset(DateFormat, date.year), NULL}, - /* %Y */ - {CFMTT_INT, "0", 4, 0, 0, 0, TclOffset(DateFormat, date.year), NULL}, - /* %C */ - {CFMTT_INT, "0", 2, 0, 100, 0, TclOffset(DateFormat, date.year), NULL}, - /* %H */ - {CFMTT_INT, "0", 2, 0, 3600, 24, TclOffset(DateFormat, date.secondOfDay), NULL}, - /* %M */ - {CFMTT_INT, "0", 2, 0, 60, 60, TclOffset(DateFormat, date.secondOfDay), NULL}, - /* %S */ - {CFMTT_INT, "0", 2, 0, 0, 60, TclOffset(DateFormat, date.secondOfDay), NULL}, - /* %I */ - {CFMTT_INT, "0", 2, CLFMT_CALC, 0, 0, TclOffset(DateFormat, date.secondOfDay), - ClockFmtToken_HourAMPM_Proc, NULL}, - /* %k */ - {CFMTT_INT, " ", 2, 0, 3600, 24, TclOffset(DateFormat, date.secondOfDay), NULL}, - /* %l */ - {CFMTT_INT, " ", 2, CLFMT_CALC, 0, 0, TclOffset(DateFormat, date.secondOfDay), - ClockFmtToken_HourAMPM_Proc, NULL}, - /* %p %P */ - {CFMTT_INT, NULL, 0, 0, 0, 0, TclOffset(DateFormat, date.secondOfDay), - ClockFmtToken_AMPM_Proc, NULL}, - /* %a */ - {CFMTT_INT, NULL, 0, CLFMT_LOCALE_INDX, 0, 7, TclOffset(DateFormat, date.dayOfWeek), - NULL, (void *)MCLIT_DAYS_OF_WEEK_ABBREV}, - /* %A */ - {CFMTT_INT, NULL, 0, CLFMT_LOCALE_INDX, 0, 7, TclOffset(DateFormat, date.dayOfWeek), - NULL, (void *)MCLIT_DAYS_OF_WEEK_FULL}, - /* %u */ - {CFMTT_INT, " ", 1, 0, 0, 0, TclOffset(DateFormat, date.dayOfWeek), NULL}, - /* %w */ - {CFMTT_INT, " ", 1, 0, 0, 7, TclOffset(DateFormat, date.dayOfWeek), NULL}, - /* %U %W */ - {CFMTT_INT, "0", 2, CLFMT_CALC, 0, 0, TclOffset(DateFormat, date.dayOfYear), - ClockFmtToken_WeekOfYear_Proc, NULL}, - /* %V */ - {CFMTT_INT, "0", 2, 0, 0, 0, TclOffset(DateFormat, date.iso8601Week), NULL}, - /* %z %Z */ - {CFMTT_INT, NULL, 0, 0, 0, 0, 0, - ClockFmtToken_TimeZone_Proc, NULL}, - /* %g */ - {CFMTT_INT, "0", 2, 0, 0, 100, TclOffset(DateFormat, date.iso8601Year), NULL}, - /* %G */ - {CFMTT_INT, "0", 4, 0, 0, 0, TclOffset(DateFormat, date.iso8601Year), NULL}, - /* %j */ - {CFMTT_INT, "0", 3, 0, 0, 0, TclOffset(DateFormat, date.dayOfYear), NULL}, - /* %J */ - {CFMTT_INT, "0", 7, 0, 0, 0, TclOffset(DateFormat, date.julianDay), NULL}, - /* %s */ - {CFMTT_WIDE, "0", 1, 0, 0, 0, TclOffset(DateFormat, date.seconds), NULL}, - /* %n */ - {CTOKT_CHAR, "\n", 0, 0, 0, 0, 0, NULL}, - /* %t */ - {CTOKT_CHAR, "\t", 0, 0, 0, 0, 0, NULL}, - /* %Q */ - {CFMTT_INT, NULL, 0, 0, 0, 0, 0, - ClockFmtToken_StarDate_Proc, NULL}, -}; -static const char *FmtSTokenMapAliasIndex[2] = { - "hPWZ", - "bpUz" -}; - -static const char *FmtETokenMapIndex = - "Eys"; -static ClockFormatTokenMap FmtETokenMap[] = { - /* %EE */ - {CFMTT_INT, NULL, 0, 0, 0, 0, TclOffset(DateFormat, date.era), - ClockFmtToken_LocaleERA_Proc, NULL}, - /* %Ey %EC */ - {CFMTT_INT, NULL, 0, 0, 0, 0, TclOffset(DateFormat, date.year), - ClockFmtToken_LocaleERAYear_Proc, NULL}, - /* %Es */ - {CFMTT_WIDE, "0", 1, 0, 0, 0, TclOffset(DateFormat, date.localSeconds), NULL}, -}; -static const char *FmtETokenMapAliasIndex[2] = { - "C", - "y" -}; - -static const char *FmtOTokenMapIndex = - "dmyHIMSuw"; -static ClockFormatTokenMap FmtOTokenMap[] = { - /* %Od %Oe */ - {CFMTT_INT, NULL, 0, CLFMT_LOCALE_INDX, 0, 100, TclOffset(DateFormat, date.dayOfMonth), - NULL, (void *)MCLIT_LOCALE_NUMERALS}, - /* %Om */ - {CFMTT_INT, NULL, 0, CLFMT_LOCALE_INDX, 0, 100, TclOffset(DateFormat, date.month), - NULL, (void *)MCLIT_LOCALE_NUMERALS}, - /* %Oy */ - {CFMTT_INT, NULL, 0, CLFMT_LOCALE_INDX, 0, 100, TclOffset(DateFormat, date.year), - NULL, (void *)MCLIT_LOCALE_NUMERALS}, - /* %OH %Ok */ - {CFMTT_INT, NULL, 0, CLFMT_LOCALE_INDX, 3600, 24, TclOffset(DateFormat, date.secondOfDay), - NULL, (void *)MCLIT_LOCALE_NUMERALS}, - /* %OI %Ol */ - {CFMTT_INT, NULL, 0, CLFMT_CALC | CLFMT_LOCALE_INDX, 0, 0, TclOffset(DateFormat, date.secondOfDay), - ClockFmtToken_HourAMPM_Proc, (void *)MCLIT_LOCALE_NUMERALS}, - /* %OM */ - {CFMTT_INT, NULL, 0, CLFMT_LOCALE_INDX, 60, 60, TclOffset(DateFormat, date.secondOfDay), - NULL, (void *)MCLIT_LOCALE_NUMERALS}, - /* %OS */ - {CFMTT_INT, NULL, 0, CLFMT_LOCALE_INDX, 0, 60, TclOffset(DateFormat, date.secondOfDay), - NULL, (void *)MCLIT_LOCALE_NUMERALS}, - /* %Ou */ - {CFMTT_INT, NULL, 0, CLFMT_LOCALE_INDX, 0, 100, TclOffset(DateFormat, date.dayOfWeek), - NULL, (void *)MCLIT_LOCALE_NUMERALS}, - /* %Ow */ - {CFMTT_INT, NULL, 0, CLFMT_LOCALE_INDX, 0, 7, TclOffset(DateFormat, date.dayOfWeek), - NULL, (void *)MCLIT_LOCALE_NUMERALS}, -}; -static const char *FmtOTokenMapAliasIndex[2] = { - "ekl", - "dHI" -}; - -static ClockFormatTokenMap FmtWordTokenMap = { - CTOKT_WORD, NULL, 0, 0, 0, 0, 0, NULL -}; - -/* - *---------------------------------------------------------------------- - */ -ClockFmtScnStorage * -ClockGetOrParseFmtFormat( - Tcl_Interp *interp, /* Tcl interpreter */ - Tcl_Obj *formatObj) /* Format container */ -{ - ClockFmtScnStorage *fss; - ClockFormatToken *tok; - - fss = Tcl_GetClockFrmScnFromObj(interp, formatObj); - if (fss == NULL) { - return NULL; - } - - /* if first time scanning - tokenize format */ - if (fss->fmtTok == NULL) { - unsigned int tokCnt; - register const char *p, *e, *cp; - - e = p = HashEntry4FmtScn(fss)->key.string; - e += strlen(p); - - /* estimate token count by % char and format length */ - fss->fmtTokC = EstimateTokenCount(p, e); - - Tcl_MutexLock(&ClockFmtMutex); - - fss->fmtTok = tok = ckalloc(sizeof(*tok) * fss->fmtTokC); - memset(tok, 0, sizeof(*(tok))); - tokCnt = 1; - while (p < e) { - switch (*p) { - case '%': - if (1) { - ClockFormatTokenMap * fmtMap = FmtSTokenMap; - const char *mapIndex = FmtSTokenMapIndex, - **aliasIndex = FmtSTokenMapAliasIndex; - if (p+1 >= e) { - goto word_tok; - } - p++; - /* try to find modifier: */ - switch (*p) { - case '%': - /* begin new word token - don't join with previous word token, - * because current mapping should be "...%%..." -> "...%..." */ - tok->map = &FmtWordTokenMap; - tok->tokWord.start = p; - tok->tokWord.end = p+1; - AllocTokenInChain(tok, fss->fmtTok, fss->fmtTokC); tokCnt++; - p++; - continue; - break; - case 'E': - fmtMap = FmtETokenMap, - mapIndex = FmtETokenMapIndex, - aliasIndex = FmtETokenMapAliasIndex; - p++; - break; - case 'O': - fmtMap = FmtOTokenMap, - mapIndex = FmtOTokenMapIndex, - aliasIndex = FmtOTokenMapAliasIndex; - p++; - break; - } - /* search direct index */ - cp = strchr(mapIndex, *p); - if (!cp || *cp == '\0') { - /* search wrapper index (multiple chars for same token) */ - cp = strchr(aliasIndex[0], *p); - if (!cp || *cp == '\0') { - p--; if (fmtMap != FmtSTokenMap) p--; - goto word_tok; - } - cp = strchr(mapIndex, aliasIndex[1][cp - aliasIndex[0]]); - if (!cp || *cp == '\0') { /* unexpected, but ... */ - #ifdef DEBUG - Tcl_Panic("token \"%c\" has no map in wrapper resolver", *p); - #endif - p--; if (fmtMap != FmtSTokenMap) p--; - goto word_tok; - } - } - tok->map = &fmtMap[cp - mapIndex]; - tok->tokWord.start = p; - /* next token */ - AllocTokenInChain(tok, fss->fmtTok, fss->fmtTokC); tokCnt++; - p++; - continue; - } - break; - default: -word_tok: - if (1) { - ClockFormatToken *wordTok = tok; - if (tok > fss->fmtTok && (tok-1)->map == &FmtWordTokenMap) { - wordTok = tok-1; - } - if (wordTok == tok) { - wordTok->tokWord.start = p; - wordTok->map = &FmtWordTokenMap; - AllocTokenInChain(tok, fss->fmtTok, fss->fmtTokC); tokCnt++; - } - p = TclUtfNext(p); - wordTok->tokWord.end = p; - } - break; - } - } - - /* correct count of real used tokens and free mem if desired - * (1 is acceptable delta to prevent memory fragmentation) */ - if (fss->fmtTokC > tokCnt + (CLOCK_MIN_TOK_CHAIN_BLOCK_SIZE / 2)) { - if ( (tok = ckrealloc(fss->fmtTok, tokCnt * sizeof(*tok))) != NULL ) { - fss->fmtTok = tok; - } - } - fss->fmtTokC = tokCnt; - -done: - Tcl_MutexUnlock(&ClockFmtMutex); - } - - return fss; -} - -/* - *---------------------------------------------------------------------- - */ -int -ClockFormat( - register DateFormat *dateFmt, /* Date fields used for parsing & converting */ - ClockFmtScnCmdArgs *opts) /* Command options */ -{ - ClockFmtScnStorage *fss; - ClockFormatToken *tok; - ClockFormatTokenMap *map; - - /* get localized format */ - if (ClockLocalizeFormat(opts) == NULL) { - return TCL_ERROR; - } - - if ( !(fss = ClockGetOrParseFmtFormat(opts->interp, opts->formatObj)) - || !(tok = fss->fmtTok) - ) { - return TCL_ERROR; - } - - /* prepare formatting */ - dateFmt->date.secondOfDay = (int)(dateFmt->date.localSeconds % SECONDS_PER_DAY); - if (dateFmt->date.secondOfDay < 0) { - dateFmt->date.secondOfDay += SECONDS_PER_DAY; - } - - /* result container object */ - dateFmt->resMem = ckalloc(MIN_FMT_RESULT_BLOCK_ALLOC); - if (dateFmt->resMem == NULL) { - return TCL_ERROR; - } - dateFmt->output = dateFmt->resMem; - dateFmt->resEnd = dateFmt->resMem + MIN_FMT_RESULT_BLOCK_ALLOC; - *dateFmt->output = '\0'; - - /* do format each token */ - for (; tok->map != NULL; tok++) { - map = tok->map; - switch (map->type) - { - case CFMTT_INT: - if (1) { - int val = (int)*(int *)(((char *)dateFmt) + map->offs); - if (map->fmtproc == NULL) { - if (map->flags & CLFMT_DECR) { - val--; - } - if (map->flags & CLFMT_INCR) { - val++; - } - if (map->divider) { - val /= map->divider; - } - if (map->divmod) { - val %= map->divmod; - } - } else { - if (map->fmtproc(opts, dateFmt, tok, &val) != TCL_OK) { - goto done; - } - /* if not calculate only (output inside fmtproc) */ - if (!(map->flags & CLFMT_CALC)) { - continue; - } - } - if (!(map->flags & CLFMT_LOCALE_INDX)) { - if (FrmResultAllocate(dateFmt, 11) != TCL_OK) { goto error; }; - if (map->width) { - dateFmt->output = _itoaw(dateFmt->output, val, *map->tostr, map->width); - } else { - dateFmt->output += sprintf(dateFmt->output, map->tostr, val); - } - } else { - const char *s; - Tcl_Obj * mcObj = ClockMCGet(opts, PTR2INT(map->data) /* mcKey */); - if (mcObj == NULL) { - goto error; - } - if ( Tcl_ListObjIndex(opts->interp, mcObj, val, &mcObj) != TCL_OK - || mcObj == NULL - ) { - goto error; - } - s = TclGetString(mcObj); - if (FrmResultAllocate(dateFmt, mcObj->length) != TCL_OK) { goto error; }; - memcpy(dateFmt->output, s, mcObj->length + 1); - dateFmt->output += mcObj->length; - } - } - break; - case CFMTT_WIDE: - if (1) { - Tcl_WideInt val = *(Tcl_WideInt *)(((char *)dateFmt) + map->offs); - if (FrmResultAllocate(dateFmt, 21) != TCL_OK) { goto error; }; - if (map->width) { - dateFmt->output = _witoaw(dateFmt->output, val, *map->tostr, map->width); - } else { - dateFmt->output += sprintf(dateFmt->output, map->tostr, val); - } - } - break; - case CTOKT_CHAR: - if (FrmResultAllocate(dateFmt, 1) != TCL_OK) { goto error; }; - *dateFmt->output++ = *map->tostr; - break; - case CFMTT_PROC: - if (map->fmtproc(opts, dateFmt, tok, NULL) != TCL_OK) { - goto error; - }; - break; - case CTOKT_WORD: - if (1) { - int len = tok->tokWord.end - tok->tokWord.start; - if (FrmResultAllocate(dateFmt, len) != TCL_OK) { goto error; }; - if (len == 1) { - *dateFmt->output++ = *tok->tokWord.start; - } else { - memcpy(dateFmt->output, tok->tokWord.start, len); - dateFmt->output += len; - } - } - break; - } - } - - goto done; - -error: - - ckfree(dateFmt->resMem); - dateFmt->resMem = NULL; - -done: - - if (dateFmt->resMem) { - Tcl_Obj * result = Tcl_NewObj(); - result->length = dateFmt->output - dateFmt->resMem; - result->bytes = NULL; - result->bytes = ckrealloc(dateFmt->resMem, result->length+1); - if (result->bytes == NULL) { - result->bytes = dateFmt->resMem; - } - result->bytes[result->length] = '\0'; - Tcl_SetObjResult(opts->interp, result); - return TCL_OK; - } - - return TCL_ERROR; -} - - -MODULE_SCOPE void -ClockFrmScnClearCaches(void) -{ - Tcl_MutexLock(&ClockFmtMutex); - /* clear caches ... */ - Tcl_MutexUnlock(&ClockFmtMutex); -} - -static void -ClockFrmScnFinalize( - ClientData clientData) /* Not used. */ -{ - Tcl_MutexLock(&ClockFmtMutex); -#if CLOCK_FMT_SCN_STORAGE_GC_SIZE > 0 - /* clear GC */ - ClockFmtScnStorage_GC.stackPtr = NULL; - ClockFmtScnStorage_GC.stackBound = NULL; - ClockFmtScnStorage_GC.count = 0; -#endif - if (initialized) { - Tcl_DeleteHashTable(&FmtScnHashTable); - initialized = 0; - } - Tcl_MutexUnlock(&ClockFmtMutex); - Tcl_MutexFinalize(&ClockFmtMutex); -} -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 9c6f6a1..a48dfc7 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,7 +282,6 @@ Tcl_CaseObjCmd( return TCL_OK; } -#endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -542,79 +556,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; + } /* @@ -642,16 +857,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\"", @@ -665,6 +880,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 a7a5f43..9fbb0ad 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -1677,7 +1677,7 @@ InfoLibraryCmd( return TCL_ERROR; } - libDirName = Tcl_GetVar2(interp, "tcl_library", NULL, TCL_GLOBAL_ONLY); + libDirName = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY); if (libDirName != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj(libDirName, -1)); return TCL_OK; @@ -1717,24 +1717,19 @@ InfoLoadedCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - const char *interpName, *packageName; + const char *interpName; - if (objc > 3) { - Tcl_WrongNumArgs(interp, 1, objv, "?interp? ?packageName?"); + if ((objc != 1) && (objc != 2)) { + Tcl_WrongNumArgs(interp, 1, objv, "?interp?"); return TCL_ERROR; } - if (objc < 2) { /* Get loaded pkgs in all interpreters. */ + if (objc == 1) { /* Get loaded pkgs in all interpreters. */ interpName = NULL; } else { /* Get pkgs just in specified interp. */ interpName = TclGetString(objv[1]); } - 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); + return TclGetLoadedPackages(interp, interpName); } /* @@ -1808,7 +1803,7 @@ InfoPatchLevelCmd( return TCL_ERROR; } - patchlevel = Tcl_GetVar2(interp, "tcl_patchLevel", NULL, + patchlevel = Tcl_GetVar(interp, "tcl_patchLevel", (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); if (patchlevel != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj(patchlevel, -1)); @@ -2160,8 +2155,8 @@ Tcl_JoinObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { - int listLen; - Tcl_Obj *resObjPtr = NULL, *joinObjPtr, **elemPtrs; + int listLen, i; + Tcl_Obj *resObjPtr, *joinObjPtr, **elemPtrs; if ((objc < 2) || (objc > 3)) { Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?"); @@ -2178,47 +2173,27 @@ 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); - 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) { + 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. - */ + /* + * 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, joinObjPtr); } + Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]); } Tcl_DecrRefCount(joinObjPtr); - if (resObjPtr) { - Tcl_SetObjResult(interp, resObjPtr); - return TCL_OK; - } - return TCL_ERROR; + Tcl_SetObjResult(interp, resObjPtr); + return TCL_OK; } /* diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index b62ccf8..8c2c026 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -324,7 +324,7 @@ Tcl_RegexpObjCmd( if (match == 0) { /* - * We want to set the value of the interpreter result only when + * We want to set the value of the intepreter result only when * this is the first time through the loop. */ @@ -990,11 +990,8 @@ 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; } @@ -1012,30 +1009,9 @@ 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; - - 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; + + return TclNREvalFile(interp, fileName, encodingName); } /* @@ -1201,7 +1177,8 @@ StringFirstCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int start = 0; + Tcl_UniChar *needleStr, *haystackStr; + int match, start, needleLen, haystackLen; if (objc < 3 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, @@ -1209,23 +1186,82 @@ 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) { - int size = Tcl_GetCharLength(objv[2]); + /* + * If a startIndex is specified, we will need to fast forward to that + * point in the string before we think about a match. + */ - if (TCL_OK != TclGetIntForIndexM(interp, objv[3], size - 1, &start)) { + if (TclGetIntForIndexM(interp, objv[3], haystackLen-1, + &start) != TCL_OK){ return TCL_ERROR; } - if (start < 0) { + /* + * 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 + */ + start = 0; } - if (start >= size) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(-1)); - return TCL_OK; + } + + /* + * 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; + } } } - Tcl_SetObjResult(interp, Tcl_NewIntObj(TclStringFind(objv[1], - objv[2], start))); + + /* + * 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)); return TCL_OK; } @@ -1254,31 +1290,76 @@ StringLastCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int last = INT_MAX - 1; + Tcl_UniChar *needleStr, *haystackStr, *p; + int match, start, needleLen, haystackLen; if (objc < 3 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, - "needleString haystackString ?lastIndex?"); + "needleString haystackString ?startIndex?"); 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) { - int size = Tcl_GetCharLength(objv[2]); + /* + * If a startIndex is specified, we will need to restrict the string + * range to that char index in the string + */ - if (TCL_OK != TclGetIntForIndexM(interp, objv[3], size - 1, &last)) { + if (TclGetIntForIndexM(interp, objv[3], haystackLen-1, + &start) != TCL_OK){ return TCL_ERROR; } - if (last < 0) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(-1)); - return TCL_OK; + /* + * 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 >= size) { - last = size - 1; + } 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; + } } } - Tcl_SetObjResult(interp, Tcl_NewIntObj(TclStringLast(objv[1], - objv[2], last))); + + str_last_done: + Tcl_SetObjResult(interp, Tcl_NewIntObj(match)); return TCL_OK; } @@ -1793,7 +1874,7 @@ StringMapCmd( /* * This test is tricky, but has to be that way or you get other strange - * inconsistencies (see test string-10.20.1 for illustration why!) + * inconsistencies (see test string-10.20 for illustration why!) */ if (objv[objc-2]->typePtr == &tclDictType && objv[objc-2]->bytes == NULL){ @@ -2143,7 +2224,9 @@ StringReptCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int count; + const char *string1; + char *string2; + int count, index, length1, length2; Tcl_Obj *resultPtr; if (objc != 3) { @@ -2161,15 +2244,70 @@ StringReptCmd( if (count == 1) { Tcl_SetObjResult(interp, objv[1]); - return TCL_OK; + goto done; } else if (count < 1) { - return TCL_OK; + 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; } + length2 = length1 * count; - if (TCL_OK != TclStringRepeat(interp, objv[1], count, &resultPtr)) { + /* + * 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); 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; } @@ -2718,7 +2856,7 @@ StringCatCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int code; + int i; Tcl_Obj *objResultPtr; if (objc < 2) { @@ -2735,16 +2873,16 @@ StringCatCmd( Tcl_SetObjResult(interp, objv[1]); return TCL_OK; } - - code = TclStringCatObjv(interp, /* inPlace */ 1, objc-1, objv+1, - &objResultPtr); - - if (code == TCL_OK) { - Tcl_SetObjResult(interp, objResultPtr); - 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]); + } + Tcl_SetObjResult(interp, objResultPtr); - return code; + return TCL_OK; } /* @@ -4527,7 +4665,7 @@ TclNRTryObjCmd( } info[0] = objv[i]; /* type */ - TclNewLongObj(info[1], code); /* returnCode */ + TclNewIntObj(info[1], code); /* returnCode */ if (info[2] == NULL) { /* errorCodePrefix */ TclNewObj(info[2]); } diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 5f4c298..c2b4bdb 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; +} + /* *---------------------------------------------------------------------- * @@ -801,7 +900,7 @@ TclCompileConcatCmd( Tcl_ListObjGetElements(NULL, listObj, &len, &objs); objPtr = Tcl_ConcatObj(len, objs); Tcl_DecrRefCount(listObj); - bytes = TclGetStringFromObj(objPtr, &len); + bytes = Tcl_GetStringFromObj(objPtr, &len); PushLiteral(envPtr, bytes, len); Tcl_DecrRefCount(objPtr); return TCL_OK; @@ -1209,7 +1308,7 @@ TclCompileDictCreateCmd( * We did! Excellent. The "verifyDict" is to do type forcing. */ - bytes = TclGetStringFromObj(dictObj, &len); + bytes = Tcl_GetStringFromObj(dictObj, &len); PushLiteral(envPtr, bytes, len); TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_DICT_VERIFY, envPtr); @@ -2650,7 +2749,7 @@ CompileEachloopCmd( int numBytes, varIndex; Tcl_ListObjIndex(NULL, varListObj, j, &varNameObj); - bytes = TclGetStringFromObj(varNameObj, &numBytes); + bytes = Tcl_GetStringFromObj(varNameObj, &numBytes); varIndex = LocalScalar(bytes, numBytes, envPtr); if (varIndex < 0) { code = TCL_ERROR; @@ -3087,7 +3186,7 @@ TclCompileFormatCmd( * literal. Job done. */ - bytes = TclGetStringFromObj(tmpObj, &len); + bytes = Tcl_GetStringFromObj(tmpObj, &len); PushLiteral(envPtr, bytes, len); Tcl_DecrRefCount(tmpObj); return TCL_OK; @@ -3158,7 +3257,7 @@ TclCompileFormatCmd( if (*++bytes == '%') { Tcl_AppendToObj(tmpObj, "%", 1); } else { - char *b = TclGetStringFromObj(tmpObj, &len); + char *b = Tcl_GetStringFromObj(tmpObj, &len); /* * If there is a non-empty literal from the format string, @@ -3192,7 +3291,7 @@ TclCompileFormatCmd( */ Tcl_AppendToObj(tmpObj, start, bytes - start); - bytes = TclGetStringFromObj(tmpObj, &len); + bytes = Tcl_GetStringFromObj(tmpObj, &len); if (len > 0) { PushLiteral(envPtr, bytes, len); i++; diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index ff5495c..ffe39ba 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -2451,7 +2451,7 @@ TclCompileRegsubCmd( * replacement "simple"? */ - bytes = TclGetStringFromObj(patternObj, &len); + bytes = Tcl_GetStringFromObj(patternObj, &len); if (TclReToGlob(NULL, bytes, len, &pattern, &exact, &quantified) != TCL_OK || exact || quantified) { goto done; @@ -2499,7 +2499,7 @@ TclCompileRegsubCmd( result = TCL_OK; bytes = Tcl_DStringValue(&pattern) + 1; PushLiteral(envPtr, bytes, len); - bytes = TclGetStringFromObj(replacementObj, &len); + bytes = Tcl_GetStringFromObj(replacementObj, &len); PushLiteral(envPtr, bytes, len); CompileWord(envPtr, stringTokenPtr, interp, parsePtr->numWords-2); TclEmitOpcode( INST_STR_MAP, envPtr); @@ -2761,7 +2761,7 @@ TclCompileSyntaxError( const char *bytes = TclGetStringFromObj(msg, &numBytes); TclErrorStackResetIf(interp, bytes, numBytes); - TclEmitPush(TclRegisterLiteral(envPtr, bytes, numBytes, 0), envPtr); + TclEmitPush(TclRegisterNewLiteral(envPtr, bytes, numBytes), envPtr); CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0, TclNoErrorStack(interp, Tcl_GetReturnOptions(interp, TCL_ERROR))); Tcl_ResetResult(interp); diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 25d10d6..101edbd 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -312,7 +312,7 @@ TclCompileStringCatCmd( Tcl_DecrRefCount(obj); if (folded) { int len; - const char *bytes = TclGetStringFromObj(folded, &len); + const char *bytes = Tcl_GetStringFromObj(folded, &len); PushLiteral(envPtr, bytes, len); Tcl_DecrRefCount(folded); @@ -330,7 +330,7 @@ TclCompileStringCatCmd( } if (folded) { int len; - const char *bytes = TclGetStringFromObj(folded, &len); + const char *bytes = Tcl_GetStringFromObj(folded, &len); PushLiteral(envPtr, bytes, len); Tcl_DecrRefCount(folded); @@ -948,12 +948,12 @@ TclCompileStringMapCmd( * correct semantics for mapping. */ - bytes = TclGetStringFromObj(objv[0], &len); + bytes = Tcl_GetStringFromObj(objv[0], &len); if (len == 0) { CompileWord(envPtr, stringTokenPtr, interp, 2); } else { PushLiteral(envPtr, bytes, len); - bytes = TclGetStringFromObj(objv[1], &len); + bytes = Tcl_GetStringFromObj(objv[1], &len); PushLiteral(envPtr, bytes, len); CompileWord(envPtr, stringTokenPtr, interp, 2); OP(STR_MAP); @@ -1456,8 +1456,8 @@ TclSubstCompile( switch (tokenPtr->type) { case TCL_TOKEN_TEXT: - literal = TclRegisterLiteral(envPtr, - tokenPtr->start, tokenPtr->size, 0); + literal = TclRegisterNewLiteral(envPtr, + tokenPtr->start, tokenPtr->size); TclEmitPush(literal, envPtr); TclAdvanceLines(&bline, tokenPtr->start, tokenPtr->start + tokenPtr->size); @@ -1466,7 +1466,7 @@ TclSubstCompile( case TCL_TOKEN_BS: length = TclParseBackslash(tokenPtr->start, tokenPtr->size, NULL, buf); - literal = TclRegisterLiteral(envPtr, buf, length, 0); + literal = TclRegisterNewLiteral(envPtr, buf, length); TclEmitPush(literal, envPtr); count++; continue; @@ -1902,10 +1902,10 @@ TclCompileSwitchCmd( } if (numWords % 2) { abort: - ckfree(bodyToken); - ckfree(bodyTokenArray); - ckfree(bodyLines); - ckfree(bodyContLines); + ckfree((char *) bodyToken); + ckfree((char *) bodyTokenArray); + ckfree((char *) bodyLines); + ckfree((char *) bodyContLines); return TCL_ERROR; } } else if (numWords % 2 || numWords == 0) { @@ -2825,7 +2825,7 @@ TclCompileTryCmd( } if (objc > 0) { int len; - const char *varname = TclGetStringFromObj(objv[0], &len); + const char *varname = Tcl_GetStringFromObj(objv[0], &len); resultVarIndices[i] = LocalScalar(varname, len, envPtr); if (resultVarIndices[i] < 0) { @@ -2837,7 +2837,7 @@ TclCompileTryCmd( } if (objc == 2) { int len; - const char *varname = TclGetStringFromObj(objv[1], &len); + const char *varname = Tcl_GetStringFromObj(objv[1], &len); optionVarIndices[i] = LocalScalar(varname, len, envPtr); if (optionVarIndices[i] < 0) { @@ -3040,7 +3040,7 @@ IssueTryClausesInstructions( OP4( DICT_GET, 1); TclAdjustStackDepth(-1, envPtr); OP44( LIST_RANGE_IMM, 0, len-1); - p = TclGetStringFromObj(matchClauses[i], &len); + p = Tcl_GetStringFromObj(matchClauses[i], &len); PushLiteral(envPtr, p, len); OP( STR_EQ); JUMP4( JUMP_FALSE, notECJumpSource); @@ -3251,7 +3251,7 @@ IssueTryClausesFinallyInstructions( OP4( DICT_GET, 1); TclAdjustStackDepth(-1, envPtr); OP44( LIST_RANGE_IMM, 0, len-1); - p = TclGetStringFromObj(matchClauses[i], &len); + p = Tcl_GetStringFromObj(matchClauses[i], &len); PushLiteral(envPtr, p, len); OP( STR_EQ); JUMP4( JUMP_FALSE, notECJumpSource); @@ -3579,7 +3579,7 @@ TclCompileUnsetCmd( const char *bytes; int len; - bytes = TclGetStringFromObj(leadingWord, &len); + bytes = Tcl_GetStringFromObj(leadingWord, &len); if (i == 1 && len == 11 && !strncmp("-nocomplain", bytes, 11)) { flags = 0; haveFlags++; diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 83bb883..4390282 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -2181,6 +2181,7 @@ ExecConstantExprTree( CompileEnv *envPtr; ByteCode *byteCodePtr; int code; + Tcl_Obj *byteCodeObj = Tcl_NewObj(); NRE_callback *rootPtr = TOP_CB(interp); /* @@ -2194,12 +2195,14 @@ ExecConstantExprTree( CompileExprTree(interp, nodes, index, litObjvPtr, NULL, NULL, envPtr, 0 /* optimize */); TclEmitOpcode(INST_DONE, envPtr); - byteCodePtr = TclInitByteCode(envPtr); + Tcl_IncrRefCount(byteCodeObj); + TclInitByteCodeObj(byteCodeObj, envPtr); TclFreeCompileEnv(envPtr); TclStackFree(interp, envPtr); + byteCodePtr = byteCodeObj->internalRep.twoPtrValue.ptr1; TclNRExecuteByteCode(interp, byteCodePtr); code = TclNRRunCallbacks(interp, TCL_OK, rootPtr); - TclReleaseByteCode(byteCodePtr); + Tcl_DecrRefCount(byteCodeObj); return code; } @@ -2267,9 +2270,9 @@ CompileExprTree( p = TclGetStringFromObj(*funcObjv, &length); funcObjv++; Tcl_DStringAppend(&cmdName, p, length); - TclEmitPush(TclRegisterLiteral(envPtr, + TclEmitPush(TclRegisterNewCmdLiteral(envPtr, Tcl_DStringValue(&cmdName), - Tcl_DStringLength(&cmdName), LITERAL_CMD_NAME), envPtr); + Tcl_DStringLength(&cmdName)), envPtr); Tcl_DStringFree(&cmdName); /* @@ -2376,8 +2379,8 @@ CompileExprTree( pc1 = CurrentOffset(envPtr); TclEmitInstInt1((nodePtr->lexeme == AND) ? INST_JUMP_FALSE1 : INST_JUMP_TRUE1, 0, envPtr); - TclEmitPush(TclRegisterLiteral(envPtr, - (nodePtr->lexeme == AND) ? "1" : "0", 1, 0), envPtr); + TclEmitPush(TclRegisterNewLiteral(envPtr, + (nodePtr->lexeme == AND) ? "1" : "0", 1), envPtr); pc2 = CurrentOffset(envPtr); TclEmitInstInt1(INST_JUMP1, 0, envPtr); TclAdjustStackDepth(-1, envPtr); @@ -2386,8 +2389,8 @@ CompileExprTree( if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) { pc2 += 3; } - TclEmitPush(TclRegisterLiteral(envPtr, - (nodePtr->lexeme == AND) ? "0" : "1", 1, 0), envPtr); + TclEmitPush(TclRegisterNewLiteral(envPtr, + (nodePtr->lexeme == AND) ? "0" : "1", 1), envPtr); TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc2, envPtr->codeStart + pc2 + 1); convert = 0; @@ -2421,7 +2424,7 @@ CompileExprTree( if (optimize) { int length; const char *bytes = TclGetStringFromObj(literal, &length); - int index = TclRegisterLiteral(envPtr, bytes, length, 0); + int index = TclRegisterNewLiteral(envPtr, bytes, length); Tcl_Obj *objPtr = TclFetchLiteral(envPtr, index); if ((objPtr->typePtr == NULL) && (literal->typePtr != NULL)) { @@ -2479,8 +2482,8 @@ CompileExprTree( if (objPtr->bytes) { Tcl_Obj *tableValue; - index = TclRegisterLiteral(envPtr, objPtr->bytes, - objPtr->length, 0); + index = TclRegisterNewLiteral(envPtr, objPtr->bytes, + objPtr->length); tableValue = TclFetchLiteral(envPtr, index); if ((tableValue->typePtr == NULL) && (objPtr->typePtr != NULL)) { diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 7e6a5af..f716195 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}} }; @@ -661,7 +666,6 @@ InstructionDesc const tclInstructionTable[] = { * Prototypes for procedures defined later in this file: */ -static void CleanupByteCode(ByteCode *codePtr); static ByteCode * CompileSubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); static void DupByteCodeInternalRep(Tcl_Obj *srcPtr, @@ -677,7 +681,6 @@ static void FreeSubstCodeInternalRep(Tcl_Obj *objPtr); static int GetCmdLocEncodingSize(CompileEnv *envPtr); static int IsCompactibleCompileEnv(Tcl_Interp *interp, CompileEnv *envPtr); -static void PreventCycle(Tcl_Obj *objPtr, CompileEnv *envPtr); #ifdef TCL_COMPILE_STATS static void RecordByteCodeStats(ByteCode *codePtr); #endif /* TCL_COMPILE_STATS */ @@ -765,8 +768,7 @@ TclSetByteCodeFromAny( Interp *iPtr = (Interp *) interp; CompileEnv compEnv; /* Compilation environment structure allocated * in frame. */ - size_t length; - int result = TCL_OK; + int length, result = TCL_OK; const char *stringPtr; Proc *procPtr = iPtr->compiledProcPtr; ContLineLoc *clLocPtr; @@ -781,8 +783,7 @@ TclSetByteCodeFromAny( } #endif - stringPtr = TclGetString(objPtr); - length = objPtr->length; + stringPtr = TclGetStringFromObj(objPtr, &length); /* * TIP #280: Pick up the CmdFrame in which the BC compiler was invoked and @@ -870,7 +871,7 @@ TclSetByteCodeFromAny( #endif /*TCL_COMPILE_DEBUG*/ if (result == TCL_OK) { - (void) TclInitByteCodeObj(objPtr, &tclByteCodeType, &compEnv); + TclInitByteCodeObj(objPtr, &compEnv); #ifdef TCL_COMPILE_DEBUG if (tclTraceCompile >= 2) { TclPrintByteCodeObj(interp, objPtr); @@ -971,13 +972,16 @@ FreeByteCodeInternalRep( { register ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; - TclReleaseByteCode(codePtr); + objPtr->typePtr = NULL; + if (codePtr->refCount-- <= 1) { + TclCleanupByteCode(codePtr); + } } /* *---------------------------------------------------------------------- * - * TclReleaseByteCode -- + * TclCleanupByteCode -- * * This procedure does all the real work of freeing up a bytecode * object's ByteCode structure. It's called only when the structure's @@ -994,26 +998,7 @@ FreeByteCodeInternalRep( */ void -TclPreserveByteCode( - register ByteCode *codePtr) -{ - codePtr->refCount++; -} - -void -TclReleaseByteCode( - register ByteCode *codePtr) -{ - if (codePtr->refCount-- > 1) { - return; - } - - /* Just dropped to refcount==0. Clean up. */ - CleanupByteCode(codePtr); -} - -static void -CleanupByteCode( +TclCleanupByteCode( register ByteCode *codePtr) /* Points to the ByteCode to free. */ { Tcl_Interp *interp = (Tcl_Interp *) *codePtr->interpHandle; @@ -1280,6 +1265,8 @@ Tcl_NRSubstObj( * * Results: * A (ByteCode *) is returned pointing to the resulting ByteCode. + * The caller must manage its refCount and arrange for a call to + * TclCleanupByteCode() when the last reference disappears. * * Side effects: * The Tcl_ObjType of objPtr is changed to the "substcode" type, and the @@ -1310,13 +1297,13 @@ CompileSubstObj( || (codePtr->nsEpoch != nsPtr->resolverEpoch) || (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) { - TclFreeIntRep(objPtr); + FreeSubstCodeInternalRep(objPtr); } } if (objPtr->typePtr != &substCodeType) { CompileEnv compEnv; int numBytes; - const char *bytes = TclGetStringFromObj(objPtr, &numBytes); + const char *bytes = Tcl_GetStringFromObj(objPtr, &numBytes); /* TODO: Check for more TIP 280 */ TclInitCompileEnv(interp, &compEnv, bytes, numBytes, NULL, 0); @@ -1324,9 +1311,11 @@ CompileSubstObj( TclSubstCompile(interp, bytes, numBytes, flags, 1, &compEnv); TclEmitOpcode(INST_DONE, &compEnv); - codePtr = TclInitByteCodeObj(objPtr, &substCodeType, &compEnv); + TclInitByteCodeObj(objPtr, &compEnv); + objPtr->typePtr = &substCodeType; TclFreeCompileEnv(&compEnv); + codePtr = objPtr->internalRep.twoPtrValue.ptr1; objPtr->internalRep.twoPtrValue.ptr1 = codePtr; objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(flags); if (iPtr->varFramePtr->localCachePtr) { @@ -1369,7 +1358,10 @@ FreeSubstCodeInternalRep( { register ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; - TclReleaseByteCode(codePtr); + objPtr->typePtr = NULL; + if (codePtr->refCount-- <= 1) { + TclCleanupByteCode(codePtr); + } } static void @@ -1382,14 +1374,14 @@ ReleaseCmdWordData( Tcl_DecrRefCount(eclPtr->path); } for (i=0 ; i<eclPtr->nuloc ; i++) { - ckfree(eclPtr->loc[i].line); + ckfree((char *) eclPtr->loc[i].line); } if (eclPtr->loc != NULL) { - ckfree(eclPtr->loc); + ckfree((char *) eclPtr->loc); } - ckfree(eclPtr); + ckfree((char *) eclPtr); } /* @@ -1803,8 +1795,8 @@ CompileCmdLiteral( extraLiteralFlags |= LITERAL_UNSHARED; } - bytes = TclGetStringFromObj(cmdObj, &numBytes); - cmdLitIdx = TclRegisterLiteral(envPtr, bytes, numBytes, extraLiteralFlags); + bytes = Tcl_GetStringFromObj(cmdObj, &numBytes); + cmdLitIdx = TclRegisterLiteral(envPtr, (char *)bytes, numBytes, extraLiteralFlags); if (cmdPtr) { TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr); @@ -1839,8 +1831,8 @@ TclCompileInvocation( continue; } - objIdx = TclRegisterLiteral(envPtr, - tokenPtr[1].start, tokenPtr[1].size, 0); + objIdx = TclRegisterNewLiteral(envPtr, + tokenPtr[1].start, tokenPtr[1].size); if (envPtr->clNext) { TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), tokenPtr[1].start - envPtr->source, envPtr->clNext); @@ -1889,8 +1881,8 @@ CompileExpanded( continue; } - objIdx = TclRegisterLiteral(envPtr, - tokenPtr[1].start, tokenPtr[1].size, 0); + objIdx = TclRegisterNewLiteral(envPtr, + tokenPtr[1].start, tokenPtr[1].size); if (envPtr->clNext) { TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), tokenPtr[1].start - envPtr->source, envPtr->clNext); @@ -2718,40 +2710,11 @@ TclCompileNoOp( *---------------------------------------------------------------------- */ -static void -PreventCycle( - Tcl_Obj *objPtr, - CompileEnv *envPtr) -{ - int i; - - for (i = 0; i < envPtr->literalArrayNext; i++) { - if (objPtr == TclFetchLiteral(envPtr, i)) { - /* - * Prevent circular reference where the bytecode intrep of - * a value contains a literal which is that same value. - * If this is allowed to happen, refcount decrements may not - * reach zero, and memory may leak. Bugs 467523, 3357771 - * - * NOTE: [Bugs 3392070, 3389764] We make a copy based completely - * on the string value, and do not call Tcl_DuplicateObj() so we - * can be sure we do not have any lingering cycles hiding in - * the intrep. - */ - int numBytes; - const char *bytes = TclGetStringFromObj(objPtr, &numBytes); - Tcl_Obj *copyPtr = Tcl_NewStringObj(bytes, numBytes); - - Tcl_IncrRefCount(copyPtr); - TclReleaseLiteral((Tcl_Interp *)envPtr->iPtr, objPtr); - - envPtr->literalArrayPtr[i].objPtr = copyPtr; - } - } -} - -ByteCode * -TclInitByteCode( +void +TclInitByteCodeObj( + Tcl_Obj *objPtr, /* Points object that should be initialized, + * and whose string rep contains the source + * code. */ register CompileEnv *envPtr)/* Points to the CompileEnv structure from * which to create a ByteCode structure. */ { @@ -2802,8 +2765,7 @@ TclInitByteCode( codePtr->compileEpoch = iPtr->compileEpoch; codePtr->nsPtr = namespacePtr; codePtr->nsEpoch = namespacePtr->resolverEpoch; - codePtr->refCount = 0; - TclPreserveByteCode(codePtr); + codePtr->refCount = 1; if (namespacePtr->compiledVarResProc || iPtr->resolverPtr) { codePtr->flags = TCL_BYTECODE_RESOLVE_VARS; } else { @@ -2829,7 +2791,29 @@ TclInitByteCode( p += TCL_ALIGN(codeBytes); /* align object array */ codePtr->objArrayPtr = (Tcl_Obj **) p; for (i = 0; i < numLitObjects; i++) { - codePtr->objArrayPtr[i] = TclFetchLiteral(envPtr, i); + Tcl_Obj *fetched = TclFetchLiteral(envPtr, i); + + if (objPtr == fetched) { + /* + * Prevent circular reference where the bytecode intrep of + * a value contains a literal which is that same value. + * If this is allowed to happen, refcount decrements may not + * reach zero, and memory may leak. Bugs 467523, 3357771 + * + * NOTE: [Bugs 3392070, 3389764] We make a copy based completely + * on the string value, and do not call Tcl_DuplicateObj() so we + * can be sure we do not have any lingering cycles hiding in + * the intrep. + */ + int numBytes; + const char *bytes = Tcl_GetStringFromObj(objPtr, &numBytes); + + codePtr->objArrayPtr[i] = Tcl_NewStringObj(bytes, numBytes); + Tcl_IncrRefCount(codePtr->objArrayPtr[i]); + TclReleaseLiteral((Tcl_Interp *)iPtr, objPtr); + } else { + codePtr->objArrayPtr[i] = fetched; + } } p += TCL_ALIGN(objArrayBytes); /* align exception range array */ @@ -2872,6 +2856,15 @@ TclInitByteCode( #endif /* TCL_COMPILE_STATS */ /* + * Free the old internal rep then convert the object to a bytecode object + * by making its internal rep point to the just compiled ByteCode. + */ + + TclFreeIntRep(objPtr); + objPtr->internalRep.twoPtrValue.ptr1 = codePtr; + objPtr->typePtr = &tclByteCodeType; + + /* * TIP #280. Associate the extended per-word line information with the * byte code object (internal rep), for use with the bc compiler. */ @@ -2884,33 +2877,6 @@ TclInitByteCode( envPtr->iPtr = NULL; codePtr->localCachePtr = NULL; - return codePtr; -} - -ByteCode * -TclInitByteCodeObj( - Tcl_Obj *objPtr, /* Points object that should be initialized, - * and whose string rep contains the source - * code. */ - const Tcl_ObjType *typePtr, - register CompileEnv *envPtr)/* Points to the CompileEnv structure from - * which to create a ByteCode structure. */ -{ - ByteCode *codePtr; - - PreventCycle(objPtr, envPtr); - - codePtr = TclInitByteCode(envPtr); - - /* - * Free the old internal rep then convert the object to a bytecode object - * by making its internal rep point to the just compiled ByteCode. - */ - - TclFreeIntRep(objPtr); - objPtr->internalRep.twoPtrValue.ptr1 = codePtr; - objPtr->typePtr = typePtr; - return codePtr; } /* @@ -2978,8 +2944,7 @@ TclFindCompiledLocal( varNamePtr = &cachePtr->varName0; for (i=0; i < cachePtr->numVars; varNamePtr++, i++) { if (*varNamePtr) { - localName = TclGetString(*varNamePtr); - len = (*varNamePtr)->length; + localName = Tcl_GetStringFromObj(*varNamePtr, &len); if ((len == nameBytes) && !strncmp(name, localName, len)) { return i; } diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 5bc3e81..90edf07 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. */ - unsigned int compileEpoch; /* Value of iPtr->compileEpoch when this + 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. */ - size_t nsEpoch; /* Value of nsPtr->resolverEpoch when this + int 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 @@ -1067,6 +1069,7 @@ MODULE_SCOPE ByteCode * TclCompileObj(Tcl_Interp *interp, Tcl_Obj *objPtr, MODULE_SCOPE int TclAttemptCompileProc(Tcl_Interp *interp, Tcl_Parse *parsePtr, int depth, Command *cmdPtr, CompileEnv *envPtr); +MODULE_SCOPE void TclCleanupByteCode(ByteCode *codePtr); MODULE_SCOPE void TclCleanupStackForBreakContinue(CompileEnv *envPtr, ExceptionAux *auxPtr); MODULE_SCOPE void TclCompileCmdWord(Tcl_Interp *interp, @@ -1095,7 +1098,7 @@ MODULE_SCOPE int TclCreateAuxData(ClientData clientData, MODULE_SCOPE int TclCreateExceptRange(ExceptionRangeType type, CompileEnv *envPtr); MODULE_SCOPE ExecEnv * TclCreateExecEnv(Tcl_Interp *interp, int size); -MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, const char *bytes, +MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, char *bytes, int length, unsigned int hash, int *newPtr, Namespace *nsPtr, int flags, LiteralEntry **globalPtrPtr); @@ -1118,9 +1121,8 @@ MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr, int distThreshold); MODULE_SCOPE void TclFreeCompileEnv(CompileEnv *envPtr); MODULE_SCOPE void TclFreeJumpFixupArray(JumpFixupArray *fixupArrayPtr); -MODULE_SCOPE ByteCode * TclInitByteCode(CompileEnv *envPtr); -MODULE_SCOPE ByteCode * TclInitByteCodeObj(Tcl_Obj *objPtr, - const Tcl_ObjType *typePtr, CompileEnv *envPtr); +MODULE_SCOPE void TclInitByteCodeObj(Tcl_Obj *objPtr, + CompileEnv *envPtr); MODULE_SCOPE void TclInitCompileEnv(Tcl_Interp *interp, CompileEnv *envPtr, const char *string, int numBytes, const CmdFrame *invoker, int word); @@ -1157,8 +1159,25 @@ MODULE_SCOPE void TclPushVarName(Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags, int *localIndexPtr, int *isScalarPtr); -MODULE_SCOPE void TclPreserveByteCode(ByteCode *codePtr); -MODULE_SCOPE void TclReleaseByteCode(ByteCode *codePtr); + +static inline void +TclPreserveByteCode( + register ByteCode *codePtr) +{ + codePtr->refCount++; +} + +static inline void +TclReleaseByteCode( + register ByteCode *codePtr) +{ + if (codePtr->refCount-- > 1) { + return; + } + /* Just dropped to refcount==0. Clean up. */ + TclCleanupByteCode(codePtr); +} + MODULE_SCOPE void TclReleaseLiteral(Tcl_Interp *interp, Tcl_Obj *objPtr); MODULE_SCOPE void TclInvalidateCmdLiteral(Tcl_Interp *interp, const char *name, Namespace *nsPtr); @@ -1213,6 +1232,29 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData, #define LITERAL_UNSHARED 0x04 /* + * Form of TclRegisterLiteral with flags == 0. In that case, it is safe to + * cast away constness, and it is cleanest to do that here, all in one place. + * + * int TclRegisterNewLiteral(CompileEnv *envPtr, const char *bytes, + * int length); + */ + +#define TclRegisterNewLiteral(envPtr, bytes, length) \ + TclRegisterLiteral(envPtr, (char *)(bytes), length, /*flags*/ 0) + +/* + * Form of TclRegisterLiteral with flags == LITERAL_CMD_NAME. In that case, it + * is safe to cast away constness, and it is cleanest to do that here, all in + * one place. + * + * int TclRegisterNewNSLiteral(CompileEnv *envPtr, const char *bytes, + * int length); + */ + +#define TclRegisterNewCmdLiteral(envPtr, bytes, length) \ + TclRegisterLiteral(envPtr, (char *)(bytes), length, LITERAL_CMD_NAME) + +/* * Macro used to manually adjust the stack requirements; used in cases where * the stack effect cannot be computed from the opcode and its operands, but * is still known at compile time. @@ -1238,10 +1280,10 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData, #define TclCheckStackDepth(depth, envPtr) \ do { \ - int dd = (depth); \ - if (dd != (envPtr)->currStackDepth) { \ + int _dd = (depth); \ + if (_dd != (envPtr)->currStackDepth) { \ Tcl_Panic("bad stack depth computations: is %i, should be %i", \ - (envPtr)->currStackDepth, dd); \ + (envPtr)->currStackDepth, _dd); \ } \ } while (0) @@ -1257,12 +1299,12 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData, #define TclUpdateStackReqs(op, i, envPtr) \ do { \ - int delta = tclInstructionTable[(op)].stackEffect; \ - if (delta) { \ - if (delta == INT_MIN) { \ - delta = 1 - (i); \ + int _delta = tclInstructionTable[(op)].stackEffect; \ + if (_delta) { \ + if (_delta == INT_MIN) { \ + _delta = 1 - (i); \ } \ - TclAdjustStackDepth(delta, envPtr); \ + TclAdjustStackDepth(_delta, envPtr); \ } \ } while (0) @@ -1376,11 +1418,11 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData, #define TclEmitPush(objIndex, envPtr) \ do { \ - register int objIndexCopy = (objIndex); \ - if (objIndexCopy <= 255) { \ - TclEmitInstInt1(INST_PUSH1, objIndexCopy, (envPtr)); \ + register int _objIndexCopy = (objIndex); \ + if (_objIndexCopy <= 255) { \ + TclEmitInstInt1(INST_PUSH1, _objIndexCopy, (envPtr)); \ } else { \ - TclEmitInstInt4(INST_PUSH4, objIndexCopy, (envPtr)); \ + TclEmitInstInt4(INST_PUSH4, _objIndexCopy, (envPtr)); \ } \ } while (0) @@ -1527,9 +1569,9 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData, */ #define PushLiteral(envPtr, string, length) \ - TclEmitPush(TclRegisterLiteral(envPtr, string, length, 0), (envPtr)) + TclEmitPush(TclRegisterNewLiteral((envPtr), (string), (length)), (envPtr)) #define PushStringLiteral(envPtr, string) \ - PushLiteral(envPtr, string, (int) (sizeof(string "") - 1)) + PushLiteral((envPtr), (string), (int) (sizeof(string "") - 1)) /* * Macro to advance to the next token; it is more mnemonic than the address diff --git a/generic/tclConfig.c b/generic/tclConfig.c index eb6807c..2fb3e92 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", - TclGetString(pkgName), NULL); + Tcl_GetString(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", - TclGetString(objv[2]), NULL); + Tcl_GetString(objv[2]), NULL); return TCL_ERROR; } @@ -333,9 +333,9 @@ QueryConfigDelete( Tcl_DictObjRemove(NULL, pDB, pkgName); Tcl_DecrRefCount(pkgName); if (cdPtr->encoding) { - ckfree(cdPtr->encoding); + ckfree((char *)cdPtr->encoding); } - ckfree(cdPtr); + ckfree((char *)cdPtr); } /* diff --git a/generic/tclDate.h b/generic/tclDate.h deleted file mode 100644 index e614f9d..0000000 --- a/generic/tclDate.h +++ /dev/null @@ -1,512 +0,0 @@ -/* - * tclDate.h -- - * - * This header file handles common usage of clock primitives - * between tclDate.c (yacc), tclClock.c and tclClockFmt.c. - * - * Copyright (c) 2014 Serg G. Brester (aka sebres) - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -#ifndef _TCLCLOCK_H -#define _TCLCLOCK_H - -/* - * Constants - */ - -#define JULIAN_DAY_POSIX_EPOCH 2440588 -#define GREGORIAN_CHANGE_DATE 2361222 -#define SECONDS_PER_DAY 86400 -#define JULIAN_SEC_POSIX_EPOCH (((Tcl_WideInt) JULIAN_DAY_POSIX_EPOCH) \ - * SECONDS_PER_DAY) -#define FOUR_CENTURIES 146097 /* days */ -#define JDAY_1_JAN_1_CE_JULIAN 1721424 -#define JDAY_1_JAN_1_CE_GREGORIAN 1721426 -#define ONE_CENTURY_GREGORIAN 36524 /* days */ -#define FOUR_YEARS 1461 /* days */ -#define ONE_YEAR 365 /* days */ - -#define RODDENBERRY 1946 /* Another epoch (Hi, Jeff!) */ - - -#define CLF_OPTIONAL (1 << 0) /* token is non mandatory */ -#define CLF_POSIXSEC (1 << 1) -#define CLF_LOCALSEC (1 << 2) -#define CLF_JULIANDAY (1 << 3) -#define CLF_TIME (1 << 4) -#define CLF_CENTURY (1 << 6) -#define CLF_DAYOFMONTH (1 << 7) -#define CLF_DAYOFYEAR (1 << 8) -#define CLF_MONTH (1 << 9) -#define CLF_YEAR (1 << 10) -#define CLF_ISO8601YEAR (1 << 12) -#define CLF_ISO8601 (1 << 13) -#define CLF_ISO8601CENTURY (1 << 14) -#define CLF_SIGNED (1 << 15) -/* On demand (lazy) assemble flags */ -#define CLF_ASSEMBLE_DATE (1 << 28) /* assemble year, month, etc. using julianDay */ -#define CLF_ASSEMBLE_JULIANDAY (1 << 29) /* assemble julianDay using year, month, etc. */ -#define CLF_ASSEMBLE_SECONDS (1 << 30) /* assemble localSeconds (and seconds at end) */ - -#define CLF_DATE (CLF_JULIANDAY | CLF_DAYOFMONTH | CLF_DAYOFYEAR | \ - CLF_MONTH | CLF_YEAR | CLF_ISO8601YEAR | CLF_ISO8601) - -/* - * Enumeration of the string literals used in [clock] - */ - -typedef enum ClockLiteral { - LIT__NIL, - LIT__DEFAULT_FORMAT, - LIT_SYSTEM, LIT_CURRENT, LIT_C, - LIT_BCE, LIT_CE, - LIT_DAYOFMONTH, LIT_DAYOFWEEK, LIT_DAYOFYEAR, - LIT_ERA, LIT_GMT, LIT_GREGORIAN, - LIT_INTEGER_VALUE_TOO_LARGE, - LIT_ISO8601WEEK, LIT_ISO8601YEAR, - LIT_JULIANDAY, LIT_LOCALSECONDS, - LIT_MONTH, - LIT_SECONDS, LIT_TZNAME, LIT_TZOFFSET, - LIT_YEAR, - LIT_TZDATA, - LIT_GETSYSTEMTIMEZONE, - LIT_SETUPTIMEZONE, - LIT_MCGET, - LIT_GETSYSTEMLOCALE, LIT_GETCURRENTLOCALE, - LIT_LOCALIZE_FORMAT, - LIT__END -} ClockLiteral; - -#define CLOCK_LITERAL_ARRAY(litarr) static const char *const litarr[] = { \ - "", \ - "%a %b %d %H:%M:%S %Z %Y", \ - "system", "current", "C", \ - "BCE", "CE", \ - "dayOfMonth", "dayOfWeek", "dayOfYear", \ - "era", ":GMT", "gregorian", \ - "integer value too large to represent", \ - "iso8601Week", "iso8601Year", \ - "julianDay", "localSeconds", \ - "month", \ - "seconds", "tzName", "tzOffset", \ - "year", \ - "::tcl::clock::TZData", \ - "::tcl::clock::GetSystemTimeZone", \ - "::tcl::clock::SetupTimeZone", \ - "::tcl::clock::mcget", \ - "::tcl::clock::GetSystemLocale", "::tcl::clock::mclocale", \ - "::tcl::clock::LocalizeFormat" \ -} - -/* - * Enumeration of the msgcat literals used in [clock] - */ - -typedef enum ClockMsgCtLiteral { - MCLIT__NIL, /* placeholder */ - MCLIT_MONTHS_FULL, MCLIT_MONTHS_ABBREV, MCLIT_MONTHS_COMB, - MCLIT_DAYS_OF_WEEK_FULL, MCLIT_DAYS_OF_WEEK_ABBREV, MCLIT_DAYS_OF_WEEK_COMB, - MCLIT_AM, MCLIT_PM, - MCLIT_LOCALE_ERAS, - MCLIT_BCE, MCLIT_CE, - MCLIT_BCE2, MCLIT_CE2, - MCLIT_BCE3, MCLIT_CE3, - MCLIT_LOCALE_NUMERALS, - MCLIT__END -} ClockMsgCtLiteral; - -#define CLOCK_LOCALE_LITERAL_ARRAY(litarr, pref) static const char *const litarr[] = { \ - pref "", \ - pref "MONTHS_FULL", pref "MONTHS_ABBREV", pref "MONTHS_COMB", \ - pref "DAYS_OF_WEEK_FULL", pref "DAYS_OF_WEEK_ABBREV", pref "DAYS_OF_WEEK_COMB", \ - pref "AM", pref "PM", \ - pref "LOCALE_ERAS", \ - pref "BCE", pref "CE", \ - pref "b.c.e.", pref "c.e.", \ - pref "b.c.", pref "a.d.", \ - pref "LOCALE_NUMERALS", \ -} - -/* - * Structure containing the fields used in [clock format] and [clock scan] - */ - -typedef struct TclDateFields { - - /* Cacheable fields: */ - - Tcl_WideInt seconds; /* Time expressed in seconds from the Posix - * epoch */ - Tcl_WideInt localSeconds; /* Local time expressed in nominal seconds - * from the Posix epoch */ - int tzOffset; /* Time zone offset in seconds east of - * Greenwich */ - int julianDay; /* Julian Day Number in local time zone */ - enum {BCE=1, CE=0} era; /* Era */ - int gregorian; /* Flag == 1 if the date is Gregorian */ - int year; /* Year of the era */ - int dayOfYear; /* Day of the year (1 January == 1) */ - int month; /* Month number */ - int dayOfMonth; /* Day of the month */ - int iso8601Year; /* ISO8601 week-based year */ - int iso8601Week; /* ISO8601 week number */ - int dayOfWeek; /* Day of the week */ - int hour; /* Hours of day (in-between time only calculation) */ - int minutes; /* Minutes of day (in-between time only calculation) */ - int secondOfDay; /* Seconds of day (in-between time only calculation) */ - - /* Non cacheable fields: */ - - Tcl_Obj *tzName; /* Name (or corresponding DST-abbreviation) of the - * time zone, if set the refCount is incremented */ -} TclDateFields; - -#define ClockCacheableDateFieldsSize \ - TclOffset(TclDateFields, tzName) - -/* - * Structure contains return parsed fields. - */ - -typedef struct DateInfo { - const char *dateStart; - const char *dateInput; - const char *dateEnd; - - TclDateFields date; - - int flags; - - int dateHaveDate; - - int dateMeridian; - int dateHaveTime; - - int dateTimezone; - int dateDSTmode; - int dateHaveZone; - - int dateRelMonth; - int dateRelDay; - int dateRelSeconds; - int dateHaveRel; - - int dateMonthOrdinalIncr; - int dateMonthOrdinal; - int dateHaveOrdinalMonth; - - int dateDayOrdinal; - int dateDayNumber; - int dateHaveDay; - - int *dateRelPointer; - - int dateSpaceCount; - int dateDigitCount; - - int dateCentury; - - Tcl_Obj* messages; /* Error messages */ - const char* separatrix; /* String separating messages */ -} DateInfo; - -#define yydate (info->date) /* Date fields used for converting */ - -#define yyDay (info->date.dayOfMonth) -#define yyMonth (info->date.month) -#define yyYear (info->date.year) - -#define yyHour (info->date.hour) -#define yyMinutes (info->date.minutes) -#define yySeconds (info->date.secondOfDay) - -#define yyDSTmode (info->dateDSTmode) -#define yyDayOrdinal (info->dateDayOrdinal) -#define yyDayNumber (info->dateDayNumber) -#define yyMonthOrdinalIncr (info->dateMonthOrdinalIncr) -#define yyMonthOrdinal (info->dateMonthOrdinal) -#define yyHaveDate (info->dateHaveDate) -#define yyHaveDay (info->dateHaveDay) -#define yyHaveOrdinalMonth (info->dateHaveOrdinalMonth) -#define yyHaveRel (info->dateHaveRel) -#define yyHaveTime (info->dateHaveTime) -#define yyHaveZone (info->dateHaveZone) -#define yyTimezone (info->dateTimezone) -#define yyMeridian (info->dateMeridian) -#define yyRelMonth (info->dateRelMonth) -#define yyRelDay (info->dateRelDay) -#define yyRelSeconds (info->dateRelSeconds) -#define yyRelPointer (info->dateRelPointer) -#define yyInput (info->dateInput) -#define yyDigitCount (info->dateDigitCount) -#define yySpaceCount (info->dateSpaceCount) - -static inline void -ClockInitDateInfo(DateInfo *info) { - memset(info, 0, sizeof(DateInfo)); -} - -/* - * Structure containing the command arguments supplied to [clock format] and [clock scan] - */ - -#define CLF_EXTENDED (1 << 4) -#define CLF_STRICT (1 << 8) -#define CLF_LOCALE_USED (1 << 15) - -typedef struct ClockFmtScnCmdArgs { - ClientData clientData; /* Opaque pointer to literal pool, etc. */ - Tcl_Interp *interp; /* Tcl interpreter */ - - Tcl_Obj *formatObj; /* Format */ - Tcl_Obj *localeObj; /* Name of the locale where the time will be expressed. */ - Tcl_Obj *timezoneObj; /* Default time zone in which the time will be expressed */ - Tcl_Obj *baseObj; /* Base (scan and add) or clockValue (format) */ - int flags; /* Flags control scanning */ - - Tcl_Obj *mcDictObj; /* Current dictionary of tcl::clock package for given localeObj*/ -} ClockFmtScnCmdArgs; - -/* - * Structure containing the client data for [clock] - */ - -typedef struct ClockClientData { - size_t refCount; /* Number of live references. */ - Tcl_Obj **literals; /* Pool of object literals (common, locale independent). */ - Tcl_Obj **mcLiterals; /* Msgcat object literals with mc-keys for search with locale. */ - Tcl_Obj **mcLitIdxs; /* Msgcat object indices prefixed with _IDX_, - * used for quick dictionary search */ - - /* Cache for current clock parameters, imparted via "configure" */ - unsigned long LastTZEpoch; - int currentYearCentury; - int yearOfCenturySwitch; - Tcl_Obj *SystemTimeZone; - Tcl_Obj *SystemSetupTZData; - Tcl_Obj *GMTSetupTimeZone; - Tcl_Obj *GMTSetupTZData; - Tcl_Obj *AnySetupTimeZone; - Tcl_Obj *AnySetupTZData; - Tcl_Obj *LastUnnormSetupTimeZone; - Tcl_Obj *LastSetupTimeZone; - Tcl_Obj *LastSetupTZData; - - Tcl_Obj *CurrentLocale; - Tcl_Obj *CurrentLocaleDict; - Tcl_Obj *LastUnnormUsedLocale; - Tcl_Obj *LastUsedLocale; - Tcl_Obj *LastUsedLocaleDict; - - /* Cache for last base (last-second fast convert if base/tz not changed) */ - struct { - Tcl_Obj *timezoneObj; - TclDateFields Date; - } lastBase; - /* Las-period cache for fast UTC2Local conversion */ - struct { - /* keys */ - Tcl_Obj *timezoneObj; - int changeover; - Tcl_WideInt seconds; - Tcl_WideInt rangesVal[2]; /* Bounds for cached time zone offset */ - /* values */ - int tzOffset; - Tcl_Obj *tzName; - } UTC2Local; - /* Las-period cache for fast Local2UTC conversion */ - struct { - /* keys */ - Tcl_Obj *timezoneObj; - int changeover; - Tcl_WideInt localSeconds; - Tcl_WideInt rangesVal[2]; /* Bounds for cached time zone offset */ - /* values */ - int tzOffset; - } Local2UTC; -} ClockClientData; - -#define ClockDefaultYearCentury 2000 -#define ClockDefaultCenturySwitch 38 - -/* - * Meridian: am, pm, or 24-hour style. - */ - -typedef enum _MERIDIAN { - MERam, MERpm, MER24 -} MERIDIAN; - -/* - * Clock scan and format facilities. - */ - -#define CLOCK_FMT_SCN_STORAGE_GC_SIZE 32 - -#define CLOCK_MIN_TOK_CHAIN_BLOCK_SIZE 2 - -typedef struct ClockScanToken ClockScanToken; - - -typedef int ClockScanTokenProc( - ClockFmtScnCmdArgs *opts, - DateInfo *info, - ClockScanToken *tok); - - -typedef enum _CLCKTOK_TYPE { - CTOKT_DIGIT = 1, CTOKT_PARSER, CTOKT_SPACE, CTOKT_WORD, CTOKT_CHAR, - CFMTT_INT, CFMTT_WIDE, CFMTT_PROC -} CLCKTOK_TYPE; - -typedef struct ClockScanTokenMap { - unsigned short int type; - unsigned short int flags; - unsigned short int clearFlags; - unsigned short int minSize; - unsigned short int maxSize; - unsigned short int offs; - ClockScanTokenProc *parser; - void *data; -} ClockScanTokenMap; - -typedef struct ClockScanToken { - ClockScanTokenMap *map; - struct { - const char *start; - const char *end; - } tokWord; - unsigned short int endDistance; - unsigned short int lookAhMin; - unsigned short int lookAhMax; - unsigned short int lookAhTok; -} ClockScanToken; - - -#define MIN_FMT_RESULT_BLOCK_ALLOC 200 - -typedef struct DateFormat { - char *resMem; - char *resEnd; - char *output; - - TclDateFields date; - - Tcl_Obj *localeEra; -} DateFormat; - -#define CLFMT_INCR (1 << 3) -#define CLFMT_DECR (1 << 4) -#define CLFMT_CALC (1 << 5) -#define CLFMT_LOCALE_INDX (1 << 8) - -typedef struct ClockFormatToken ClockFormatToken; - -typedef int ClockFormatTokenProc( - ClockFmtScnCmdArgs *opts, - DateFormat *dateFmt, - ClockFormatToken *tok, - int *val); - -typedef struct ClockFormatTokenMap { - unsigned short int type; - const char *tostr; - unsigned short int width; - unsigned short int flags; - unsigned short int divider; - unsigned short int divmod; - unsigned short int offs; - ClockFormatTokenProc *fmtproc; - void *data; -} ClockFormatTokenMap; -typedef struct ClockFormatToken { - ClockFormatTokenMap *map; - struct { - const char *start; - const char *end; - } tokWord; -} ClockFormatToken; - - -typedef struct ClockFmtScnStorage ClockFmtScnStorage; - -typedef struct ClockFmtScnStorage { - int objRefCount; /* Reference count shared across threads */ - ClockScanToken *scnTok; - unsigned int scnTokC; - unsigned int scnSpaceCount; /* Count of mandatory spaces used in format */ - ClockFormatToken *fmtTok; - unsigned int fmtTokC; -#if CLOCK_FMT_SCN_STORAGE_GC_SIZE > 0 - ClockFmtScnStorage *nextPtr; - ClockFmtScnStorage *prevPtr; -#endif -#if 0 - +Tcl_HashEntry hashEntry /* ClockFmtScnStorage is a derivate of Tcl_HashEntry, - * stored by offset +sizeof(self) */ -#endif -} ClockFmtScnStorage; - -/* - * Prototypes of module functions. - */ - -MODULE_SCOPE int ToSeconds(int Hours, int Minutes, - int Seconds, MERIDIAN Meridian); -MODULE_SCOPE int IsGregorianLeapYear(TclDateFields *); -MODULE_SCOPE void - GetJulianDayFromEraYearWeekDay( - TclDateFields *fields, int changeover); -MODULE_SCOPE void - GetJulianDayFromEraYearMonthDay( - TclDateFields *fields, int changeover); -MODULE_SCOPE void - GetJulianDayFromEraYearDay( - TclDateFields *fields, int changeover); -MODULE_SCOPE int ConvertUTCToLocal(ClientData clientData, Tcl_Interp *, - TclDateFields *, Tcl_Obj *timezoneObj, int); -MODULE_SCOPE Tcl_Obj * - LookupLastTransition(Tcl_Interp *, Tcl_WideInt, - int, Tcl_Obj *const *, Tcl_WideInt rangesVal[2]); - -MODULE_SCOPE int TclClockFreeScan(Tcl_Interp *interp, DateInfo *info); - -/* tclClock.c module declarations */ - -MODULE_SCOPE Tcl_Obj * - ClockSetupTimeZone(ClientData clientData, - Tcl_Interp *interp, Tcl_Obj *timezoneObj); - -MODULE_SCOPE Tcl_Obj * - ClockMCDict(ClockFmtScnCmdArgs *opts); -MODULE_SCOPE Tcl_Obj * - ClockMCGet(ClockFmtScnCmdArgs *opts, int mcKey); -MODULE_SCOPE Tcl_Obj * - ClockMCGetIdx(ClockFmtScnCmdArgs *opts, int mcKey); -MODULE_SCOPE int ClockMCSetIdx(ClockFmtScnCmdArgs *opts, int mcKey, - Tcl_Obj *valObj); - -/* tclClockFmt.c module declarations */ - -MODULE_SCOPE Tcl_Obj* - ClockFrmObjGetLocFmtKey(Tcl_Interp *interp, - Tcl_Obj *objPtr); - -MODULE_SCOPE ClockFmtScnStorage * - Tcl_GetClockFrmScnFromObj(Tcl_Interp *interp, - Tcl_Obj *objPtr); -MODULE_SCOPE Tcl_Obj * - ClockLocalizeFormat(ClockFmtScnCmdArgs *opts); - -MODULE_SCOPE int ClockScan(register DateInfo *info, - Tcl_Obj *strObj, ClockFmtScnCmdArgs *opts); - -MODULE_SCOPE int ClockFormat(register DateFormat *dateFmt, - ClockFmtScnCmdArgs *opts); - -MODULE_SCOPE void ClockFrmScnClearCaches(void); - -#endif /* _TCLCLOCK_H */ diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 0dbf345..3de71af 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1816,12 +1816,6 @@ 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; @@ -2488,7 +2482,6 @@ 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; @@ -3781,8 +3774,6 @@ 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) */ @@ -3863,28 +3854,6 @@ 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_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) diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 44ab882..4088883 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -145,7 +145,7 @@ typedef struct Dict { * the entries in the order that they are * created. */ int epoch; /* Epoch counter */ - size_t refCount; /* Reference counter (see above) */ + int refcount; /* Reference counter (see above) */ Tcl_Obj *chain; /* Linked list used for invalidating the * string representations of updated nested * dictionaries. */ @@ -395,7 +395,7 @@ DupDictInternalRep( newDict->epoch = 0; newDict->chain = NULL; - newDict->refCount = 1; + newDict->refcount = 1; /* * Store in the object. @@ -430,7 +430,8 @@ FreeDictInternalRep( { Dict *dict = DICT(dictPtr); - if (dict->refCount-- <= 1) { + dict->refcount--; + if (dict->refcount <= 0) { DeleteDict(dict); } dictPtr->typePtr = NULL; @@ -509,7 +510,7 @@ UpdateStringOfDict( /* Handle empty list case first, simplifies what follows */ if (numElems == 0) { - dictPtr->bytes = &tclEmptyString; + dictPtr->bytes = tclEmptyStringRep; dictPtr->length = 0; return; } @@ -715,7 +716,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; @@ -1119,7 +1120,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); } @@ -1233,7 +1234,8 @@ Tcl_DictObjDone( if (searchPtr->epoch != -1) { searchPtr->epoch = -1; dict = (Dict *) searchPtr->dictionaryPtr; - if (dict->refCount-- <= 1) { + dict->refcount--; + if (dict->refcount <= 0) { DeleteDict(dict); } } @@ -1385,7 +1387,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; @@ -1435,7 +1437,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; @@ -2379,7 +2381,7 @@ DictAppendCmd( Tcl_Obj *const *objv) { Tcl_Obj *dictPtr, *valuePtr, *resultPtr; - int allocatedDict = 0; + int i, allocatedDict = 0; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?value ...?"); @@ -2402,44 +2404,17 @@ DictAppendCmd( return TCL_ERROR; } - if ((objc > 3) || (valuePtr == NULL)) { - /* Only go through append activites when something will change. */ - Tcl_Obj *appendObjPtr = NULL; - - 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); - } + if (valuePtr == NULL) { + TclNewObj(valuePtr); + } else if (Tcl_IsShared(valuePtr)) { + valuePtr = Tcl_DuplicateObj(valuePtr); + } - Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr); + for (i=3 ; i<objc ; i++) { + Tcl_AppendObjToObj(valuePtr, objv[i]); } - /* - * Even if nothing changed, we still overwrite so that variable - * trace expectations are met. - */ + Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr); resultPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr, TCL_LEAVE_ERR_MSG); diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 0d6da8e..f62c260 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -27,9 +27,8 @@ static Tcl_Obj * DisassembleByteCodeObj(Tcl_Interp *interp, Tcl_Obj *objPtr); static int FormatInstruction(ByteCode *codePtr, const unsigned char *pc, Tcl_Obj *bufferObj); -static void GetLocationInformation(Tcl_Interp *interp, - Proc *procPtr, Tcl_Obj **fileObjPtr, - int *linePtr); +static void GetLocationInformation(Proc *procPtr, + Tcl_Obj **fileObjPtr, int *linePtr); static void PrintSourceToObj(Tcl_Obj *appendObj, const char *stringPtr, int maxChars); static void UpdateStringOfInstName(Tcl_Obj *objPtr); @@ -73,8 +72,6 @@ static const Tcl_ObjType tclInstNameType = { static void GetLocationInformation( - Tcl_Interp *interp, /* Where to look up the location - * information. */ Proc *procPtr, /* What to look up the information for. */ Tcl_Obj **fileObjPtr, /* Where to write the information about what * file the code came from. Will be written @@ -88,20 +85,21 @@ GetLocationInformation( * either with the line number or with -1 if * the information is not available. */ { - Interp *iPtr = (Interp *) interp; - Tcl_HashEntry *hePtr; - CmdFrame *cfPtr; + CmdFrame *cfPtr = TclGetCmdFrameForProcedure(procPtr); *fileObjPtr = NULL; *linePtr = -1; - if (iPtr != NULL && procPtr != NULL) { - hePtr = Tcl_FindHashEntry(iPtr->linePBodyPtr, procPtr); - if (hePtr != NULL && (cfPtr = Tcl_GetHashValue(hePtr)) != NULL) { - *linePtr = cfPtr->line[0]; - if (cfPtr->type == TCL_LOCATION_SOURCE) { - *fileObjPtr = cfPtr->data.eval.path; - } - } + if (cfPtr == NULL) { + return; + } + + /* + * Get the source location data out of the CmdFrame. + */ + + *linePtr = cfPtr->line[0]; + if (cfPtr->type == TCL_LOCATION_SOURCE) { + *fileObjPtr = cfPtr->data.eval.path; } } @@ -193,7 +191,7 @@ TclPrintObject( char *bytes; int length; - bytes = TclGetStringFromObj(objPtr, &length); + bytes = Tcl_GetStringFromObj(objPtr, &length); TclPrintSource(outFile, bytes, TclMin(length, maxChars)); } @@ -278,7 +276,7 @@ DisassembleByteCodeObj( Tcl_AppendToObj(bufferObj, " Source ", -1); PrintSourceToObj(bufferObj, codePtr->source, TclMin(codePtr->numSrcBytes, 55)); - GetLocationInformation(interp, codePtr->procPtr, &fileObj, &line); + GetLocationInformation(codePtr->procPtr, &fileObj, &line); if (line > -1 && fileObj != NULL) { Tcl_AppendPrintfToObj(bufferObj, "\n File \"%s\" Line %d", Tcl_GetString(fileObj), line); @@ -650,7 +648,7 @@ FormatInstruction( int length; Tcl_AppendToObj(bufferObj, "\t# ", -1); - bytes = TclGetStringFromObj(codePtr->objArrayPtr[opnd], &length); + bytes = Tcl_GetStringFromObj(codePtr->objArrayPtr[opnd], &length); PrintSourceToObj(bufferObj, bytes, TclMin(length, 40)); } else if (suffixBuffer[0]) { Tcl_AppendPrintfToObj(bufferObj, "\t# %s", suffixBuffer); @@ -1221,7 +1219,7 @@ DisassembleByteCodeAsDicts( * system if it is available. */ - GetLocationInformation(interp, codePtr->procPtr, &file, &line); + GetLocationInformation(codePtr->procPtr, &file, &line); /* * Build the overall result. diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 91c2278..6820faa 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. */ - size_t refCount; /* Number of uses of this structure. */ + int 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 = TclGetString(objPtr); + const char *name = Tcl_GetString(objPtr); if (objPtr->typePtr != &encodingType) { Tcl_Encoding encoding = Tcl_GetEncoding(interp, name); @@ -355,7 +355,6 @@ DupEncodingIntRep( Tcl_Obj *dupPtr) { dupPtr->internalRep.twoPtrValue.ptr1 = Tcl_GetEncoding(NULL, srcPtr->bytes); - dupPtr->typePtr = &encodingType; } /* @@ -705,7 +704,7 @@ Tcl_GetDefaultEncodingDir(void) } Tcl_ListObjIndex(NULL, searchPath, 0, &first); - return TclGetString(first); + return Tcl_GetString(first); } /* @@ -844,7 +843,11 @@ FreeEncoding( if (encodingPtr == NULL) { return; } - if (encodingPtr->refCount-- <= 1) { + if (encodingPtr->refCount<=0) { + Tcl_Panic("FreeEncoding: refcount problem !!!"); + } + encodingPtr->refCount--; + if (encodingPtr->refCount == 0) { if (encodingPtr->freeProc != NULL) { encodingPtr->freeProc(encodingPtr->clientData); } @@ -1515,10 +1518,10 @@ OpenEncodingFileChannel( } } if (!verified) { - const char *dirString = TclGetString(directory); + const char *dirString = Tcl_GetString(directory); for (i=0; i<numDirs && !verified; i++) { - if (strcmp(dirString, TclGetString(dir[i])) == 0) { + if (strcmp(dirString, Tcl_GetString(dir[i])) == 0) { verified = 1; } } @@ -1759,7 +1762,7 @@ LoadTableEncoding( const char *p; Tcl_ReadChars(chan, objPtr, 3 + 16 * (16 * 4 + 1), 0); - p = TclGetString(objPtr); + p = Tcl_GetString(objPtr); hi = (staticHex[UCHAR(p[0])] << 4) + staticHex[UCHAR(p[1])]; dataPtr->toUnicode[hi] = pageMemPtr; p += 2; @@ -3596,11 +3599,11 @@ unilen( static void InitializeEncodingSearchPath( char **valuePtr, - size_t *lengthPtr, + int *lengthPtr, Tcl_Encoding *encodingPtr) { const char *bytes; - int i, numDirs; + int i, numDirs, numBytes; Tcl_Obj *libPathObj, *encodingObj, *searchPathObj; TclNewLiteralStringObj(encodingObj, "encoding"); @@ -3630,11 +3633,11 @@ InitializeEncodingSearchPath( if (*encodingPtr) { ((Encoding *)(*encodingPtr))->refCount++; } - bytes = TclGetString(searchPathObj); + bytes = Tcl_GetStringFromObj(searchPathObj, &numBytes); - *lengthPtr = searchPathObj->length; - *valuePtr = ckalloc(*lengthPtr + 1); - memcpy(*valuePtr, bytes, *lengthPtr + 1); + *lengthPtr = numBytes; + *valuePtr = ckalloc(numBytes + 1); + memcpy(*valuePtr, bytes, (size_t) numBytes + 1); Tcl_DecrRefCount(searchPathObj); } diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index f3e8187..c1b0890 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -92,7 +92,7 @@ static const Tcl_ObjType ensembleCmdType = { */ typedef struct { - size_t epoch; /* Used to confirm when the data in this + int 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(nameParts); + ckfree((char *) nameParts); } return ensemble; } @@ -1771,7 +1771,7 @@ NsEnsembleImplementationCmdNR( int tableLength = ensemblePtr->subcommandTable.numEntries; Tcl_Obj *fix; - subcmdName = TclGetStringFromObj(subObj, &stringLength); + subcmdName = Tcl_GetStringFromObj(subObj, &stringLength); for (i=0 ; i<tableLength ; i++) { register int cmp = strncmp(subcmdName, ensemblePtr->subcommandArrayPtr[i], @@ -2917,7 +2917,7 @@ TclCompileEnsemble( goto failed; } for (i=0 ; i<len ; i++) { - str = TclGetStringFromObj(elems[i], &sclen); + str = Tcl_GetStringFromObj(elems[i], &sclen); if ((sclen == (int) numBytes) && !memcmp(word, str, numBytes)) { /* * Exact match! Excellent! @@ -3306,7 +3306,7 @@ CompileToInvokedCommand( Tcl_Token *tokPtr; Tcl_Obj *objPtr, **words; char *bytes; - int i, numWords, cmdLit, extraLiteralFlags = LITERAL_CMD_NAME; + int length, i, numWords, cmdLit, extraLiteralFlags = LITERAL_CMD_NAME; DefineLineInformation; /* @@ -3319,15 +3319,15 @@ CompileToInvokedCommand( for (i = 0, tokPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++, tokPtr = TokenAfter(tokPtr)) { if (i > 0 && i < numWords+1) { - bytes = TclGetString(words[i-1]); - PushLiteral(envPtr, bytes, words[i-1]->length); + bytes = Tcl_GetStringFromObj(words[i-1], &length); + PushLiteral(envPtr, bytes, length); continue; } SetLineInformation(i); if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) { - int literal = TclRegisterLiteral(envPtr, - tokPtr[1].start, tokPtr[1].size, 0); + int literal = TclRegisterNewLiteral(envPtr, + tokPtr[1].start, tokPtr[1].size); if (envPtr->clNext) { TclContinuationsEnterDerived( @@ -3348,11 +3348,11 @@ CompileToInvokedCommand( objPtr = Tcl_NewObj(); Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); - bytes = TclGetString(objPtr); + bytes = Tcl_GetStringFromObj(objPtr, &length); if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) { extraLiteralFlags |= LITERAL_UNSHARED; } - cmdLit = TclRegisterLiteral(envPtr, bytes, objPtr->length, extraLiteralFlags); + cmdLit = TclRegisterLiteral(envPtr, (char *)bytes, length, extraLiteralFlags); TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLit), cmdPtr); TclEmitPush(cmdLit, envPtr); TclDecrRefCount(objPtr); diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 436db7a..b0b8188 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -1043,9 +1043,6 @@ TclInitSubsystems(void) #if USE_TCLALLOC TclInitAlloc(); /* Process wide mutex init */ #endif -#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) - TclInitThreadAlloc(); /* Setup thread allocator caches */ -#endif #ifdef TCL_MEM_DEBUG TclInitDbCkalloc(); /* Process wide mutex init */ #endif diff --git a/generic/tclExecute.c b/generic/tclExecute.c index c244b08..6499cf8 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -34,14 +34,14 @@ #endif /* - * A counter that is used to work out when the bytecode engine should call - * Tcl_AsyncReady() to see whether there is a signal that needs handling, and - * other expensive periodic operations. + * A mask (should be 2**n-1) that is used to work out when the bytecode engine + * should call Tcl_AsyncReady() to see whether there is a signal that needs + * handling. */ -#ifndef ASYNC_CHECK_COUNT -# define ASYNC_CHECK_COUNT 64 -#endif /* !ASYNC_CHECK_COUNT */ +#ifndef ASYNC_CHECK_COUNT_MASK +# define ASYNC_CHECK_COUNT_MASK 63 +#endif /* !ASYNC_CHECK_COUNT_MASK */ /* * Boolean flag indicating whether the Tcl bytecode interpreter has been @@ -325,7 +325,7 @@ VarHashCreateVar( NEXT_INST_F(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \ default: \ if ((condition) < 0) { \ - TclNewLongObj(objResultPtr, -1); \ + TclNewIntObj(objResultPtr, -1); \ } else { \ objResultPtr = TCONST((condition) > 0); \ } \ @@ -346,7 +346,7 @@ VarHashCreateVar( NEXT_INST_V(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \ default: \ if ((condition) < 0) { \ - TclNewLongObj(objResultPtr, -1); \ + TclNewIntObj(objResultPtr, -1); \ } else { \ objResultPtr = TCONST((condition) > 0); \ } \ @@ -357,7 +357,7 @@ VarHashCreateVar( #define JUMP_PEEPHOLE_F(condition, pcAdjustment, cleanup) \ do{ \ if ((condition) < 0) { \ - TclNewLongObj(objResultPtr, -1); \ + TclNewIntObj(objResultPtr, -1); \ } else { \ objResultPtr = TCONST((condition) > 0); \ } \ @@ -366,7 +366,7 @@ VarHashCreateVar( #define JUMP_PEEPHOLE_V(condition, pcAdjustment, cleanup) \ do{ \ if ((condition) < 0) { \ - TclNewLongObj(objResultPtr, -1); \ + TclNewIntObj(objResultPtr, -1); \ } else { \ objResultPtr = TCONST((condition) > 0); \ } \ @@ -510,9 +510,8 @@ VarHashCreateVar( : (*(tPtr) = TCL_NUMBER_DOUBLE)), \ *(ptrPtr) = (ClientData) \ (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ - ((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \ - (((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \ - ? TCL_ERROR : \ + (((objPtr)->bytes != NULL) && ((objPtr)->length == 0)) \ + ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \ TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) #else /* !TCL_WIDE_INT_IS_LONG */ #define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ @@ -530,9 +529,8 @@ VarHashCreateVar( : (*(tPtr) = TCL_NUMBER_DOUBLE)), \ *(ptrPtr) = (ClientData) \ (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ - ((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \ - (((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \ - ? TCL_ERROR : \ + (((objPtr)->bytes != NULL) && ((objPtr)->length == 0)) \ + ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \ TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) #endif /* TCL_WIDE_INT_IS_LONG */ @@ -1274,7 +1272,7 @@ TclStackFree( Tcl_Obj **markerPtr, *marker; if (iPtr == NULL || iPtr->execEnvPtr == NULL) { - ckfree(freePtr); + ckfree((char *) freePtr); return; } @@ -1498,9 +1496,11 @@ ExprObjCallback( * * Results: * A (ByteCode *) is returned pointing to the resulting ByteCode. + * The caller must manage its refCount and arrange for a call to + * TclCleanupByteCode() when the last reference disappears. * * Side effects: - * The Tcl_ObjType of objPtr is changed to the "exprcode" type, + * The Tcl_ObjType of objPtr is changed to the "bytecode" type, * and the ByteCode is kept in the internal rep (along with context * data for checking validity) for faster operations the next time * CompileExprObj is called on the same value. @@ -1533,7 +1533,7 @@ CompileExprObj( || (codePtr->nsPtr != namespacePtr) || (codePtr->nsEpoch != namespacePtr->resolverEpoch) || (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) { - TclFreeIntRep(objPtr); + FreeExprCodeInternalRep(objPtr); } } if (objPtr->typePtr != &exprCodeType) { @@ -1541,10 +1541,11 @@ CompileExprObj( * TIP #280: No invoker (yet) - Expression compilation. */ - const char *string = TclGetString(objPtr); + int length; + const char *string = TclGetStringFromObj(objPtr, &length); - TclInitCompileEnv(interp, &compEnv, string, objPtr->length, NULL, 0); - TclCompileExpr(interp, string, objPtr->length, &compEnv, 0); + TclInitCompileEnv(interp, &compEnv, string, length, NULL, 0); + TclCompileExpr(interp, string, length, &compEnv, 0); /* * Successful compilation. If the expression yielded no instructions, @@ -1552,7 +1553,7 @@ CompileExprObj( */ if (compEnv.codeNext == compEnv.codeStart) { - TclEmitPush(TclRegisterLiteral(&compEnv, "0", 1, 0), + TclEmitPush(TclRegisterNewLiteral(&compEnv, "0", 1), &compEnv); } @@ -1563,8 +1564,10 @@ CompileExprObj( */ TclEmitOpcode(INST_DONE, &compEnv); - codePtr = TclInitByteCodeObj(objPtr, &exprCodeType, &compEnv); + TclInitByteCodeObj(objPtr, &compEnv); + objPtr->typePtr = &exprCodeType; TclFreeCompileEnv(&compEnv); + codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (iPtr->varFramePtr->localCachePtr) { codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; @@ -1638,7 +1641,10 @@ FreeExprCodeInternalRep( { ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; - TclReleaseByteCode(codePtr); + objPtr->typePtr = NULL; + if (codePtr->refCount-- <= 1) { + TclCleanupByteCode(codePtr); + } } /* @@ -2024,7 +2030,7 @@ TclNRExecuteByteCode( * sizeof(void *); int numWords = (size + sizeof(Tcl_Obj *) - 1) / sizeof(Tcl_Obj *); - TclPreserveByteCode(codePtr); + codePtr->refCount++; /* * Reserve the stack, setup the TEBCdataPtr (TD) and CallFrame @@ -2113,14 +2119,8 @@ TEBCresume( * sporadically: no special need for speed. */ - unsigned interruptCounter = 1; - /* Counter that is used to work out when to - * call Tcl_AsyncReady(). This must be 1 - * initially so that we call the async-check - * stanza early, otherwise there are command - * sequences that can make the interpreter - * busy-loop without an opportunity to - * recognise an interrupt. */ + int instructionCount = 0; /* Counter that is used to work out when to + * call Tcl_AsyncReady() */ const char *curInstName; #ifdef TCL_COMPILE_DEBUG int traceInstructions; /* Whether we are doing instruction-level @@ -2318,11 +2318,10 @@ TEBCresume( /* * Check for asynchronous handlers [Bug 746722]; we do the check every - * ASYNC_CHECK_COUNT instructions. + * ASYNC_CHECK_COUNT_MASK instruction, of the form (2**n-1). */ - if ((--interruptCounter) == 0) { - interruptCounter = ASYNC_CHECK_COUNT; + if ((instructionCount++ & ASYNC_CHECK_COUNT_MASK) == 0) { DECACHE_STACK_INFO(); if (TclAsyncReady(iPtr)) { result = Tcl_AsyncInvoke(interp, result); @@ -2536,7 +2535,7 @@ TEBCresume( /* FIXME: What is the right thing to trace? */ fprintf(stdout, "%d: (%u) yielding to [%.30s]\n", iPtr->numLevels, (unsigned)(pc - codePtr->codeStart), - TclGetString(valuePtr)); + Tcl_GetString(valuePtr)); } fflush(stdout); } @@ -2683,18 +2682,154 @@ TEBCresume( NEXT_INST_F(5, 0, 0); } - case INST_STR_CONCAT1: + case INST_STR_CONCAT1: { + int appendLen = 0; + char *bytes, *p; + Tcl_Obj **currPtr; + int onlyb = 1; opnd = TclGetUInt1AtPtr(pc+1); - if (TCL_OK != TclStringCatObjv(interp, /* inPlace */ 1, - opnd, &OBJ_AT_DEPTH(opnd-1), &objResultPtr)) { - TRACE_ERROR(interp); - goto gotError; + /* + * 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; + } + } } TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); NEXT_INST_V(2, opnd, 1); + } case INST_CONCAT_STK: /* @@ -4528,7 +4663,7 @@ TEBCresume( NEXT_INST_F(1, 0, 1); } case INST_INFO_LEVEL_NUM: - TclNewLongObj(objResultPtr, iPtr->varFramePtr->level); + TclNewIntObj(objResultPtr, iPtr->varFramePtr->level); TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); case INST_INFO_LEVEL_ARGS: { @@ -4897,7 +5032,7 @@ TEBCresume( TRACE_ERROR(interp); goto gotError; } - TclNewLongObj(objResultPtr, length); + TclNewIntObj(objResultPtr, length); TRACE_APPEND(("%d\n", length)); NEXT_INST_F(1, 1, 1); @@ -5145,10 +5280,23 @@ TEBCresume( toIdx = objc-1; } if (fromIdx == 0 && toIdx != objc-1 && !Tcl_IsShared(valuePtr)) { - Tcl_ListObjReplace(interp, valuePtr, - toIdx + 1, LIST_MAX, 0, NULL); - TRACE_APPEND(("%.30s\n", O2S(valuePtr))); - NEXT_INST_F(9, 0, 0); + /* + * BEWARE! This is looking inside the implementation of the + * list type. + */ + + List *listPtr = valuePtr->internalRep.twoPtrValue.ptr1; + + if (listPtr->refCount == 1) { + for (index=toIdx+1; index<objc ; index++) { + TclDecrRefCount(objv[index]); + } + listPtr->elemCount = toIdx+1; + listPtr->canonicalFlag = 1; + TclInvalidateStringRep(valuePtr); + TRACE_APPEND(("%.30s\n", O2S(valuePtr))); + NEXT_INST_F(9, 0, 0); + } } objResultPtr = Tcl_NewListObj(toIdx-fromIdx+1, objv+fromIdx); } else { @@ -5368,7 +5516,7 @@ TEBCresume( case INST_STR_LEN: valuePtr = OBJ_AT_TOS; length = Tcl_GetCharLength(valuePtr); - TclNewLongObj(objResultPtr, length); + TclNewIntObj(objResultPtr, length); TRACE(("\"%.20s\" => %d\n", O2S(valuePtr), length)); NEXT_INST_F(1, 1, 1); @@ -5719,19 +5867,45 @@ TEBCresume( NEXT_INST_V(1, 3, 1); case INST_STR_FIND: - match = TclStringFind(OBJ_UNDER_TOS, OBJ_AT_TOS, 0); + 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; + } + } + } TRACE(("%.20s %.20s => %d\n", O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match)); - TclNewLongObj(objResultPtr, match); + TclNewIntObj(objResultPtr, match); NEXT_INST_F(1, 2, 1); case INST_STR_FIND_LAST: - match = TclStringLast(OBJ_UNDER_TOS, OBJ_AT_TOS, INT_MAX - 1); + 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; + } + } + } TRACE(("%.20s %.20s => %d\n", O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match)); - TclNewLongObj(objResultPtr, match); + + TclNewIntObj(objResultPtr, match); NEXT_INST_F(1, 2, 1); case INST_STR_CLASS: @@ -5935,7 +6109,7 @@ TEBCresume( type1 = TCL_NUMBER_WIDE; } } - TclNewLongObj(objResultPtr, type1); + TclNewIntObj(objResultPtr, type1); TRACE(("\"%.20s\" => %d\n", O2S(OBJ_AT_TOS), type1)); NEXT_INST_F(1, 1, 1); @@ -6128,7 +6302,7 @@ TEBCresume( if (l1 > 0L) { objResultPtr = TCONST(0); } else { - TclNewLongObj(objResultPtr, -1); + TclNewIntObj(objResultPtr, -1); } TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); @@ -7028,7 +7202,7 @@ TEBCresume( NEXT_INST_F(1, 0, -1); case INST_PUSH_RETURN_CODE: - TclNewLongObj(objResultPtr, result); + TclNewIntObj(objResultPtr, result); TRACE(("=> %u\n", result)); NEXT_INST_F(1, 0, 1); @@ -7664,6 +7838,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 */ @@ -7952,7 +8159,9 @@ TEBCresume( } iPtr->cmdFramePtr = bcFramePtr->nextPtr; - TclReleaseByteCode(codePtr); + if (codePtr->refCount-- <= 1) { + TclCleanupByteCode(codePtr); + } TclStackFree(interp, TD); /* free my stack */ return result; @@ -8920,7 +9129,7 @@ ExecuteExtendedBinaryMathOp( } Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); mp_init(&bigResult); - mp_expt_d_ex(&big1, big2.dp[0], &bigResult, 1); + mp_expt_d(&big1, big2.dp[0], &bigResult); mp_clear(&big1); mp_clear(&big2); BIG_RESULT(&bigResult); @@ -9199,7 +9408,7 @@ TclCompareTwoNumbers( Tcl_Obj *valuePtr, Tcl_Obj *value2Ptr) { - int type1, type2, compare; + int type1 = TCL_NUMBER_NAN, type2 = TCL_NUMBER_NAN, compare; ClientData ptr1, ptr2; mp_int big1, big2; double d1, d2, tmp; @@ -9444,9 +9653,9 @@ PrintByteCodeInfo( Proc *procPtr = codePtr->procPtr; Interp *iPtr = (Interp *) *codePtr->interpHandle; - 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, "\nExecuting ByteCode 0x%p, refCt %u, epoch %u, interp 0x%p (epoch %u)\n", + codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr, + iPtr->compileEpoch); fprintf(stdout, " Source: "); TclPrintSource(stdout, codePtr->source, 60); @@ -9543,7 +9752,7 @@ ValidatePcAndStackTop( TclNewLiteralStringObj(message, "\n executing "); Tcl_IncrRefCount(message); Tcl_AppendLimitedToObj(message, cmd, numChars, 100, NULL); - fprintf(stderr,"%s\n", TclGetString(message)); + fprintf(stderr,"%s\n", Tcl_GetString(message)); Tcl_DecrRefCount(message); } else { fprintf(stderr, "\n"); @@ -9593,7 +9802,7 @@ IllegalExprOperandType( if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) { int numBytes; - const char *bytes = TclGetStringFromObj(opndPtr, &numBytes); + const char *bytes = Tcl_GetStringFromObj(opndPtr, &numBytes); if (numBytes == 0) { description = "empty string"; @@ -10006,7 +10215,7 @@ TclExprFloatError( "unknown floating-point error, errno = %d", errno); Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", - TclGetString(objPtr), NULL); + Tcl_GetString(objPtr), NULL); Tcl_SetObjResult(interp, objPtr); } } @@ -10222,7 +10431,7 @@ EvalStatsCmd( if (entryPtr->objPtr->typePtr == &tclByteCodeType) { numByteCodeLits++; } - (void) TclGetStringFromObj(entryPtr->objPtr, &length); + (void) Tcl_GetStringFromObj(entryPtr->objPtr, &length); refCountSum += entryPtr->refCount; objBytesIfUnshared += (entryPtr->refCount * sizeof(Tcl_Obj)); strBytesIfUnshared += (entryPtr->refCount * (length+1)); @@ -10444,7 +10653,7 @@ EvalStatsCmd( Tcl_SetObjResult(interp, objPtr); } else { Tcl_Channel outChan; - char *str = TclGetStringFromObj(objv[1], &length); + char *str = Tcl_GetStringFromObj(objv[1], &length); if (length) { if (strcmp(str, "stdout") == 0) { diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 80898fc..bb814ea 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -1079,9 +1079,12 @@ TclFileAttrsCmd( } if (Tcl_GetIndexFromObj(interp, objv[0], attributeStrings, - "option", INDEX_TEMP_TABLE, &index) != TCL_OK) { + "option", 0, &index) != TCL_OK) { goto end; } + if (attributeStringsAllocated != NULL) { + TclFreeIntRep(objv[0]); + } if (Tcl_FSFileAttrsGet(interp, index, filePtr, &objPtr) != TCL_OK) { goto end; @@ -1104,9 +1107,12 @@ TclFileAttrsCmd( for (i = 0; i < objc ; i += 2) { if (Tcl_GetIndexFromObj(interp, objv[i], attributeStrings, - "option", INDEX_TEMP_TABLE, &index) != TCL_OK) { + "option", 0, &index) != TCL_OK) { goto end; } + if (attributeStringsAllocated != NULL) { + TclFreeIntRep(objv[i]); + } if (i + 1 == objc) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "value for \"%s\" missing", TclGetString(objv[i]))); diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 150fb8c..2136883 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -387,7 +387,7 @@ TclpGetNativePathType( { Tcl_PathType type = TCL_PATH_ABSOLUTE; int pathLen; - const char *path = TclGetStringFromObj(pathPtr, &pathLen); + const char *path = Tcl_GetStringFromObj(pathPtr, &pathLen); if (path[0] == '~') { /* @@ -578,7 +578,7 @@ Tcl_SplitPath( size = 1; for (i = 0; i < *argcPtr; i++) { Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr); - TclGetStringFromObj(eltPtr, &len); + Tcl_GetStringFromObj(eltPtr, &len); size += len + 1; } @@ -597,7 +597,7 @@ Tcl_SplitPath( p = (char *) &(*argvPtr)[(*argcPtr) + 1]; for (i = 0; i < *argcPtr; i++) { Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr); - str = TclGetStringFromObj(eltPtr, &len); + str = Tcl_GetStringFromObj(eltPtr, &len); memcpy(p, str, (size_t) len+1); p += len+1; } @@ -857,7 +857,7 @@ TclpNativeJoinPath( const char *p; const char *start; - start = TclGetStringFromObj(prefix, &length); + start = Tcl_GetStringFromObj(prefix, &length); /* * Remove the ./ from tilde prefixed elements, and drive-letter prefixed @@ -885,7 +885,7 @@ TclpNativeJoinPath( if (length > 0 && (start[length-1] != '/')) { Tcl_AppendToObj(prefix, "/", 1); - TclGetStringFromObj(prefix, &length); + Tcl_GetStringFromObj(prefix, &length); } needsSep = 0; @@ -921,7 +921,7 @@ TclpNativeJoinPath( if ((length > 0) && (start[length-1] != '/') && (start[length-1] != ':')) { Tcl_AppendToObj(prefix, "/", 1); - TclGetStringFromObj(prefix, &length); + Tcl_GetStringFromObj(prefix, &length); } needsSep = 0; @@ -1003,7 +1003,7 @@ Tcl_JoinPath( * Store the result. */ - resultStr = TclGetStringFromObj(resultObj, &len); + resultStr = Tcl_GetStringFromObj(resultObj, &len); Tcl_DStringAppend(resultPtr, resultStr, len); Tcl_DecrRefCount(resultObj); @@ -1249,7 +1249,7 @@ Tcl_GlobObjCmd( for (i = 1; i < objc; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) != TCL_OK) { - string = TclGetStringFromObj(objv[i], &length); + string = Tcl_GetStringFromObj(objv[i], &length); if (string[0] == '-') { /* * It looks like the command contains an option so signal an @@ -1357,7 +1357,7 @@ Tcl_GlobObjCmd( if (dir == PATH_GENERAL) { int pathlength; const char *last; - const char *first = TclGetStringFromObj(pathOrDir,&pathlength); + const char *first = Tcl_GetStringFromObj(pathOrDir,&pathlength); /* * Find the last path separator in the path @@ -1460,7 +1460,7 @@ Tcl_GlobObjCmd( const char *str; Tcl_ListObjIndex(interp, typePtr, length, &look); - str = TclGetStringFromObj(look, &len); + str = Tcl_GetStringFromObj(look, &len); if (strcmp("readonly", str) == 0) { globTypes->perm |= TCL_GLOB_PERM_RONLY; } else if (strcmp("hidden", str) == 0) { @@ -1992,7 +1992,7 @@ TclGlob( Tcl_Panic("Called TclGlob with TCL_GLOBMODE_TAILS and pathPrefix==NULL"); } - pre = TclGetStringFromObj(pathPrefix, &prefixLen); + pre = Tcl_GetStringFromObj(pathPrefix, &prefixLen); if (prefixLen > 0 && (strchr(separators, pre[prefixLen-1]) == NULL)) { /* @@ -2010,7 +2010,7 @@ TclGlob( Tcl_ListObjGetElements(NULL, filenamesObj, &objc, &objv); for (i = 0; i< objc; i++) { int len; - const char *oldStr = TclGetStringFromObj(objv[i], &len); + const char *oldStr = Tcl_GetStringFromObj(objv[i], &len); Tcl_Obj *elem; if (len == prefixLen) { @@ -2362,7 +2362,7 @@ DoGlob( Tcl_Obj *fixme, *newObj; Tcl_ListObjIndex(NULL, matchesObj, repair, &fixme); - bytes = TclGetStringFromObj(fixme, &numBytes); + bytes = Tcl_GetStringFromObj(fixme, &numBytes); newObj = Tcl_NewStringObj(bytes+2, numBytes-2); Tcl_ListObjReplace(NULL, matchesObj, repair, 1, 1, &newObj); @@ -2400,7 +2400,7 @@ DoGlob( Tcl_DStringAppend(&append, pattern, p-pattern); if (pathPtr != NULL) { - (void) TclGetStringFromObj(pathPtr, &length); + (void) Tcl_GetStringFromObj(pathPtr, &length); } else { length = 0; } @@ -2446,7 +2446,7 @@ DoGlob( */ int len; - const char *joined = TclGetStringFromObj(joinedPtr,&len); + const char *joined = Tcl_GetStringFromObj(joinedPtr,&len); if (strchr(separators, joined[len-1]) == NULL) { Tcl_AppendToObj(joinedPtr, "/", 1); @@ -2483,7 +2483,7 @@ DoGlob( */ int len; - const char *joined = TclGetStringFromObj(joinedPtr,&len); + const char *joined = Tcl_GetStringFromObj(joinedPtr,&len); if (strchr(separators, joined[len-1]) == NULL) { if (Tcl_FSGetPathType(pathPtr) != TCL_PATH_VOLUME_RELATIVE) { diff --git a/generic/tclHash.c b/generic/tclHash.c index 78ad514..1991aea 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.c @@ -43,7 +43,7 @@ static Tcl_HashEntry * AllocArrayEntry(Tcl_HashTable *tablePtr, void *keyPtr); static int CompareArrayKeys(void *keyPtr, Tcl_HashEntry *hPtr); -static TCL_HASH_TYPE HashArrayKey(Tcl_HashTable *tablePtr, void *keyPtr); +static unsigned int HashArrayKey(Tcl_HashTable *tablePtr, void *keyPtr); /* * Prototypes for the one word hash key methods. Not actually declared because @@ -65,7 +65,7 @@ static unsigned int HashOneWordKey(Tcl_HashTable *tablePtr, void *keyPtr); static Tcl_HashEntry * AllocStringEntry(Tcl_HashTable *tablePtr, void *keyPtr); static int CompareStringKeys(void *keyPtr, Tcl_HashEntry *hPtr); -static TCL_HASH_TYPE HashStringKey(Tcl_HashTable *tablePtr, void *keyPtr); +static unsigned int HashStringKey(Tcl_HashTable *tablePtr, void *keyPtr); /* * Function prototypes for static functions in this file: @@ -321,9 +321,11 @@ CreateHashEntry( for (hPtr = tablePtr->buckets[index]; hPtr != NULL; hPtr = hPtr->nextPtr) { +#if TCL_HASH_KEY_STORE_HASH if (hash != PTR2UINT(hPtr->hash)) { continue; } +#endif if (((void *) key == hPtr) || compareKeysProc((void *) key, hPtr)) { if (newPtr) { *newPtr = 0; @@ -334,9 +336,11 @@ CreateHashEntry( } else { for (hPtr = tablePtr->buckets[index]; hPtr != NULL; hPtr = hPtr->nextPtr) { +#if TCL_HASH_KEY_STORE_HASH if (hash != PTR2UINT(hPtr->hash)) { continue; } +#endif if (key == hPtr->key.oneWordValue) { if (newPtr) { *newPtr = 0; @@ -364,9 +368,15 @@ CreateHashEntry( } hPtr->tablePtr = tablePtr; +#if TCL_HASH_KEY_STORE_HASH hPtr->hash = UINT2PTR(hash); hPtr->nextPtr = tablePtr->buckets[index]; tablePtr->buckets[index] = hPtr; +#else + hPtr->bucketPtr = &tablePtr->buckets[index]; + hPtr->nextPtr = *hPtr->bucketPtr; + *hPtr->bucketPtr = hPtr; +#endif tablePtr->numEntries++; /* @@ -406,7 +416,9 @@ Tcl_DeleteHashEntry( const Tcl_HashKeyType *typePtr; Tcl_HashTable *tablePtr; Tcl_HashEntry **bucketPtr; +#if TCL_HASH_KEY_STORE_HASH int index; +#endif tablePtr = entryPtr->tablePtr; @@ -421,6 +433,7 @@ Tcl_DeleteHashEntry( typePtr = &tclArrayHashKeyType; } +#if TCL_HASH_KEY_STORE_HASH if (typePtr->hashKeyProc == NULL || typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) { index = RANDOM_INDEX(tablePtr, PTR2INT(entryPtr->hash)); @@ -429,6 +442,9 @@ Tcl_DeleteHashEntry( } bucketPtr = &tablePtr->buckets[index]; +#else + bucketPtr = entryPtr->bucketPtr; +#endif if (*bucketPtr == entryPtr) { *bucketPtr = entryPtr->nextPtr; @@ -774,7 +790,7 @@ CompareArrayKeys( *---------------------------------------------------------------------- */ -static TCL_HASH_TYPE +static unsigned int HashArrayKey( Tcl_HashTable *tablePtr, /* Hash table. */ void *keyPtr) /* Key from which to compute hash value. */ @@ -787,7 +803,7 @@ HashArrayKey( count--, array++) { result += *array; } - return (TCL_HASH_TYPE) result; + return result; } /* @@ -870,7 +886,7 @@ CompareStringKeys( *---------------------------------------------------------------------- */ -static TCL_HASH_TYPE +static unsigned HashStringKey( Tcl_HashTable *tablePtr, /* Hash table. */ void *keyPtr) /* Key from which to compute hash value. */ @@ -916,7 +932,7 @@ HashStringKey( result += (result << 3) + UCHAR(c); } } - return (TCL_HASH_TYPE) result; + return result; } /* @@ -924,7 +940,7 @@ HashStringKey( * * BogusFind -- * - * This function is invoked when Tcl_FindHashEntry is called on a + * This function is invoked when an Tcl_FindHashEntry is called on a * table that has been deleted. * * Results: @@ -951,7 +967,7 @@ BogusFind( * * BogusCreate -- * - * This function is invoked when Tcl_CreateHashEntry is called on a + * This function is invoked when an Tcl_CreateHashEntry is called on a * table that has been deleted. * * Results: @@ -1046,6 +1062,7 @@ RebuildTable( for (oldChainPtr = oldBuckets; oldSize > 0; oldSize--, oldChainPtr++) { for (hPtr = *oldChainPtr; hPtr != NULL; hPtr = *oldChainPtr) { *oldChainPtr = hPtr->nextPtr; +#if TCL_HASH_KEY_STORE_HASH if (typePtr->hashKeyProc == NULL || typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) { index = RANDOM_INDEX(tablePtr, PTR2INT(hPtr->hash)); @@ -1054,6 +1071,26 @@ RebuildTable( } hPtr->nextPtr = tablePtr->buckets[index]; tablePtr->buckets[index] = hPtr; +#else + void *key = Tcl_GetHashKey(tablePtr, hPtr); + + if (typePtr->hashKeyProc) { + unsigned int hash; + + hash = typePtr->hashKeyProc(tablePtr, key); + if (typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) { + index = RANDOM_INDEX(tablePtr, hash); + } else { + index = hash & tablePtr->mask; + } + } else { + index = RANDOM_INDEX(tablePtr, key); + } + + hPtr->bucketPtr = &tablePtr->buckets[index]; + hPtr->nextPtr = *hPtr->bucketPtr; + *hPtr->bucketPtr = hPtr; +#endif } } diff --git a/generic/tclHistory.c b/generic/tclHistory.c index 47806d4..b08e352 100644 --- a/generic/tclHistory.c +++ b/generic/tclHistory.c @@ -62,14 +62,15 @@ Tcl_RecordAndEval( * instead of Tcl_Eval. */ { register Tcl_Obj *cmdPtr; + int length = strlen(cmd); int result; - if (cmd[0]) { + if (length > 0) { /* * Call Tcl_RecordAndEvalObj to do the actual work. */ - cmdPtr = Tcl_NewStringObj(cmd, -1); + cmdPtr = Tcl_NewStringObj(cmd, length); Tcl_IncrRefCount(cmdPtr); result = Tcl_RecordAndEvalObj(interp, cmdPtr, flags); diff --git a/generic/tclIO.c b/generic/tclIO.c index 6bf8451..64501fd 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -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. */ - size_t epoch; /* The epoch of the channel when the lookup + int epoch; /* The epoch of the channel when the lookup * was done. Use to verify validity. */ - size_t refCount; /* Share this struct among many Tcl_Obj. */ + int refCount; /* Share this struct among many Tcl_Obj. */ } ResolvedChanName; static void DupChannelIntRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); @@ -7127,6 +7127,47 @@ Tcl_Tell( /* *--------------------------------------------------------------------------- * + * Tcl_SeekOld, Tcl_TellOld -- + * + * Backward-compatibility 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. @@ -9276,7 +9317,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); @@ -11153,7 +11194,7 @@ FreeChannelIntRep( ResolvedChanName *resPtr = objPtr->internalRep.twoPtrValue.ptr1; objPtr->typePtr = NULL; - if (resPtr->refCount-- > 1) { + if (--resPtr->refCount) { return; } Tcl_Release(resPtr->statePtr); diff --git a/generic/tclIO.h b/generic/tclIO.h index 07c54fa..ffbfa31 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'. */ - size_t epoch; /* Used to test validity of stored channelname + int epoch; /* Used to test validity of stored channelname * lookup results. */ } ChannelState; diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 1bd3fe7..834f225 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -16,7 +16,7 @@ */ typedef struct AcceptCallback { - Tcl_Obj *script; /* Script to invoke. */ + char *script; /* Script to invoke. */ Tcl_Interp *interp; /* Interpreter in which to run it. */ } AcceptCallback; @@ -37,7 +37,8 @@ static Tcl_ThreadDataKey dataKey; */ static void FinalizeIOCmdTSD(ClientData clientData); -static Tcl_TcpAcceptProc AcceptCallbackProc; +static void AcceptCallbackProc(ClientData callbackData, + Tcl_Channel chan, char *address, int port); static int ChanPendingObjCmd(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -1372,22 +1373,15 @@ AcceptCallbackProc( */ if (acceptCallbackPtr->interp != NULL) { + char portBuf[TCL_INTEGER_SPACE]; + char *script = acceptCallbackPtr->script; Tcl_Interp *interp = acceptCallbackPtr->interp; - Tcl_Obj *script, *objv[2]; - int result = TCL_OK; - - objv[0] = acceptCallbackPtr->script; - objv[1] = Tcl_NewListObj(3, NULL); - Tcl_ListObjAppendElement(NULL, objv[1], Tcl_NewStringObj( - Tcl_GetChannelName(chan), -1)); - Tcl_ListObjAppendElement(NULL, objv[1], Tcl_NewStringObj(address, -1)); - Tcl_ListObjAppendElement(NULL, objv[1], Tcl_NewIntObj(port)); - - script = Tcl_ConcatObj(2, objv); - Tcl_IncrRefCount(script); - Tcl_DecrRefCount(objv[1]); + int result; + Tcl_Preserve(script); Tcl_Preserve(interp); + + TclFormatInt(portBuf, port); Tcl_RegisterChannel(interp, chan); /* @@ -1397,9 +1391,8 @@ AcceptCallbackProc( Tcl_RegisterChannel(NULL, chan); - result = Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT|TCL_EVAL_GLOBAL); - Tcl_DecrRefCount(script); - + result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan), + " ", address, " ", portBuf, NULL); if (result != TCL_OK) { Tcl_BackgroundException(interp, result); Tcl_UnregisterChannel(interp, chan); @@ -1413,6 +1406,7 @@ AcceptCallbackProc( Tcl_UnregisterChannel(NULL, chan); Tcl_Release(interp); + Tcl_Release(script); } else { /* * The interpreter has been deleted, so there is no useful way to use @@ -1456,7 +1450,7 @@ TcpServerCloseProc( UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp, acceptCallbackPtr); } - Tcl_DecrRefCount(acceptCallbackPtr->script); + Tcl_EventuallyFree(acceptCallbackPtr->script, TCL_DYNAMIC); ckfree(acceptCallbackPtr); } @@ -1485,18 +1479,13 @@ Tcl_SocketObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { static const char *const socketOptions[] = { - "-async", "-myaddr", "-myport", "-reuseaddr", "-reuseport", "-server", - NULL + "-async", "-myaddr", "-myport", "-server", NULL }; enum socketOptions { - SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_REUSEADDR, SKT_REUSEPORT, - SKT_SERVER + SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER }; - 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; + int optionIndex, a, server = 0, port, myport = 0, async = 0; + const char *host, *script = NULL, *myaddr = NULL; Tcl_Channel chan; if (TclpHasSockets(interp) != TCL_OK) { @@ -1559,29 +1548,7 @@ Tcl_SocketObjCmd( "no argument given for -server option", -1)); return TCL_ERROR; } - 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; - } + script = TclGetString(objv[a]); break; default: Tcl_Panic("Tcl_SocketObjCmd: bad option index to SocketOptions"); @@ -1606,49 +1573,32 @@ Tcl_SocketObjCmd( "?-myaddr addr? ?-myport myport? ?-async? host port"); iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS; Tcl_WrongNumArgs(interp, 1, objv, - "-server command ?-reuseaddr boolean? ?-reuseport boolean? " - "?-myaddr addr? port"); + "-server command ?-myaddr addr? port"); return TCL_ERROR; } - 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) { + if (a == objc-1) { + if (TclSockGetPort(interp, TclGetString(objv[a]), "tcp", + &port) != TCL_OK) { + return TCL_ERROR; + } + } else { goto wrongNumArgs; } - port = TclGetString(objv[a]); - if (server) { AcceptCallback *acceptCallbackPtr = ckalloc(sizeof(AcceptCallback)); + unsigned len = strlen(script) + 1; + char *copyScript = ckalloc(len); - Tcl_IncrRefCount(script); - acceptCallbackPtr->script = script; + memcpy(copyScript, script, len); + acceptCallbackPtr->script = copyScript; acceptCallbackPtr->interp = interp; - - chan = Tcl_OpenTcpServerEx(interp, port, host, flags, AcceptCallbackProc, - acceptCallbackPtr); + chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc, + acceptCallbackPtr); if (chan == NULL) { - Tcl_DecrRefCount(script); + ckfree(copyScript); ckfree(acceptCallbackPtr); return TCL_ERROR; } @@ -1670,13 +1620,7 @@ Tcl_SocketObjCmd( Tcl_CreateCloseHandler(chan, TcpServerCloseProc, acceptCallbackPtr); } else { - int portNum; - - if (TclSockGetPort(interp, port, "tcp", &portNum) != TCL_OK) { - return TCL_ERROR; - } - - chan = Tcl_OpenTcpClient(interp, portNum, host, myaddr, myport, async); + chan = Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async); if (chan == NULL) { return TCL_ERROR; } diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c index c1e8c44..7f61def 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. */ - size_t refCount; + int refCount; }; static void @@ -225,7 +225,7 @@ static void ReleaseData( TransformChannelData *dataPtr) { - if (dataPtr->refCount-- > 1) { + if (--dataPtr->refCount) { return; } ResultClear(&dataPtr->result); diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index 2fed3f4..f476a1a 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -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", - TclGetString(cmdObj), TclGetString(resObj))); + Tcl_GetString(cmdObj), Tcl_GetString(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", - TclGetString(cmdObj))); + Tcl_GetString(cmdObj))); goto error; } if ((mode & TCL_READABLE) && !HAS(methods, METH_READ)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s\" lacks a \"read\" method", - TclGetString(cmdObj))); + Tcl_GetString(cmdObj))); goto error; } if ((mode & TCL_WRITABLE) && !HAS(methods, METH_WRITE)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s\" lacks a \"write\" method", - TclGetString(cmdObj))); + Tcl_GetString(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\"", - TclGetString(cmdObj))); + Tcl_GetString(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\"", - TclGetString(cmdObj))); + Tcl_GetString(cmdObj))); goto error; } @@ -1152,7 +1152,7 @@ ReflectClose( tctPtr = ((Channel *)rcPtr->chan)->typePtr; if (tctPtr && tctPtr != &tclRChannelType) { - ckfree(tctPtr); + ckfree((char *)tctPtr); ((Channel *)rcPtr->chan)->typePtr = NULL; } Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); @@ -1221,7 +1221,7 @@ ReflectClose( #endif tctPtr = ((Channel *)rcPtr->chan)->typePtr; if (tctPtr && tctPtr != &tclRChannelType) { - ckfree(tctPtr); + ckfree((char *)tctPtr); ((Channel *)rcPtr->chan)->typePtr = NULL; } Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); @@ -1946,7 +1946,7 @@ ReflectGetOption( goto error; } else { int len; - const char *str = TclGetStringFromObj(resObj, &len); + const char *str = Tcl_GetStringFromObj(resObj, &len); if (len) { TclDStringAppendLiteral(dsPtr, " "); @@ -2319,7 +2319,7 @@ InvokeTclMethod( if (result != TCL_ERROR) { int cmdLen; - const char *cmdString = TclGetStringFromObj(cmd, &cmdLen); + const char *cmdString = Tcl_GetStringFromObj(cmd, &cmdLen); Tcl_IncrRefCount(cmd); Tcl_ResetResult(rcPtr->interp); @@ -2398,7 +2398,7 @@ ErrnoReturn( if (((Tcl_GetIntFromObj(rcPtr->interp, resObj, &code) != TCL_OK) || (code >= 0))) { - if (strcmp("EAGAIN", TclGetString(resObj)) == 0) { + if (strcmp("EAGAIN", Tcl_GetString(resObj)) == 0) { code = -EAGAIN; } else { code = 0; @@ -3174,7 +3174,7 @@ ForwardProc( ForwardSetDynamicError(paramPtr, buf); } else { int len; - const char *str = TclGetStringFromObj(resObj, &len); + const char *str = Tcl_GetStringFromObj(resObj, &len); if (len) { TclDStringAppendLiteral(paramPtr->getOpt.value, " "); @@ -3273,7 +3273,7 @@ ForwardSetObjError( Tcl_Obj *obj) { int len; - const char *msgStr = TclGetStringFromObj(obj, &len); + const char *msgStr = Tcl_GetStringFromObj(obj, &len); len++; ForwardSetDynamicError(paramPtr, ckalloc(len)); diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c index 8375926..af86ba5 100644 --- a/generic/tclIORTrans.c +++ b/generic/tclIORTrans.c @@ -554,7 +554,7 @@ TclChanPushObjCmd( */ chanObj = objv[CHAN]; - parentChan = Tcl_GetChannel(interp, TclGetString(chanObj), &mode); + parentChan = Tcl_GetChannel(interp, Tcl_GetString(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", - TclGetString(cmdObj), TclGetString(resObj))); + Tcl_GetString(cmdObj), Tcl_GetString(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", - TclGetString(cmdObj), + Tcl_GetString(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", - TclGetString(cmdObj))); + Tcl_GetString(cmdObj))); goto error; } @@ -655,7 +655,7 @@ TclChanPushObjCmd( if (!mode) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s\" makes the channel inaccessible", - TclGetString(cmdObj))); + Tcl_GetString(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\"", - TclGetString(cmdObj))); + Tcl_GetString(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\"", - TclGetString(cmdObj))); + Tcl_GetString(cmdObj))); goto error; } @@ -694,14 +694,14 @@ TclChanPushObjCmd( */ rtmPtr = GetReflectedTransformMap(interp); - hPtr = Tcl_CreateHashEntry(&rtmPtr->map, TclGetString(rtId), &isNew); + hPtr = Tcl_CreateHashEntry(&rtmPtr->map, Tcl_GetString(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, TclGetString(rtId), &isNew); + hPtr = Tcl_CreateHashEntry(&rtmPtr->map, Tcl_GetString(rtId), &isNew); Tcl_SetHashValue(hPtr, rtPtr); #endif /* TCL_THREADS */ @@ -1027,7 +1027,7 @@ ReflectClose( #ifdef TCL_THREADS rtmPtr = GetThreadReflectedTransformMap(); - hPtr = Tcl_FindHashEntry(&rtmPtr->map, TclGetString(rtPtr->handle)); + hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle)); if (hPtr) { Tcl_DeleteHashEntry(hPtr); } @@ -2043,7 +2043,7 @@ InvokeTclMethod( if (result != TCL_ERROR) { Tcl_Obj *cmd = Tcl_NewListObj(cmdc, rtPtr->argv); int cmdLen; - const char *cmdString = TclGetStringFromObj(cmd, &cmdLen); + const char *cmdString = Tcl_GetStringFromObj(cmd, &cmdLen); Tcl_IncrRefCount(cmd); Tcl_ResetResult(rtPtr->interp); @@ -2568,7 +2568,7 @@ ForwardProc( */ rtmPtr = GetReflectedTransformMap(interp); - hPtr = Tcl_FindHashEntry(&rtmPtr->map, TclGetString(rtPtr->handle)); + hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle)); Tcl_DeleteHashEntry(hPtr); /* @@ -2578,7 +2578,7 @@ ForwardProc( */ rtmPtr = GetThreadReflectedTransformMap(); - hPtr = Tcl_FindHashEntry(&rtmPtr->map, TclGetString(rtPtr->handle)); + hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle)); Tcl_DeleteHashEntry(hPtr); FreeReflectedTransformArgs(rtPtr); @@ -2807,7 +2807,7 @@ ForwardSetObjError( Tcl_Obj *obj) { int len; - const char *msgStr = TclGetStringFromObj(obj, &len); + const char *msgStr = Tcl_GetStringFromObj(obj, &len); len++; ForwardSetDynamicError(paramPtr, ckalloc(len)); @@ -2955,7 +2955,7 @@ ResultClear( return; } - ckfree(rPtr->buf); + ckfree((char *) rPtr->buf); rPtr->buf = NULL; rPtr->allocated = 0; } diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c index 8ad268a..c5b7d28 100644 --- a/generic/tclIOSock.c +++ b/generic/tclIOSock.c @@ -56,8 +56,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 */ @@ -154,15 +154,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,31 +181,30 @@ 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_GetVar(interp, "::tcl::unsupported::socketAF", 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; @@ -252,7 +251,6 @@ 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) { @@ -285,34 +283,6 @@ 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 de5d62d..e00b9ac 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -544,8 +544,8 @@ TclFSCwdPointerEquals( int len1, len2; const char *str1, *str2; - str1 = TclGetStringFromObj(tsdPtr->cwdPathPtr, &len1); - str2 = TclGetStringFromObj(*pathPtrPtr, &len2); + str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1); + str2 = Tcl_GetStringFromObj(*pathPtrPtr, &len2); if ((len1 == len2) && !memcmp(str1, str2, len1)) { /* * They are equal, but different objects. Update so they will be @@ -688,7 +688,7 @@ FsUpdateCwd( ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); if (cwdObj != NULL) { - str = TclGetStringFromObj(cwdObj, &len); + str = Tcl_GetStringFromObj(cwdObj, &len); } Tcl_MutexLock(&cwdMutex); @@ -1224,8 +1224,8 @@ FsAddMountsToGlobResult( if (norm != NULL) { const char *path, *mount; - mount = TclGetStringFromObj(mElt, &mlen); - path = TclGetStringFromObj(norm, &len); + mount = Tcl_GetStringFromObj(mElt, &mlen); + path = Tcl_GetStringFromObj(norm, &len); if (path[len-1] == '/') { /* * Deal with the root of the volume. @@ -1816,7 +1816,7 @@ Tcl_FSEvalFileEx( oldScriptFile = iPtr->scriptFile; iPtr->scriptFile = pathPtr; Tcl_IncrRefCount(iPtr->scriptFile); - string = TclGetStringFromObj(objPtr, &length); + string = Tcl_GetStringFromObj(objPtr, &length); /* * TIP #280 Force the evaluator to open a frame for a sourced file. @@ -1843,7 +1843,7 @@ Tcl_FSEvalFileEx( * Record information telling where the error occurred. */ - const char *pathString = TclGetStringFromObj(pathPtr, &length); + const char *pathString = Tcl_GetStringFromObj(pathPtr, &length); int limit = 150; int overflow = (length > limit); @@ -1890,7 +1890,6 @@ 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 @@ -1995,7 +1994,7 @@ EvalFileCallback( */ int length; - const char *pathString = TclGetStringFromObj(pathPtr, &length); + const char *pathString = Tcl_GetStringFromObj(pathPtr, &length); const int limit = 150; int overflow = (length > limit); @@ -2847,8 +2846,8 @@ Tcl_FSGetCwd( int len1, len2; const char *str1, *str2; - str1 = TclGetStringFromObj(tsdPtr->cwdPathPtr, &len1); - str2 = TclGetStringFromObj(norm, &len2); + str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1); + str2 = Tcl_GetStringFromObj(norm, &len2); if ((len1 == len2) && (strcmp(str1, str2) == 0)) { /* * If the paths were equal, we can be more efficient and @@ -4116,7 +4115,7 @@ TclGetPathType( * caller. */ { int pathLen; - const char *path = TclGetStringFromObj(pathPtr, &pathLen); + const char *path = Tcl_GetStringFromObj(pathPtr, &pathLen); Tcl_PathType type; type = TclFSNonnativePathType(path, pathLen, filesystemPtrPtr, @@ -4228,7 +4227,7 @@ TclFSNonnativePathType( numVolumes--; Tcl_ListObjIndex(NULL, thisFsVolumes, numVolumes, &vol); - strVol = TclGetStringFromObj(vol,&len); + strVol = Tcl_GetStringFromObj(vol,&len); if (pathLen < len) { continue; } @@ -4575,8 +4574,8 @@ Tcl_FSRemoveDirectory( Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr); if (normPath != NULL) { - normPathStr = TclGetStringFromObj(normPath, &normLen); - cwdStr = TclGetStringFromObj(cwdPtr, &cwdLen); + normPathStr = Tcl_GetStringFromObj(normPath, &normLen); + cwdStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen); if ((cwdLen >= normLen) && (strncmp(normPathStr, cwdStr, (size_t) normLen) == 0)) { /* diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 6a3e4e3..0e0ddc9 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -114,13 +114,14 @@ Tcl_GetIndexFromObj( int flags, /* 0 or TCL_EXACT */ int *indexPtr) /* Place to store resulting integer index. */ { + /* * See if there is a valid cached result from a previous lookup (doing the * check here saves the overhead of calling Tcl_GetIndexFromObjStruct in * the common case where the result is cached). */ - if (!(flags & INDEX_TEMP_TABLE) && objPtr->typePtr == &indexType) { + if (objPtr->typePtr == &indexType) { IndexRep *indexRep = objPtr->internalRep.twoPtrValue.ptr1; /* @@ -210,8 +211,13 @@ GetIndexFromObjList( tablePtr[objc] = NULL; result = Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, - sizeof(char *), msg, flags | INDEX_TEMP_TABLE, indexPtr); + sizeof(char *), msg, flags, indexPtr); + + /* + * The internal rep must be cleared since tablePtr will go away. + */ + TclFreeIntRep(objPtr); ckfree(tablePtr); return result; @@ -273,7 +279,7 @@ Tcl_GetIndexFromObjStruct( * See if there is a valid cached result from a previous lookup. */ - if (!(flags & INDEX_TEMP_TABLE) && objPtr->typePtr == &indexType) { + if (objPtr->typePtr == &indexType) { indexRep = objPtr->internalRep.twoPtrValue.ptr1; if (indexRep->tablePtr==tablePtr && indexRep->offset==offset) { *indexPtr = indexRep->index; @@ -334,19 +340,17 @@ Tcl_GetIndexFromObjStruct( * operation. */ - if (!(flags & INDEX_TEMP_TABLE)) { - if (objPtr->typePtr == &indexType) { - indexRep = objPtr->internalRep.twoPtrValue.ptr1; - } else { - TclFreeIntRep(objPtr); - indexRep = ckalloc(sizeof(IndexRep)); - objPtr->internalRep.twoPtrValue.ptr1 = indexRep; - objPtr->typePtr = &indexType; - } - indexRep->tablePtr = (void *) tablePtr; - indexRep->offset = offset; - indexRep->index = index; + if (objPtr->typePtr == &indexType) { + indexRep = objPtr->internalRep.twoPtrValue.ptr1; + } else { + TclFreeIntRep(objPtr); + indexRep = ckalloc(sizeof(IndexRep)); + objPtr->internalRep.twoPtrValue.ptr1 = indexRep; + objPtr->typePtr = &indexType; } + indexRep->tablePtr = (void *) tablePtr; + indexRep->offset = offset; + indexRep->index = index; *indexPtr = index; return TCL_OK; @@ -708,10 +712,10 @@ PrefixAllObjCmd( return result; } resultPtr = Tcl_NewListObj(0, NULL); - string = TclGetStringFromObj(objv[2], &length); + string = Tcl_GetStringFromObj(objv[2], &length); for (t = 0; t < tableObjc; t++) { - elemString = TclGetStringFromObj(tableObjv[t], &elemLength); + elemString = Tcl_GetStringFromObj(tableObjv[t], &elemLength); /* * A prefix cannot match if it is longest. @@ -764,13 +768,13 @@ PrefixLongestObjCmd( if (result != TCL_OK) { return result; } - string = TclGetStringFromObj(objv[2], &length); + string = Tcl_GetStringFromObj(objv[2], &length); resultString = NULL; resultLength = 0; for (t = 0; t < tableObjc; t++) { - elemString = TclGetStringFromObj(tableObjv[t], &elemLength); + elemString = Tcl_GetStringFromObj(tableObjv[t], &elemLength); /* * First check if the prefix string matches the element. A prefix @@ -1144,7 +1148,7 @@ Tcl_ParseArgsObjv( curArg = objv[srcIndex]; srcIndex++; objc--; - str = TclGetStringFromObj(curArg, &length); + str = Tcl_GetStringFromObj(curArg, &length); if (length > 0) { c = str[1]; } else { diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 8314925..4e7e422 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -1009,7 +1009,7 @@ declare 250 { # Allow extensions for optimization declare 251 { int TclRegisterLiteral(void *envPtr, - const char *bytes, int length, int flags) + char *bytes, int length, int flags) } ############################################################################## @@ -1246,7 +1246,7 @@ declare 19 macosx { } declare 29 {win unix} { - int TclWinCPUID(int index, int *regs) + int TclWinCPUID(unsigned int index, unsigned int *regs) } # Added in 8.6; core of TclpOpenTemporaryFile declare 30 {win unix} { diff --git a/generic/tclInt.h b/generic/tclInt.h index 6f45a05..ea4c73e 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -26,19 +26,6 @@ #undef ACCEPT_NAN /* - * In Tcl 8.7, stop supporting special hacks for legacy Itcl 3. - * Itcl 4 doesn't need them. Itcl 3 can be updated to not need them - * using the Tcl(Init|Reset)RewriteEnsemble() routines in all Tcl 8.6+ - * releases. Perhaps Tcl 8.7 will add even better public interfaces - * supporting all the re-invocation mechanisms extensions like Itcl 3 - * need. As an absolute last resort, folks who must make Itcl 3 work - * unchanged with Tcl 8.7 can remove this line to regain the migration - * support. Tcl 9 will no longer offer even that option. - */ - -#define AVOID_HACKS_FOR_ITCL 1 - -/* * Common include files needed by most of the Tcl source files are included * here, so that system-dependent personalizations for the include files only * have to be made in once place. This results in a few extra includes, but @@ -265,7 +252,7 @@ typedef struct Namespace { * strings; values have type (Namespace *). If * NULL, there are no children. */ #endif - size_t nsId; /* Unique id for the namespace. */ + long 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 +286,12 @@ typedef struct Namespace { * registered using "namespace export". */ int maxExportPatterns; /* Mumber of export patterns for which space * is currently allocated. */ - size_t cmdRefEpoch; /* Incremented if a newly added command + int 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. */ - size_t resolverEpoch; /* Incremented whenever (a) the name + int 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 +318,7 @@ typedef struct Namespace { * LookupCompiledLocal to resolve variable * references within the namespace at compile * time. */ - size_t exportLookupEpoch; /* Incremented whenever a command is added to + int 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 +419,7 @@ typedef struct EnsembleConfig { * if the command has been deleted (or never * existed; the global namespace never has an * ensemble command.) */ - size_t epoch; /* The epoch at which this ensemble's table of + int 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 @@ -1639,7 +1626,7 @@ typedef struct Command { * representing a command's name in a ByteCode * instruction sequence. This structure can be * freed when refCount becomes zero. */ - size_t cmdEpoch; /* Incremented to invalidate any references + int 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 @@ -1898,7 +1885,7 @@ typedef struct Interp { * compiled by the interpreter. Indexed by the * string representations of literals. Used to * avoid creating duplicate objects. */ - unsigned int compileEpoch; /* Holds the current "compilation epoch" for + 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 @@ -2550,15 +2537,6 @@ typedef struct TclFileAttrProcs { } TclFileAttrProcs; /* - * Private flag value which controls Tcl_GetIndexFromObj*() routines - * to instruct them not to cache lookups because the table will not - * live long enough to make it worthwhile. Must not clash with public - * flag value TCL_EXACT. - */ - -#define INDEX_TEMP_TABLE 2 - -/* * Opaque handle used in pipeline routines to encapsulate platform-dependent * state. */ @@ -2608,7 +2586,7 @@ typedef Tcl_ObjCmdProc *TclObjCmdProcType; *---------------------------------------------------------------- */ -typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, size_t *lengthPtr, +typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, int *lengthPtr, Tcl_Encoding *encodingPtr); /* @@ -2620,9 +2598,9 @@ typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, size_t *lengthPtr, */ typedef struct ProcessGlobalValue { - size_t epoch; /* Epoch counter to detect changes in the + int epoch; /* Epoch counter to detect changes in the * master value. */ - size_t numBytes; /* Length of the master string. */ + int numBytes; /* Length of the master string. */ char *value; /* The master string value. */ Tcl_Encoding encoding; /* system encoding when master string was * initialized. */ @@ -2709,6 +2687,7 @@ MODULE_SCOPE const Tcl_ObjType tclListType; MODULE_SCOPE const Tcl_ObjType tclDictType; MODULE_SCOPE const Tcl_ObjType tclProcBodyType; MODULE_SCOPE const Tcl_ObjType tclStringType; +MODULE_SCOPE const Tcl_ObjType tclArraySearchType; MODULE_SCOPE const Tcl_ObjType tclEnsembleCmdType; #ifndef TCL_WIDE_INT_IS_LONG MODULE_SCOPE const Tcl_ObjType tclWideIntType; @@ -2745,6 +2724,7 @@ 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,7 +2925,6 @@ 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); @@ -2962,7 +2941,8 @@ MODULE_SCOPE Tcl_Obj * TclGetBgErrorHandler(Tcl_Interp *interp); MODULE_SCOPE int TclGetChannelFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Channel *chanPtr, int *modePtr, int flags); -MODULE_SCOPE int TclGetCompletionCodeFromObj(Tcl_Interp *interp, +MODULE_SCOPE CmdFrame * TclGetCmdFrameForProcedure(Proc *procPtr); +MODULE_SCOPE int TclGetCompletionCodeFromObj(Tcl_Interp *interp, Tcl_Obj *value, int *code); MODULE_SCOPE int TclGetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, ClientData *clientDataPtr, @@ -2975,9 +2955,6 @@ 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); @@ -3076,7 +3053,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, - size_t *lengthPtr, Tcl_Encoding *encodingPtr); + int *lengthPtr, Tcl_Encoding *encodingPtr); MODULE_SCOPE void TclpInitLock(void); MODULE_SCOPE void TclpInitPlatform(void); MODULE_SCOPE void TclpInitUnlock(void); @@ -3104,8 +3081,6 @@ 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, @@ -3141,20 +3116,11 @@ 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); @@ -3171,7 +3137,6 @@ MODULE_SCOPE int TclTrimLeft(const char *bytes, int numBytes, MODULE_SCOPE int TclTrimRight(const char *bytes, int numBytes, const char *trim, int numTrim); MODULE_SCOPE int TclUtfCasecmp(const char *cs, const char *ct); -MODULE_SCOPE int TclUtfCount(int ch); MODULE_SCOPE Tcl_Obj * TclpNativeToNormalized(ClientData clientData); MODULE_SCOPE Tcl_Obj * TclpFilesystemPathType(Tcl_Obj *pathPtr); MODULE_SCOPE int TclpDlopen(Tcl_Interp *interp, Tcl_Obj *pathPtr, @@ -3231,11 +3196,9 @@ 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[]); @@ -3290,10 +3253,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[]); @@ -3534,6 +3495,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); @@ -3970,7 +3937,7 @@ MODULE_SCOPE int TclCompileAssembleCmd(Tcl_Interp *interp, struct CompileEnv *envPtr); /* - * Functions defined in generic/tclVar.c and currenttly exported only for use + * Functions defined in generic/tclVar.c and currently exported only for use * by the bytecode compiler and engine. Some of these could later be placed in * the public interface. */ @@ -4019,7 +3986,7 @@ MODULE_SCOPE int TclObjCallVarTraces(Interp *iPtr, Var *arrayPtr, MODULE_SCOPE int TclCompareObjKeys(void *keyPtr, Tcl_HashEntry *hPtr); MODULE_SCOPE void TclFreeObjEntry(Tcl_HashEntry *hPtr); -MODULE_SCOPE TCL_HASH_TYPE TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr); +MODULE_SCOPE unsigned TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr); MODULE_SCOPE int TclFullFinalizationRequested(void); @@ -4081,7 +4048,7 @@ typedef const char *TclDTraceStr; TclIncrObjsAllocated(); \ TclAllocObjStorage(objPtr); \ (objPtr)->refCount = 0; \ - (objPtr)->bytes = &tclEmptyString; \ + (objPtr)->bytes = tclEmptyStringRep; \ (objPtr)->length = 0; \ (objPtr)->typePtr = NULL; \ TCL_DTRACE_OBJ_CREATE(objPtr) @@ -4098,8 +4065,8 @@ typedef const char *TclDTraceStr; if (!(objPtr)->typePtr || !(objPtr)->typePtr->freeIntRepProc) { \ TCL_DTRACE_OBJ_FREE(objPtr); \ if ((objPtr)->bytes \ - && ((objPtr)->bytes != &tclEmptyString)) { \ - ckfree((objPtr)->bytes); \ + && ((objPtr)->bytes != tclEmptyStringRep)) { \ + ckfree((char *) (objPtr)->bytes); \ } \ (objPtr)->length = -1; \ TclFreeObjStorage(objPtr); \ @@ -4122,7 +4089,7 @@ typedef const char *TclDTraceStr; (objPtr) = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj)) # define TclFreeObjStorageEx(interp, objPtr) \ - ckfree(objPtr) + ckfree((char *) (objPtr)) #undef USE_THREAD_ALLOC #undef USE_TCLALLOC @@ -4140,7 +4107,6 @@ MODULE_SCOPE void TclFreeAllocCache(void *); MODULE_SCOPE void * TclpGetAllocCache(void); MODULE_SCOPE void TclpSetAllocCache(void *); MODULE_SCOPE void TclpFreeAllocMutex(Tcl_Mutex *mutex); -MODULE_SCOPE void TclpInitAllocCache(void); MODULE_SCOPE void TclpFreeAllocCache(void *); /* @@ -4259,7 +4225,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, #define TclInitStringRep(objPtr, bytePtr, len) \ if ((len) == 0) { \ - (objPtr)->bytes = &tclEmptyString; \ + (objPtr)->bytes = tclEmptyStringRep; \ (objPtr)->length = 0; \ } else { \ (objPtr)->bytes = (char *) ckalloc((unsigned) ((len) + 1)); \ @@ -4281,7 +4247,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 \ @@ -4316,11 +4282,11 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, */ #define TclInvalidateStringRep(objPtr) \ - if ((objPtr)->bytes != NULL) { \ - if ((objPtr)->bytes != &tclEmptyString) { \ - ckfree((objPtr)->bytes); \ + if (objPtr->bytes != NULL) { \ + if (objPtr->bytes != tclEmptyStringRep) { \ + ckfree((char *) objPtr->bytes); \ } \ - (objPtr)->bytes = NULL; \ + objPtr->bytes = NULL; \ } /* @@ -4355,13 +4321,13 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, #define TCL_MAX_TOKENS (int)(UINT_MAX / sizeof(Tcl_Token)) #define TclGrowTokenArray(tokenPtr, used, available, append, staticPtr) \ do { \ - int needed = (used) + (append); \ - if (needed > TCL_MAX_TOKENS) { \ + int _needed = (used) + (append); \ + if (_needed > TCL_MAX_TOKENS) { \ Tcl_Panic("max # of tokens for a Tcl parse (%d) exceeded", \ TCL_MAX_TOKENS); \ } \ - if (needed > (available)) { \ - int allocated = 2 * needed; \ + if (_needed > (available)) { \ + int allocated = 2 * _needed; \ Tcl_Token *oldPtr = (tokenPtr); \ Tcl_Token *newPtr; \ if (oldPtr == (staticPtr)) { \ @@ -4373,7 +4339,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, newPtr = (Tcl_Token *) attemptckrealloc((char *) oldPtr, \ (unsigned int) (allocated * sizeof(Tcl_Token))); \ if (newPtr == NULL) { \ - allocated = needed + (append) + TCL_MIN_TOKEN_GROWTH; \ + allocated = _needed + (append) + TCL_MIN_TOKEN_GROWTH; \ if (allocated > TCL_MAX_TOKENS) { \ allocated = TCL_MAX_TOKENS; \ } \ @@ -4425,14 +4391,14 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, #define TclNumUtfChars(numChars, bytes, numBytes) \ do { \ - int count, i = (numBytes); \ - unsigned char *str = (unsigned char *) (bytes); \ - while (i && (*str < 0xC0)) { i--; str++; } \ - count = (numBytes) - i; \ - if (i) { \ - count += Tcl_NumUtfChars((bytes) + count, i); \ + int _count, _i = (numBytes); \ + unsigned char *_str = (unsigned char *) (bytes); \ + while (_i && (*_str < 0xC0)) { _i--; _str++; } \ + _count = (numBytes) - _i; \ + if (_i) { \ + _count += Tcl_NumUtfChars((bytes) + _count, _i); \ } \ - (numChars) = count; \ + (numChars) = _count; \ } while (0); /* @@ -4450,7 +4416,8 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, *---------------------------------------------------------------- */ -MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr); +#define TclIsPureByteArray(objPtr) \ + (((objPtr)->typePtr==&tclByteArrayType) && ((objPtr)->bytes==NULL)) /* *---------------------------------------------------------------- @@ -4585,12 +4552,13 @@ 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, const char *s, int len); - * MODULE_SCOPE void TclNewLiteralStringObj(Tcl_Obj*objPtr, const char *sLiteral); + * MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, char *s, int len); + * MODULE_SCOPE void TclNewLiteralStringObj(Tcl_Obj*objPtr, char*sLiteral); * *---------------------------------------------------------------- */ @@ -4607,6 +4575,9 @@ 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. @@ -4636,6 +4607,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) @@ -4723,7 +4697,7 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; #define TclCleanupCommandMacro(cmdPtr) \ if ((cmdPtr)->refCount-- <= 1) { \ - ckfree(cmdPtr);\ + ckfree((char *) (cmdPtr));\ } /* @@ -4783,11 +4757,11 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; #ifndef TCL_MEM_DEBUG #define TclSmallAllocEx(interp, nbytes, memPtr) \ do { \ - Tcl_Obj *objPtr; \ + Tcl_Obj *_objPtr; \ TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj)); \ TclIncrObjsAllocated(); \ - TclAllocObjStorageEx((interp), (objPtr)); \ - memPtr = (ClientData) (objPtr); \ + TclAllocObjStorageEx((interp), (_objPtr)); \ + memPtr = (ClientData) (_objPtr); \ } while (0) #define TclSmallFreeEx(interp, memPtr) \ @@ -4799,19 +4773,19 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; #else /* TCL_MEM_DEBUG */ #define TclSmallAllocEx(interp, nbytes, memPtr) \ do { \ - Tcl_Obj *objPtr; \ + Tcl_Obj *_objPtr; \ TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj)); \ - TclNewObj(objPtr); \ - memPtr = (ClientData) objPtr; \ + TclNewObj(_objPtr); \ + memPtr = (ClientData) _objPtr; \ } while (0) #define TclSmallFreeEx(interp, memPtr) \ do { \ - Tcl_Obj *objPtr = (Tcl_Obj *) memPtr; \ + Tcl_Obj *_objPtr = (Tcl_Obj *) memPtr; \ objPtr->bytes = NULL; \ objPtr->typePtr = NULL; \ objPtr->refCount = 1; \ - TclDecrRefCount(objPtr); \ + TclDecrRefCount(_objPtr); \ } while (0) #endif /* TCL_MEM_DEBUG */ @@ -4863,15 +4837,15 @@ typedef struct NRE_callback { #define TclNRAddCallback(interp,postProcPtr,data0,data1,data2,data3) \ do { \ - NRE_callback *callbackPtr; \ - TCLNR_ALLOC((interp), (callbackPtr)); \ - callbackPtr->procPtr = (postProcPtr); \ - callbackPtr->data[0] = (ClientData)(data0); \ - callbackPtr->data[1] = (ClientData)(data1); \ - callbackPtr->data[2] = (ClientData)(data2); \ - callbackPtr->data[3] = (ClientData)(data3); \ - callbackPtr->nextPtr = TOP_CB(interp); \ - TOP_CB(interp) = callbackPtr; \ + NRE_callback *_callbackPtr; \ + TCLNR_ALLOC((interp), (_callbackPtr)); \ + _callbackPtr->procPtr = (postProcPtr); \ + _callbackPtr->data[0] = (ClientData)(data0); \ + _callbackPtr->data[1] = (ClientData)(data1); \ + _callbackPtr->data[2] = (ClientData)(data2); \ + _callbackPtr->data[3] = (ClientData)(data3); \ + _callbackPtr->nextPtr = TOP_CB(interp); \ + TOP_CB(interp) = _callbackPtr; \ } while (0) #if NRE_USE_SMALL_ALLOC @@ -4881,7 +4855,7 @@ typedef struct NRE_callback { #else #define TCLNR_ALLOC(interp, ptr) \ (ptr = ((ClientData) ckalloc(sizeof(NRE_callback)))) -#define TCLNR_FREE(interp, ptr) ckfree(ptr) +#define TCLNR_FREE(interp, ptr) ckfree((char *) (ptr)) #endif #if NRE_ENABLE_ASSERTS diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index dfa5727..f95f999 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -615,7 +615,7 @@ EXTERN char * TclDoubleDigits(double dv, int ndigits, int flags, EXTERN void TclSetSlaveCancelFlags(Tcl_Interp *interp, int flags, int force); /* 251 */ -EXTERN int TclRegisterLiteral(void *envPtr, const char *bytes, +EXTERN int TclRegisterLiteral(void *envPtr, char *bytes, int length, int flags); typedef struct TclIntStubs { @@ -873,7 +873,7 @@ typedef struct TclIntStubs { int (*tclCopyChannel) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, Tcl_WideInt toRead, Tcl_Obj *cmdPtr); /* 248 */ char * (*tclDoubleDigits) (double dv, int ndigits, int flags, int *decpt, int *signum, char **endPtr); /* 249 */ void (*tclSetSlaveCancelFlags) (Tcl_Interp *interp, int flags, int force); /* 250 */ - int (*tclRegisterLiteral) (void *envPtr, const char *bytes, int length, int flags); /* 251 */ + int (*tclRegisterLiteral) (void *envPtr, char *bytes, int length, int flags); /* 251 */ } TclIntStubs; extern const TclIntStubs *tclIntStubsPtr; diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index 494d6f1..ac06787 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(int index, int *regs); +EXTERN int TclWinCPUID(unsigned int index, unsigned 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(int index, int *regs); +EXTERN int TclWinCPUID(unsigned int index, unsigned 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(int index, int *regs); +EXTERN int TclWinCPUID(unsigned int index, unsigned 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) (int index, int *regs); /* 29 */ + int (*tclWinCPUID) (unsigned int index, unsigned 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) (int index, int *regs); /* 29 */ + int (*tclWinCPUID) (unsigned int index, unsigned 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) (int index, int *regs); /* 29 */ + int (*tclWinCPUID) (unsigned int index, unsigned 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 af9f1bf..8a0d653 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -331,24 +331,13 @@ 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) { - goto end; + if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) { + return TCL_ERROR; } } @@ -393,7 +382,7 @@ Tcl_Init( * alternate tclInit command before calling Tcl_Init(). */ - result = Tcl_EvalEx(interp, + return Tcl_Eval(interp, "if {[namespace which -command tclInit] eq \"\"} {\n" " proc tclInit {} {\n" " global tcl_libPath tcl_library env tclDefaultLibrary\n" @@ -421,7 +410,6 @@ 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" @@ -456,11 +444,7 @@ Tcl_Init( " error $msg\n" " }\n" "}\n" -"tclInit", -1, 0); - -end: - *names = (*names)->nextPtr; - return result; +"tclInit"); } /* @@ -2379,7 +2363,7 @@ SlaveCreate( SlaveObjCmd, NRSlaveCmd, slaveInterp, SlaveObjCmdDeleteProc); Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); Tcl_SetHashValue(hPtr, slavePtr); - Tcl_SetVar2(slaveInterp, "tcl_interactive", NULL, "0", TCL_GLOBAL_ONLY); + Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); /* * Inherit the recursion limit. @@ -3206,8 +3190,8 @@ Tcl_MakeSafe( * Assume these functions all work. [Bug 2895741] */ - (void) Tcl_EvalEx(interp, - "namespace eval ::tcl {namespace eval mathfunc {}}", -1, 0); + (void) Tcl_Eval(interp, + "namespace eval ::tcl {namespace eval mathfunc {}}"); (void) Tcl_CreateAlias(interp, "::tcl::mathfunc::min", master, "::tcl::mathfunc::min", 0, NULL); (void) Tcl_CreateAlias(interp, "::tcl::mathfunc::max", master, @@ -4513,7 +4497,7 @@ SlaveCommandLimitCmd( switch ((enum Options) index) { case OPT_CMD: scriptObj = objv[i+1]; - (void) TclGetStringFromObj(scriptObj, &scriptLen); + (void) Tcl_GetStringFromObj(objv[i+1], &scriptLen); break; case OPT_GRAN: granObj = objv[i+1]; @@ -4530,7 +4514,7 @@ SlaveCommandLimitCmd( break; case OPT_VAL: limitObj = objv[i+1]; - (void) TclGetStringFromObj(objv[i+1], &limitLen); + (void) Tcl_GetStringFromObj(objv[i+1], &limitLen); if (limitLen == 0) { break; } @@ -4722,7 +4706,7 @@ SlaveTimeLimitCmd( switch ((enum Options) index) { case OPT_CMD: scriptObj = objv[i+1]; - (void) TclGetStringFromObj(objv[i+1], &scriptLen); + (void) Tcl_GetStringFromObj(objv[i+1], &scriptLen); break; case OPT_GRAN: granObj = objv[i+1]; @@ -4739,7 +4723,7 @@ SlaveTimeLimitCmd( break; case OPT_MILLI: milliObj = objv[i+1]; - (void) TclGetStringFromObj(objv[i+1], &milliLen); + (void) Tcl_GetStringFromObj(objv[i+1], &milliLen); if (milliLen == 0) { break; } @@ -4757,7 +4741,7 @@ SlaveTimeLimitCmd( break; case OPT_SEC: secObj = objv[i+1]; - (void) TclGetStringFromObj(objv[i+1], &secLen); + (void) Tcl_GetStringFromObj(objv[i+1], &secLen); if (secLen == 0) { break; } diff --git a/generic/tclLink.c b/generic/tclLink.c index a39dfcd..7d1e3a8 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -36,10 +36,8 @@ 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; @@ -131,14 +129,6 @@ 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 { @@ -345,14 +335,12 @@ 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; @@ -495,7 +483,6 @@ LinkTraceProc( 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(NULL, valueObj, &valueWide) != TCL_OK && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK) @@ -517,7 +504,6 @@ LinkTraceProc( } LinkedVar(unsigned long) = linkPtr->lastValue.ul = (unsigned long)valueWide; break; -#endif case TCL_LINK_WIDE_UINT: /* @@ -595,7 +581,7 @@ ObjValue( return Tcl_NewDoubleObj(linkPtr->lastValue.d); case TCL_LINK_BOOLEAN: linkPtr->lastValue.i = LinkedVar(int); - return Tcl_NewBooleanObj(linkPtr->lastValue.i); + return Tcl_NewBooleanObj(linkPtr->lastValue.i != 0); case TCL_LINK_CHAR: linkPtr->lastValue.c = LinkedVar(char); return Tcl_NewIntObj(linkPtr->lastValue.c); @@ -611,14 +597,12 @@ 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); @@ -659,16 +643,17 @@ static Tcl_ObjType invalidRealType = { static int SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr) { + int length; const char *str; const char *endPtr; - str = TclGetString(objPtr); - if ((objPtr->length == 1) && (str[0] == '.')){ + str = TclGetStringFromObj(objPtr, &length); + if ((length == 1) && (str[0] == '.')){ objPtr->typePtr = &invalidRealType; objPtr->internalRep.doubleValue = 0.0; return TCL_OK; } - if (TclParseNumber(NULL, objPtr, NULL, str, objPtr->length, &endPtr, + if (TclParseNumber(NULL, objPtr, NULL, str, 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. */ @@ -678,7 +663,7 @@ SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr) { if (*endPtr == 0) { double doubleValue = 0.0; Tcl_GetDoubleFromObj(NULL, objPtr, &doubleValue); - TclFreeIntRep(objPtr); + if (objPtr->typePtr->freeIntRepProc) objPtr->typePtr->freeIntRepProc(objPtr); objPtr->typePtr = &invalidRealType; objPtr->internalRep.doubleValue = doubleValue; return TCL_OK; @@ -696,7 +681,8 @@ SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr) { * (upperand lowercase). See bug [39f6304c2e]. */ int -GetInvalidIntFromObj(Tcl_Obj *objPtr, int *intPtr) +GetInvalidIntFromObj(Tcl_Obj *objPtr, + int *intPtr) { const char *str = TclGetString(objPtr); @@ -730,7 +716,8 @@ GetInvalidWideFromObj(Tcl_Obj *objPtr, Tcl_WideInt *widePtr) * (upper- and lowercase) and sequences like "1e-". See bug [39f6304c2e]. */ int -GetInvalidDoubleFromObj(Tcl_Obj *objPtr, double *doublePtr) +GetInvalidDoubleFromObj(Tcl_Obj *objPtr, + double *doublePtr) { int intValue; diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 11374cc..344d0fd 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 = &tclEmptyString; + objPtr->bytes = tclEmptyStringRep; objPtr->length = 0; } } @@ -465,7 +465,7 @@ Tcl_ListObjGetElements( if (listPtr->typePtr != &tclListType) { int result; - if (listPtr->bytes == &tclEmptyString) { + if (listPtr->bytes == tclEmptyStringRep) { *objcPtr = 0; *objvPtr = NULL; return TCL_OK; @@ -575,7 +575,7 @@ Tcl_ListObjAppendElement( if (listPtr->typePtr != &tclListType) { int result; - if (listPtr->bytes == &tclEmptyString) { + if (listPtr->bytes == tclEmptyStringRep) { Tcl_SetListObj(listPtr, 1, &objPtr); return TCL_OK; } @@ -739,7 +739,7 @@ Tcl_ListObjIndex( if (listPtr->typePtr != &tclListType) { int result; - if (listPtr->bytes == &tclEmptyString) { + if (listPtr->bytes == tclEmptyStringRep) { *objPtrPtr = NULL; return TCL_OK; } @@ -792,7 +792,7 @@ Tcl_ListObjLength( if (listPtr->typePtr != &tclListType) { int result; - if (listPtr->bytes == &tclEmptyString) { + if (listPtr->bytes == tclEmptyStringRep) { *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 == &tclEmptyString) { + if (listPtr->bytes == tclEmptyStringRep) { if (!objc) { return TCL_OK; } @@ -1650,7 +1650,7 @@ TclListObjSetElement( if (listPtr->typePtr != &tclListType) { int result; - if (listPtr->bytes == &tclEmptyString) { + if (listPtr->bytes == tclEmptyStringRep) { 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(listRepPtr); + ckfree((char *) listRepPtr); return TCL_ERROR; } if (elemStart == limit) { @@ -1979,7 +1979,7 @@ UpdateStringOfList( */ if (numElems == 0) { - listPtr->bytes = &tclEmptyString; + listPtr->bytes = tclEmptyStringRep; listPtr->length = 0; return; } diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index 7acc9ad..4ae94a0 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -174,7 +174,7 @@ TclDeleteLiteralTable( Tcl_Obj * TclCreateLiteral( Interp *iPtr, - const char *bytes, /* The start of the string. Note that this is + char *bytes, /* The start of the string. Note that this is * not a NUL-terminated string. */ int length, /* Number of bytes in the string. */ unsigned hash, /* The string's hash. If -1, it will be @@ -229,22 +229,20 @@ TclCreateLiteral( } /* - * The literal is new to the interpreter. + * The literal is new to the interpreter. Add it to the global literal + * table. */ TclNewObj(objPtr); if ((flags & LITERAL_ON_HEAP)) { - objPtr->bytes = (char *) bytes; + objPtr->bytes = bytes; objPtr->length = length; } else { TclInitStringRep(objPtr, bytes, length); } - /* Should the new literal be shared globally? */ - if ((flags & LITERAL_UNSHARED)) { /* - * No, do *not* add it the global literal table * Make clear, that no global value is returned */ if (globalPtrPtr != NULL) { @@ -253,9 +251,6 @@ TclCreateLiteral( return objPtr; } - /* - * Yes, add it to the global literal table. - */ #ifdef TCL_COMPILE_DEBUG if (LookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) { Tcl_Panic("%s: literal \"%.*s\" found globally but shouldn't be", @@ -375,7 +370,7 @@ int TclRegisterLiteral( void *ePtr, /* Points to the CompileEnv in whose object * array an object is found or created. */ - register const char *bytes, /* Points to string for which to find or + register char *bytes, /* Points to string for which to find or * create an object in CompileEnv's object * array. */ int length, /* Number of bytes in the string. If < 0, the @@ -687,7 +682,7 @@ AddLocalLiteralEntry( } if (!found) { - bytes = TclGetStringFromObj(objPtr, &length); + bytes = Tcl_GetStringFromObj(objPtr, &length); Tcl_Panic("%s: literal \"%.*s\" wasn't found locally", "AddLocalLiteralEntry", (length>60? 60 : length), bytes); } @@ -1041,7 +1036,7 @@ TclInvalidateCmdLiteral( * invalidate a cmd literal. */ { Interp *iPtr = (Interp *) interp; - Tcl_Obj *literalObjPtr = TclCreateLiteral(iPtr, name, + Tcl_Obj *literalObjPtr = TclCreateLiteral(iPtr, (char *) name, strlen(name), -1, NULL, nsPtr, 0, NULL); if (literalObjPtr != NULL) { @@ -1163,7 +1158,7 @@ TclVerifyLocalLiteralTable( localPtr=localPtr->nextPtr) { count++; if (localPtr->refCount != -1) { - bytes = TclGetStringFromObj(localPtr->objPtr, &length); + bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length); Tcl_Panic("%s: local literal \"%.*s\" had bad refCount %d", "TclVerifyLocalLiteralTable", (length>60? 60 : length), bytes, localPtr->refCount); @@ -1214,7 +1209,7 @@ TclVerifyGlobalLiteralTable( globalPtr=globalPtr->nextPtr) { count++; if (globalPtr->refCount < 1) { - bytes = TclGetStringFromObj(globalPtr->objPtr, &length); + bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length); Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %d", "TclVerifyGlobalLiteralTable", (length>60? 60 : length), bytes, globalPtr->refCount); diff --git a/generic/tclLoad.c b/generic/tclLoad.c index bcda420..7c70e03 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -998,7 +998,7 @@ Tcl_StaticPackage( } /* - * Package isn't loaded in the current interp yet. Mark it as now being + * Package isn't loade in the current interp yet. Mark it as now being * loaded. */ @@ -1012,10 +1012,10 @@ Tcl_StaticPackage( /* *---------------------------------------------------------------------- * - * TclGetLoadedPackages, TclGetLoadedPackagesEx -- + * TclGetLoadedPackages -- * * This function returns information about all of the files that are - * loaded (either in a particular interpreter, or for all interpreters). + * loaded (either in a particular intepreter, or for all interpreters). * * Results: * The return value is a standard Tcl completion code. If successful, a @@ -1039,27 +1039,16 @@ 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; @@ -1074,38 +1063,16 @@ TclGetLoadedPackagesEx( return TCL_OK; } - 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. */ + target = Tcl_GetSlave(interp, targetName); + if (target == NULL) { + return TCL_ERROR; + } + ipPtr = Tcl_GetAssocData(target, "tclLoad", NULL); resultObj = Tcl_NewObj(); for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { pkgPtr = ipPtr->pkgPtr; diff --git a/generic/tclMain.c b/generic/tclMain.c index f89bd5e..927de7e 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -112,7 +112,7 @@ typedef enum { PROMPT_CONTINUE /* Print prompt for command continuation */ } PromptType; -typedef struct { +typedef struct InteractiveState { Tcl_Channel input; /* The standard input channel from which lines * are read. */ int tty; /* Non-zero means standard input is a @@ -246,7 +246,7 @@ Tcl_SourceRCFile( const char *fileName; Tcl_Channel chan; - fileName = Tcl_GetVar2(interp, "tcl_rcFileName", NULL, TCL_GLOBAL_ONLY); + fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY); if (fileName != NULL) { Tcl_Channel c; const char *fullName; @@ -266,18 +266,14 @@ Tcl_SourceRCFile( c = Tcl_OpenFileChannel(NULL, fullName, "r", 0); if (c != NULL) { - Tcl_Obj *fullNameObj = Tcl_NewStringObj(fullName, -1); - Tcl_Close(NULL, c); - Tcl_IncrRefCount(fullNameObj); - if (Tcl_FSEvalFileEx(interp, fullNameObj, NULL) != TCL_OK) { + if (Tcl_EvalFile(interp, fullName) != TCL_OK) { chan = Tcl_GetStdChannel(TCL_STDERR); if (chan) { Tcl_WriteObj(chan, Tcl_GetObjResult(interp)); Tcl_WriteChars(chan, "\n", 1); } } - Tcl_DecrRefCount(fullNameObj); } } Tcl_DStringFree(&temp); @@ -287,7 +283,7 @@ Tcl_SourceRCFile( /*---------------------------------------------------------------------- * - * Tcl_MainEx -- + * Tcl_Main, Tcl_MainEx -- * * Main program for tclsh and most other Tcl-based applications. * @@ -536,7 +532,7 @@ Tcl_MainEx( * error messages troubles deeper in, so lop it back off. */ - TclGetStringFromObj(is.commandPtr, &length); + Tcl_GetStringFromObj(is.commandPtr, &length); Tcl_SetObjLength(is.commandPtr, --length); code = Tcl_RecordAndEvalObj(interp, is.commandPtr, TCL_EVAL_GLOBAL); @@ -553,7 +549,7 @@ Tcl_MainEx( } else if (is.tty) { resultPtr = Tcl_GetObjResult(interp); Tcl_IncrRefCount(resultPtr); - TclGetStringFromObj(resultPtr, &length); + Tcl_GetStringFromObj(resultPtr, &length); chan = Tcl_GetStdChannel(TCL_STDOUT); if ((length > 0) && chan) { Tcl_WriteObj(chan, resultPtr); @@ -638,6 +634,21 @@ Tcl_MainEx( Tcl_Exit(exitCode); } + +#if (TCL_MAJOR_VERSION == 8) && !defined(UNICODE) +#undef Tcl_Main +extern DLLEXPORT void +Tcl_Main( + int argc, /* Number of arguments. */ + char **argv, /* Array of argument strings. */ + Tcl_AppInitProc *appInitProc) + /* Application-specific initialization + * function to call after most initialization + * but before starting to execute commands. */ +{ + Tcl_MainEx(argc, argv, appInitProc, Tcl_CreateInterp()); +} +#endif /* TCL_MAJOR_VERSION == 8 && !UNICODE */ #ifndef TCL_ASCII_MAIN @@ -797,7 +808,7 @@ StdinProc( goto prompt; } isPtr->prompt = PROMPT_START; - TclGetStringFromObj(commandPtr, &length); + Tcl_GetStringFromObj(commandPtr, &length); Tcl_SetObjLength(commandPtr, --length); /* @@ -828,7 +839,7 @@ StdinProc( chan = Tcl_GetStdChannel(TCL_STDOUT); Tcl_IncrRefCount(resultPtr); - TclGetStringFromObj(resultPtr, &length); + Tcl_GetStringFromObj(resultPtr, &length); if ((length > 0) && (chan != NULL)) { Tcl_WriteObj(chan, resultPtr); Tcl_WriteChars(chan, "\n", 1); diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 1e360d1..a8d351f 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -32,7 +32,7 @@ */ typedef struct ThreadSpecificData { - size_t numNsCreated; /* Count of the number of namespaces created + long 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. */ - size_t refCount; /* Reference count: 1 for each nsName object + int 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,7 +1326,8 @@ void TclNsDecrRefCount( Namespace *nsPtr) { - if ((nsPtr->refCount-- <= 1) && (nsPtr->flags & NS_DEAD)) { + nsPtr->refCount--; + if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) { NamespaceFree(nsPtr); } } @@ -2885,9 +2886,9 @@ GetNamespaceFromObj( resNamePtr = objPtr->internalRep.twoPtrValue.ptr1; nsPtr = resNamePtr->nsPtr; refNsPtr = resNamePtr->refNsPtr; - if (!(nsPtr->flags & NS_DYING) && (interp == nsPtr->interp) - && (!refNsPtr || (refNsPtr == - (Namespace *) TclGetCurrentNamespace(interp)))) { + if (!(nsPtr->flags & NS_DYING) && (interp == nsPtr->interp) && + (!refNsPtr || ((interp == refNsPtr->interp) && + (refNsPtr== (Namespace *) Tcl_GetCurrentNamespace(interp))))){ *nsPtrPtr = (Tcl_Namespace *) nsPtr; return TCL_OK; } @@ -4670,7 +4671,8 @@ FreeNsNameInternalRep( * references, free it up. */ - if (resNamePtr->refCount-- <= 1) { + resNamePtr->refCount--; + if (resNamePtr->refCount == 0) { /* * Decrement the reference count for the cached namespace. If the * namespace is dead, and there are no more references to it, free @@ -4780,7 +4782,7 @@ SetNsNameFromAny( if ((name[0] == ':') && (name[1] == ':')) { resNamePtr->refNsPtr = NULL; } else { - resNamePtr->refNsPtr = (Namespace *) TclGetCurrentNamespace(interp); + resNamePtr->refNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); } resNamePtr->refCount = 1; TclFreeIntRep(objPtr); diff --git a/generic/tclOO.c b/generic/tclOO.c index ef0c987..ec666ee 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -266,7 +266,7 @@ TclOOInit( * to be fully provided. */ - if (Tcl_EvalEx(interp, initScript, -1, 0) != TCL_OK) { + if (Tcl_Eval(interp, initScript) != TCL_OK) { return TCL_ERROR; } @@ -460,7 +460,7 @@ InitFoundation( if (TclOODefineSlots(fPtr) != TCL_OK) { return TCL_ERROR; } - return Tcl_EvalEx(interp, slotScript, -1, 0); + return Tcl_Eval(interp, slotScript); } /* diff --git a/generic/tclOO.h b/generic/tclOO.h index 696908a..46f01fb 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -24,7 +24,7 @@ * win/tclooConfig.sh */ -#define TCLOO_VERSION "1.0.4" +#define TCLOO_VERSION "1.0.5" #define TCLOO_PATCHLEVEL TCLOO_VERSION #include "tcl.h" diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index 8003345..ac0b94d 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -619,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 5b0dfc3..8747ff5 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -525,7 +525,7 @@ TclOOUnknownDefinition( return TCL_ERROR; } - soughtStr = TclGetStringFromObj(objv[1], &soughtLen); + soughtStr = Tcl_GetStringFromObj(objv[1], &soughtLen); if (soughtLen == 0) { goto noMatch; } @@ -585,7 +585,7 @@ FindCommand( Tcl_Namespace *const namespacePtr) { int length; - const char *nameStr, *string = TclGetStringFromObj(stringObj, &length); + const char *nameStr, *string = Tcl_GetStringFromObj(stringObj, &length); register Namespace *const nsPtr = (Namespace *) namespacePtr; FOREACH_HASH_DECLS; Tcl_Command cmd, cmd2; @@ -774,7 +774,7 @@ GenerateErrorInfo( int length; Tcl_Obj *realNameObj = Tcl_ObjectDeleted((Tcl_Object) oPtr) ? savedNameObj : TclOOObjectName(interp, oPtr); - const char *objName = TclGetStringFromObj(realNameObj, &length); + const char *objName = Tcl_GetStringFromObj(realNameObj, &length); int limit = OBJNAME_LENGTH_IN_ERRORINFO_LIMIT; int overflow = (length > limit); @@ -1239,7 +1239,7 @@ TclOODefineConstructorObjCmd( } clsPtr = oPtr->classPtr; - TclGetStringFromObj(objv[2], &bodyLength); + Tcl_GetStringFromObj(objv[2], &bodyLength); if (bodyLength > 0) { /* * Create the method structure. @@ -1358,7 +1358,7 @@ TclOODefineDestructorObjCmd( } clsPtr = oPtr->classPtr; - TclGetStringFromObj(objv[1], &bodyLength); + Tcl_GetStringFromObj(objv[1], &bodyLength); if (bodyLength > 0) { /* * Create the method structure. @@ -2217,7 +2217,7 @@ ClassSuperSet( "attempt to form circular dependency graph", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", NULL); failedAfterAlloc: - ckfree(superclasses); + ckfree((char *) superclasses); return TCL_ERROR; } } @@ -2234,7 +2234,7 @@ ClassSuperSet( FOREACH(superPtr, oPtr->classPtr->superclasses) { TclOORemoveFromSubclasses(oPtr->classPtr, superPtr); } - ckfree(oPtr->classPtr->superclasses.list); + ckfree((char *) 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 = TclGetString(varv[i]); + const char *varName = Tcl_GetString(varv[i]); if (strstr(varName, "::") != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -2349,7 +2349,7 @@ ClassVarsSet( } if (i != varc) { if (varc == 0) { - ckfree(oPtr->classPtr->variables.list); + ckfree((char *) 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 = TclGetString(varv[i]); + const char *varName = Tcl_GetString(varv[i]); if (strstr(varName, "::") != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -2630,7 +2630,7 @@ ObjVarsSet( } if (i != varc) { if (varc == 0) { - ckfree(oPtr->variables.list); + ckfree((char *) 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 ae24dee..b75ffdb 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(ptr); \ + ckfree((char *) (ptr)); \ } \ } while(0) diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 9c49caa..99a8bfc 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -1166,7 +1166,7 @@ MethodErrorHandler( CallContext *contextPtr = ((Interp *) interp)->varFramePtr->clientData; Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr; const char *objectName, *kindName, *methodName = - TclGetStringFromObj(mPtr->namePtr, &nameLen); + Tcl_GetStringFromObj(mPtr->namePtr, &nameLen); Object *declarerPtr; if (mPtr->declaringObjectPtr != NULL) { diff --git a/generic/tclObj.c b/generic/tclObj.c index 7ec259f..a346987 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -49,6 +49,7 @@ Tcl_Mutex tclObjMutex; */ char tclEmptyString = '\0'; +char *tclEmptyStringRep = &tclEmptyString; #if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) /* @@ -344,23 +345,23 @@ typedef struct ResolvedCmdName { * reference (not the namespace that contains * the referenced command). NULL if the name * is fully qualified.*/ - size_t refNsId; /* refNsPtr's unique namespace id. Used to + long 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). */ - size_t refNsCmdEpoch; /* Value of the referencing namespace's + int 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. */ - size_t cmdEpoch; /* Value of the command's cmdEpoch when this + int 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. */ - size_t refCount; /* Reference count: 1 for each cmdName object + int 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 @@ -401,6 +402,7 @@ TclInitObjSubsystem(void) Tcl_RegisterObjType(&tclListType); Tcl_RegisterObjType(&tclDictType); Tcl_RegisterObjType(&tclByteCodeType); + Tcl_RegisterObjType(&tclArraySearchType); Tcl_RegisterObjType(&tclCmdNameType); Tcl_RegisterObjType(&tclRegexpType); Tcl_RegisterObjType(&tclProcBodyType); @@ -1059,7 +1061,7 @@ TclDbInitNewObj( * debugging. */ { objPtr->refCount = 0; - objPtr->bytes = &tclEmptyString; + objPtr->bytes = tclEmptyStringRep; objPtr->length = 0; objPtr->typePtr = NULL; @@ -1809,7 +1811,7 @@ Tcl_DbNewBooleanObj( TclDbNewObj(objPtr, file, line); objPtr->bytes = NULL; - objPtr->internalRep.longValue = (boolValue != 0); + objPtr->internalRep.longValue = (boolValue? 1 : 0); objPtr->typePtr = &tclIntType; return objPtr; } @@ -2003,10 +2005,9 @@ static int ParseBoolean( register Tcl_Obj *objPtr) /* The object to parse/convert. */ { - int newBool; + int i, length, newBool; char lowerCase[6]; - const char *str = TclGetString(objPtr); - size_t i, length = objPtr->length; + const char *str = TclGetStringFromObj(objPtr, &length); if ((length == 0) || (length > 5)) { /* @@ -2058,25 +2059,25 @@ ParseBoolean( /* * Checking the 'y' is redundant, but makes the code clearer. */ - if (strncmp(lowerCase, "yes", length) == 0) { + if (strncmp(lowerCase, "yes", (size_t) length) == 0) { newBool = 1; goto goodBoolean; } return TCL_ERROR; case 'n': - if (strncmp(lowerCase, "no", length) == 0) { + if (strncmp(lowerCase, "no", (size_t) length) == 0) { newBool = 0; goto goodBoolean; } return TCL_ERROR; case 't': - if (strncmp(lowerCase, "true", length) == 0) { + if (strncmp(lowerCase, "true", (size_t) length) == 0) { newBool = 1; goto goodBoolean; } return TCL_ERROR; case 'f': - if (strncmp(lowerCase, "false", length) == 0) { + if (strncmp(lowerCase, "false", (size_t) length) == 0) { newBool = 0; goto goodBoolean; } @@ -2085,10 +2086,10 @@ ParseBoolean( if (length < 2) { return TCL_ERROR; } - if (strncmp(lowerCase, "on", length) == 0) { + if (strncmp(lowerCase, "on", (size_t) length) == 0) { newBool = 1; goto goodBoolean; - } else if (strncmp(lowerCase, "off", length) == 0) { + } else if (strncmp(lowerCase, "off", (size_t) length) == 0) { newBool = 0; goto goodBoolean; } @@ -2425,7 +2426,7 @@ Tcl_NewIntObj( { register Tcl_Obj *objPtr; - TclNewLongObj(objPtr, intValue); + TclNewIntObj(objPtr, intValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ @@ -3394,7 +3395,7 @@ GetBignumFromObj( objPtr->internalRep.twoPtrValue.ptr2 = NULL; objPtr->typePtr = NULL; if (objPtr->bytes == NULL) { - TclInitStringRep(objPtr, &tclEmptyString, 0); + TclInitStringRep(objPtr, tclEmptyStringRep, 0); } } return TCL_OK; @@ -4045,7 +4046,7 @@ TclFreeObjEntry( *---------------------------------------------------------------------- */ -TCL_HASH_TYPE +unsigned int TclHashObjKey( Tcl_HashTable *tablePtr, /* Hash table. */ void *keyPtr) /* Key from which to compute hash value. */ @@ -4095,7 +4096,7 @@ TclHashObjKey( result += (result << 3) + UCHAR(*++string); } } - return (TCL_HASH_TYPE) result; + return result; } /* @@ -4149,10 +4150,11 @@ Tcl_GetCommandFromObj( */ resPtr = objPtr->internalRep.twoPtrValue.ptr1; - if (objPtr->typePtr == &tclCmdNameType) { + if ((objPtr->typePtr == &tclCmdNameType) && (resPtr != NULL)) { register Command *cmdPtr = resPtr->cmdPtr; if ((cmdPtr->cmdEpoch == resPtr->cmdEpoch) + && !(cmdPtr->flags & CMD_IS_DELETED) && (interp == cmdPtr->nsPtr->interp) && !(cmdPtr->nsPtr->flags & NS_DYING)) { register Namespace *refNsPtr = (Namespace *) @@ -4172,7 +4174,7 @@ Tcl_GetCommandFromObj( * had is invalid one way or another. */ - /* See [07d13d99b0a9] why we cannot call SetCmdNameFromAny() directly here. */ + /* See [] why we cannot call SetCmdNameFromAny() directly here. */ if (tclCmdNameType.setFromAnyProc(interp, objPtr) != TCL_OK) { return NULL; } @@ -4200,59 +4202,6 @@ Tcl_GetCommandFromObj( *---------------------------------------------------------------------- */ -static void -SetCmdNameObj( - Tcl_Interp *interp, - Tcl_Obj *objPtr, - Command *cmdPtr, - ResolvedCmdName *resPtr) -{ - Interp *iPtr = (Interp *) interp; - ResolvedCmdName *fillPtr; - const char *name = TclGetString(objPtr); - - if (resPtr) { - fillPtr = resPtr; - } else { - fillPtr = ckalloc(sizeof(ResolvedCmdName)); - fillPtr->refCount = 1; - } - - fillPtr->cmdPtr = cmdPtr; - cmdPtr->refCount++; - fillPtr->cmdEpoch = cmdPtr->cmdEpoch; - - /* NOTE: relying on NULL termination here. */ - if ((name[0] == ':') && (name[1] == ':')) { - /* - * Fully qualified names always resolve to same thing. No need - * to record resolution context information. - */ - - fillPtr->refNsPtr = NULL; - fillPtr->refNsId = 0; /* Will not be read */ - fillPtr->refNsCmdEpoch = 0; /* Will not be read */ - } else { - /* - * Record current state of current namespace as the resolution - * context of this command name lookup. - */ - Namespace *currNsPtr = iPtr->varFramePtr->nsPtr; - - fillPtr->refNsPtr = currNsPtr; - fillPtr->refNsId = currNsPtr->nsId; - fillPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; - } - - if (resPtr == NULL) { - TclFreeIntRep(objPtr); - - objPtr->internalRep.twoPtrValue.ptr1 = fillPtr; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; - objPtr->typePtr = &tclCmdNameType; - } -} - void TclSetCmdNameObj( Tcl_Interp *interp, /* Points to interpreter containing command @@ -4262,7 +4211,10 @@ TclSetCmdNameObj( Command *cmdPtr) /* Points to Command structure that the * CmdName object should refer to. */ { + Interp *iPtr = (Interp *) interp; register ResolvedCmdName *resPtr; + register Namespace *currNsPtr; + const char *name; if (objPtr->typePtr == &tclCmdNameType) { resPtr = objPtr->internalRep.twoPtrValue.ptr1; @@ -4271,7 +4223,36 @@ TclSetCmdNameObj( } } - SetCmdNameObj(interp, objPtr, cmdPtr, NULL); + cmdPtr->refCount++; + resPtr = ckalloc(sizeof(ResolvedCmdName)); + resPtr->cmdPtr = cmdPtr; + resPtr->cmdEpoch = cmdPtr->cmdEpoch; + resPtr->refCount = 1; + + name = TclGetString(objPtr); + if ((*name++ == ':') && (*name == ':')) { + /* + * The name is fully qualified: set the referring namespace to + * NULL. + */ + + resPtr->refNsPtr = NULL; + } else { + /* + * Get the current namespace. + */ + + currNsPtr = iPtr->varFramePtr->nsPtr; + + resPtr->refNsPtr = currNsPtr; + resPtr->refNsId = currNsPtr->nsId; + resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; + } + + TclFreeIntRep(objPtr); + objPtr->internalRep.twoPtrValue.ptr1 = resPtr; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; + objPtr->typePtr = &tclCmdNameType; } /* @@ -4302,12 +4283,13 @@ FreeCmdNameInternalRep( { register ResolvedCmdName *resPtr = objPtr->internalRep.twoPtrValue.ptr1; + if (resPtr != NULL) { /* * Decrement the reference count of the ResolvedCmdName structure. If * 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 @@ -4319,6 +4301,7 @@ FreeCmdNameInternalRep( TclCleanupCommandMacro(cmdPtr); ckfree(resPtr); } + } objPtr->typePtr = NULL; } @@ -4351,7 +4334,9 @@ DupCmdNameInternalRep( copyPtr->internalRep.twoPtrValue.ptr1 = resPtr; copyPtr->internalRep.twoPtrValue.ptr2 = NULL; + if (resPtr != NULL) { resPtr->refCount++; + } copyPtr->typePtr = &tclCmdNameType; } @@ -4381,8 +4366,10 @@ SetCmdNameFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ register Tcl_Obj *objPtr) /* The object to convert. */ { + Interp *iPtr = (Interp *) interp; const char *name; register Command *cmdPtr; + Namespace *currNsPtr; register ResolvedCmdName *resPtr; if (interp == NULL) { @@ -4402,31 +4389,59 @@ SetCmdNameFromAny( Tcl_FindCommand(interp, name, /*ns*/ NULL, /*flags*/ 0); /* - * Stop shimmering and caching nothing when we found nothing. Just - * report the failure to find the command as an error. + * Free the old internalRep before setting the new one. Do this after + * getting the string rep to allow the conversion code (in particular, + * Tcl_GetStringFromObj) to use that old internalRep. */ - if (cmdPtr == NULL) { - return TCL_ERROR; - } + if (cmdPtr) { + cmdPtr->refCount++; + resPtr = objPtr->internalRep.twoPtrValue.ptr1; + if ((objPtr->typePtr == &tclCmdNameType) + && resPtr && (resPtr->refCount == 1)) { + /* + * Reuse the old ResolvedCmdName struct instead of freeing it + */ - resPtr = objPtr->internalRep.twoPtrValue.ptr1; - if ((objPtr->typePtr == &tclCmdNameType) && (resPtr->refCount == 1)) { - /* - * Re-use existing ResolvedCmdName struct when possible. - * Cleanup the old fields that need it. - */ + Command *oldCmdPtr = resPtr->cmdPtr; - Command *oldCmdPtr = resPtr->cmdPtr; + if (--oldCmdPtr->refCount == 0) { + TclCleanupCommandMacro(oldCmdPtr); + } + } else { + TclFreeIntRep(objPtr); + resPtr = ckalloc(sizeof(ResolvedCmdName)); + resPtr->refCount = 1; + objPtr->internalRep.twoPtrValue.ptr1 = resPtr; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; + objPtr->typePtr = &tclCmdNameType; + } + resPtr->cmdPtr = cmdPtr; + resPtr->cmdEpoch = cmdPtr->cmdEpoch; + if ((*name++ == ':') && (*name == ':')) { + /* + * The name is fully qualified: set the referring namespace to + * NULL. + */ - if (oldCmdPtr->refCount-- <= 1) { - TclCleanupCommandMacro(oldCmdPtr); + resPtr->refNsPtr = NULL; + } else { + /* + * Get the current namespace. + */ + + currNsPtr = iPtr->varFramePtr->nsPtr; + + resPtr->refNsPtr = currNsPtr; + resPtr->refNsId = currNsPtr->nsId; + resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; } } else { - resPtr = NULL; + TclFreeIntRep(objPtr); + objPtr->internalRep.twoPtrValue.ptr1 = NULL; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; + objPtr->typePtr = &tclCmdNameType; } - - SetCmdNameObj(interp, objPtr, cmdPtr, resPtr); return TCL_OK; } diff --git a/generic/tclOptimize.c b/generic/tclOptimize.c index 8267a7d..827d89d 100644 --- a/generic/tclOptimize.c +++ b/generic/tclOptimize.c @@ -233,7 +233,7 @@ ConvertZeroEffectToNOP( TclGetUInt1AtPtr(currentInstPtr + 1)); int numBytes; - (void) TclGetStringFromObj(litPtr, &numBytes); + (void) Tcl_GetStringFromObj(litPtr, &numBytes); if (numBytes == 0) { blank = size + InstLength(nextInst); } @@ -248,7 +248,7 @@ ConvertZeroEffectToNOP( TclGetUInt4AtPtr(currentInstPtr + 1)); int numBytes; - (void) TclGetStringFromObj(litPtr, &numBytes); + (void) Tcl_GetStringFromObj(litPtr, &numBytes); if (numBytes == 0) { blank = size + InstLength(nextInst); } diff --git a/generic/tclParse.c b/generic/tclParse.c index 9b801a3..ce87fb0 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -167,8 +167,6 @@ static int ParseTokens(const char *src, int numBytes, int mask, int flags, Tcl_Parse *parsePtr); static int ParseWhiteSpace(const char *src, int numBytes, int *incompletePtr, char *typePtr); -static int ParseAllWhiteSpace(const char *src, int numBytes, - int *incompletePtr); /* *---------------------------------------------------------------------- @@ -300,43 +298,9 @@ Tcl_ParseCommand( */ parsePtr->commandStart = src; - type = CHAR_TYPE(*src); - scanned = 1; /* Can't have missing whitepsace before first word. */ while (1) { int expandWord = 0; - /* Are we at command termination? */ - - if ((numBytes == 0) || (type & terminators) != 0) { - parsePtr->term = src; - parsePtr->commandSize = src + (numBytes != 0) - - parsePtr->commandStart; - return TCL_OK; - } - - /* Are we missing white space after previous word? */ - - if (scanned == 0) { - if (src[-1] == '"') { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "extra characters after close-quote", -1)); - } - parsePtr->errorType = TCL_PARSE_QUOTE_EXTRA; - } else { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "extra characters after close-brace", -1)); - } - parsePtr->errorType = TCL_PARSE_BRACE_EXTRA; - } - parsePtr->term = src; - error: - Tcl_FreeParse(parsePtr); - parsePtr->commandSize = parsePtr->end - parsePtr->commandStart; - return TCL_ERROR; - } - /* * Create the token for the word. */ @@ -346,6 +310,23 @@ Tcl_ParseCommand( tokenPtr = &parsePtr->tokenPtr[wordIndex]; tokenPtr->type = TCL_TOKEN_WORD; + /* + * Skip white space before the word. Also skip a backslash-newline + * sequence: it should be treated just like white space. + */ + + scanned = ParseWhiteSpace(src,numBytes, &parsePtr->incomplete, &type); + src += scanned; + numBytes -= scanned; + if (numBytes == 0) { + parsePtr->term = src; + break; + } + if ((type & terminators) != 0) { + parsePtr->term = src; + src++; + break; + } tokenPtr->start = src; parsePtr->numTokens++; parsePtr->numWords++; @@ -565,12 +546,52 @@ Tcl_ParseCommand( tokenPtr->type = TCL_TOKEN_SIMPLE_WORD; } - /* Parse the whitespace between words. */ + /* + * Do two additional checks: (a) make sure we're really at the end of + * a word (there might have been garbage left after a quoted or braced + * word), and (b) check for the end of the command. + */ scanned = ParseWhiteSpace(src,numBytes, &parsePtr->incomplete, &type); - src += scanned; - numBytes -= scanned; + if (scanned) { + src += scanned; + numBytes -= scanned; + continue; + } + + if (numBytes == 0) { + parsePtr->term = src; + break; + } + if ((type & terminators) != 0) { + parsePtr->term = src; + src++; + break; + } + if (src[-1] == '"') { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "extra characters after close-quote", -1)); + } + parsePtr->errorType = TCL_PARSE_QUOTE_EXTRA; + } else { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "extra characters after close-brace", -1)); + } + parsePtr->errorType = TCL_PARSE_BRACE_EXTRA; + } + parsePtr->term = src; + goto error; } + + parsePtr->commandSize = src - parsePtr->commandStart; + return TCL_OK; + + error: + Tcl_FreeParse(parsePtr); + parsePtr->commandSize = parsePtr->end - parsePtr->commandStart; + return TCL_ERROR; } /* @@ -712,32 +733,23 @@ ParseWhiteSpace( *---------------------------------------------------------------------- */ -static int -ParseAllWhiteSpace( +int +TclParseAllWhiteSpace( const char *src, /* First character to parse. */ - int numBytes, /* Max number of byes to scan */ - int *incompletePtr) /* Set true if parse is incomplete. */ + int numBytes) /* Max number of byes to scan */ { + int dummy; char type; const char *p = src; do { - int scanned = ParseWhiteSpace(p, numBytes, incompletePtr, &type); + int scanned = ParseWhiteSpace(p, numBytes, &dummy, &type); p += scanned; numBytes -= scanned; } while (numBytes && (*p == '\n') && (p++, --numBytes)); return (p-src); } - -int -TclParseAllWhiteSpace( - const char *src, /* First character to parse. */ - int numBytes) /* Max number of byes to scan */ -{ - int dummy; - return ParseAllWhiteSpace(src, numBytes, &dummy); -} /* *---------------------------------------------------------------------- @@ -1009,12 +1021,17 @@ ParseComment( * command. */ { register const char *p = src; - int incomplete = parsePtr->incomplete; while (numBytes) { - int scanned = ParseAllWhiteSpace(p, numBytes, &incomplete); - p += scanned; - numBytes -= scanned; + char type; + int scanned; + + do { + scanned = ParseWhiteSpace(p, numBytes, + &parsePtr->incomplete, &type); + p += scanned; + numBytes -= scanned; + } while (numBytes && (*p == '\n') && (p++,numBytes--)); if ((numBytes == 0) || (*p != '#')) { break; @@ -1023,28 +1040,35 @@ ParseComment( parsePtr->commentStart = p; } - p++; - numBytes--; while (numBytes) { - if (*p == '\n') { - p++; - numBytes--; - break; - } if (*p == '\\') { + scanned = ParseWhiteSpace(p, numBytes, &parsePtr->incomplete, + &type); + if (scanned) { + p += scanned; + numBytes -= scanned; + } else { + /* + * General backslash substitution in comments isn't part + * of the formal spec, but test parse-15.47 and history + * indicate that it has been the de facto rule. Don't + * change it now. + */ + + TclParseBackslash(p, numBytes, &scanned, NULL); + p += scanned; + numBytes -= scanned; + } + } else { p++; numBytes--; - if (numBytes == 0) { + if (p[-1] == '\n') { break; } } - incomplete = (*p == '\n'); - p++; - numBytes--; } parsePtr->commentSize = p - parsePtr->commentStart; } - parsePtr->incomplete = incomplete; return (p - src); } @@ -1170,7 +1194,7 @@ ParseTokens( 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; @@ -2223,7 +2247,7 @@ TclSubstTokens( if (result == 0) { clPos = 0; } else { - TclGetStringFromObj(result, &clPos); + Tcl_GetStringFromObj(result, &clPos); } if (numCL >= maxNumCL) { @@ -2499,7 +2523,7 @@ TclObjCommandComplete( * check. */ { int length; - const char *script = TclGetStringFromObj(objPtr, &length); + const char *script = Tcl_GetStringFromObj(objPtr, &length); return CommandComplete(script, length); } diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 0053041..31ed68e 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -231,7 +231,7 @@ TclFSNormalizeAbsolutePath( retVal = Tcl_NewStringObj(path, dirSep - path); Tcl_IncrRefCount(retVal); } - TclGetStringFromObj(retVal, &curLen); + Tcl_GetStringFromObj(retVal, &curLen); if (curLen == 0) { Tcl_AppendToObj(retVal, dirSep, 1); } @@ -257,7 +257,7 @@ TclFSNormalizeAbsolutePath( retVal = Tcl_NewStringObj(path, dirSep - path); Tcl_IncrRefCount(retVal); } - TclGetStringFromObj(retVal, &curLen); + Tcl_GetStringFromObj(retVal, &curLen); if (curLen == 0) { Tcl_AppendToObj(retVal, dirSep, 1); } @@ -288,7 +288,7 @@ TclFSNormalizeAbsolutePath( */ const char *path = - TclGetStringFromObj(retVal, &curLen); + Tcl_GetStringFromObj(retVal, &curLen); while (--curLen >= 0) { if (IsSeparatorOrNull(path[curLen])) { @@ -303,7 +303,7 @@ TclFSNormalizeAbsolutePath( Tcl_SetObjLength(retVal, curLen+1); Tcl_AppendObjToObj(retVal, linkObj); TclDecrRefCount(linkObj); - linkStr = TclGetStringFromObj(retVal, &curLen); + linkStr = Tcl_GetStringFromObj(retVal, &curLen); } else { /* * Absolute link. @@ -316,7 +316,7 @@ TclFSNormalizeAbsolutePath( } else { retVal = linkObj; } - linkStr = TclGetStringFromObj(retVal, &curLen); + linkStr = Tcl_GetStringFromObj(retVal, &curLen); /* * Convert to forward-slashes on windows. @@ -333,7 +333,7 @@ TclFSNormalizeAbsolutePath( } } } else { - linkStr = TclGetStringFromObj(retVal, &curLen); + linkStr = Tcl_GetStringFromObj(retVal, &curLen); } /* @@ -404,7 +404,7 @@ TclFSNormalizeAbsolutePath( if (tclPlatform == TCL_PLATFORM_WINDOWS) { int len; - const char *path = TclGetStringFromObj(retVal, &len); + const char *path = Tcl_GetStringFromObj(retVal, &len); if (len == 2 && path[0] != 0 && path[1] == ':') { if (Tcl_IsShared(retVal)) { @@ -579,7 +579,7 @@ TclPathPart( int numBytes; const char *rest = - TclGetStringFromObj(fsPathPtr->normPathPtr, &numBytes); + Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &numBytes); if (strchr(rest, '/') != NULL) { goto standardPath; @@ -617,7 +617,7 @@ TclPathPart( int numBytes; const char *rest = - TclGetStringFromObj(fsPathPtr->normPathPtr, &numBytes); + Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &numBytes); if (strchr(rest, '/') != NULL) { goto standardPath; @@ -646,7 +646,7 @@ TclPathPart( const char *fileName, *extension; int length; - fileName = TclGetStringFromObj(fsPathPtr->normPathPtr, + fileName = Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &length); extension = TclGetExtension(fileName); if (extension == NULL) { @@ -698,7 +698,7 @@ TclPathPart( int length; const char *fileName, *extension; - fileName = TclGetStringFromObj(pathPtr, &length); + fileName = Tcl_GetStringFromObj(pathPtr, &length); extension = TclGetExtension(fileName); if (extension == NULL) { Tcl_IncrRefCount(pathPtr); @@ -885,7 +885,7 @@ TclJoinPath( const char *str; int len; - str = TclGetStringFromObj(tailObj, &len); + str = Tcl_GetStringFromObj(tailObj, &len); if (len == 0) { /* * This happens if we try to handle the root volume '/'. @@ -921,7 +921,17 @@ TclJoinPath( if (res != NULL) { TclDecrRefCount(res); } - return TclNewFSPathObj(elt, str, len); + + if (PATHFLAGS(elt)) { + return TclNewFSPathObj(elt, str, len); + } + if (TCL_PATH_ABSOLUTE != Tcl_FSGetPathType(elt)) { + return TclNewFSPathObj(elt, str, len); + } + (void) Tcl_FSGetNormalizedPath(NULL, elt); + if (elt == PATHOBJ(elt)->normPathPtr) { + return TclNewFSPathObj(elt, str, len); + } } } @@ -947,7 +957,8 @@ TclJoinPath( } } } - strElt = TclGetStringFromObj(elt, &strEltLen); + strElt = Tcl_GetStringFromObj(elt, &strEltLen); + driveNameLength = 0; type = TclGetPathType(elt, &fsPtr, &driveNameLength, &driveName); if (type != TCL_PATH_RELATIVE) { /* @@ -1003,6 +1014,12 @@ TclJoinPath( } } ptr = strElt; + /* [Bug f34cf83dd0] */ + if (driveNameLength > 0) { + if (ptr[0] == '/' && ptr[-1] == '/') { + goto noQuickReturn; + } + } while (*ptr != '\0') { if (*ptr == '/' && (ptr[1] == '/' || ptr[1] == '\0')) { /* @@ -1034,9 +1051,9 @@ TclJoinPath( noQuickReturn: if (res == NULL) { res = Tcl_NewObj(); - ptr = TclGetStringFromObj(res, &length); + ptr = Tcl_GetStringFromObj(res, &length); } else { - ptr = TclGetStringFromObj(res, &length); + ptr = Tcl_GetStringFromObj(res, &length); } /* @@ -1081,7 +1098,7 @@ TclJoinPath( if (length > 0 && ptr[length -1] != '/') { Tcl_AppendToObj(res, &separator, 1); - TclGetStringFromObj(res, &length); + Tcl_GetStringFromObj(res, &length); } Tcl_SetObjLength(res, length + (int) strlen(strElt)); @@ -1376,7 +1393,7 @@ AppendPath( * intrep produce the same results; that is, bugward compatibility. If * we need to fix that bug here, it needs fixing in TclJoinPath() too. */ - bytes = TclGetStringFromObj(tail, &numBytes); + bytes = Tcl_GetStringFromObj(tail, &numBytes); if (numBytes == 0) { Tcl_AppendToObj(copy, "/", 1); } else { @@ -1435,7 +1452,7 @@ TclFSMakePathRelative( * too little below, leading to wrong answers returned by glob. */ - tempStr = TclGetStringFromObj(cwdPtr, &cwdLen); + tempStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen); /* * Should we perhaps use 'Tcl_FSPathSeparator'? But then what about the @@ -1455,7 +1472,7 @@ TclFSMakePathRelative( } break; } - tempStr = TclGetStringFromObj(pathPtr, &len); + tempStr = Tcl_GetStringFromObj(pathPtr, &len); return Tcl_NewStringObj(tempStr + cwdLen, len - cwdLen); } @@ -1719,7 +1736,7 @@ Tcl_FSGetTranslatedStringPath( if (transPtr != NULL) { int len; - const char *orig = TclGetStringFromObj(transPtr, &len); + const char *orig = Tcl_GetStringFromObj(transPtr, &len); char *result = ckalloc(len+1); memcpy(result, orig, (size_t) len+1); @@ -1780,7 +1797,7 @@ Tcl_FSGetNormalizedPath( UpdateStringOfFsPath(pathPtr); } - TclGetStringFromObj(fsPathPtr->normPathPtr, &tailLen); + Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &tailLen); if (tailLen) { copy = AppendPath(dir, fsPathPtr->normPathPtr); } else { @@ -1793,7 +1810,7 @@ Tcl_FSGetNormalizedPath( * We now own a reference on both 'dir' and 'copy' */ - (void) TclGetStringFromObj(dir, &cwdLen); + (void) Tcl_GetStringFromObj(dir, &cwdLen); cwdLen += (Tcl_GetString(copy)[cwdLen] == '/'); /* Normalize the combined string. */ @@ -1887,7 +1904,7 @@ Tcl_FSGetNormalizedPath( copy = AppendPath(fsPathPtr->cwdPtr, pathPtr); - (void) TclGetStringFromObj(fsPathPtr->cwdPtr, &cwdLen); + (void) Tcl_GetStringFromObj(fsPathPtr->cwdPtr, &cwdLen); cwdLen += (Tcl_GetString(copy)[cwdLen] == '/'); /* @@ -2337,7 +2354,7 @@ SetFsPathFromAny( * cmdAH.test exercise most of the code). */ - name = TclGetStringFromObj(pathPtr, &len); + name = Tcl_GetStringFromObj(pathPtr, &len); /* * Handle tilde substitutions, if needed. @@ -2606,9 +2623,9 @@ UpdateStringOfFsPath( copy = AppendPath(fsPathPtr->cwdPtr, fsPathPtr->normPathPtr); - pathPtr->bytes = TclGetStringFromObj(copy, &cwdLen); + pathPtr->bytes = Tcl_GetStringFromObj(copy, &cwdLen); pathPtr->length = cwdLen; - copy->bytes = &tclEmptyString; + copy->bytes = tclEmptyStringRep; copy->length = 0; TclDecrRefCount(copy); } @@ -2667,7 +2684,7 @@ TclNativePathInFilesystem( int len; - (void) TclGetStringFromObj(pathPtr, &len); + (void) Tcl_GetStringFromObj(pathPtr, &len); if (len == 0) { /* * We reject the empty path "". diff --git a/generic/tclPipe.c b/generic/tclPipe.c index d6cd188..83fb818 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, /* Interpreter to use for error reporting. */ + Tcl_Interp *interp, /* Intepreter 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 9ad3cb7..f6e8b20 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -17,10 +17,6 @@ #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 @@ -32,22 +28,10 @@ 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 @@ -97,7 +81,7 @@ static const char * PkgRequireCore(Tcl_Interp *interp, const char *name, ((v) = ckalloc(len), memcpy((v),(s),(len))) #define DupString(v,s) \ do { \ - size_t local__len = strlen(s) + 1; \ + unsigned local__len = (unsigned) (strlen(s) + 1); \ DupBlock((v),(s),local__len); \ } while (0) @@ -205,62 +189,6 @@ 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( @@ -561,26 +489,12 @@ PkgRequireCore( */ char *versionToProvide = bestPtr->version; - PkgFiles *pkgFiles; - PkgName *pkgName; script = bestPtr->script; pkgPtr->clientData = versionToProvide; - Tcl_Preserve(versionToProvide); Tcl_Preserve(script); - pkgFiles = TclInitPkgFiles(interp); - /* Push "ifneeded" package name in "tclPkgFiles" assocdata. */ - pkgName = ckalloc(sizeof(PkgName) + strlen(name)); - pkgName->nextPtr = pkgFiles->names; - strcpy(pkgName->name, name); - pkgFiles->names = pkgName; - if (bestPtr->pkgIndex) { - TclPkgFileSeen(interp, bestPtr->pkgIndex); - } + Tcl_Preserve(versionToProvide); 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); @@ -850,14 +764,14 @@ Tcl_PackageObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { static const char *const pkgOptions[] = { - "files", "forget", "ifneeded", "names", "prefer", - "present", "provide", "require", "unknown", "vcompare", - "versions", "vsatisfies", NULL + "forget", "ifneeded", "names", "prefer", "present", + "provide", "require", "unknown", "vcompare", "versions", + "vsatisfies", NULL }; enum pkgOptions { - PKG_FILES, PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, PKG_PREFER, - PKG_PRESENT, PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE, - PKG_VERSIONS, PKG_VSATISFIES + 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; @@ -880,37 +794,11 @@ 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; @@ -925,9 +813,6 @@ 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); @@ -957,7 +842,7 @@ Tcl_PackageObjCmd( } else { pkgPtr = FindPackage(interp, argv2); } - argv3 = TclGetStringFromObj(objv[3], &length); + argv3 = Tcl_GetStringFromObj(objv[3], &length); for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL; prevPtr = availPtr, availPtr = availPtr->nextPtr) { @@ -978,9 +863,6 @@ Tcl_PackageObjCmd( return TCL_OK; } Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); - if (availPtr->pkgIndex) { - Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC); - } break; } } @@ -991,7 +873,6 @@ Tcl_PackageObjCmd( } if (availPtr == NULL) { availPtr = ckalloc(sizeof(PkgAvail)); - availPtr->pkgIndex = 0; DupBlock(availPtr->version, argv3, (unsigned) length + 1); if (prevPtr == NULL) { @@ -1002,11 +883,7 @@ 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); + argv4 = Tcl_GetStringFromObj(objv[4], &length); DupBlock(availPtr->script, argv4, (unsigned) length + 1); break; } @@ -1157,7 +1034,7 @@ Tcl_PackageObjCmd( if (iPtr->packageUnknown != NULL) { ckfree(iPtr->packageUnknown); } - argv2 = TclGetStringFromObj(objv[2], &length); + argv2 = Tcl_GetStringFromObj(objv[2], &length); if (argv2[0] == 0) { iPtr->packageUnknown = NULL; } else { @@ -1343,7 +1220,7 @@ FindPackage( void TclFreePackageInfo( - Interp *iPtr) /* Interpreter that is being deleted. */ + Interp *iPtr) /* Interpereter that is being deleted. */ { Package *pkgPtr; Tcl_HashSearch search; @@ -1361,9 +1238,6 @@ 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); @@ -1808,7 +1682,7 @@ AddRequirementsToResult( int i, length; for (i = 0; i < reqc; i++) { - const char *v = TclGetStringFromObj(reqv[i], &length); + const char *v = Tcl_GetStringFromObj(reqv[i], &length); if ((length & 0x1) && (v[length/2] == '-') && (strncmp(v, v+((length+1)/2), length/2) == 0)) { @@ -2021,7 +1895,7 @@ Tcl_PkgInitStubsCheck( { const char *actualVersion = Tcl_PkgPresent(interp, "Tcl", version, 0); - if ((exact&1) && actualVersion) { + if (exact && actualVersion) { const char *p = version; int count = 0; diff --git a/generic/tclPreserve.c b/generic/tclPreserve.c index 2d0e15c..cca13e8 100644 --- a/generic/tclPreserve.c +++ b/generic/tclPreserve.c @@ -22,7 +22,7 @@ typedef struct { ClientData clientData; /* Address of preserved block. */ - size_t refCount; /* Number of Tcl_Preserve calls in effect for + int 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 - size_t refCount; /* Number of TclHandlePreserve() calls in + int refCount; /* Number of TclHandlePreserve() calls in * effect on this handle. */ } HandleStruct; @@ -195,7 +195,7 @@ Tcl_Release( continue; } - if (refPtr->refCount-- > 1) { + if (--refPtr->refCount != 0) { Tcl_MutexUnlock(&preserveMutex); return; } @@ -459,7 +459,7 @@ TclHandleRelease( handlePtr, handlePtr->ptr2, handlePtr->ptr); } #endif - if ((handlePtr->refCount-- <= 1) && (handlePtr->ptr == NULL)) { + if ((--handlePtr->refCount == 0) && (handlePtr->ptr == NULL)) { ckfree(handlePtr); } } diff --git a/generic/tclProc.c b/generic/tclProc.c index 373192c..5c68e17 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -343,7 +343,7 @@ Tcl_ProcObjCmd( * The argument list is just "args"; check the body */ - procBody = TclGetStringFromObj(objv[3], &numBytes); + procBody = Tcl_GetStringFromObj(objv[3], &numBytes); if (TclParseAllWhiteSpace(procBody, numBytes) < numBytes) { goto done; } @@ -500,8 +500,7 @@ TclCreateProc( } for (i = 0; i < numArgs; i++) { - int fieldCount, nameLength; - size_t valueLength; + int fieldCount, nameLength, valueLength; const char **fieldValues; /* @@ -603,11 +602,12 @@ TclCreateProc( */ if (localPtr->defValuePtr != NULL) { - const char *tmpPtr = TclGetString(localPtr->defValuePtr); - size_t tmpLength = localPtr->defValuePtr->length; + int tmpLength; + const char *tmpPtr = TclGetStringFromObj(localPtr->defValuePtr, + &tmpLength); if ((valueLength != tmpLength) || - strncmp(fieldValues[1], tmpPtr, tmpLength)) { + strncmp(fieldValues[1], tmpPtr, (size_t) tmpLength)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "procedure \"%s\": formal parameter \"%s\" has " "default value inconsistent with precompiled body", @@ -2083,7 +2083,7 @@ MakeProcError( * messages and trace information. */ { int overflow, limit = 60, nameLen; - const char *procName = TclGetStringFromObj(procNameObj, &nameLen); + const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen); overflow = (nameLen > limit); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( @@ -2654,6 +2654,30 @@ TclNRApplyObjCmd( procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1; } +#define JOE_EXTENSION 0 +/* + * Note: this code is NOT FUNCTIONAL due to the NR implementation; DO NOT + * ENABLE! Leaving here as reminder to (a) TIP the suggestion, and (b) adapt + * the code. (MS) + */ + +#if JOE_EXTENSION + else { + /* + * Joe English's suggestion to allow cmdNames to function as lambdas. + */ + + Tcl_Obj *elemPtr; + int numElem; + + if ((lambdaPtr->typePtr == &tclCmdNameType) || + (TclListObjGetElements(interp, lambdaPtr, &numElem, + &elemPtr) == TCL_OK && numElem == 1)) { + return Tcl_EvalObjv(interp, objc-1, objv+1, 0); + } + } +#endif + if ((procPtr == NULL) || (procPtr->iPtr != iPtr)) { result = SetLambdaFromAny(interp, lambdaPtr); if (result != TCL_OK) { @@ -2740,7 +2764,7 @@ MakeLambdaError( * messages and trace information. */ { int overflow, limit = 60, nameLen; - const char *procName = TclGetStringFromObj(procNameObj, &nameLen); + const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen); overflow = (nameLen > limit); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( @@ -2750,6 +2774,41 @@ MakeLambdaError( } /* + *---------------------------------------------------------------------- + * + * TclGetCmdFrameForProcedure -- + * + * How to get the CmdFrame information for a procedure. + * + * Results: + * A pointer to the CmdFrame (only guaranteed to be valid until the next + * Tcl command is processed or the interpreter's state is otherwise + * modified) or a NULL if the information is not available. + * + * Side effects: + * none. + * + *---------------------------------------------------------------------- + */ + +CmdFrame * +TclGetCmdFrameForProcedure( + Proc *procPtr) /* The procedure whose cmd-frame is to be + * looked up. */ +{ + Tcl_HashEntry *hePtr; + + if (procPtr == NULL || procPtr->iPtr == NULL) { + return NULL; + } + hePtr = Tcl_FindHashEntry(procPtr->iPtr->linePBodyPtr, procPtr); + if (hePtr == NULL) { + return NULL; + } + return (CmdFrame *) Tcl_GetHashValue(hePtr); +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c index eb23f72..ea25d4b 100644 --- a/generic/tclRegexp.c +++ b/generic/tclRegexp.c @@ -502,16 +502,9 @@ Tcl_RegExpMatchObj( { Tcl_RegExp re; - /* - * 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))) { + re = Tcl_GetRegExpFromObj(interp, patternObj, + TCL_REG_ADVANCED | TCL_REG_NOSUB); + if (re == NULL) { return -1; } return Tcl_RegExpExecObj(interp, re, textObj, 0 /* offset */, diff --git a/generic/tclRegexp.h b/generic/tclRegexp.h index eac0aaa..3b2433e 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). */ - unsigned int refCount; /* Count of number of references to this + int refCount; /* Count of number of references to this * compiled regexp. */ } TclRegexp; diff --git a/generic/tclResult.c b/generic/tclResult.c index ddf764b..9d0714c 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -27,9 +27,7 @@ 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 @@ -37,7 +35,7 @@ static void SetupAppendBuffer(Interp *iPtr, int newSpace); * then back up to the result or the error that was previously in progress. */ -typedef struct { +typedef struct InterpState { int status; /* return code status */ int flags; /* Each remaining field saves the */ int returnLevel; /* corresponding field of the Interp */ @@ -409,7 +407,6 @@ Tcl_DiscardResult( *---------------------------------------------------------------------- */ -#ifndef TCL_NO_DEPRECATED void Tcl_SetResult( Tcl_Interp *interp, /* Interpreter with which to associate the @@ -464,7 +461,6 @@ Tcl_SetResult( ResetObjResult(iPtr); } -#endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -487,21 +483,18 @@ 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 } /* @@ -543,7 +536,6 @@ Tcl_SetObjResult( TclDecrRefCount(oldObjResult); -#ifndef TCL_NO_DEPRECATED /* * Reset the string result since we just set the result object. */ @@ -558,7 +550,6 @@ Tcl_SetObjResult( } iPtr->result = iPtr->resultSpace; iPtr->resultSpace[0] = 0; -#endif } /* @@ -587,7 +578,6 @@ Tcl_GetObjResult( Tcl_Interp *interp) /* Interpreter whose result to return. */ { register Interp *iPtr = (Interp *) interp; -#ifndef TCL_NO_DEPRECATED Tcl_Obj *objResultPtr; int length; @@ -614,7 +604,6 @@ Tcl_GetObjResult( iPtr->result = iPtr->resultSpace; iPtr->result[0] = 0; } -#endif /* !TCL_NO_DEPRECATED */ return iPtr->objResultPtr; } @@ -733,21 +722,6 @@ 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; @@ -791,7 +765,6 @@ Tcl_AppendElement( flags |= TCL_DONT_QUOTE_HASH; } iPtr->appendUsed += Tcl_ConvertElement(element, dst, flags); -#endif /* !TCL_NO_DEPRECATED */ } /* @@ -813,7 +786,6 @@ Tcl_AppendElement( *---------------------------------------------------------------------- */ -#ifndef TCL_NO_DEPRECATED static void SetupAppendBuffer( Interp *iPtr, /* Interpreter whose result is being set up. */ @@ -874,7 +846,6 @@ SetupAppendBuffer( Tcl_FreeResult((Tcl_Interp *) iPtr); iPtr->result = iPtr->appendResult; } -#endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -904,7 +875,6 @@ Tcl_FreeResult( { register Interp *iPtr = (Interp *) interp; -#ifndef TCL_NO_DEPRECATED if (iPtr->freeProc != NULL) { if (iPtr->freeProc == TCL_DYNAMIC) { ckfree(iPtr->result); @@ -914,7 +884,6 @@ Tcl_FreeResult( iPtr->freeProc = 0; } -#endif /* !TCL_NO_DEPRECATED */ ResetObjResult(iPtr); } @@ -944,7 +913,6 @@ 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); @@ -955,7 +923,6 @@ 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) { @@ -1015,11 +982,11 @@ ResetObjResult( Tcl_IncrRefCount(objResultPtr); iPtr->objResultPtr = objResultPtr; } else { - if (objResultPtr->bytes != &tclEmptyString) { + if (objResultPtr->bytes != tclEmptyStringRep) { if (objResultPtr->bytes) { ckfree(objResultPtr->bytes); } - objResultPtr->bytes = &tclEmptyString; + objResultPtr->bytes = tclEmptyStringRep; objResultPtr->length = 0; } TclFreeIntRep(objResultPtr); @@ -1309,8 +1276,10 @@ TclProcessReturn( Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO], &valuePtr); if (valuePtr != NULL) { - (void) TclGetString(valuePtr); - if (valuePtr->length) { + int infoLen; + + (void) TclGetStringFromObj(valuePtr, &infoLen); + if (infoLen) { iPtr->errorInfo = valuePtr; Tcl_IncrRefCount(iPtr->errorInfo); iPtr->flags |= ERR_ALREADY_LOGGED; @@ -1413,11 +1382,13 @@ TclMergeReturnOptions( Tcl_Obj **keys = GetKeys(); for (; objc > 1; objv += 2, objc -= 2) { - const char *opt = TclGetString(objv[0]); - const char *compare = TclGetString(keys[KEY_OPTIONS]); + int optLen; + const char *opt = TclGetStringFromObj(objv[0], &optLen); + int compareLen; + const char *compare = + TclGetStringFromObj(keys[KEY_OPTIONS], &compareLen); - if ((objv[0]->length == keys[KEY_OPTIONS]->length) - && (memcmp(opt, compare, objv[0]->length) == 0)) { + if ((optLen == compareLen) && (memcmp(opt, compare, optLen) == 0)) { Tcl_DictSearch search; int done = 0; Tcl_Obj *keyPtr; diff --git a/generic/tclStrIdxTree.c b/generic/tclStrIdxTree.c deleted file mode 100644 index d9b5da0..0000000 --- a/generic/tclStrIdxTree.c +++ /dev/null @@ -1,520 +0,0 @@ -/* - * tclStrIdxTree.c -- - * - * Contains the routines for managing string index tries in Tcl. - * - * This code is back-ported from the tclSE engine, by Serg G. Brester. - * - * Copyright (c) 2016 by Sergey G. Brester aka sebres. All rights reserved. - * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * ----------------------------------------------------------------------- - * - * String index tries are prepaired structures used for fast greedy search of the string - * (index) by unique string prefix as key. - * - * Index tree build for two lists together can be explained in the following datagram - * - * Lists: - * - * {Januar Februar Maerz April Mai Juni Juli August September Oktober November Dezember} - * {Jnr Fbr Mrz Apr Mai Jni Jli Agt Spt Okt Nvb Dzb} - * - * Index-Tree: - * - * j -1 * ... - * anuar 0 * - * u -1 * a -1 - * ni 5 * pril 3 - * li 6 * ugust 7 - * n -1 * gt 7 - * r 0 * s 8 - * i 5 * eptember 8 - * li 6 * pt 8 - * f 1 * oktober 9 - * ebruar 1 * n 10 - * br 1 * ovember 10 - * m -1 * vb 10 - * a -1 * d 11 - * erz 2 * ezember 11 - * i 4 * zb 11 - * rz 2 * - * ... - * - * Thereby value -1 shows pure group items (corresponding ambigous matches). - * - * StrIdxTree's are very fast, so: - * build of above-mentioned tree takes about 10 microseconds. - * search of string index in this tree takes fewer as 0.1 microseconds. - * - */ - -#include "tclInt.h" -#include "tclStrIdxTree.h" - - -/* - *---------------------------------------------------------------------- - * - * TclStrIdxTreeSearch -- - * - * Find largest part of string "start" in indexed tree (case sensitive). - * - * Also used for building of string index tree. - * - * Results: - * Return position of UTF character in start after last equal character - * and found item (with parent). - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -MODULE_SCOPE const char* -TclStrIdxTreeSearch( - TclStrIdxTree **foundParent, /* Return value of found sub tree (used for tree build) */ - TclStrIdx **foundItem, /* Return value of found item */ - TclStrIdxTree *tree, /* Index tree will be browsed */ - const char *start, /* UTF string to find in tree */ - const char *end) /* End of string */ -{ - TclStrIdxTree *parent = tree, *prevParent = tree; - TclStrIdx *item = tree->firstPtr, *prevItem = NULL; - const char *s = start, *f, *cin, *cinf, *prevf; - int offs = 0; - - if (item == NULL) { - goto done; - } - - /* search in tree */ - do { - cinf = cin = TclGetString(item->key) + offs; - f = TclUtfFindEqualNCInLwr(s, end, cin, cin + item->length, &cinf); - /* if something was found */ - if (f > s) { - /* if whole string was found */ - if (f >= end) { - start = f; - goto done; - }; - /* set new offset and shift start string */ - offs += cinf - cin; - s = f; - /* if match item, go deeper as long as possible */ - if (offs >= item->length && item->childTree.firstPtr) { - /* save previuosly found item (if not ambigous) for - * possible fallback (few greedy match) */ - if (item->value != -1) { - prevf = f; - prevItem = item; - prevParent = parent; - } - parent = &item->childTree; - item = item->childTree.firstPtr; - continue; - } - /* no children - return this item and current chars found */ - start = f; - goto done; - } - - item = item->nextPtr; - - } while (item != NULL); - - /* fallback (few greedy match) not ambigous (has a value) */ - if (prevItem != NULL) { - item = prevItem; - parent = prevParent; - start = prevf; - } - -done: - - if (foundParent) - *foundParent = parent; - if (foundItem) - *foundItem = item; - return start; -} - -MODULE_SCOPE void -TclStrIdxTreeFree( - TclStrIdx *tree) -{ - while (tree != NULL) { - TclStrIdx *t; - Tcl_DecrRefCount(tree->key); - if (tree->childTree.firstPtr != NULL) { - TclStrIdxTreeFree(tree->childTree.firstPtr); - } - t = tree, tree = tree->nextPtr; - ckfree(t); - } -} - -/* - * Several bidirectional list primitives - */ -inline void -TclStrIdxTreeInsertBranch( - TclStrIdxTree *parent, - register TclStrIdx *item, - register TclStrIdx *child) -{ - if (parent->firstPtr == child) - parent->firstPtr = item; - if (parent->lastPtr == child) - parent->lastPtr = item; - if ( (item->nextPtr = child->nextPtr) ) { - item->nextPtr->prevPtr = item; - child->nextPtr = NULL; - } - if ( (item->prevPtr = child->prevPtr) ) { - item->prevPtr->nextPtr = item; - child->prevPtr = NULL; - } - item->childTree.firstPtr = child; - item->childTree.lastPtr = child; -} - -inline void -TclStrIdxTreeAppend( - register TclStrIdxTree *parent, - register TclStrIdx *item) -{ - if (parent->lastPtr != NULL) { - parent->lastPtr->nextPtr = item; - } - item->prevPtr = parent->lastPtr; - item->nextPtr = NULL; - parent->lastPtr = item; - if (parent->firstPtr == NULL) { - parent->firstPtr = item; - } -} - - -/* - *---------------------------------------------------------------------- - * - * TclStrIdxTreeBuildFromList -- - * - * Build or extend string indexed tree from tcl list. - * - * Important: by multiple lists, optimal tree can be created only if list with - * larger strings used firstly. - * - * Results: - * Returns a standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -MODULE_SCOPE int -TclStrIdxTreeBuildFromList( - TclStrIdxTree *idxTree, - int lstc, - Tcl_Obj **lstv) -{ - Tcl_Obj **lwrv; - int i, ret = TCL_ERROR; - const char *s, *e, *f; - TclStrIdx *item; - - /* create lowercase reflection of the list keys */ - - lwrv = ckalloc(sizeof(Tcl_Obj*) * lstc); - if (lwrv == NULL) { - return TCL_ERROR; - } - for (i = 0; i < lstc; i++) { - lwrv[i] = Tcl_DuplicateObj(lstv[i]); - if (lwrv[i] == NULL) { - return TCL_ERROR; - } - Tcl_IncrRefCount(lwrv[i]); - lwrv[i]->length = Tcl_UtfToLower(TclGetString(lwrv[i])); - } - - /* build index tree of the list keys */ - for (i = 0; i < lstc; i++) { - TclStrIdxTree *foundParent = idxTree; - e = s = TclGetString(lwrv[i]); - e += lwrv[i]->length; - - /* ignore empty values (impossible to index it) */ - if (lwrv[i]->length == 0) continue; - - item = NULL; - if (idxTree->firstPtr != NULL) { - TclStrIdx *foundItem; - f = TclStrIdxTreeSearch(&foundParent, &foundItem, - idxTree, s, e); - /* if common prefix was found */ - if (f > s) { - /* ignore element if fulfilled or ambigous */ - if (f == e) { - continue; - } - /* if shortest key was found with the same value, - * just replace its current key with longest key */ - if ( foundItem->value == i - && foundItem->length < lwrv[i]->length - && foundItem->childTree.firstPtr == NULL - ) { - Tcl_SetObjRef(foundItem->key, lwrv[i]); - foundItem->length = lwrv[i]->length; - continue; - } - /* split tree (e. g. j->(jan,jun) + jul == j->(jan,ju->(jun,jul)) ) - * but don't split by fulfilled child of found item ( ii->iii->iiii ) */ - if (foundItem->length != (f - s)) { - /* first split found item (insert one between parent and found + new one) */ - item = ckalloc(sizeof(*item)); - if (item == NULL) { - goto done; - } - Tcl_InitObjRef(item->key, foundItem->key); - item->length = f - s; - /* set value or mark as ambigous if not the same value of both */ - item->value = (foundItem->value == i) ? i : -1; - /* insert group item between foundParent and foundItem */ - TclStrIdxTreeInsertBranch(foundParent, item, foundItem); - foundParent = &item->childTree; - } else { - /* the new item should be added as child of found item */ - foundParent = &foundItem->childTree; - } - } - } - /* append item at end of found parent */ - item = ckalloc(sizeof(*item)); - if (item == NULL) { - goto done; - } - item->childTree.lastPtr = item->childTree.firstPtr = NULL; - Tcl_InitObjRef(item->key, lwrv[i]); - item->length = lwrv[i]->length; - item->value = i; - TclStrIdxTreeAppend(foundParent, item); - }; - - ret = TCL_OK; - -done: - - if (lwrv != NULL) { - for (i = 0; i < lstc; i++) { - Tcl_DecrRefCount(lwrv[i]); - } - ckfree(lwrv); - } - - if (ret != TCL_OK) { - if (idxTree->firstPtr != NULL) { - TclStrIdxTreeFree(idxTree->firstPtr); - } - } - - return ret; -} - - -static void -StrIdxTreeObj_DupIntRepProc(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); -static void -StrIdxTreeObj_FreeIntRepProc(Tcl_Obj *objPtr); -static void -StrIdxTreeObj_UpdateStringProc(Tcl_Obj *objPtr); - -Tcl_ObjType StrIdxTreeObjType = { - "str-idx-tree", /* name */ - StrIdxTreeObj_FreeIntRepProc, /* freeIntRepProc */ - StrIdxTreeObj_DupIntRepProc, /* dupIntRepProc */ - StrIdxTreeObj_UpdateStringProc, /* updateStringProc */ - NULL /* setFromAnyProc */ -}; - -MODULE_SCOPE Tcl_Obj* -TclStrIdxTreeNewObj() -{ - Tcl_Obj *objPtr = Tcl_NewObj(); - objPtr->internalRep.twoPtrValue.ptr1 = NULL; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; - objPtr->typePtr = &StrIdxTreeObjType; - /* return tree root in internal representation */ - return objPtr; -} - -static void -StrIdxTreeObj_DupIntRepProc(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr) -{ - /* follow links (smart pointers) */ - if ( srcPtr->internalRep.twoPtrValue.ptr1 != NULL - && srcPtr->internalRep.twoPtrValue.ptr2 == NULL - ) { - srcPtr = (Tcl_Obj*)srcPtr->internalRep.twoPtrValue.ptr1; - } - /* create smart pointer to it (ptr1 != NULL, ptr2 = NULL) */ - Tcl_InitObjRef(*((Tcl_Obj **)©Ptr->internalRep.twoPtrValue.ptr1), - srcPtr); - copyPtr->internalRep.twoPtrValue.ptr2 = NULL; - copyPtr->typePtr = &StrIdxTreeObjType; -} - -static void -StrIdxTreeObj_FreeIntRepProc(Tcl_Obj *objPtr) -{ - /* follow links (smart pointers) */ - if ( objPtr->internalRep.twoPtrValue.ptr1 != NULL - && objPtr->internalRep.twoPtrValue.ptr2 == NULL - ) { - /* is a link */ - Tcl_UnsetObjRef(*((Tcl_Obj **)&objPtr->internalRep.twoPtrValue.ptr1)); - } else { - /* is a tree */ - TclStrIdxTree *tree = (TclStrIdxTree*)&objPtr->internalRep.twoPtrValue.ptr1; - if (tree->firstPtr != NULL) { - TclStrIdxTreeFree(tree->firstPtr); - } - objPtr->internalRep.twoPtrValue.ptr1 = NULL; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; - } - objPtr->typePtr = NULL; -}; - -static void -StrIdxTreeObj_UpdateStringProc(Tcl_Obj *objPtr) -{ - /* currently only dummy empty string possible */ - objPtr->length = 0; - objPtr->bytes = &tclEmptyString; -}; - -MODULE_SCOPE TclStrIdxTree * -TclStrIdxTreeGetFromObj(Tcl_Obj *objPtr) { - /* follow links (smart pointers) */ - if (objPtr->typePtr != &StrIdxTreeObjType) { - return NULL; - } - if ( objPtr->internalRep.twoPtrValue.ptr1 != NULL - && objPtr->internalRep.twoPtrValue.ptr2 == NULL - ) { - objPtr = (Tcl_Obj*)objPtr->internalRep.twoPtrValue.ptr1; - } - /* return tree root in internal representation */ - return (TclStrIdxTree*)&objPtr->internalRep.twoPtrValue.ptr1; -} - -/* - * Several debug primitives - */ -#if 0 -/* currently unused, debug resp. test purposes only */ - -void -TclStrIdxTreePrint( - Tcl_Interp *interp, - TclStrIdx *tree, - int offs) -{ - Tcl_Obj *obj[2]; - const char *s; - Tcl_InitObjRef(obj[0], Tcl_NewStringObj("::puts", -1)); - while (tree != NULL) { - s = TclGetString(tree->key) + offs; - Tcl_InitObjRef(obj[1], Tcl_ObjPrintf("%*s%.*s\t:%d", - offs, "", tree->length - offs, s, tree->value)); - Tcl_PutsObjCmd(NULL, interp, 2, obj); - Tcl_UnsetObjRef(obj[1]); - if (tree->childTree.firstPtr != NULL) { - TclStrIdxTreePrint(interp, tree->childTree.firstPtr, tree->length); - } - tree = tree->nextPtr; - } - Tcl_UnsetObjRef(obj[0]); -} - - -MODULE_SCOPE int -TclStrIdxTreeTestObjCmd( - ClientData clientData, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]) -{ - const char *cs, *cin, *ret; - - static const char *const options[] = { - "index", "puts-index", "findequal", - NULL - }; - enum optionInd { - O_INDEX, O_PUTS_INDEX, O_FINDEQUAL - }; - int optionIndex; - - if (objc < 2) { - Tcl_SetResult(interp, "wrong # args", TCL_STATIC); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[1], options, - "option", 0, &optionIndex) != TCL_OK) { - Tcl_SetErrorCode(interp, "CLOCK", "badOption", - Tcl_GetString(objv[1]), NULL); - return TCL_ERROR; - } - switch (optionIndex) { - case O_FINDEQUAL: - if (objc < 4) { - Tcl_SetResult(interp, "wrong # args", TCL_STATIC); - return TCL_ERROR; - } - cs = TclGetString(objv[2]); - cin = TclGetString(objv[3]); - ret = TclUtfFindEqual( - cs, cs + objv[1]->length, cin, cin + objv[2]->length); - Tcl_SetObjResult(interp, Tcl_NewIntObj(ret - cs)); - break; - case O_INDEX: - case O_PUTS_INDEX: - - if (1) { - Tcl_Obj **lstv; - int i, lstc; - TclStrIdxTree idxTree = {NULL, NULL}; - i = 1; - while (++i < objc) { - if (TclListObjGetElements(interp, objv[i], - &lstc, &lstv) != TCL_OK) { - return TCL_ERROR; - }; - TclStrIdxTreeBuildFromList(&idxTree, lstc, lstv); - } - if (optionIndex == O_PUTS_INDEX) { - TclStrIdxTreePrint(interp, idxTree.firstPtr, 0); - } - TclStrIdxTreeFree(idxTree.firstPtr); - } - break; - } - - return TCL_OK; -} - -#endif - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ diff --git a/generic/tclStrIdxTree.h b/generic/tclStrIdxTree.h deleted file mode 100644 index 305053c..0000000 --- a/generic/tclStrIdxTree.h +++ /dev/null @@ -1,169 +0,0 @@ -/* - * tclStrIdxTree.h -- - * - * Declarations of string index tries and other primitives currently - * back-ported from tclSE. - * - * Copyright (c) 2016 Serg G. Brester (aka sebres) - * - * See the file "license.terms" for information on usage and redistribution - * of this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -#ifndef _TCLSTRIDXTREE_H -#define _TCLSTRIDXTREE_H - - -/* - * Main structures declarations of index tree and entry - */ - -typedef struct TclStrIdxTree { - struct TclStrIdx *firstPtr; - struct TclStrIdx *lastPtr; -} TclStrIdxTree; - -typedef struct TclStrIdx { - struct TclStrIdxTree childTree; - struct TclStrIdx *nextPtr; - struct TclStrIdx *prevPtr; - Tcl_Obj *key; - int length; - int value; -} TclStrIdx; - - -/* - *---------------------------------------------------------------------- - * - * TclUtfFindEqual, TclUtfFindEqualNC -- - * - * Find largest part of string cs in string cin (case sensitive and not). - * - * Results: - * Return position of UTF character in cs after last equal character. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static inline const char * -TclUtfFindEqual( - register const char *cs, /* UTF string to find in cin. */ - register const char *cse, /* End of cs */ - register const char *cin, /* UTF string will be browsed. */ - register const char *cine) /* End of cin */ -{ - register const char *ret = cs; - Tcl_UniChar ch1, ch2; - do { - cs += TclUtfToUniChar(cs, &ch1); - cin += TclUtfToUniChar(cin, &ch2); - if (ch1 != ch2) break; - } while ((ret = cs) < cse && cin < cine); - return ret; -} - -static inline const char * -TclUtfFindEqualNC( - register const char *cs, /* UTF string to find in cin. */ - register const char *cse, /* End of cs */ - register const char *cin, /* UTF string will be browsed. */ - register const char *cine, /* End of cin */ - const char **cinfnd) /* Return position in cin */ -{ - register const char *ret = cs; - Tcl_UniChar ch1, ch2; - do { - cs += TclUtfToUniChar(cs, &ch1); - cin += TclUtfToUniChar(cin, &ch2); - if (ch1 != ch2) { - ch1 = Tcl_UniCharToLower(ch1); - ch2 = Tcl_UniCharToLower(ch2); - if (ch1 != ch2) break; - } - *cinfnd = cin; - } while ((ret = cs) < cse && cin < cine); - return ret; -} - -static inline const char * -TclUtfFindEqualNCInLwr( - register const char *cs, /* UTF string (in anycase) to find in cin. */ - register const char *cse, /* End of cs */ - register const char *cin, /* UTF string (in lowercase) will be browsed. */ - register const char *cine, /* End of cin */ - const char **cinfnd) /* Return position in cin */ -{ - register const char *ret = cs; - Tcl_UniChar ch1, ch2; - do { - cs += TclUtfToUniChar(cs, &ch1); - cin += TclUtfToUniChar(cin, &ch2); - if (ch1 != ch2) { - ch1 = Tcl_UniCharToLower(ch1); - if (ch1 != ch2) break; - } - *cinfnd = cin; - } while ((ret = cs) < cse && cin < cine); - return ret; -} - -static inline const char * -TclUtfNext( - register const char *src) /* The current location in the string. */ -{ - if (((unsigned char) *(src)) < 0xC0) { - return ++src; - } else { - Tcl_UniChar ch; - return src + TclUtfToUniChar(src, &ch); - } -} - - -/* - * Primitives to safe set, reset and free references. - */ - -#define Tcl_UnsetObjRef(obj) \ - if (obj != NULL) { Tcl_DecrRefCount(obj); obj = NULL; } -#define Tcl_InitObjRef(obj, val) \ - obj = val; if (obj) { Tcl_IncrRefCount(obj); } -#define Tcl_SetObjRef(obj, val) \ -if (1) { \ - Tcl_Obj *nval = val; \ - if (obj != nval) { \ - Tcl_Obj *prev = obj; \ - Tcl_InitObjRef(obj, nval); \ - if (prev != NULL) { Tcl_DecrRefCount(prev); }; \ - } \ -} - -/* - * Prototypes of module functions. - */ - -MODULE_SCOPE const char* - TclStrIdxTreeSearch(TclStrIdxTree **foundParent, - TclStrIdx **foundItem, TclStrIdxTree *tree, - const char *start, const char *end); - -MODULE_SCOPE int TclStrIdxTreeBuildFromList(TclStrIdxTree *idxTree, - int lstc, Tcl_Obj **lstv); - -MODULE_SCOPE Tcl_Obj* - TclStrIdxTreeNewObj(); - -MODULE_SCOPE TclStrIdxTree* - TclStrIdxTreeGetFromObj(Tcl_Obj *objPtr); - -#if 1 - -MODULE_SCOPE int TclStrIdxTreeTestObjCmd(ClientData, Tcl_Interp *, - int, Tcl_Obj *const objv[]); -#endif - -#endif /* _TCLSTRIDXTREE_H */ diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 224ab45..67b6482 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -18,6 +18,13 @@ #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. @@ -539,20 +546,6 @@ 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); } @@ -664,7 +657,7 @@ TclParseNumber( state = ZERO_O; break; } -#ifdef TCL_NO_DEPRECATED +#ifdef KILL_OCTAL goto decimal; #endif /* FALLTHROUGH */ @@ -747,7 +740,7 @@ TclParseNumber( goto endgame; } -#ifndef TCL_NO_DEPRECATED +#ifndef KILL_OCTAL /* * Scanned a number with a leading zero that contains an 8, 9, @@ -886,7 +879,7 @@ TclParseNumber( * digits. */ -#ifdef TCL_NO_DEPRECATED +#ifdef KILL_OCTAL decimal: #endif acceptState = state; @@ -3805,7 +3798,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 @@ -3970,7 +3963,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 c45baa1..4e19750 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -39,6 +39,15 @@ #include "tclStringRep.h" /* + * Set COMPAT to 1 to restore the shimmering patterns to those of Tcl 8.5. + * This is an escape hatch in case the changes have some unexpected unwelcome + * impact on performance. If things go well, this mechanism can go away when + * post-8.6 development begins. + */ + +#define COMPAT 0 + +/* * Prototypes for functions defined later in this file: */ @@ -136,7 +145,7 @@ GrowStringBuffer( char *ptr = NULL; int attempt; - if (objPtr->bytes == &tclEmptyString) { + if (objPtr->bytes == tclEmptyStringRep) { objPtr->bytes = NULL; } if (flag == 0 || stringPtr->allocated > 0) { @@ -409,15 +418,6 @@ 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. @@ -445,6 +445,18 @@ Tcl_GetCharLength( if (numChars == -1) { TclNumUtfChars(numChars, objPtr->bytes, objPtr->length); stringPtr->numChars = numChars; + +#if COMPAT + if (numChars < objPtr->length) { + /* + * Since we've just computed the number of chars, and not all UTF + * chars are 1-byte long, go ahead and populate the unicode + * string. + */ + + FillUnicodeRep(objPtr); + } +#endif } return numChars; } @@ -767,7 +779,7 @@ Tcl_SetObjLength( /* * Need to enlarge the buffer. */ - if (objPtr->bytes == &tclEmptyString) { + if (objPtr->bytes == tclEmptyStringRep) { objPtr->bytes = ckalloc(length + 1); } else { objPtr->bytes = ckrealloc(objPtr->bytes, length + 1); @@ -873,7 +885,7 @@ Tcl_AttemptSetObjLength( char *newBytes; - if (objPtr->bytes == &tclEmptyString) { + if (objPtr->bytes == tclEmptyStringRep) { newBytes = attemptckalloc(length + 1); } else { newBytes = attemptckrealloc(objPtr->bytes, length + 1); @@ -1161,7 +1173,11 @@ Tcl_AppendUnicodeToObj( * objPtr's string rep. */ - if (stringPtr->hasUnicode) { + if (stringPtr->hasUnicode +#if COMPAT + && stringPtr->numChars > 0 +#endif + ) { AppendUnicodeToUnicodeRep(objPtr, unicode, length); } else { AppendUnicodeToUtfRep(objPtr, unicode, length); @@ -1202,7 +1218,7 @@ Tcl_AppendObjToObj( * that appending nothing to anything leaves that starting anything... */ - if (appendObjPtr->bytes == &tclEmptyString) { + if (appendObjPtr->bytes == tclEmptyStringRep) { return; } @@ -1213,7 +1229,7 @@ Tcl_AppendObjToObj( * information; this is a special-case optimization only. */ - if ((TclIsPureByteArray(objPtr) || objPtr->bytes == &tclEmptyString) + if ((TclIsPureByteArray(objPtr) || objPtr->bytes == tclEmptyStringRep) && TclIsPureByteArray(appendObjPtr)) { /* @@ -1267,7 +1283,11 @@ Tcl_AppendObjToObj( * appendObjPtr and append it. */ - if (stringPtr->hasUnicode) { + if (stringPtr->hasUnicode +#if COMPAT + && stringPtr->numChars > 0 +#endif + ) { /* * If appendObjPtr is not of the "String" type, don't convert it. */ @@ -1300,7 +1320,11 @@ Tcl_AppendObjToObj( AppendUtfToUtfRep(objPtr, bytes, length); - if (numChars >= 0 && appendNumChars >= 0) { + if (numChars >= 0 && appendNumChars >= 0 +#if COMPAT + && appendNumChars == length +#endif + ) { stringPtr->numChars = numChars + appendNumChars; } } @@ -1424,6 +1448,14 @@ AppendUnicodeToUtfRep( if (stringPtr->numChars != -1) { stringPtr->numChars += numChars; } + +#if COMPAT + /* + * Invalidate the unicode rep. + */ + + stringPtr->hasUnicode = 0; +#endif } /* @@ -1670,8 +1702,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; @@ -1747,7 +1782,6 @@ Tcl_AppendFormatToObj( * Step 2. Set of flags. */ - gotMinus = gotHash = gotZero = gotSpace = gotPlus = 0; sawFlag = 1; do { switch (ch) { @@ -1848,7 +1882,6 @@ Tcl_AppendFormatToObj( * Step 5. Length modifier. */ - useShort = useWide = useBig = 0; if (ch == 'h') { useShort = 1; format += step; @@ -1865,14 +1898,6 @@ Tcl_AppendFormatToObj( useWide = 1; #endif } - } else if ((ch == 'I') && (format[1] == '6') && (format[2] == '4')) { - format += (step + 2); - step = Tcl_UtfToUniChar(format, &ch); - useBig = 1; - } else if (ch == 'L') { - format += step; - step = Tcl_UtfToUniChar(format, &ch); - useBig = 1; } format += step; @@ -1940,6 +1965,7 @@ Tcl_AppendFormatToObj( 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; @@ -1954,6 +1980,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; @@ -2020,8 +2047,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 { @@ -2104,6 +2133,7 @@ Tcl_AppendFormatToObj( numDigits++; us /= base; } +#ifndef TCL_WIDE_INT_IS_LONG } else if (useWide) { Tcl_WideUInt uw = (Tcl_WideUInt) w; @@ -2112,6 +2142,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); @@ -2480,10 +2511,6 @@ 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': @@ -2512,20 +2539,9 @@ AppendPrintfToObjVA( gotPrecision = 1; p++; break; - /* TODO: support for bignum arguments */ + /* TODO: support for wide (and bignum?) arguments */ case 'l': - ++size; - p++; - break; - case 'L': - size = 2; - p++; - break; - case 'I': - if (p[1]=='6' && p[2]=='4') { - p += 2; - size = 2; - } + size = 1; p++; break; case 'h': @@ -2632,616 +2648,6 @@ 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 "u 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 "u 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 "u 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; - } -} - /* *--------------------------------------------------------------------------- * @@ -3474,6 +2880,7 @@ DupStringInternalRep( String *srcStringPtr = GET_STRING(srcPtr); String *copyStringPtr = NULL; +#if COMPAT==0 if (srcStringPtr->numChars == -1) { /* * The String struct in the source value holds zero useful data. Don't @@ -3516,6 +2923,41 @@ DupStringInternalRep( */ copyStringPtr->allocated = copyPtr->bytes ? copyPtr->length : 0; +#else /* COMPAT!=0 */ + /* + * If the src obj is a string of 1-byte Utf chars, then copy the string + * rep of the source object and create an "empty" Unicode internal rep for + * the new object. Otherwise, copy Unicode internal rep, and invalidate + * the string rep of the new object. + */ + + if (srcStringPtr->hasUnicode && srcStringPtr->numChars > 0) { + /* + * Copy the full allocation for the Unicode buffer. + */ + + copyStringPtr = stringAlloc(srcStringPtr->maxChars); + copyStringPtr->maxChars = srcStringPtr->maxChars; + memcpy(copyStringPtr->unicode, srcStringPtr->unicode, + srcStringPtr->numChars * sizeof(Tcl_UniChar)); + copyStringPtr->unicode[srcStringPtr->numChars] = 0; + copyStringPtr->allocated = 0; + } else { + copyStringPtr = stringAlloc(0); + copyStringPtr->unicode[0] = 0; + copyStringPtr->maxChars = 0; + + /* + * Tricky point: the string value was copied by generic object + * management code, so it doesn't contain any extra bytes that might + * exist in the source object. + */ + + copyStringPtr->allocated = copyPtr->length; + } + copyStringPtr->numChars = srcStringPtr->numChars; + copyStringPtr->hasUnicode = srcStringPtr->hasUnicode; +#endif /* COMPAT==0 */ SET_STRING(copyPtr, copyStringPtr); copyPtr->typePtr = &tclStringType; @@ -3603,7 +3045,7 @@ UpdateStringOfString( stringPtr->allocated = 0; if (stringPtr->numChars == 0) { - TclInitStringRep(objPtr, &tclEmptyString, 0); + TclInitStringRep(objPtr, tclEmptyStringRep, 0); } else { (void) ExtendStringRepWithUnicode(objPtr, stringPtr->unicode, stringPtr->numChars); @@ -3621,7 +3063,7 @@ ExtendStringRepWithUnicode( */ int i, origLength, size = 0; - char *dst; + char *dst, buf[TCL_UTF_MAX]; String *stringPtr = GET_STRING(objPtr); if (numChars < 0) { @@ -3647,7 +3089,7 @@ ExtendStringRepWithUnicode( } for (i = 0; i < numChars && size >= 0; i++) { - size += TclUtfCount(unicode[i]); + size += Tcl_UniCharToUtf((int) unicode[i], buf); } if (size < 0) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); diff --git a/generic/tclStringRep.h b/generic/tclStringRep.h index 1ef1957..227e6bc 100644 --- a/generic/tclStringRep.h +++ b/generic/tclStringRep.h @@ -46,7 +46,7 @@ * tcl.h, but do not do that unless you are sure what you're doing! */ -typedef struct { +typedef struct String { int numChars; /* The number of chars in the string. -1 means * this value has not been calculated. >= 0 * means that there is a valid Unicode rep, or @@ -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", \ - (int)STRING_MAXCHARS); \ + STRING_MAXCHARS); \ } \ } while (0) #define stringAttemptAlloc(numChars) \ - (String *) attemptckalloc(STRING_SIZE(numChars)) + (String *) attemptckalloc((unsigned) STRING_SIZE(numChars)) #define stringAlloc(numChars) \ - (String *) ckalloc(STRING_SIZE(numChars)) + (String *) ckalloc((unsigned) STRING_SIZE(numChars)) #define stringRealloc(ptr, numChars) \ - (String *) ckrealloc((ptr), STRING_SIZE(numChars)) + (String *) ckrealloc((ptr), (unsigned) STRING_SIZE(numChars)) #define stringAttemptRealloc(ptr, numChars) \ - (String *) attemptckrealloc((ptr), STRING_SIZE(numChars)) + (String *) attemptckrealloc((ptr), (unsigned) 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 561b9dd..5b7a1cd 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -290,47 +290,10 @@ static int formatInt(char *buffer, int n){ #endif #else /* UNIX and MAC */ -# ifdef TCL_NO_DEPRECATED -# define TclpLocaltime_unix 0 -# define TclpGmtime_unix 0 -# else -# define TclpLocaltime_unix TclpLocaltime -# define TclpGmtime_unix TclpGmtime -# endif +# define TclpLocaltime_unix TclpLocaltime +# define TclpGmtime_unix TclpGmtime #endif -#ifdef TCL_NO_DEPRECATED -# define Tcl_SeekOld 0 -# define Tcl_TellOld 0 -# undef Tcl_SetResult -# define Tcl_SetResult 0 -#else /* TCL_NO_DEPRECATED */ -# define Tcl_SeekOld seekOld -# define Tcl_TellOld tellOld - -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 * tools/genStubs.tcl script. Any modifications to the function declarations @@ -786,7 +749,6 @@ const TclTomMathStubs tclTomMathStubs = { TclBNInitBignumFromLong, /* 64 */ TclBNInitBignumFromWideInt, /* 65 */ TclBNInitBignumFromWideUInt, /* 66 */ - TclBN_mp_expt_d_ex, /* 67 */ }; static const TclStubHooks tclStubHooks = { @@ -1453,7 +1415,6 @@ 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 dd951bf..859cbf9 100644 --- a/generic/tclStubLib.c +++ b/generic/tclStubLib.c @@ -24,10 +24,13 @@ const TclIntStubs *tclIntStubsPtr = NULL; const TclIntPlatStubs *tclIntPlatStubsPtr = NULL; /* - * Use our own ISDIGIT to avoid linking to libc on windows + * Use our own isDigit to avoid linking to libc on windows */ -#define ISDIGIT(c) (((unsigned)((c)-'0')) <= 9) +static int isDigit(const int c) +{ + return (c >= '0' && c <= '9'); +} /* *---------------------------------------------------------------------- @@ -51,8 +54,7 @@ MODULE_SCOPE const char * Tcl_InitStubs( Tcl_Interp *interp, const char *version, - int exact, - int magic) + int exact) { Interp *iPtr = (Interp *) interp; const char *actualVersion = NULL; @@ -65,8 +67,8 @@ Tcl_InitStubs( * times. [Bug 615304] */ - if (!stubsPtr || (stubsPtr->magic != (((exact&0xff00) >= 0x900) ? magic : TCL_STUB_MAGIC))) { - iPtr->result = (char *)"interpreter uses an incompatible stubs mechanism"; + if (!stubsPtr || (stubsPtr->magic != TCL_STUB_MAGIC)) { + iPtr->result = "interpreter uses an incompatible stubs mechanism"; iPtr->freeProc = TCL_STATIC; return NULL; } @@ -75,12 +77,12 @@ Tcl_InitStubs( if (actualVersion == NULL) { return NULL; } - if (exact&1) { + if (exact) { const char *p = version; int count = 0; while (*p) { - count += !ISDIGIT(*p++); + count += !isDigit(*p++); } if (count == 1) { const char *q = actualVersion; @@ -89,7 +91,7 @@ Tcl_InitStubs( while (*p && (*p == *q)) { p++; q++; } - if (*p || ISDIGIT(*q)) { + if (*p || isDigit(*q)) { /* Construct error message */ stubsPtr->tcl_PkgRequireEx(interp, "Tcl", version, 1, NULL); return NULL; @@ -101,16 +103,12 @@ Tcl_InitStubs( } } } - if (((exact&0xff00) < 0x900)) { - /* We are running Tcl 8.x */ - stubsPtr = (TclStubs *)pkgData; - } - tclStubsPtr = stubsPtr; + tclStubsPtr = (TclStubs *)pkgData; - if (stubsPtr->hooks) { - tclPlatStubsPtr = stubsPtr->hooks->tclPlatStubs; - tclIntStubsPtr = stubsPtr->hooks->tclIntStubs; - tclIntPlatStubsPtr = stubsPtr->hooks->tclIntPlatStubs; + if (tclStubsPtr->hooks) { + tclPlatStubsPtr = tclStubsPtr->hooks->tclPlatStubs; + tclIntStubsPtr = tclStubsPtr->hooks->tclIntStubs; + tclIntPlatStubsPtr = tclStubsPtr->hooks->tclIntPlatStubs; } else { tclPlatStubsPtr = NULL; tclIntStubsPtr = NULL; diff --git a/generic/tclTest.c b/generic/tclTest.c index a9dc1ca..f2dbfc9 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -42,8 +42,16 @@ * Declare external functions used in Windows tests. */ -DLLEXPORT int Tcltest_Init(Tcl_Interp *interp); -DLLEXPORT int Tcltest_SafeInit(Tcl_Interp *interp); +/* + * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the + * Tcltest_Init declaration is in the source file itself, which is only + * accessed when we are building a library. + */ + +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLEXPORT +EXTERN int Tcltest_Init(Tcl_Interp *interp); +EXTERN int Tcltest_SafeInit(Tcl_Interp *interp); /* * Dynamic string shared by TestdcallCmd and DelCallbackProc; used to collect @@ -90,7 +98,7 @@ static Tcl_Trace cmdTrace; * TestdelCmd: */ -typedef struct { +typedef struct DelCmd { Tcl_Interp *interp; /* Interpreter in which command exists. */ char *deleteCmd; /* Script to execute when command is deleted. * Malloc'ed. */ @@ -101,7 +109,7 @@ typedef struct { * command. */ -typedef struct { +typedef struct TclEncoding { Tcl_Interp *interp; char *toUtfCmd; char *fromUtfCmd; @@ -124,7 +132,7 @@ static int exitMainLoop = 0; * Event structure used in testing the event queue management procedures. */ -typedef struct { +typedef struct TestEvent { 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,14 +298,12 @@ 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, @@ -317,12 +323,6 @@ static int TestparsevarObjCmd(ClientData dummy, static int TestparsevarnameObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -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[]); @@ -532,9 +532,7 @@ int Tcltest_Init( Tcl_Interp *interp) /* Interpreter for application. */ { -#ifndef TCL_NO_DEPRECATED Tcl_ValueType t3ArgTypes[2]; -#endif /* TCL_NO_DEPRECATED */ Tcl_Obj *listPtr; Tcl_Obj **objv; @@ -544,10 +542,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) { @@ -555,7 +553,7 @@ Tcltest_Init( } /* TIP #268: Full patchlevel instead of just major.minor */ - if (Tcl_PkgProvideEx(interp, "Tcltest", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) { + if (Tcl_PkgProvide(interp, "Tcltest", TCL_PATCH_LEVEL) == TCL_ERROR) { return TCL_ERROR; } @@ -650,10 +648,6 @@ Tcltest_Init( NULL, NULL); Tcl_CreateObjCommand(interp, "testparsevarname", TestparsevarnameObjCmd, 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, @@ -681,10 +675,8 @@ Tcltest_Init( Tcl_CreateCommand(interp, "testtranslatefilename", TesttranslatefilenameCmd, NULL, NULL); Tcl_CreateCommand(interp, "testupvar", TestupvarCmd, NULL, NULL); -#ifndef TCL_NO_DEPRECATED Tcl_CreateMathFunc(interp, "T1", 0, NULL, TestMathFunc, (ClientData) 123); Tcl_CreateMathFunc(interp, "T2", 0, NULL, TestMathFunc, (ClientData) 345); -#endif /* TCL_NO_DEPRECATED */ Tcl_CreateCommand(interp, "testmainthread", TestmainthreadCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsetmainloop", TestsetmainloopCmd, @@ -695,12 +687,10 @@ Tcltest_Init( Tcl_CreateObjCommand(interp, "testcpuid", TestcpuidCmd, (ClientData) 0, NULL); #endif -#ifndef TCL_NO_DEPRECATED t3ArgTypes[0] = TCL_EITHER; t3ArgTypes[1] = TCL_EITHER; Tcl_CreateMathFunc(interp, "T3", 2, t3ArgTypes, TestMathFunc2, NULL); -#endif /* TCL_NO_DEPRECATED */ Tcl_CreateObjCommand(interp, "testnreunwind", TestNREUnwind, NULL, NULL); @@ -784,7 +774,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); @@ -821,7 +811,7 @@ TestasyncCmd( if (argc < 2) { wrongNumArgs: - Tcl_AppendResult(interp, "wrong # args", NULL); + Tcl_SetResult(interp, "wrong # args", TCL_STATIC); return TCL_ERROR; } if (strcmp(argv[1], "create") == 0) { @@ -911,7 +901,7 @@ TestasyncCmd( if (Tcl_CreateThread(&threadID, AsyncThreadProc, INT2PTR(id), TCL_THREAD_STACK_DEFAULT, TCL_THREAD_NOFLAGS) != TCL_OK) { - Tcl_AppendResult(interp, "can't create thread", NULL); + Tcl_SetResult(interp, "can't create thread", TCL_STATIC); Tcl_MutexUnlock(&asyncTestMutex); return TCL_ERROR; } @@ -1058,7 +1048,7 @@ TestcmdinfoCmd( Tcl_DStringResult(interp, &delString); } else if (strcmp(argv[1], "get") == 0) { if (Tcl_GetCommandInfo(interp, argv[2], &info) ==0) { - Tcl_AppendResult(interp, "??", NULL); + Tcl_SetResult(interp, "??", TCL_STATIC); return TCL_OK; } if (info.proc == CmdProc1) { @@ -1185,7 +1175,7 @@ TestcmdtokenCmd( token = Tcl_CreateCommand(interp, argv[2], CmdProc1, (ClientData) "original", NULL); sprintf(buf, "%p", (void *)token); - Tcl_AppendResult(interp, buf, NULL); + Tcl_SetResult(interp, buf, TCL_VOLATILE); } else if (strcmp(argv[1], "name") == 0) { Tcl_Obj *objPtr; @@ -1288,10 +1278,10 @@ TestcmdtraceCmd( cmdTrace = Tcl_CreateObjTrace(interp, 50000, TCL_ALLOW_INLINE_COMPILATION, ObjTraceProc, (ClientData) &deleteCalled, ObjTraceDeleteProc); - result = Tcl_EvalEx(interp, argv[2], -1, 0); + result = Tcl_Eval(interp, argv[2]); Tcl_DeleteTrace(interp, cmdTrace); if (!deleteCalled) { - Tcl_AppendResult(interp, "Delete wasn't called", NULL); + Tcl_SetResult(interp, "Delete wasn't called", TCL_STATIC); return TCL_ERROR; } else { return result; @@ -1302,7 +1292,7 @@ TestcmdtraceCmd( Tcl_DStringInit(&buffer); t1 = Tcl_CreateTrace(interp, 1, CmdTraceProc, &buffer); t2 = Tcl_CreateTrace(interp, 50000, CmdTraceProc, &buffer); - result = Tcl_EvalEx(interp, argv[2], -1, 0); + result = Tcl_Eval(interp, argv[2]); if (result == TCL_OK) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL); @@ -1591,7 +1581,7 @@ TestdelCmd( Tcl_Interp *slave; if (argc != 4) { - Tcl_AppendResult(interp, "wrong # args", NULL); + Tcl_SetResult(interp, "wrong # args", TCL_STATIC); return TCL_ERROR; } @@ -1631,7 +1621,7 @@ DelDeleteProc( { DelCmd *dPtr = clientData; - Tcl_EvalEx(dPtr->interp, dPtr->deleteCmd, -1, 0); + Tcl_Eval(dPtr->interp, dPtr->deleteCmd); Tcl_ResetResult(dPtr->interp); ckfree(dPtr->deleteCmd); ckfree(dPtr); @@ -1796,7 +1786,7 @@ TestdstringCmd( if (argc < 2) { wrongNumArgs: - Tcl_AppendResult(interp, "wrong # args", NULL); + Tcl_SetResult(interp, "wrong # args", TCL_STATIC); return TCL_ERROR; } if (strcmp(argv[1], "append") == 0) { @@ -1832,9 +1822,9 @@ TestdstringCmd( goto wrongNumArgs; } if (strcmp(argv[2], "staticsmall") == 0) { - Tcl_AppendResult(interp, "short", NULL); + Tcl_SetResult(interp, "short", TCL_STATIC); } else if (strcmp(argv[2], "staticlarge") == 0) { - 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); + 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); } else if (strcmp(argv[2], "free") == 0) { char *s = ckalloc(100); strcpy(s, "This is a malloc-ed string"); @@ -1994,7 +1984,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) { @@ -2026,7 +2016,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) { @@ -2434,7 +2424,7 @@ TestexprlongCmd( " expression\"", NULL); return TCL_ERROR; } - Tcl_AppendResult(interp, "This is a result", NULL); + Tcl_SetResult(interp, "This is a result", TCL_STATIC); result = Tcl_ExprLong(interp, argv[1], &exprResult); if (result != TCL_OK) { return result; @@ -2476,7 +2466,7 @@ TestexprlongobjCmd( Tcl_WrongNumArgs(interp, 1, objv, "expression"); return TCL_ERROR; } - Tcl_AppendResult(interp, "This is a result", NULL); + Tcl_SetResult(interp, "This is a result", TCL_STATIC); result = Tcl_ExprLongObj(interp, objv[1], &exprResult); if (result != TCL_OK) { return result; @@ -2519,7 +2509,7 @@ TestexprdoubleCmd( " expression\"", NULL); return TCL_ERROR; } - Tcl_AppendResult(interp, "This is a result", NULL); + Tcl_SetResult(interp, "This is a result", TCL_STATIC); result = Tcl_ExprDouble(interp, argv[1], &exprResult); if (result != TCL_OK) { return result; @@ -2562,7 +2552,7 @@ TestexprdoubleobjCmd( Tcl_WrongNumArgs(interp, 1, objv, "expression"); return TCL_ERROR; } - Tcl_AppendResult(interp, "This is a result", NULL); + Tcl_SetResult(interp, "This is a result", TCL_STATIC); result = Tcl_ExprDoubleObj(interp, objv[1], &exprResult); if (result != TCL_OK) { return result; @@ -3339,7 +3329,6 @@ TestlocaleCmd( */ /* ARGSUSED */ -#ifndef TCL_NO_DEPRECATED static int TestMathFunc( ClientData clientData, /* Integer value to return. */ @@ -3405,7 +3394,7 @@ TestMathFunc2( resultPtr->type = TCL_WIDE_INT; resultPtr->wideValue = ((w0 > w1)? w0 : w1); } else { - Tcl_SetResult(interp, (char *)"T3: wrong type for arg 2", TCL_STATIC); + Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC); result = TCL_ERROR; } } else if (args[0].type == TCL_DOUBLE) { @@ -3427,7 +3416,7 @@ TestMathFunc2( resultPtr->type = TCL_DOUBLE; resultPtr->doubleValue = ((d0 > d1)? d0 : d1); } else { - Tcl_SetResult(interp, (char *)"T3: wrong type for arg 2", TCL_STATIC); + Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC); result = TCL_ERROR; } } else if (args[0].type == TCL_WIDE_INT) { @@ -3450,16 +3439,15 @@ TestMathFunc2( resultPtr->type = TCL_WIDE_INT; resultPtr->wideValue = ((w0 > w1)? w0 : w1); } else { - Tcl_SetResult(interp, (char *)"T3: wrong type for arg 2", TCL_STATIC); + Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC); result = TCL_ERROR; } } else { - Tcl_SetResult(interp, (char *)"T3: wrong type for arg 1", TCL_STATIC); + Tcl_SetResult(interp, "T3: wrong type for arg 1", TCL_STATIC); result = TCL_ERROR; } return result; } -#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -3795,73 +3783,6 @@ TestparsevarnameObjCmd( /* *---------------------------------------------------------------------- * - * TestpreferstableObjCmd -- - * - * This procedure implements the "testpreferstable" command. It is - * used for being able to test the "package" command even when the - * environment variable TCL_PKG_PREFER_LATEST is set in your environment. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TestpreferstableObjCmd( - ClientData clientData, /* Not used. */ - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* The argument objects. */ -{ - Interp *iPtr = (Interp *) interp; - iPtr->packagePrefer = PKG_PREFER_STABLE; - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * 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; - - if (objc < 2 || objc > 3) { - Tcl_WrongNumArgs(interp, 1, objv, "format wideint"); - } - - if (objc > 1) { - Tcl_GetWideIntFromObj(interp, objv[2], &argv1); - } - Tcl_SetObjResult(interp, Tcl_ObjPrintf(Tcl_GetString(objv[1]), argv1)); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * * TestregexpObjCmd -- * * This procedure implements the "testregexp" command. It is used to give @@ -4005,7 +3926,7 @@ TestregexpObjCmd( varName = Tcl_GetString(objv[2]); TclRegExpRangeUniChar(regExpr, -1, &start, &end); sprintf(resinfo, "%d %d", start, end-1); - value = Tcl_SetVar2(interp, varName, NULL, resinfo, 0); + value = Tcl_SetVar(interp, varName, resinfo, 0); if (value == NULL) { Tcl_AppendResult(interp, "couldn't set variable \"", varName, "\"", NULL); @@ -4019,7 +3940,7 @@ TestregexpObjCmd( Tcl_RegExpGetInfo(regExpr, &info); varName = Tcl_GetString(objv[2]); sprintf(resinfo, "%ld", info.extendStart); - value = Tcl_SetVar2(interp, varName, NULL, resinfo, 0); + value = Tcl_SetVar(interp, varName, resinfo, 0); if (value == NULL) { Tcl_AppendResult(interp, "couldn't set variable \"", varName, "\"", NULL); @@ -4362,7 +4283,7 @@ StaticInitProc( Tcl_Interp *interp) /* Interpreter in which package is supposedly * being loaded. */ { - Tcl_SetVar2(interp, "x", NULL, "loaded", TCL_GLOBAL_ONLY); + Tcl_SetVar(interp, "x", "loaded", TCL_GLOBAL_ONLY); return TCL_OK; } @@ -4446,7 +4367,7 @@ TestupvarCmd( } else if (strcmp(argv[4], "namespace") == 0) { flags = TCL_NAMESPACE_ONLY; } - return Tcl_UpVar2(interp, argv[1], argv[2], NULL, argv[3], flags); + return Tcl_UpVar(interp, argv[1], argv[2], argv[3], flags); } else { if (strcmp(argv[5], "global") == 0) { flags = TCL_GLOBAL_ONLY; @@ -4486,7 +4407,7 @@ TestseterrorcodeCmd( const char **argv) /* Argument strings. */ { if (argc > 6) { - Tcl_AppendResult(interp, "too many args", NULL); + Tcl_SetResult(interp, "too many args", TCL_STATIC); return TCL_ERROR; } switch (argc) { @@ -4940,10 +4861,10 @@ GetTimesObjCmd( timePer/100000); /* Tcl_SetVar 100000 times */ - fprintf(stderr, "Tcl_SetVar2 of \"12345\" 100000 times\n"); + fprintf(stderr, "Tcl_SetVar of \"12345\" 100000 times\n"); Tcl_GetTime(&start); for (i = 0; i < 100000; i++) { - s = Tcl_SetVar2(interp, "a", NULL, "12345", TCL_LEAVE_ERR_MSG); + s = Tcl_SetVar(interp, "a", "12345", TCL_LEAVE_ERR_MSG); if (s == NULL) { return TCL_ERROR; } @@ -4957,7 +4878,7 @@ GetTimesObjCmd( fprintf(stderr, "Tcl_GetVar of a==\"12345\" 100000 times\n"); Tcl_GetTime(&start); for (i = 0; i < 100000; i++) { - s = Tcl_GetVar2(interp, "a", NULL, TCL_LEAVE_ERR_MSG); + s = Tcl_GetVar(interp, "a", TCL_LEAVE_ERR_MSG); if (s == NULL) { return TCL_ERROR; } @@ -5090,7 +5011,7 @@ TestsetCmd( const char *value; if (argc == 2) { - Tcl_AppendResult(interp, "before get", NULL); + Tcl_SetResult(interp, "before get", TCL_STATIC); value = Tcl_GetVar2(interp, argv[1], NULL, flags); if (value == NULL) { return TCL_ERROR; @@ -5098,7 +5019,7 @@ TestsetCmd( Tcl_AppendElement(interp, value); return TCL_OK; } else if (argc == 3) { - Tcl_AppendResult(interp, "before set", NULL); + Tcl_SetResult(interp, "before set", TCL_STATIC); value = Tcl_SetVar2(interp, argv[1], NULL, argv[2], flags); if (value == NULL) { return TCL_ERROR; @@ -5122,7 +5043,7 @@ Testset2Cmd( const char *value; if (argc == 3) { - Tcl_AppendResult(interp, "before get", NULL); + Tcl_SetResult(interp, "before get", TCL_STATIC); value = Tcl_GetVar2(interp, argv[1], argv[2], flags); if (value == NULL) { return TCL_ERROR; @@ -5130,7 +5051,7 @@ Testset2Cmd( Tcl_AppendElement(interp, value); return TCL_OK; } else if (argc == 4) { - Tcl_AppendResult(interp, "before set", NULL); + Tcl_SetResult(interp, "before set", TCL_STATIC); value = Tcl_SetVar2(interp, argv[1], argv[2], argv[3], flags); if (value == NULL) { return TCL_ERROR; @@ -5196,11 +5117,10 @@ TestsaveresultCmd( return TCL_ERROR; } - freeCount = 0; objPtr = NULL; /* Lint. */ switch ((enum options) index) { case RESULT_SMALL: - Tcl_AppendResult(interp, "small result", NULL); + Tcl_SetResult(interp, "small result", TCL_VOLATILE); break; case RESULT_APPEND: Tcl_AppendResult(interp, "append result", NULL); @@ -5221,12 +5141,13 @@ TestsaveresultCmd( break; } + freeCount = 0; Tcl_SaveResult(interp, &state); if (((enum options) index) == RESULT_OBJECT) { result = Tcl_EvalObjEx(interp, objv[2], 0); } else { - result = Tcl_EvalEx(interp, Tcl_GetString(objv[2]), -1, 0); + result = Tcl_Eval(interp, Tcl_GetString(objv[2])); } if (discard) { @@ -5238,9 +5159,11 @@ TestsaveresultCmd( switch ((enum options) index) { case RESULT_DYNAMIC: { - int presentOrFreed = (iPtr->freeProc == TestsaveresultFree) ^ freeCount; + int present = iPtr->freeProc == TestsaveresultFree; + int called = freeCount; - Tcl_AppendElement(interp, presentOrFreed ? "presentOrFreed" : "missingOrLeak"); + Tcl_AppendElement(interp, called ? "called" : "notCalled"); + Tcl_AppendElement(interp, present ? "present" : "missing"); break; } case RESULT_OBJECT: @@ -5306,7 +5229,7 @@ TestmainthreadCmd( Tcl_SetObjResult(interp, idObj); return TCL_OK; } else { - Tcl_AppendResult(interp, "wrong # args", NULL); + Tcl_SetResult(interp, "wrong # args", TCL_STATIC); return TCL_ERROR; } } @@ -6107,7 +6030,7 @@ TestWrongNumArgsObjCmd( * Don't use Tcl_WrongNumArgs here, as that is the function * we want to test! */ - Tcl_AppendResult(interp, "insufficient arguments", NULL); + Tcl_SetResult(interp, "insufficient arguments", TCL_STATIC); return TCL_ERROR; } @@ -6124,7 +6047,7 @@ TestWrongNumArgsObjCmd( /* * Asked for more arguments than were given. */ - Tcl_AppendResult(interp, "insufficient arguments", NULL); + Tcl_SetResult(interp, "insufficient arguments", TCL_STATIC); return TCL_ERROR; } @@ -6326,7 +6249,7 @@ TestReport( savedResult = Tcl_GetObjResult(interp); Tcl_IncrRefCount(savedResult); Tcl_SetObjResult(interp, Tcl_NewObj()); - Tcl_EvalEx(interp, Tcl_DStringValue(&ds), -1, 0); + Tcl_Eval(interp, Tcl_DStringValue(&ds)); Tcl_DStringFree(&ds); Tcl_ResetResult(interp); Tcl_SetObjResult(interp, savedResult); @@ -6789,7 +6712,7 @@ TestcpuidCmd( Tcl_Obj *const * objv) /* Parameter vector */ { int status, index, i; - int regs[4]; + unsigned int regs[4]; Tcl_Obj *regsObjs[4]; if (objc != 2) { @@ -6799,14 +6722,14 @@ TestcpuidCmd( if (Tcl_GetIntFromObj(interp, objv[1], &index) != TCL_OK) { return TCL_ERROR; } - status = TclWinCPUID(index, regs); + status = TclWinCPUID((unsigned) 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(regs[i]); + regsObjs[i] = Tcl_NewIntObj((int) regs[i]); } Tcl_SetObjResult(interp, Tcl_NewListObj(4, regsObjs)); return TCL_OK; @@ -6901,7 +6824,7 @@ TestgetintCmd( const char **argv) { if (argc < 2) { - Tcl_AppendResult(interp, "wrong # args", NULL); + Tcl_SetResult(interp, "wrong # args", TCL_STATIC); return TCL_ERROR; } else { int val, i, total=0; @@ -7425,7 +7348,7 @@ InterpCmdResolver( */ CallFrame *parentFramePtr = varFramePtr->callerPtr; - const char *context = parentFramePtr != NULL ? parentFramePtr->nsPtr->name : "(NULL)"; + 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 5627608..f7d2bae 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -622,9 +622,23 @@ TestindexobjCmd( } argv[objc-4] = NULL; + /* + * Tcl_GetIndexFromObj assumes that the table is statically-allocated so + * that its address is different for each index object. If we accidently + * allocate a table at the same address as that cached in the index + * object, clear out the object's cached state. + */ + + if (objv[3]->typePtr != NULL + && !strcmp("index", objv[3]->typePtr->name)) { + indexRep = objv[3]->internalRep.twoPtrValue.ptr1; + if (indexRep->tablePtr == (void *) argv) { + TclFreeIntRep(objv[3]); + } + } + result = Tcl_GetIndexFromObj((setError? interp : NULL), objv[3], - argv, "token", INDEX_TEMP_TABLE|(allowAbbrev? 0 : TCL_EXACT), - &index); + argv, "token", (allowAbbrev? 0 : TCL_EXACT), &index); ckfree(argv); if (result == TCL_OK) { Tcl_SetIntObj(Tcl_GetObjResult(interp), index); @@ -1101,7 +1115,7 @@ TestobjCmd( if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(varPtr[varIndex]->refCount)); + Tcl_SetObjResult(interp, Tcl_NewIntObj(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 8077de4..2ee758e 100644 --- a/generic/tclThreadAlloc.c +++ b/generic/tclThreadAlloc.c @@ -196,11 +196,20 @@ GetCache(void) if (listLockPtr == NULL) { Tcl_Mutex *initLockPtr; + unsigned int i; initLockPtr = Tcl_GetAllocMutex(); Tcl_MutexLock(initLockPtr); if (listLockPtr == NULL) { - TclInitThreadAlloc(); + 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(); + } } Tcl_MutexUnlock(initLockPtr); } @@ -1055,40 +1064,6 @@ 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(); -} /* *---------------------------------------------------------------------- diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c index 1a05f80..fcf3880 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); @@ -657,7 +657,7 @@ ThreadErrorProc( sprintf(buf, "%" TCL_LL_MODIFIER "d", (Tcl_WideInt)(size_t)Tcl_GetCurrentThread()); - errorInfo = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY); + errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY); if (errorProcString == NULL) { errChannel = Tcl_GetStdChannel(TCL_STDERR); Tcl_WriteChars(errChannel, "Error from thread ", -1); @@ -1032,8 +1032,8 @@ ThreadEventProc( code = Tcl_EvalEx(interp, threadEventPtr->script,-1,TCL_EVAL_GLOBAL); Tcl_DeleteThreadExitHandler(ThreadFreeProc, threadEventPtr->script); if (code != TCL_OK) { - errorCode = Tcl_GetVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY); - errorInfo = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY); + errorCode = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY); + errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY); } else { errorCode = errorInfo = NULL; } diff --git a/generic/tclTimer.c b/generic/tclTimer.c index 6d3938b..c10986a 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -91,7 +91,7 @@ typedef struct IdleHandler { * The structure defined below is used in this file only. */ -typedef struct { +typedef struct ThreadSpecificData { TimerHandler *firstTimerHandlerPtr; /* First event in queue. */ int lastTimerId; /* Timer identifier of most recently created * timer. */ @@ -900,10 +900,10 @@ Tcl_AfterObjCmd( } else { commandPtr = Tcl_ConcatObj(objc-2, objv+2);; } - command = TclGetStringFromObj(commandPtr, &length); + command = Tcl_GetStringFromObj(commandPtr, &length); for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; afterPtr = afterPtr->nextPtr) { - tempCommand = TclGetStringFromObj(afterPtr->commandPtr, + tempCommand = Tcl_GetStringFromObj(afterPtr->commandPtr, &tempLength); if ((length == tempLength) && !memcmp(command, tempCommand, (unsigned) length)) { diff --git a/generic/tclTomMath.decls b/generic/tclTomMath.decls index 74ccefc..610a031 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, const mp_int *b) + int TclBN_mp_init_copy(mp_int *a, 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(const mp_int *a, int radix, int *size) + int TclBN_mp_radix_size(mp_int *a, int radix, int *size) } declare 36 { int TclBN_mp_read_radix(mp_int *a, const char *str, int radix) @@ -233,11 +233,6 @@ 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 001019c..41512f0 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, tstdenis82@gmail.com, http://math.libtomcrypt.com + * Tom St Denis, tomstdenis@gmail.com, http://math.libtomcrypt.com */ #ifndef BN_H_ #define BN_H_ @@ -22,15 +22,33 @@ +#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_32BIT) || defined(MP_16BIT) || defined(MP_8BIT)) - #define MP_64BIT - #endif +#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 #endif /* some default configurations. @@ -43,89 +61,83 @@ extern "C" { */ #ifdef MP_8BIT #ifndef MP_DIGIT_DECLARED - typedef uint8_t mp_digit; + typedef unsigned char mp_digit; #define MP_DIGIT_DECLARED #endif - 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 + typedef unsigned short mp_word; #elif defined(MP_16BIT) #ifndef MP_DIGIT_DECLARED - typedef uint16_t mp_digit; + typedef unsigned short mp_digit; #define MP_DIGIT_DECLARED #endif - 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 + typedef unsigned long mp_word; #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 ulong64 mp_digit; + typedef unsigned long mp_digit; #define MP_DIGIT_DECLARED #endif -#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 + typedef unsigned long mp_word __attribute__ ((mode(TI))); - #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 - typedef unsigned long long ulong64; - typedef signed long long long64; +# 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 #endif #ifndef MP_DIGIT_DECLARED - typedef uint32_t mp_digit; + typedef unsigned int mp_digit; #define MP_DIGIT_DECLARED #endif - typedef ulong64 mp_word; + typedef ulong64 mp_word; #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 +# 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 (((CHAR_BIT * MP_SIZEOF_MP_DIGIT) - 1)) /* bits per digit */ - typedef uint_least32_t mp_min_u32; -#else - typedef mp_digit mp_min_u32; +/* 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 #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() + +/* 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 */ #endif #define MP_DIGIT_BIT DIGIT_BIT @@ -168,15 +180,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 @@ -197,7 +209,9 @@ typedef int ltm_prime_callback(unsigned char *dst, int len, void *dat); #define SIGN(m) ((m)->sign) /* error code to char* string */ -const char *mp_error_to_string(int code); +/* +char *mp_error_to_string(int code); +*/ /* ---> init and deinit bignum functions <--- */ /* init a bignum */ @@ -242,9 +256,8 @@ 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] & 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) +#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) /* set to zero */ /* @@ -261,25 +274,9 @@ 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); @@ -297,7 +294,7 @@ int mp_copy(const mp_int *a, mp_int *b); /* inits and copies, a = b */ /* -int mp_init_copy(mp_int *a, const mp_int *b); +int mp_init_copy(mp_int *a, mp_int *b); */ /* trim unused digits */ @@ -305,16 +302,6 @@ int mp_init_copy(mp_int *a, const 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 */ @@ -327,7 +314,7 @@ void mp_rshd(mp_int *a, int b); int mp_lshd(mp_int *a, int b); */ -/* c = a / 2**b, implemented as c = a >> b */ +/* c = a / 2**b */ /* int mp_div_2d(const mp_int *a, int b, mp_int *c, mp_int *d); */ @@ -337,7 +324,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, implemented as c = a << b */ +/* c = a * 2**b */ /* int mp_mul_2d(const mp_int *a, int b, mp_int *c); */ @@ -347,7 +334,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**b */ +/* c = a mod 2**d */ /* int mp_mod_2d(const mp_int *a, int b, mp_int *c); */ @@ -473,9 +460,6 @@ 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 */ /* @@ -531,20 +515,12 @@ 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); @@ -647,7 +623,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[PRIME_SIZE]; +MODULE_SCOPE const mp_digit ltm_prime_tab[]; #endif /* result=1 if a is divisible by one of the first PRIME_SIZE primes */ @@ -713,6 +689,7 @@ int mp_prime_next_prime(mp_int *a, int t, int bbs_style); * * 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 @@ -765,17 +742,15 @@ 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(const mp_int *a, int radix, int *size); +int mp_radix_size(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) @@ -789,14 +764,69 @@ 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) -#ifdef __cplusplus - } -#endif +/* 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 -/* $Source$ */ -/* $Revision$ */ -/* $Date$ */ - +#endif diff --git a/generic/tclTomMathDecls.h b/generic/tclTomMathDecls.h index 209c486..2ce9d5a 100644 --- a/generic/tclTomMathDecls.h +++ b/generic/tclTomMathDecls.h @@ -73,7 +73,6 @@ #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 @@ -191,7 +190,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, const mp_int *b); +EXTERN int TclBN_mp_init_copy(mp_int *a, mp_int *b); /* 23 */ EXTERN int TclBN_mp_init_multi(mp_int *a, ...); /* 24 */ @@ -217,8 +216,7 @@ 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(const mp_int *a, int radix, - int *size); +EXTERN int TclBN_mp_radix_size(mp_int *a, int radix, int *size); /* 36 */ EXTERN int TclBN_mp_read_radix(mp_int *a, const char *str, int radix); @@ -289,9 +287,6 @@ 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; @@ -319,7 +314,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, const mp_int *b); /* 22 */ + int (*tclBN_mp_init_copy) (mp_int *a, 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 */ @@ -332,7 +327,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) (const mp_int *a, int radix, int *size); /* 35 */ + int (*tclBN_mp_radix_size) (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 */ @@ -364,7 +359,6 @@ 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; @@ -513,8 +507,6 @@ 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 bea3162..4e74c54 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 */ - size_t refCount; /* Used to ensure this structure is not + int 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. */ @@ -143,7 +143,7 @@ static int TraceVarEx(Tcl_Interp *interp, const char *part1, * trace procs */ -typedef struct { +typedef struct StringTraceData { ClientData clientData; /* Client data from Tcl_CreateTrace */ Tcl_CmdTraceProc *proc; /* Trace function from Tcl_CreateTrace */ } StringTraceData; @@ -278,7 +278,7 @@ Tcl_TraceObjCmd( opsList = Tcl_NewObj(); Tcl_IncrRefCount(opsList); - flagOps = TclGetStringFromObj(objv[3], &numFlags); + flagOps = Tcl_GetStringFromObj(objv[3], &numFlags); if (numFlags == 0) { Tcl_DecrRefCount(opsList); goto badVarOps; @@ -462,7 +462,7 @@ TraceExecutionObjCmd( break; } } - command = TclGetStringFromObj(objv[5], &commandLength); + command = Tcl_GetStringFromObj(objv[5], &commandLength); length = (size_t) commandLength; if ((enum traceOptions) optionIndex == TRACE_ADD) { TraceCommandInfo *tcmdPtr = ckalloc( @@ -701,7 +701,7 @@ TraceCommandObjCmd( } } - command = TclGetStringFromObj(objv[5], &commandLength); + command = Tcl_GetStringFromObj(objv[5], &commandLength); length = (size_t) commandLength; if ((enum traceOptions) optionIndex == TRACE_ADD) { TraceCommandInfo *tcmdPtr = ckalloc( @@ -904,7 +904,7 @@ TraceVariableObjCmd( break; } } - command = TclGetStringFromObj(objv[5], &commandLength); + command = Tcl_GetStringFromObj(objv[5], &commandLength); length = (size_t) commandLength; if ((enum traceOptions) optionIndex == TRACE_ADD) { CombinedTraceVarInfo *ctvarPtr = ckalloc( diff --git a/generic/tclUtf.c b/generic/tclUtf.c index b33bf6a..68119a4 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -75,11 +75,17 @@ static const unsigned char totalBytes[256] = { #endif 1,1,1,1,1,1,1,1 }; + +/* + * Functions used only in this module. + */ + +static int UtfCount(int ch); /* *--------------------------------------------------------------------------- * - * TclUtfCount -- + * UtfCount -- * * Find the number of bytes in the Utf character "ch". * @@ -92,8 +98,8 @@ static const unsigned char totalBytes[256] = { *--------------------------------------------------------------------------- */ -int -TclUtfCount( +INLINE static int +UtfCount( int ch) /* The Tcl_UniChar whose size is returned. */ { if ((unsigned)(ch - 1) < (UNICODE_SELF - 1)) { @@ -128,7 +134,7 @@ TclUtfCount( *--------------------------------------------------------------------------- */ -int +INLINE int Tcl_UniCharToUtf( int ch, /* The Tcl_UniChar to be stored in the * buffer. */ @@ -803,7 +809,7 @@ Tcl_UtfToUpper( * char to dst if its size is <= the original char. */ - if (bytes < TclUtfCount(upChar)) { + if (bytes < UtfCount(upChar)) { memcpy(dst, src, (size_t) bytes); dst += bytes; } else { @@ -856,7 +862,7 @@ Tcl_UtfToLower( * char to dst if its size is <= the original char. */ - if (bytes < TclUtfCount(lowChar)) { + if (bytes < UtfCount(lowChar)) { memcpy(dst, src, (size_t) bytes); dst += bytes; } else { @@ -906,7 +912,7 @@ Tcl_UtfToTitle( bytes = TclUtfToUniChar(src, &ch); titleChar = Tcl_UniCharToTitle(ch); - if (bytes < TclUtfCount(titleChar)) { + if (bytes < UtfCount(titleChar)) { memcpy(dst, src, (size_t) bytes); dst += bytes; } else { @@ -918,7 +924,7 @@ Tcl_UtfToTitle( bytes = TclUtfToUniChar(src, &ch); lowChar = Tcl_UniCharToLower(ch); - if (bytes < TclUtfCount(lowChar)) { + if (bytes < UtfCount(lowChar)) { memcpy(dst, src, (size_t) bytes); dst += bytes; } else { diff --git a/generic/tclUtil.c b/generic/tclUtil.c index a4d523a..553593c 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -1384,7 +1384,7 @@ TclConvertElement( */ if ((src == NULL) || (length == 0) || (*src == '\0' && length == -1)) { - src = &tclEmptyString; + src = tclEmptyStringRep; length = 0; conversion = CONVERT_BRACE; } @@ -1968,7 +1968,7 @@ Tcl_ConcatObj( if (TclListObjIsCanonical(objPtr)) { continue; } - TclGetStringFromObj(objPtr, &length); + Tcl_GetStringFromObj(objPtr, &length); if (length > 0) { break; } @@ -2677,7 +2677,7 @@ TclDStringAppendObj( Tcl_Obj *objPtr) { int length; - char *bytes = TclGetStringFromObj(objPtr, &length); + char *bytes = Tcl_GetStringFromObj(objPtr, &length); return Tcl_DStringAppend(dsPtr, bytes, length); } @@ -2894,6 +2894,7 @@ Tcl_DStringResult( Tcl_DString *dsPtr) /* Dynamic string that is to become the * result of interp. */ { + Tcl_ResetResult(interp); Tcl_SetObjResult(interp, TclDStringToObj(dsPtr)); } @@ -2923,14 +2924,6 @@ 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) { @@ -2939,7 +2932,7 @@ Tcl_DStringGetResult( /* * Do more efficient transfer when we know the result is a Tcl_Obj. When - * there's no string result, we only have to deal with two cases: + * there's no st`ring 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. @@ -2954,17 +2947,17 @@ Tcl_DStringGetResult( if (!iPtr->result[0] && iPtr->objResultPtr && !Tcl_IsShared(iPtr->objResultPtr)) { - if (iPtr->objResultPtr->bytes == &tclEmptyString) { + if (iPtr->objResultPtr->bytes == tclEmptyStringRep) { dsPtr->string = dsPtr->staticSpace; dsPtr->string[0] = 0; dsPtr->length = 0; dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; } else { - dsPtr->string = TclGetString(iPtr->objResultPtr); + dsPtr->string = Tcl_GetString(iPtr->objResultPtr); dsPtr->length = iPtr->objResultPtr->length; dsPtr->spaceAvl = dsPtr->length + 1; TclFreeIntRep(iPtr->objResultPtr); - iPtr->objResultPtr->bytes = &tclEmptyString; + iPtr->objResultPtr->bytes = tclEmptyStringRep; iPtr->objResultPtr->length = 0; } return; @@ -3002,7 +2995,6 @@ Tcl_DStringGetResult( iPtr->result = iPtr->resultSpace; iPtr->resultSpace[0] = 0; -#endif /* !TCL_NO_DEPRECATED */ } /* @@ -3584,7 +3576,7 @@ TclGetIntForIndex( int *indexPtr) /* Location filled in with an integer * representing an index. */ { - size_t length; + int length; char *opPtr; const char *bytes; @@ -3602,8 +3594,7 @@ TclGetIntForIndex( return TCL_OK; } - bytes = TclGetString(objPtr); - length = objPtr->length; + bytes = TclGetStringFromObj(objPtr, &length); /* * Leading whitespace is acceptable in an index. @@ -3648,7 +3639,7 @@ TclGetIntForIndex( parseError: if (interp != NULL) { - bytes = TclGetString(objPtr); + bytes = Tcl_GetString(objPtr); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad index \"%s\": must be integer?[+-]integer? or" " end?[+-]integer?", bytes)); @@ -4009,10 +4000,9 @@ TclSetProcessGlobalValue( } else { Tcl_CreateExitHandler(FreeProcessGlobalValue, pgvPtr); } - bytes = TclGetString(newValue); - pgvPtr->numBytes = newValue->length; + bytes = Tcl_GetStringFromObj(newValue, &pgvPtr->numBytes); pgvPtr->value = ckalloc(pgvPtr->numBytes + 1); - memcpy(pgvPtr->value, bytes, pgvPtr->numBytes + 1); + memcpy(pgvPtr->value, bytes, (unsigned) pgvPtr->numBytes + 1); if (pgvPtr->encoding) { Tcl_FreeEncoding(pgvPtr->encoding); } @@ -4027,7 +4017,7 @@ TclSetProcessGlobalValue( Tcl_IncrRefCount(newValue); cacheMap = GetThreadHash(&pgvPtr->key); ClearHash(cacheMap); - hPtr = Tcl_CreateHashEntry(cacheMap, (void *)(pgvPtr->epoch), &dummy); + hPtr = Tcl_CreateHashEntry(cacheMap, INT2PTR(pgvPtr->epoch), &dummy); Tcl_SetHashValue(hPtr, newValue); Tcl_MutexUnlock(&pgvPtr->mutex); } @@ -4053,7 +4043,7 @@ TclGetProcessGlobalValue( Tcl_Obj *value = NULL; Tcl_HashTable *cacheMap; Tcl_HashEntry *hPtr; - size_t epoch = pgvPtr->epoch; + int epoch = pgvPtr->epoch; if (pgvPtr->encoding) { Tcl_Encoding current = Tcl_GetEncoding(NULL, NULL); @@ -4068,7 +4058,8 @@ TclGetProcessGlobalValue( Tcl_DString native, newValue; Tcl_MutexLock(&pgvPtr->mutex); - epoch = ++pgvPtr->epoch; + pgvPtr->epoch++; + epoch = pgvPtr->epoch; Tcl_UtfToExternalDString(pgvPtr->encoding, pgvPtr->value, pgvPtr->numBytes, &native); Tcl_ExternalToUtfDString(current, Tcl_DStringValue(&native), @@ -4087,7 +4078,7 @@ TclGetProcessGlobalValue( } } cacheMap = GetThreadHash(&pgvPtr->key); - hPtr = Tcl_FindHashEntry(cacheMap, (void *) (epoch)); + hPtr = Tcl_FindHashEntry(cacheMap, (char *) INT2PTR(epoch)); if (NULL == hPtr) { int dummy; @@ -4120,7 +4111,7 @@ TclGetProcessGlobalValue( value = Tcl_NewStringObj(pgvPtr->value, pgvPtr->numBytes); hPtr = Tcl_CreateHashEntry(cacheMap, - (void *)(pgvPtr->epoch), &dummy); + INT2PTR(pgvPtr->epoch), &dummy); Tcl_MutexUnlock(&pgvPtr->mutex); Tcl_SetHashValue(hPtr, value); Tcl_IncrRefCount(value); @@ -4203,10 +4194,11 @@ TclGetObjNameOfExecutable(void) const char * Tcl_GetNameOfExecutable(void) { - Tcl_Obj *obj = TclGetObjNameOfExecutable(); - const char *bytes = TclGetString(obj); + int numBytes; + const char *bytes = + Tcl_GetStringFromObj(TclGetObjNameOfExecutable(), &numBytes); - if (obj->length == 0) { + if (numBytes == 0) { return NULL; } return bytes; diff --git a/generic/tclVar.c b/generic/tclVar.c index 5ab6e8b..30e2f9b 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -149,7 +149,6 @@ static const char *isArrayElement = */ typedef struct ArraySearch { - Tcl_Obj *name; /* Name of this search */ int id; /* Integer id used to distinguish among * multiple concurrent searches for the same * array. */ @@ -189,7 +188,8 @@ static ArraySearch * ParseSearchId(Tcl_Interp *interp, const Var *varPtr, static void UnsetVarStruct(Var *varPtr, Var *arrayPtr, Interp *iPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags, int index); -static Var * VerifyArray(Tcl_Interp *interp, Tcl_Obj *varNameObj); +static int SetArraySearchObj(Tcl_Interp *interp, + Tcl_Obj *objPtr); /* * Functions defined in this file that may be exported in the future for use @@ -202,9 +202,14 @@ MODULE_SCOPE Var * TclLookupSimpleVar(Tcl_Interp *interp, static Tcl_DupInternalRepProc DupLocalVarName; static Tcl_FreeInternalRepProc FreeLocalVarName; +static Tcl_UpdateStringProc PanicOnUpdateVarName; static Tcl_FreeInternalRepProc FreeParsedVarName; static Tcl_DupInternalRepProc DupParsedVarName; +static Tcl_UpdateStringProc UpdateParsedVarName; + +static Tcl_UpdateStringProc PanicOnUpdateVarName; +static Tcl_SetFromAnyProc PanicOnSetVarName; /* * Types of Tcl_Objs used to cache variable lookups. @@ -223,14 +228,30 @@ static Tcl_DupInternalRepProc DupParsedVarName; static const Tcl_ObjType localVarNameType = { "localVarName", - FreeLocalVarName, DupLocalVarName, NULL, NULL + FreeLocalVarName, DupLocalVarName, PanicOnUpdateVarName, PanicOnSetVarName }; static const Tcl_ObjType tclParsedVarNameType = { "parsedVarName", - FreeParsedVarName, DupParsedVarName, NULL, NULL + FreeParsedVarName, DupParsedVarName, UpdateParsedVarName, PanicOnSetVarName }; +/* + * Type of Tcl_Objs used to speed up array searches. + * + * INTERNALREP DEFINITION: + * twoPtrValue.ptr1: searchIdNumber (cast to pointer) + * twoPtrValue.ptr2: variableNameStartInString (cast to pointer) + * + * Note that the value stored in ptr2 is the offset into the string of the + * start of the variable name and not the address of the variable name itself, + * as this can be safely copied. + */ + +const Tcl_ObjType tclArraySearchType = { + "array search", + NULL, NULL, NULL, SetArraySearchObj +}; Var * TclVarHashCreateVar( @@ -501,13 +522,17 @@ TclObjLookupVarEx( * is set to NULL. */ { Interp *iPtr = (Interp *) interp; - CallFrame *varFramePtr = iPtr->varFramePtr; register Var *varPtr; /* Points to the variable's in-frame Var * structure. */ - const char *errMsg = NULL; - int index, parsed = 0; + const char *part1; + int index, len1, len2; + int parsed = 0; + Tcl_Obj *objPtr; const Tcl_ObjType *typePtr = part1Ptr->typePtr; - + const char *errMsg = NULL; + CallFrame *varFramePtr = iPtr->varFramePtr; + const char *part2 = part2Ptr? TclGetString(part2Ptr):NULL; + char *newPart2 = NULL; *arrayPtrPtr = NULL; if (typePtr == &localVarNameType) { @@ -523,7 +548,7 @@ TclObjLookupVarEx( */ Tcl_Obj *namePtr = part1Ptr->internalRep.twoPtrValue.ptr1; - Tcl_Obj *checkNamePtr = localName(varFramePtr, localIndex); + Tcl_Obj *checkNamePtr = localName(iPtr->varFramePtr, localIndex); if ((!namePtr && (checkNamePtr == part1Ptr)) || (namePtr && (checkNamePtr == namePtr))) { @@ -554,7 +579,13 @@ TclObjLookupVarEx( } return NULL; } - part2Ptr = part1Ptr->internalRep.twoPtrValue.ptr2; + part2 = newPart2 = part1Ptr->internalRep.twoPtrValue.ptr2; + if (newPart2) { + part2Ptr = Tcl_NewStringObj(newPart2, -1); + if (createPart2) { + Tcl_IncrRefCount(part2Ptr); + } + } part1Ptr = part1Ptr->internalRep.twoPtrValue.ptr1; typePtr = part1Ptr->typePtr; if (typePtr == &localVarNameType) { @@ -563,23 +594,18 @@ TclObjLookupVarEx( } parsed = 1; } + part1 = TclGetStringFromObj(part1Ptr, &len1); - if (!parsed) { - + if (!parsed && len1 && (*(part1 + len1 - 1) == ')')) { /* * part1Ptr is possibly an unparsed array element. */ - int len; - const char *part1 = TclGetStringFromObj(part1Ptr, &len); - - if (len > 1 && (part1[len - 1] == ')')) { - - const char *part2 = strchr(part1, '('); - - if (part2) { - Tcl_Obj *arrayPtr; + register int i; + len2 = -1; + for (i = 0; i < len1; i++) { + if (*(part1 + i) == '(') { if (part2Ptr != NULL) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg, @@ -590,19 +616,50 @@ TclObjLookupVarEx( return NULL; } - arrayPtr = Tcl_NewStringObj(part1, (part2 - part1)); - part2Ptr = Tcl_NewStringObj(part2 + 1, len - (part2 - part1) - 2); + /* + * part1Ptr points to an array element; first copy the element + * name to a new string part2. + */ - TclFreeIntRep(part1Ptr); + part2 = part1 + i + 1; + len2 = len1 - i - 2; + len1 = i; + + newPart2 = ckalloc(len2 + 1); + memcpy(newPart2, part2, (unsigned) len2); + *(newPart2+len2) = '\0'; + part2 = newPart2; + part2Ptr = Tcl_NewStringObj(newPart2, -1); + if (createPart2) { + Tcl_IncrRefCount(part2Ptr); + } - Tcl_IncrRefCount(arrayPtr); - part1Ptr->internalRep.twoPtrValue.ptr1 = arrayPtr; - Tcl_IncrRefCount(part2Ptr); - part1Ptr->internalRep.twoPtrValue.ptr2 = part2Ptr; - part1Ptr->typePtr = &tclParsedVarNameType; + /* + * Free the internal rep of the original part1Ptr, now renamed + * objPtr, and set it to tclParsedVarNameType. + */ + + objPtr = part1Ptr; + TclFreeIntRep(objPtr); + objPtr->typePtr = &tclParsedVarNameType; + + /* + * Define a new string object to hold the new part1Ptr, i.e., + * the array name. Set the internal rep of objPtr, reset + * typePtr and part1 to contain the references to the array + * name. + */ + + TclNewStringObj(part1Ptr, part1, len1); + Tcl_IncrRefCount(part1Ptr); - part1Ptr = arrayPtr; - } + objPtr->internalRep.twoPtrValue.ptr1 = part1Ptr; + objPtr->internalRep.twoPtrValue.ptr2 = (void *) part2; + + typePtr = part1Ptr->typePtr; + part1 = TclGetString(part1Ptr); + break; + } } } @@ -612,6 +669,8 @@ TclObjLookupVarEx( * the cached types if possible. */ + TclFreeIntRep(part1Ptr); + varPtr = TclLookupSimpleVar(interp, part1Ptr, flags, createPart1, &errMsg, &index); if (varPtr == NULL) { @@ -620,6 +679,9 @@ TclObjLookupVarEx( Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", TclGetString(part1Ptr), NULL); } + if (newPart2) { + Tcl_DecrRefCount(part2Ptr); + } return NULL; } @@ -627,12 +689,11 @@ TclObjLookupVarEx( * Cache the newly found variable if possible. */ - TclFreeIntRep(part1Ptr); if (index >= 0) { /* * An indexed local variable. */ - Tcl_Obj *cachedNamePtr = localName(varFramePtr, index); + Tcl_Obj *cachedNamePtr = localName(iPtr->varFramePtr, index); part1Ptr->typePtr = &localVarNameType; if (part1Ptr != cachedNamePtr) { @@ -669,6 +730,9 @@ TclObjLookupVarEx( *arrayPtrPtr = varPtr; varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, flags, msg, createPart1, createPart2, varPtr, -1); + if (newPart2) { + Tcl_DecrRefCount(part2Ptr); + } } return varPtr; } @@ -2847,22 +2911,34 @@ TclArraySet( */ /* ARGSUSED */ - -static Var * -VerifyArray( +static int +ArrayStartSearchCmd( + ClientData clientData, Tcl_Interp *interp, - Tcl_Obj *varNameObj) + int objc, + Tcl_Obj *const objv[]) { Interp *iPtr = (Interp *) interp; - const char *varName = TclGetString(varNameObj); - Var *arrayPtr; + Var *varPtr, *arrayPtr; + Tcl_HashEntry *hPtr; + Tcl_Obj *varNameObj; + int isNew; + ArraySearch *searchPtr; + const char *varName; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "arrayName"); + return TCL_ERROR; + } + varNameObj = objv[1]; /* * Locate the array variable. */ - Var *varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, + varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); + varName = TclGetString(varNameObj); /* * Special array trace used to keep the env array in sync for array names, @@ -2874,7 +2950,7 @@ VerifyArray( if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { - return NULL; + return TCL_ERROR; } } @@ -2884,36 +2960,11 @@ VerifyArray( * traces. */ - if ((varPtr == NULL) || !TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr)) { + if ((varPtr == NULL) || !TclIsVarArray(varPtr) + || TclIsVarUndefined(varPtr)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" isn't an array", varName)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", varName, NULL); - return NULL; - } - - return varPtr; -} - -static int -ArrayStartSearchCmd( - ClientData clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - Interp *iPtr = (Interp *) interp; - Var *varPtr; - Tcl_HashEntry *hPtr; - int isNew; - ArraySearch *searchPtr; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "arrayName"); - return TCL_ERROR; - } - - varPtr = VerifyArray(interp, objv[1]); - if (varPtr == NULL) { return TCL_ERROR; } @@ -2935,9 +2986,8 @@ ArrayStartSearchCmd( searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr, &searchPtr->search); Tcl_SetHashValue(hPtr, searchPtr); - searchPtr->name = Tcl_ObjPrintf("s-%d-%s", searchPtr->id, TclGetString(objv[1])); - Tcl_IncrRefCount(searchPtr->name); - Tcl_SetObjResult(interp, searchPtr->name); + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("s-%d-%s", searchPtr->id, varName)); return TCL_OK; } @@ -2967,7 +3017,7 @@ ArrayAnyMoreCmd( Tcl_Obj *const objv[]) { Interp *iPtr = (Interp *) interp; - Var *varPtr; + Var *varPtr, *arrayPtr; Tcl_Obj *varNameObj, *searchObj; int gotValue; ArraySearch *searchPtr; @@ -2979,8 +3029,39 @@ ArrayAnyMoreCmd( varNameObj = objv[1]; searchObj = objv[2]; - varPtr = VerifyArray(interp, varNameObj); - if (varPtr == NULL) { + /* + * Locate the array variable. + */ + + varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, + /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); + + /* + * Special array trace used to keep the env array in sync for array names, + * array get, etc. + */ + + if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) + && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { + if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, + (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| + TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { + return TCL_ERROR; + } + } + + /* + * Verify that it is indeed an array variable. This test comes after the + * traces - the variable may actually become an array as an effect of said + * traces. + */ + + if ((varPtr == NULL) || !TclIsVarArray(varPtr) + || TclIsVarUndefined(varPtr)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't an array", TclGetString(varNameObj))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", + TclGetString(varNameObj), NULL); return TCL_ERROR; } @@ -3042,7 +3123,8 @@ ArrayNextElementCmd( int objc, Tcl_Obj *const objv[]) { - Var *varPtr; + Interp *iPtr = (Interp *) interp; + Var *varPtr, *arrayPtr; Tcl_Obj *varNameObj, *searchObj; ArraySearch *searchPtr; @@ -3053,8 +3135,39 @@ ArrayNextElementCmd( varNameObj = objv[1]; searchObj = objv[2]; - varPtr = VerifyArray(interp, varNameObj); - if (varPtr == NULL) { + /* + * Locate the array variable. + */ + + varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, + /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); + + /* + * Special array trace used to keep the env array in sync for array names, + * array get, etc. + */ + + if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) + && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { + if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, + (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| + TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { + return TCL_ERROR; + } + } + + /* + * Verify that it is indeed an array variable. This test comes after the + * traces - the variable may actually become an array as an effect of said + * traces. + */ + + if ((varPtr == NULL) || !TclIsVarArray(varPtr) + || TclIsVarUndefined(varPtr)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't an array", TclGetString(varNameObj))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", + TclGetString(varNameObj), NULL); return TCL_ERROR; } @@ -3120,7 +3233,7 @@ ArrayDoneSearchCmd( Tcl_Obj *const objv[]) { Interp *iPtr = (Interp *) interp; - Var *varPtr; + Var *varPtr, *arrayPtr; Tcl_HashEntry *hPtr; Tcl_Obj *varNameObj, *searchObj; ArraySearch *searchPtr, *prevPtr; @@ -3132,8 +3245,39 @@ ArrayDoneSearchCmd( varNameObj = objv[1]; searchObj = objv[2]; - varPtr = VerifyArray(interp, varNameObj); - if (varPtr == NULL) { + /* + * Locate the array variable. + */ + + varPtr = TclObjLookupVarEx(interp, varNameObj, NULL, /*flags*/ 0, + /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); + + /* + * Special array trace used to keep the env array in sync for array names, + * array get, etc. + */ + + if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) + && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { + if (TclObjCallVarTraces(iPtr, arrayPtr, varPtr, varNameObj, NULL, + (TCL_LEAVE_ERR_MSG|TCL_NAMESPACE_ONLY|TCL_GLOBAL_ONLY| + TCL_TRACE_ARRAY), /* leaveErrMsg */ 1, -1) == TCL_ERROR) { + return TCL_ERROR; + } + } + + /* + * Verify that it is indeed an array variable. This test comes after the + * traces - the variable may actually become an array as an effect of said + * traces. + */ + + if ((varPtr == NULL) || !TclIsVarArray(varPtr) + || TclIsVarUndefined(varPtr)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "\"%s\" isn't an array", TclGetString(varNameObj))); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAY", + TclGetString(varNameObj), NULL); return TCL_ERROR; } @@ -3167,7 +3311,6 @@ ArrayDoneSearchCmd( } } } - Tcl_DecrRefCount(searchPtr->name); ckfree(searchPtr); return TCL_OK; } @@ -4807,6 +4950,75 @@ Tcl_UpvarObjCmd( /* *---------------------------------------------------------------------- * + * SetArraySearchObj -- + * + * This function converts the given tcl object into one that has the + * "array search" internal type. + * + * Results: + * TCL_OK if the conversion succeeded, and TCL_ERROR if it failed (when + * an error message will be placed in the interpreter's result.) + * + * Side effects: + * Updates the internal type and representation of the object to make + * this an array-search object. See the tclArraySearchType declaration + * above for details of the internal representation. + * + *---------------------------------------------------------------------- + */ + +static int +SetArraySearchObj( + Tcl_Interp *interp, + Tcl_Obj *objPtr) +{ + const char *string; + char *end; /* Can't be const due to strtoul defn. */ + int id; + size_t offset; + + /* + * Get the string representation. Make it up-to-date if necessary. + */ + + string = TclGetString(objPtr); + + /* + * Parse the id into the three parts separated by dashes. + */ + + if ((string[0] != 's') || (string[1] != '-')) { + goto syntax; + } + id = strtoul(string+2, &end, 10); + if ((end == (string+2)) || (*end != '-')) { + goto syntax; + } + + /* + * Can't perform value check in this context, so place reference to place + * in string to use for the check in the object instead. + */ + + end++; + offset = end - string; + + TclFreeIntRep(objPtr); + objPtr->typePtr = &tclArraySearchType; + objPtr->internalRep.twoPtrValue.ptr1 = INT2PTR(id); + objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(offset); + return TCL_OK; + + syntax: + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "illegal search identifier \"%s\"", string)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", string, NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * * ParseSearchId -- * * This function translates from a tcl object to a pointer to an active @@ -4817,6 +5029,10 @@ Tcl_UpvarObjCmd( * or NULL if there isn't one. If NULL is returned, the interp's result * contains an error message. * + * Side effects: + * The tcl object might have its internal type and representation + * modified. + * *---------------------------------------------------------------------- */ @@ -4832,43 +5048,65 @@ ParseSearchId( * name. */ { Interp *iPtr = (Interp *) interp; + register const char *string; + register size_t offset; + int id; ArraySearch *searchPtr; - const char *handle = TclGetString(handleObj); - char *end; + const char *varName = TclGetString(varNamePtr); + + /* + * Parse the id. + */ + + if ((handleObj->typePtr != &tclArraySearchType) + && (SetArraySearchObj(interp, handleObj) != TCL_OK)) { + return NULL; + } + + /* + * Extract the information out of the Tcl_Obj. + */ + + id = PTR2INT(handleObj->internalRep.twoPtrValue.ptr1); + string = TclGetString(handleObj); + offset = PTR2INT(handleObj->internalRep.twoPtrValue.ptr2); + + /* + * This test cannot be placed inside the Tcl_Obj machinery, since it is + * dependent on the variable context. + */ + + if (strcmp(string+offset, varName) != 0) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "search identifier \"%s\" isn't for variable \"%s\"", + string, varName)); + goto badLookup; + } + + /* + * Search through the list of active searches on the interpreter to see if + * the desired one exists. + * + * Note that we cannot store the searchPtr directly in the Tcl_Obj as that + * would run into trouble when DeleteSearches() was called so we must scan + * this list every time. + */ if (varPtr->flags & VAR_SEARCH_ACTIVE) { Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&iPtr->varSearches, varPtr); - /* First look for same (Tcl_Obj *) */ for (searchPtr = Tcl_GetHashValue(hPtr); searchPtr != NULL; searchPtr = searchPtr->nextPtr) { - if (searchPtr->name == handleObj) { + if (searchPtr->id == id) { return searchPtr; } } - /* Fallback: do string compares. */ - for (searchPtr = Tcl_GetHashValue(hPtr); searchPtr != NULL; - searchPtr = searchPtr->nextPtr) { - if (strcmp(TclGetString(searchPtr->name), handle) == 0) { - return searchPtr; - } - } - } - if ((handle[0] != 's') || (handle[1] != '-') - || (strtoul(handle + 2, &end, 10), end == (handle + 2)) - || (*end != '-')) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "illegal search identifier \"%s\"", handle)); - } else if (strcmp(end + 1, TclGetString(varNamePtr)) != 0) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "search identifier \"%s\" isn't for variable \"%s\"", - handle, TclGetString(varNamePtr))); - } else { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't find search \"%s\"", handle)); } - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", handle, NULL); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "couldn't find search \"%s\"", string)); + badLookup: + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", string, NULL); return NULL; } @@ -4903,7 +5141,6 @@ DeleteSearches( for (searchPtr = Tcl_GetHashValue(sPtr); searchPtr != NULL; searchPtr = nextPtr) { nextPtr = searchPtr->nextPtr; - Tcl_DecrRefCount(searchPtr->name); ckfree(searchPtr); } arrayVarPtr->flags &= ~VAR_SEARCH_ACTIVE; @@ -5277,6 +5514,28 @@ TclObjVarErrMsg( */ /* + * Panic functions that should never be called in normal operation. + */ + +static void +PanicOnUpdateVarName( + Tcl_Obj *objPtr) +{ + Tcl_Panic("%s of type %s should not be called", "updateStringProc", + objPtr->typePtr->name); +} + +static int +PanicOnSetVarName( + Tcl_Interp *interp, + Tcl_Obj *objPtr) +{ + Tcl_Panic("%s of type %s should not be called", "setFromAnyProc", + objPtr->typePtr->name); + return TCL_ERROR; +} + +/* * localVarName - * * INTERNALREP DEFINITION: @@ -5329,11 +5588,11 @@ FreeParsedVarName( Tcl_Obj *objPtr) { register Tcl_Obj *arrayPtr = objPtr->internalRep.twoPtrValue.ptr1; - register Tcl_Obj *elem = objPtr->internalRep.twoPtrValue.ptr2; + register char *elem = objPtr->internalRep.twoPtrValue.ptr2; if (arrayPtr != NULL) { TclDecrRefCount(arrayPtr); - TclDecrRefCount(elem); + ckfree(elem); } objPtr->typePtr = NULL; } @@ -5344,17 +5603,58 @@ DupParsedVarName( Tcl_Obj *dupPtr) { register Tcl_Obj *arrayPtr = srcPtr->internalRep.twoPtrValue.ptr1; - register Tcl_Obj *elem = srcPtr->internalRep.twoPtrValue.ptr2; + register char *elem = srcPtr->internalRep.twoPtrValue.ptr2; + char *elemCopy; + unsigned elemLen; if (arrayPtr != NULL) { Tcl_IncrRefCount(arrayPtr); - Tcl_IncrRefCount(elem); + elemLen = strlen(elem); + elemCopy = ckalloc(elemLen + 1); + memcpy(elemCopy, elem, elemLen); + *(elemCopy + elemLen) = '\0'; + elem = elemCopy; } dupPtr->internalRep.twoPtrValue.ptr1 = arrayPtr; dupPtr->internalRep.twoPtrValue.ptr2 = elem; dupPtr->typePtr = &tclParsedVarNameType; } + +static void +UpdateParsedVarName( + Tcl_Obj *objPtr) +{ + Tcl_Obj *arrayPtr = objPtr->internalRep.twoPtrValue.ptr1; + char *part2 = objPtr->internalRep.twoPtrValue.ptr2; + const char *part1; + char *p; + int len1, len2, totalLen; + + if (arrayPtr == NULL) { + /* + * This is a parsed scalar name: what is it doing here? + */ + + Tcl_Panic("scalar parsedVarName without a string rep"); + } + + part1 = TclGetStringFromObj(arrayPtr, &len1); + len2 = strlen(part2); + + totalLen = len1 + len2 + 2; + p = ckalloc(totalLen + 1); + objPtr->bytes = p; + objPtr->length = totalLen; + + memcpy(p, part1, (unsigned) len1); + p += len1; + *p++ = '('; + memcpy(p, part2, (unsigned) len2); + p += len2; + *p++ = ')'; + *p = '\0'; +} /* *---------------------------------------------------------------------- diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 96b8318..fc20d7e 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -373,7 +373,7 @@ ConvertErrorToList( default: TclNewLiteralStringObj(objv[2], "UNKNOWN"); - TclNewLongObj(objv[3], code); + TclNewIntObj(objv[3], code); return Tcl_NewListObj(4, objv); } } @@ -440,7 +440,7 @@ GenerateHeader( if (GetValue(interp, dictObj, "comment", &value) != TCL_OK) { goto error; } else if (value != NULL) { - valueStr = TclGetStringFromObj(value, &len); + valueStr = Tcl_GetStringFromObj(value, &len); Tcl_UtfToExternal(NULL, latin1enc, valueStr, len, 0, NULL, headerPtr->nativeCommentBuf, MAX_COMMENT_LEN-1, NULL, &len, NULL); @@ -461,7 +461,7 @@ GenerateHeader( if (GetValue(interp, dictObj, "filename", &value) != TCL_OK) { goto error; } else if (value != NULL) { - valueStr = TclGetStringFromObj(value, &len); + valueStr = Tcl_GetStringFromObj(value, &len); Tcl_UtfToExternal(NULL, latin1enc, valueStr, len, 0, NULL, headerPtr->nativeFilenameBuf, MAXPATHLEN-1, NULL, &len, NULL); headerPtr->nativeFilenameBuf[len] = '\0'; @@ -3113,30 +3113,28 @@ ZlibTransformOutput( errorCodePtr); } + /* + * No zero-length writes. Flushes must be explicit. + */ + + if (toWrite == 0) { + return 0; + } + cd->outStream.next_in = (Bytef *) buf; cd->outStream.avail_in = toWrite; - do { + while (cd->outStream.avail_in > 0) { e = Deflate(&cd->outStream, cd->outBuffer, cd->outAllocated, Z_NO_FLUSH, &produced); + if (e != Z_OK || produced == 0) { + break; + } - if ((e == Z_OK && produced > 0) || e == Z_BUF_ERROR) { - /* - * deflate() indicates that it is out of space by returning - * 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) { - produced = cd->outAllocated; - e = Z_OK; - } - if (Tcl_WriteRaw(cd->parent, cd->outBuffer, produced) < 0) { - *errorCodePtr = Tcl_GetErrno(); - return -1; - } + if (Tcl_WriteRaw(cd->parent, cd->outBuffer, produced) < 0) { + *errorCodePtr = Tcl_GetErrno(); + return -1; } - } while (e == Z_OK && produced > 0 && cd->outStream.avail_in > 0); + } if (e == Z_OK) { return toWrite - cd->outStream.avail_in; @@ -3389,7 +3387,7 @@ ZlibTransformGetOption( } else { if (cd->compDictObj) { int len; - const char *str = TclGetStringFromObj(cd->compDictObj, &len); + const char *str = Tcl_GetStringFromObj(cd->compDictObj, &len); Tcl_DStringAppend(dsPtr, str, len); } |