diff options
Diffstat (limited to 'generic')
115 files changed, 24836 insertions, 11232 deletions
diff --git a/generic/regc_lex.c b/generic/regc_lex.c index affcb48..4c8f15f 100644 --- a/generic/regc_lex.c +++ b/generic/regc_lex.c @@ -457,7 +457,7 @@ next( if (ATEOS()) { FAILW(REG_EESCAPE); } - (DISCARD)lexescape(v); + (void)lexescape(v); switch (v->nexttype) { /* not all escapes okay here */ case PLAIN: return 1; @@ -716,7 +716,7 @@ next( } RETV(PLAIN, *v->now++); } - (DISCARD)lexescape(v); + (void)lexescape(v); if (ISERR()) { FAILW(REG_EESCAPE); } @@ -1143,7 +1143,7 @@ skip( /* - newline - return the chr for a newline * This helps confine use of CHR to this source file. - ^ static chr newline(NOPARMS); + ^ static chr newline(void); */ static chr newline(void) diff --git a/generic/regc_locale.c b/generic/regc_locale.c index 6efab07..0614fb6 100644 --- a/generic/regc_locale.c +++ b/generic/regc_locale.c @@ -833,7 +833,7 @@ element( */ Tcl_DStringInit(&ds); - np = Tcl_UniCharToUtfDString(startp, (int)len, &ds); + np = Tcl_UniCharToUtfDString(startp, len, &ds); for (cn=cnames; cn->name!=NULL; cn++) { if (strlen(cn->name)==len && strncmp(cn->name, np, len)==0) { break; /* NOTE BREAK OUT */ @@ -1245,7 +1245,7 @@ cmp( const chr *x, const chr *y, /* strings to compare */ size_t len) /* exact length of comparison */ { - return memcmp(VS(x), VS(y), len*sizeof(chr)); + return memcmp((void*)(x), (void*)(y), len*sizeof(chr)); } /* diff --git a/generic/regc_nfa.c b/generic/regc_nfa.c index 088c6c0..240fcfe 100644 --- a/generic/regc_nfa.c +++ b/generic/regc_nfa.c @@ -843,7 +843,7 @@ moveins( /* - copyins - copy in arcs of a state to another state - ^ static VOID copyins(struct nfa *, struct state *, struct state *, int); + ^ static void copyins(struct nfa *, struct state *, struct state *, int); */ static void copyins( @@ -1100,7 +1100,7 @@ moveouts( /* - copyouts - copy out arcs of a state to another state - ^ static VOID copyouts(struct nfa *, struct state *, struct state *, int); + ^ static void copyouts(struct nfa *, struct state *, struct state *, int); */ static void copyouts( diff --git a/generic/regcomp.c b/generic/regcomp.c index 211cd70..49b024f 100644 --- a/generic/regcomp.c +++ b/generic/regcomp.c @@ -82,7 +82,7 @@ static int lexescape(struct vars *); static int lexdigits(struct vars *, int, int, int); static int brenext(struct vars *, pchr); static void skip(struct vars *); -static chr newline(NOPARMS); +static chr newline(void); static chr chrnamed(struct vars *, const chr *, const chr *, pchr); /* === regc_color.c === */ static void initcm(struct vars *, struct colormap *); @@ -206,11 +206,11 @@ struct vars { int cflags; /* copy of compile flags */ int lasttype; /* type of previous token */ int nexttype; /* type of next token */ - chr nextvalue; /* value (if any) of next token */ + int nextvalue; /* value (if any) of next token */ int lexcon; /* lexical context type (see lex.c) */ int nsubexp; /* subexpression count */ struct subre **subs; /* subRE pointer vector */ - size_t nsubs; /* length of vector */ + int nsubs; /* length of vector */ struct subre *sub10[10]; /* initial vector, enough for most */ struct nfa *nfa; /* the NFA */ struct colormap *cm; /* character color map */ @@ -287,8 +287,7 @@ compile( { AllocVars(v); struct guts *g; - int i; - size_t j; + int i, j; FILE *debug = (flags®_PROGRESS) ? stdout : NULL; #define CNOERR() { if (ISERR()) return freev(v, v->err); } @@ -341,13 +340,13 @@ compile( re->re_info = 0; /* bits get set during parse */ re->re_csize = sizeof(chr); re->re_guts = NULL; - re->re_fns = VS(&functions); + re->re_fns = (void*)(&functions); /* * More complex setup, malloced things. */ - re->re_guts = VS(MALLOC(sizeof(struct guts))); + re->re_guts = (void*)(MALLOC(sizeof(struct guts))); if (re->re_guts == NULL) { return freev(v, REG_ESPACE); } @@ -434,7 +433,7 @@ compile( * Can sacrifice main NFA now, so use it as work area. */ - (DISCARD) optimize(v->nfa, debug); + (void) optimize(v->nfa, debug); CNOERR(); makesearch(v, v->nfa); CNOERR(); @@ -477,10 +476,10 @@ moresubs( int wanted) /* want enough room for this one */ { struct subre **p; - size_t n; + int n; - assert(wanted > 0 && (size_t)wanted >= v->nsubs); - n = (size_t)wanted * 3 / 2 + 1; + assert(wanted > 0 && wanted >= v->nsubs); + n = wanted * 3 / 2 + 1; if (v->subs == v->sub10) { p = (struct subre **) MALLOC(n * sizeof(struct subre *)); if (p != NULL) { @@ -499,7 +498,7 @@ moresubs( *p = NULL; } assert(v->nsubs == n); - assert((size_t)wanted < v->nsubs); + assert(wanted < v->nsubs); } /* @@ -954,10 +953,10 @@ parseqatom( if (cap) { v->nsubexp++; subno = v->nsubexp; - if ((size_t)subno >= v->nsubs) { + if (subno >= v->nsubs) { moresubs(v, subno); } - assert((size_t)subno < v->nsubs); + assert(subno < v->nsubs); } else { atomtype = PLAIN; /* something that's not '(' */ } @@ -1920,10 +1919,10 @@ nfatree( assert(t != NULL && t->begin != NULL); if (t->left != NULL) { - (DISCARD) nfatree(v, t->left, f); + (void) nfatree(v, t->left, f); } if (t->right != NULL) { - (DISCARD) nfatree(v, t->right, f); + (void) nfatree(v, t->right, f); } return nfanode(v, t, f); diff --git a/generic/regcustom.h b/generic/regcustom.h index 681b97d..4396399 100644 --- a/generic/regcustom.h +++ b/generic/regcustom.h @@ -36,10 +36,9 @@ * Overrides for regguts.h definitions, if any. */ -#define FUNCPTR(name, args) (*name)args -#define MALLOC(n) VS(attemptckalloc(n)) -#define FREE(p) ckfree(VS(p)) -#define REALLOC(p,n) VS(attemptckrealloc(VS(p),n)) +#define MALLOC(n) (void*)(attemptckalloc(n)) +#define FREE(p) ckfree((void*)(p)) +#define REALLOC(p,n) (void*)(attemptckrealloc((void*)(p),n)) /* * Do not insert extras between the "begin" and "end" lines - this chunk is @@ -92,7 +91,7 @@ typedef int celt; /* Type to hold chr, or NOCELT */ #if TCL_UTF_MAX > 4 #define CHRBITS 32 /* Bits in a chr; must not use sizeof */ #define CHR_MIN 0x00000000 /* Smallest and largest chr; the value */ -#define CHR_MAX 0xffffffff /* CHR_MAX-CHR_MIN+1 should fit in uchr */ +#define CHR_MAX 0x10ffff /* CHR_MAX-CHR_MIN+1 should fit in uchr */ #else #define CHRBITS 16 /* Bits in a chr; must not use sizeof */ #define CHR_MIN 0x0000 /* Smallest and largest chr; the value */ @@ -132,7 +131,7 @@ typedef int celt; /* Type to hold chr, or NOCELT */ #if 1 #define AllocVars(vPtr) \ static Tcl_ThreadDataKey varsKey; \ - register struct vars *vPtr = (struct vars *) \ + struct vars *vPtr = (struct vars *) \ Tcl_GetThreadData(&varsKey, sizeof(struct vars)) #else /* @@ -141,7 +140,7 @@ typedef int celt; /* Type to hold chr, or NOCELT */ * faster in practice (measured!) */ #define AllocVars(vPtr) \ - register struct vars *vPtr = (struct vars *) MALLOC(sizeof(struct vars)) + struct vars *vPtr = (struct vars *) MALLOC(sizeof(struct vars)) #define FreeVars(vPtr) \ FREE(vPtr) #endif diff --git a/generic/regex.h b/generic/regex.h index 8845f72..f3159c6 100644 --- a/generic/regex.h +++ b/generic/regex.h @@ -151,8 +151,8 @@ typedef struct { int re_csize; /* sizeof(character) */ char *re_endp; /* backward compatibility kludge */ /* the rest is opaque pointers to hidden innards */ - char *re_guts; /* `char *' is more portable than `void *' */ - char *re_fns; + void *re_guts; + void *re_fns; } regex_t; /* result reporting (may acquire more fields later) */ diff --git a/generic/regexec.c b/generic/regexec.c index 6d12827..1a3e114 100644 --- a/generic/regexec.c +++ b/generic/regexec.c @@ -44,7 +44,7 @@ struct sset { /* state set */ unsigned hash; /* hash of bitvector */ #define HASH(bv, nw) (((nw) == 1) ? *(bv) : hash(bv, nw)) #define HIT(h,bv,ss,nw) ((ss)->hash == (h) && ((nw) == 1 || \ - memcmp(VS(bv), VS((ss)->states), (nw)*sizeof(unsigned)) == 0)) + memcmp((void*)(bv), (void*)((ss)->states), (nw)*sizeof(unsigned)) == 0)) int flags; #define STARTER 01 /* the initial state set */ #define POSTSTATE 02 /* includes the goal state */ @@ -172,8 +172,8 @@ exec( { AllocVars(v); int st, backref; - size_t n; - size_t i; + int n; + int i; #define LOCALMAT 20 regmatch_t mat[LOCALMAT]; #define LOCALDFAS 40 @@ -236,7 +236,7 @@ exec( v->stop = (chr *)string + len; v->err = 0; assert(v->g->ntree >= 0); - n = (size_t) v->g->ntree; + n = v->g->ntree; if (n <= LOCALDFAS) v->subdfas = subdfas; else @@ -268,7 +268,7 @@ exec( if (st == REG_OKAY && v->pmatch != pmatch && nmatch > 0) { zapallsubs(pmatch, nmatch); n = (nmatch < v->nmatch) ? nmatch : v->nmatch; - memcpy(VS(pmatch), VS(v->pmatch), n*sizeof(regmatch_t)); + memcpy((void*)(pmatch), (void*)(v->pmatch), n*sizeof(regmatch_t)); } /* @@ -278,7 +278,7 @@ exec( if (v->pmatch != pmatch && v->pmatch != mat) { FREE(v->pmatch); } - n = (size_t) v->g->ntree; + n = v->g->ntree; for (i = 0; i < n; i++) { if (v->subdfas[i] != NULL) freeDFA(v->subdfas[i]); @@ -889,7 +889,7 @@ cbrdissect( MDEBUG(("cbackref n%d %d{%d-%d}\n", t->id, n, min, max)); /* get the backreferenced string */ - if (v->pmatch[n].rm_so == -1) { + if (v->pmatch[n].rm_so == TCL_INDEX_NONE) { return REG_NOMATCH; } brstring = v->start + v->pmatch[n].rm_so; diff --git a/generic/regguts.h b/generic/regguts.h index 1ac2465..da38ef2 100644 --- a/generic/regguts.h +++ b/generic/regguts.h @@ -49,41 +49,15 @@ #include <assert.h> #endif -/* voids */ -#ifndef VOID -#define VOID void /* for function return values */ -#endif -#ifndef DISCARD -#define DISCARD void /* for throwing values away */ -#endif -#ifndef PVOID -#define PVOID void * /* generic pointer */ -#endif -#ifndef VS -#define VS(x) ((void*)(x)) /* cast something to generic ptr */ -#endif -#ifndef NOPARMS -#define NOPARMS void /* for empty parm lists */ -#endif - -/* function-pointer declarator */ -#ifndef FUNCPTR -#if __STDC__ >= 1 -#define FUNCPTR(name, args) (*name)args -#else -#define FUNCPTR(name, args) (*name)() -#endif -#endif - /* memory allocation */ #ifndef MALLOC #define MALLOC(n) malloc(n) #endif #ifndef REALLOC -#define REALLOC(p, n) realloc(VS(p), n) +#define REALLOC(p, n) realloc(p, n) #endif #ifndef FREE -#define FREE(p) free(VS(p)) +#define FREE(p) free(p) #endif /* want size of a char in bits, and max value in bounded quantifiers */ @@ -96,7 +70,6 @@ */ #define NOTREACHED 0 -#define xxx 1 #define DUPMAX _POSIX2_RE_DUP_MAX #define DUPINF (DUPMAX+1) @@ -408,7 +381,7 @@ struct subre { */ struct fns { - void FUNCPTR(free, (regex_t *)); + void (*free) (regex_t *); }; /* @@ -425,7 +398,7 @@ struct guts { struct cnfa search; /* for fast preliminary search */ int ntree; /* number of subre's, plus one */ struct colormap cmap; - int FUNCPTR(compare, (const chr *, const chr *, size_t)); + int (*compare) (const chr *, const chr *, size_t); struct subre *lacons; /* lookahead-constraint vector */ int nlacons; /* size of lacons */ }; @@ -438,7 +411,7 @@ struct guts { #ifndef AllocVars #define AllocVars(vPtr) \ struct vars var; \ - register struct vars *vPtr = &var + struct vars *vPtr = &var #endif #ifndef FreeVars #define FreeVars(vPtr) ((void) 0) diff --git a/generic/tcl.decls b/generic/tcl.decls index b62cd28..19672a7 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -32,7 +32,7 @@ declare 0 { const char *version, const void *clientData) } declare 1 { - CONST84_RETURN char *Tcl_PkgRequireEx(Tcl_Interp *interp, + const char *Tcl_PkgRequireEx(Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr) } @@ -104,7 +104,7 @@ declare 20 { declare 21 { int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file, int line) } -declare 22 { +declare 22 {deprecated {No longer in use, changed to macro}} { Tcl_Obj *Tcl_DbNewBooleanObj(int boolValue, const char *file, int line) } declare 23 { @@ -119,7 +119,7 @@ declare 25 { Tcl_Obj *Tcl_DbNewListObj(int objc, Tcl_Obj *const *objv, const char *file, int line) } -declare 26 { +declare 26 {deprecated {No longer in use, changed to macro}} { Tcl_Obj *Tcl_DbNewLongObj(long longValue, const char *file, int line) } declare 27 { @@ -132,8 +132,9 @@ declare 28 { declare 29 { Tcl_Obj *Tcl_DuplicateObj(Tcl_Obj *objPtr) } +# Only available as stub-entry, for backwards-compatible stub-enabled extensions declare 30 { - void TclFreeObj(Tcl_Obj *objPtr) + void TclOldFreeObj(Tcl_Obj *objPtr) } declare 31 { int Tcl_GetBoolean(Tcl_Interp *interp, const char *src, int *boolPtr) @@ -152,9 +153,9 @@ declare 35 { int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr) } -declare 36 { +declare 36 {deprecated {No longer in use, changed to macro}} { int Tcl_GetIndexFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - CONST84 char *const *tablePtr, const char *msg, int flags, int *indexPtr) + const char *const *tablePtr, const char *msg, int flags, int *indexPtr) } declare 37 { int Tcl_GetInt(Tcl_Interp *interp, const char *src, int *intPtr) @@ -198,7 +199,7 @@ declare 48 { int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, int objc, Tcl_Obj *const objv[]) } -declare 49 { +declare 49 {deprecated {No longer in use, changed to macro}} { Tcl_Obj *Tcl_NewBooleanObj(int boolValue) } declare 50 { @@ -207,13 +208,13 @@ declare 50 { declare 51 { Tcl_Obj *Tcl_NewDoubleObj(double doubleValue) } -declare 52 { +declare 52 {deprecated {No longer in use, changed to macro}} { Tcl_Obj *Tcl_NewIntObj(int intValue) } declare 53 { Tcl_Obj *Tcl_NewListObj(int objc, Tcl_Obj *const objv[]) } -declare 54 { +declare 54 {deprecated {No longer in use, changed to macro}} { Tcl_Obj *Tcl_NewLongObj(long longValue) } declare 55 { @@ -222,7 +223,7 @@ declare 55 { declare 56 { Tcl_Obj *Tcl_NewStringObj(const char *bytes, int length) } -declare 57 { +declare 57 {deprecated {No longer in use, changed to macro}} { void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue) } declare 58 { @@ -235,13 +236,13 @@ declare 59 { declare 60 { void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue) } -declare 61 { +declare 61 {deprecated {No longer in use, changed to macro}} { void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue) } declare 62 { void Tcl_SetListObj(Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[]) } -declare 63 { +declare 63 {deprecated {No longer in use, changed to macro}} { void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue) } declare 64 { @@ -250,10 +251,10 @@ declare 64 { declare 65 { void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, int length) } -declare 66 { +declare 66 {deprecated {No longer in use, changed to macro}} { void Tcl_AddErrorInfo(Tcl_Interp *interp, const char *message) } -declare 67 { +declare 67 {deprecated {No longer in use, changed to macro}} { void Tcl_AddObjErrorInfo(Tcl_Interp *interp, const char *message, int length) } @@ -282,10 +283,10 @@ declare 74 { declare 75 { int Tcl_AsyncReady(void) } -declare 76 { +declare 76 {deprecated {No longer in use, changed to macro}} { void Tcl_BackgroundError(Tcl_Interp *interp) } -declare 77 { +declare 77 {deprecated {Use Tcl_UtfBackslash}} { char Tcl_Backslash(const char *src, int *readPtr) } declare 78 { @@ -306,7 +307,7 @@ declare 82 { int Tcl_CommandComplete(const char *cmd) } declare 83 { - char *Tcl_Concat(int argc, CONST84 char *const *argv) + char *Tcl_Concat(int argc, const char *const *argv) } declare 84 { int Tcl_ConvertElement(const char *src, char *dst, int flags) @@ -318,7 +319,7 @@ declare 85 { declare 86 { int Tcl_CreateAlias(Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int argc, - CONST84 char *const *argv) + const char *const *argv) } declare 87 { int Tcl_CreateAliasObj(Tcl_Interp *slave, const char *slaveCmd, @@ -352,7 +353,7 @@ declare 93 { declare 94 { Tcl_Interp *Tcl_CreateInterp(void) } -declare 95 { +declare 95 {deprecated {}} { void Tcl_CreateMathFunc(Tcl_Interp *interp, const char *name, int numArgs, Tcl_ValueType *argTypes, Tcl_MathProc *proc, ClientData clientData) @@ -461,10 +462,10 @@ declare 126 { int Tcl_Eof(Tcl_Channel chan) } declare 127 { - CONST84_RETURN char *Tcl_ErrnoId(void) + const char *Tcl_ErrnoId(void) } declare 128 { - CONST84_RETURN char *Tcl_ErrnoMsg(int err) + const char *Tcl_ErrnoMsg(int err) } declare 129 { int Tcl_Eval(Tcl_Interp *interp, const char *script) @@ -472,7 +473,7 @@ declare 129 { declare 130 { int Tcl_EvalFile(Tcl_Interp *interp, const char *fileName) } -declare 131 { +declare 131 {deprecated {No longer in use, changed to macro}} { int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr) } declare 132 { @@ -513,7 +514,7 @@ declare 142 { declare 143 { void Tcl_Finalize(void) } -declare 144 { +declare 144 {nostub {Don't use this function in a stub-enabled extension}} { void Tcl_FindExecutable(const char *argv0) } declare 145 { @@ -528,12 +529,12 @@ declare 147 { } declare 148 { int Tcl_GetAlias(Tcl_Interp *interp, const char *slaveCmd, - Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, - int *argcPtr, CONST84 char ***argvPtr) + Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, + int *argcPtr, const char ***argvPtr) } declare 149 { int Tcl_GetAliasObj(Tcl_Interp *interp, const char *slaveCmd, - Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, + Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv) } declare 150 { @@ -558,7 +559,7 @@ declare 155 { int Tcl_GetChannelMode(Tcl_Channel chan) } declare 156 { - CONST84_RETURN char *Tcl_GetChannelName(Tcl_Channel chan) + const char *Tcl_GetChannelName(Tcl_Channel chan) } declare 157 { int Tcl_GetChannelOption(Tcl_Interp *interp, Tcl_Channel chan, @@ -572,14 +573,14 @@ declare 159 { Tcl_CmdInfo *infoPtr) } declare 160 { - CONST84_RETURN char *Tcl_GetCommandName(Tcl_Interp *interp, + const char *Tcl_GetCommandName(Tcl_Interp *interp, Tcl_Command command) } declare 161 { int Tcl_GetErrno(void) } declare 162 { - CONST84_RETURN char *Tcl_GetHostName(void) + const char *Tcl_GetHostName(void) } declare 163 { int Tcl_GetInterpPath(Tcl_Interp *askInterp, Tcl_Interp *slaveInterp) @@ -622,20 +623,20 @@ declare 173 { Tcl_Channel Tcl_GetStdChannel(int type) } declare 174 { - CONST84_RETURN char *Tcl_GetStringResult(Tcl_Interp *interp) + const char *Tcl_GetStringResult(Tcl_Interp *interp) } -declare 175 { - CONST84_RETURN char *Tcl_GetVar(Tcl_Interp *interp, const char *varName, +declare 175 {deprecated {No longer in use, changed to macro}} { + const char *Tcl_GetVar(Tcl_Interp *interp, const char *varName, int flags) } declare 176 { - CONST84_RETURN char *Tcl_GetVar2(Tcl_Interp *interp, const char *part1, + const char *Tcl_GetVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags) } declare 177 { int Tcl_GlobalEval(Tcl_Interp *interp, const char *command) } -declare 178 { +declare 178 {deprecated {No longer in use, changed to macro}} { int Tcl_GlobalEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr) } declare 179 { @@ -662,11 +663,11 @@ declare 185 { } # Obsolete, use Tcl_FSJoinPath declare 186 { - char *Tcl_JoinPath(int argc, CONST84 char *const *argv, + char *Tcl_JoinPath(int argc, const char *const *argv, Tcl_DString *resultPtr) } declare 187 { - int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, char *addr, + int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, void *addr, int type) } @@ -685,7 +686,7 @@ declare 191 { Tcl_Channel Tcl_MakeTcpClientChannel(ClientData tcpSocket) } declare 192 { - char *Tcl_Merge(int argc, CONST84 char *const *argv) + char *Tcl_Merge(int argc, const char *const *argv) } declare 193 { Tcl_HashEntry *Tcl_NextHashEntry(Tcl_HashSearch *searchPtr) @@ -703,7 +704,7 @@ declare 196 { } declare 197 { Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp, int argc, - CONST84 char **argv, int flags) + const char **argv, int flags) } # This is obsolete, use Tcl_FSOpenFileChannel declare 198 { @@ -729,7 +730,7 @@ declare 203 { int Tcl_PutEnv(const char *assignment) } declare 204 { - CONST84_RETURN char *Tcl_PosixError(Tcl_Interp *interp) + const char *Tcl_PosixError(Tcl_Interp *interp) } declare 205 { void Tcl_QueueEvent(Tcl_Event *evPtr, Tcl_QueuePosition position) @@ -765,7 +766,7 @@ declare 214 { } declare 215 { void Tcl_RegExpRange(Tcl_RegExp regexp, int index, - CONST84 char **startPtr, CONST84 char **endPtr) + const char **startPtr, const char **endPtr) } declare 216 { void Tcl_Release(ClientData clientData) @@ -779,8 +780,7 @@ declare 218 { declare 219 { int Tcl_ScanCountedElement(const char *src, int length, int *flagPtr) } -# Obsolete -declare 220 { +declare 220 {deprecated {}} { int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode) } declare 221 { @@ -813,7 +813,7 @@ declare 228 { declare 229 { void Tcl_SetMaxBlockTime(const Tcl_Time *timePtr) } -declare 230 { +declare 230 {nostub {Don't use this function in a stub-enabled extension}} { void Tcl_SetPanicProc(TCL_NORETURN1 Tcl_PanicProc *panicProc) } declare 231 { @@ -835,43 +835,42 @@ declare 235 { declare 236 { void Tcl_SetStdChannel(Tcl_Channel channel, int type) } -declare 237 { - CONST84_RETURN char *Tcl_SetVar(Tcl_Interp *interp, const char *varName, +declare 237 {deprecated {No longer in use, changed to macro}} { + const char *Tcl_SetVar(Tcl_Interp *interp, const char *varName, const char *newValue, int flags) } declare 238 { - CONST84_RETURN char *Tcl_SetVar2(Tcl_Interp *interp, const char *part1, + const char *Tcl_SetVar2(Tcl_Interp *interp, const char *part1, const char *part2, const char *newValue, int flags) } declare 239 { - CONST84_RETURN char *Tcl_SignalId(int sig) + const char *Tcl_SignalId(int sig) } declare 240 { - CONST84_RETURN char *Tcl_SignalMsg(int sig) + const char *Tcl_SignalMsg(int sig) } declare 241 { void Tcl_SourceRCFile(Tcl_Interp *interp) } declare 242 { int Tcl_SplitList(Tcl_Interp *interp, const char *listStr, int *argcPtr, - CONST84 char ***argvPtr) + const char ***argvPtr) } # Obsolete, use Tcl_FSSplitPath declare 243 { - void Tcl_SplitPath(const char *path, int *argcPtr, CONST84 char ***argvPtr) + void Tcl_SplitPath(const char *path, int *argcPtr, const char ***argvPtr) } -declare 244 { +declare 244 {nostub {Don't use this function in a stub-enabled extension}} { void Tcl_StaticPackage(Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc) } -declare 245 { +declare 245 {deprecated {No longer in use, changed to macro}} { int Tcl_StringMatch(const char *str, const char *pattern) } -# Obsolete -declare 246 { +declare 246 {deprecated {}} { int Tcl_TellOld(Tcl_Channel chan) } -declare 247 { +declare 247 {deprecated {No longer in use, changed to macro}} { int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData) } @@ -892,14 +891,14 @@ declare 251 { declare 252 { int Tcl_UnregisterChannel(Tcl_Interp *interp, Tcl_Channel chan) } -declare 253 { +declare 253 {deprecated {No longer in use, changed to macro}} { int Tcl_UnsetVar(Tcl_Interp *interp, const char *varName, int flags) } declare 254 { int Tcl_UnsetVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags) } -declare 255 { +declare 255 {deprecated {No longer in use, changed to macro}} { void Tcl_UntraceVar(Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData) } @@ -911,7 +910,7 @@ declare 256 { declare 257 { void Tcl_UpdateLinkedVar(Tcl_Interp *interp, const char *varName) } -declare 258 { +declare 258 {deprecated {No longer in use, changed to macro}} { int Tcl_UpVar(Tcl_Interp *interp, const char *frameName, const char *varName, const char *localName, int flags) } @@ -922,7 +921,7 @@ declare 259 { declare 260 { int Tcl_VarEval(Tcl_Interp *interp, ...) } -declare 261 { +declare 261 {deprecated {No longer in use, changed to macro}} { ClientData Tcl_VarTraceInfo(Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData) } @@ -944,47 +943,47 @@ declare 265 { declare 266 { void Tcl_ValidateAllMemory(const char *file, int line) } -declare 267 { +declare 267 {deprecated {see TIP #422}} { void Tcl_AppendResultVA(Tcl_Interp *interp, va_list argList) } -declare 268 { +declare 268 {deprecated {see TIP #422}} { void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, va_list argList) } declare 269 { char *Tcl_HashStats(Tcl_HashTable *tablePtr) } declare 270 { - CONST84_RETURN char *Tcl_ParseVar(Tcl_Interp *interp, const char *start, - CONST84 char **termPtr) + const char *Tcl_ParseVar(Tcl_Interp *interp, const char *start, + const char **termPtr) } -declare 271 { - CONST84_RETURN char *Tcl_PkgPresent(Tcl_Interp *interp, const char *name, +declare 271 {deprecated {No longer in use, changed to macro}} { + const char *Tcl_PkgPresent(Tcl_Interp *interp, const char *name, const char *version, int exact) } declare 272 { - CONST84_RETURN char *Tcl_PkgPresentEx(Tcl_Interp *interp, + const char *Tcl_PkgPresentEx(Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr) } -declare 273 { +declare 273 {deprecated {No longer in use, changed to macro}} { int Tcl_PkgProvide(Tcl_Interp *interp, const char *name, const char *version) } # TIP #268: The internally used new Require function is in slot 573. -declare 274 { - CONST84_RETURN char *Tcl_PkgRequire(Tcl_Interp *interp, const char *name, +declare 274 {deprecated {No longer in use, changed to macro}} { + const char *Tcl_PkgRequire(Tcl_Interp *interp, const char *name, const char *version, int exact) } -declare 275 { +declare 275 {deprecated {see TIP #422}} { void Tcl_SetErrorCodeVA(Tcl_Interp *interp, va_list argList) } -declare 276 { +declare 276 {deprecated {see TIP #422}} { int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList) } declare 277 { Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options) } -declare 278 { +declare 278 {deprecated {see TIP #422}} { TCL_NORETURN void Tcl_PanicVA(const char *format, va_list argList) } declare 279 { @@ -1058,7 +1057,7 @@ declare 293 { int Tcl_EvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags) } declare 294 { - void Tcl_ExitThread(int status) + TCL_NORETURN void Tcl_ExitThread(int status) } declare 295 { int Tcl_ExternalToUtf(Tcl_Interp *interp, Tcl_Encoding encoding, @@ -1086,7 +1085,7 @@ declare 301 { Tcl_Encoding Tcl_GetEncoding(Tcl_Interp *interp, const char *name) } declare 302 { - CONST84_RETURN char *Tcl_GetEncodingName(Tcl_Encoding encoding) + const char *Tcl_GetEncodingName(Tcl_Encoding encoding) } declare 303 { void Tcl_GetEncodingNames(Tcl_Interp *interp) @@ -1147,22 +1146,22 @@ declare 319 { Tcl_QueuePosition position) } declare 320 { - Tcl_UniChar Tcl_UniCharAtIndex(const char *src, int index) + int Tcl_UniCharAtIndex(const char *src, int index) } declare 321 { - Tcl_UniChar Tcl_UniCharToLower(int ch) + int Tcl_UniCharToLower(int ch) } declare 322 { - Tcl_UniChar Tcl_UniCharToTitle(int ch) + int Tcl_UniCharToTitle(int ch) } declare 323 { - Tcl_UniChar Tcl_UniCharToUpper(int ch) + int Tcl_UniCharToUpper(int ch) } declare 324 { int Tcl_UniCharToUtf(int ch, char *buf) } declare 325 { - CONST84_RETURN char *Tcl_UtfAtIndex(const char *src, int index) + const char *Tcl_UtfAtIndex(const char *src, int index) } declare 326 { int Tcl_UtfCharComplete(const char *src, int length) @@ -1171,16 +1170,16 @@ declare 327 { int Tcl_UtfBackslash(const char *src, int *readPtr, char *dst) } declare 328 { - CONST84_RETURN char *Tcl_UtfFindFirst(const char *src, int ch) + const char *Tcl_UtfFindFirst(const char *src, int ch) } declare 329 { - CONST84_RETURN char *Tcl_UtfFindLast(const char *src, int ch) + const char *Tcl_UtfFindLast(const char *src, int ch) } declare 330 { - CONST84_RETURN char *Tcl_UtfNext(const char *src) + const char *Tcl_UtfNext(const char *src) } declare 331 { - CONST84_RETURN char *Tcl_UtfPrev(const char *src, const char *start) + const char *Tcl_UtfPrev(const char *src, const char *start) } declare 332 { int Tcl_UtfToExternal(Tcl_Interp *interp, Tcl_Encoding encoding, @@ -1213,10 +1212,10 @@ declare 339 { declare 340 { char *Tcl_GetString(Tcl_Obj *objPtr) } -declare 341 { - CONST84_RETURN char *Tcl_GetDefaultEncodingDir(void) +declare 341 {deprecated {Use Tcl_GetEncodingSearchPath}} { + const char *Tcl_GetDefaultEncodingDir(void) } -declare 342 { +declare 342 {deprecated {Use Tcl_SetEncodingSearchPath}} { void Tcl_SetDefaultEncodingDir(const char *path) } declare 343 { @@ -1265,7 +1264,7 @@ declare 356 { Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj, int flags) } -declare 357 { +declare 357 {deprecated {Use Tcl_EvalTokensStandard}} { Tcl_Obj *Tcl_EvalTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, int count) } @@ -1278,7 +1277,7 @@ declare 359 { } declare 360 { int Tcl_ParseBraces(Tcl_Interp *interp, const char *start, int numBytes, - Tcl_Parse *parsePtr, int append, CONST84 char **termPtr) + Tcl_Parse *parsePtr, int append, const char **termPtr) } declare 361 { int Tcl_ParseCommand(Tcl_Interp *interp, const char *start, int numBytes, @@ -1291,7 +1290,7 @@ declare 362 { declare 363 { int Tcl_ParseQuotedString(Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, - CONST84 char **termPtr) + const char **termPtr) } declare 364 { int Tcl_ParseVarName(Tcl_Interp *interp, const char *start, int numBytes, @@ -1350,9 +1349,9 @@ declare 380 { int Tcl_GetCharLength(Tcl_Obj *objPtr) } declare 381 { - Tcl_UniChar Tcl_GetUniChar(Tcl_Obj *objPtr, int index) + int Tcl_GetUniChar(Tcl_Obj *objPtr, int index) } -declare 382 { +declare 382 {deprecated {No longer in use, changed to macro}} { Tcl_UniChar *Tcl_GetUnicode(Tcl_Obj *objPtr) } declare 383 { @@ -1407,7 +1406,7 @@ declare 397 { int Tcl_ChannelBuffered(Tcl_Channel chan) } declare 398 { - CONST84_RETURN char *Tcl_ChannelName(const Tcl_ChannelType *chanTypePtr) + const char *Tcl_ChannelName(const Tcl_ChannelType *chanTypePtr) } declare 399 { Tcl_ChannelTypeVersion Tcl_ChannelVersion( @@ -1547,12 +1546,12 @@ declare 434 { } # TIP#15 (math function introspection) dkf -declare 435 { +declare 435 {deprecated {}} { int Tcl_GetMathFuncInfo(Tcl_Interp *interp, const char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, ClientData *clientDataPtr) } -declare 436 { +declare 436 {deprecated {}} { Tcl_Obj *Tcl_ListMathFuncs(Tcl_Interp *interp, const char *pattern) } @@ -1870,7 +1869,7 @@ declare 518 { } # TIP#121 (exit handler) dkf for Joe Mistachkin -declare 519 { +declare 519 {nostub {Don't use this function in a stub-enabled extension}} { Tcl_ExitProc *Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc) } @@ -2325,6 +2324,74 @@ 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) +} + +# TIP #430 +declare 632 { + int TclZipfs_Mount(Tcl_Interp *interp, const char *mountPoint, + const char *zipname, const char *passwd) +} +declare 633 { + int TclZipfs_Unmount(Tcl_Interp *interp, const char *mountPoint) +} +declare 634 { + Tcl_Obj *TclZipfs_TclLibrary(void) +} +declare 635 { + int TclZipfs_MountBuffer(Tcl_Interp *interp, const char *mountPoint, + unsigned char *data, size_t datalen, int copy) +} + +# TIP #445 +declare 636 { + void Tcl_FreeIntRep(Tcl_Obj *objPtr) +} +declare 637 { + char *Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes, + unsigned int numBytes) +} +declare 638 { + Tcl_ObjIntRep *Tcl_FetchIntRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr) +} +declare 639 { + void Tcl_StoreIntRep(Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, + const Tcl_ObjIntRep *irPtr) +} +declare 640 { + int Tcl_HasStringRep(Tcl_Obj *objPtr) +} + +# TIP #506 +declare 641 { + void Tcl_IncrRefCount(Tcl_Obj *objPtr) +} + +declare 642 { + void Tcl_DecrRefCount(Tcl_Obj *objPtr) +} + +declare 643 { + int Tcl_IsShared(Tcl_Obj *objPtr) +} + +# TIP#312 New Tcl_LinkArray() function +declare 644 { + int Tcl_LinkArray(Tcl_Interp *interp, const char *varName, void *addr, + int type, int size) +} + +declare 645 { + int Tcl_GetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr, + int endValue, int *indexPtr) +} + +# ----- BASELINE -- FOR -- 8.7.0 ----- # + ############################################################################## # Define the platform specific public Tcl interface. These functions are only @@ -2374,6 +2441,19 @@ export { Tcl_Interp *interp) } export { + void Tcl_StaticPackage(Tcl_Interp *interp, const char *pkgName, + Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc) +} +export { + void Tcl_SetPanicProc(TCL_NORETURN1 Tcl_PanicProc *panicProc) +} +export { + Tcl_ExitProc *Tcl_SetExitProc(TCL_NORETURN1 Tcl_ExitProc *proc) +} +export { + void Tcl_FindExecutable(const char *argv0) +} +export { const char *Tcl_InitStubs(Tcl_Interp *interp, const char *version, int exact) } diff --git a/generic/tcl.h b/generic/tcl.h index 2077a32..f3253db 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -38,8 +38,8 @@ extern "C" { * update the version numbers: * * library/init.tcl (1 LOC patch) - * unix/configure.in (2 LOC Major, 2 LOC minor, 1 LOC patch) - * win/configure.in (as above) + * unix/configure.ac (2 LOC Major, 2 LOC minor, 1 LOC patch) + * win/configure.ac (as above) * win/tcl.m4 (not patchlevel) * README (sections 0 and 2, with and without separator) * macosx/Tcl-Common.xcconfig (not patchlevel) 1 LOC @@ -49,13 +49,14 @@ extern "C" { */ #define TCL_MAJOR_VERSION 8 -#define TCL_MINOR_VERSION 6 -#define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE -#define TCL_RELEASE_SERIAL 9 +#define TCL_MINOR_VERSION 7 +#define TCL_RELEASE_LEVEL TCL_ALPHA_RELEASE +#define TCL_RELEASE_SERIAL 2 -#define TCL_VERSION "8.6" -#define TCL_PATCH_LEVEL "8.6.9" +#define TCL_VERSION "8.7" +#define TCL_PATCH_LEVEL "8.7a2" +#if !defined(TCL_NO_DEPRECATED) || defined(RC_INVOKED) /* *---------------------------------------------------------------------------- * The following definitions set up the proper options for Windows compilers. @@ -85,6 +86,11 @@ extern "C" { # define JOIN1(a,b) a##b #endif +#ifndef TCL_THREADS +# define TCL_THREADS 1 +#endif +#endif /* !TCL_NO_DEPRECATED */ + /* * A special definition used to allow this header file to be included from * windows resource files so that they can obtain version information. @@ -97,15 +103,10 @@ extern "C" { #ifndef RC_INVOKED /* - * Special macro to define mutexes, that doesn't do anything if we are not - * using threads. + * Special macro to define mutexes. */ -#ifdef TCL_THREADS #define TCL_DECLARE_MUTEX(name) static Tcl_Mutex name; -#else -#define TCL_DECLARE_MUTEX(name) -#endif /* * Tcl's public routine Tcl_FSSeek() uses the values SEEK_SET, SEEK_CUR, and @@ -131,14 +132,15 @@ extern "C" { */ #include <stdarg.h> -#ifndef TCL_NO_DEPRECATED +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 # define TCL_VARARGS(type, name) (type name, ...) # define TCL_VARARGS_DEF(type, name) (type name, ...) # define TCL_VARARGS_START(type, name, list) (va_start(list, name), name) -#endif +#endif /* !TCL_NO_DEPRECATED */ #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 @@ -148,8 +150,10 @@ 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 @@ -216,7 +220,7 @@ extern "C" { * to be included in a shared library, then it should have the DLLEXPORT * storage class. If is being declared for use by a module that is going to * link against the shared library, then it should have the DLLIMPORT storage - * class. If the symbol is beind declared for a static build or for use from a + * class. If the symbol is being declared for a static build or for use from a * stub library, then the storage class should be empty. * * The convention is that a macro called BUILD_xxxx, where xxxx is the name of @@ -245,10 +249,9 @@ extern "C" { * New code should use prototypes. */ -#ifndef TCL_NO_DEPRECATED +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 # undef _ANSI_ARGS_ # define _ANSI_ARGS_(x) x -#endif /* * Definitions that allow this header file to be used either with or without @@ -258,34 +261,14 @@ extern "C" { #ifndef INLINE # define INLINE #endif - -#ifdef NO_CONST -# ifndef const -# define const -# endif -#endif #ifndef CONST # define CONST const #endif -#ifdef USE_NON_CONST -# ifdef USE_COMPAT_CONST -# error define at most one of USE_NON_CONST and USE_COMPAT_CONST -# endif -# define CONST84 -# define CONST84_RETURN -#else -# ifdef USE_COMPAT_CONST -# define CONST84 -# define CONST84_RETURN const -# else -# define CONST84 const -# define CONST84_RETURN const -# endif -#endif +#endif /* !TCL_NO_DEPRECATED */ #ifndef CONST86 -# define CONST86 CONST84 +# define CONST86 const #endif /* @@ -309,6 +292,7 @@ extern "C" { * VOID. This block is skipped under Cygwin and Mingw. */ +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 #if defined(_WIN32) && !defined(HAVE_WINNT_IGNORE_VOID) #ifndef VOID #define VOID void @@ -324,23 +308,16 @@ typedef long LONG; */ #ifndef __VXWORKS__ -# ifndef NO_VOID -# define VOID void -# else -# define VOID char -# endif +# define VOID void #endif +#endif /* !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 */ /* * Miscellaneous declarations. */ #ifndef _CLIENTDATA -# ifndef NO_VOID - typedef void *ClientData; -# else - typedef int *ClientData; -# endif + typedef void *ClientData; # define _CLIENTDATA #endif @@ -386,56 +363,45 @@ typedef long LONG; #if !defined(TCL_WIDE_INT_TYPE)&&!defined(TCL_WIDE_INT_IS_LONG) # if defined(_WIN32) # define TCL_WIDE_INT_TYPE __int64 -# ifdef __BORLANDC__ -# define TCL_LL_MODIFIER "L" -# else /* __BORLANDC__ */ -# define TCL_LL_MODIFIER "I64" -# endif /* __BORLANDC__ */ +# define TCL_LL_MODIFIER "I64" +# if defined(_WIN64) +# define TCL_Z_MODIFIER "I" +# endif # elif defined(__GNUC__) -# define TCL_WIDE_INT_TYPE long long -# define TCL_LL_MODIFIER "ll" +# define TCL_Z_MODIFIER "z" # else /* ! _WIN32 && ! __GNUC__ */ /* * Don't know what platform it is and configure hasn't discovered what is * going on for us. Try to guess... */ # include <limits.h> -# if (INT_MAX < LONG_MAX) +# if defined(LLONG_MAX) && (LLONG_MAX == LONG_MAX) # define TCL_WIDE_INT_IS_LONG 1 -# else -# define TCL_WIDE_INT_TYPE long long # endif # endif /* _WIN32 */ #endif /* !TCL_WIDE_INT_TYPE & !TCL_WIDE_INT_IS_LONG */ -#ifdef TCL_WIDE_INT_IS_LONG -# undef TCL_WIDE_INT_TYPE -# define TCL_WIDE_INT_TYPE long -#endif /* TCL_WIDE_INT_IS_LONG */ + +#ifndef TCL_WIDE_INT_TYPE +# define TCL_WIDE_INT_TYPE long long +#endif /* !TCL_WIDE_INT_TYPE */ typedef TCL_WIDE_INT_TYPE Tcl_WideInt; typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; -#ifdef TCL_WIDE_INT_IS_LONG -# define Tcl_WideAsLong(val) ((long)(val)) -# define Tcl_LongAsWide(val) ((long)(val)) -# define Tcl_WideAsDouble(val) ((double)((long)(val))) -# define Tcl_DoubleAsWide(val) ((long)((double)(val))) -# ifndef TCL_LL_MODIFIER -# define TCL_LL_MODIFIER "l" -# endif /* !TCL_LL_MODIFIER */ -#else /* TCL_WIDE_INT_IS_LONG */ -/* - * The next short section of defines are only done when not running on Windows - * or some other strange platform. - */ -# ifndef TCL_LL_MODIFIER -# define TCL_LL_MODIFIER "ll" -# endif /* !TCL_LL_MODIFIER */ -# define Tcl_WideAsLong(val) ((long)((Tcl_WideInt)(val))) -# define Tcl_LongAsWide(val) ((Tcl_WideInt)((long)(val))) -# define Tcl_WideAsDouble(val) ((double)((Tcl_WideInt)(val))) -# define Tcl_DoubleAsWide(val) ((Tcl_WideInt)((double)(val))) -#endif /* TCL_WIDE_INT_IS_LONG */ +#ifndef TCL_LL_MODIFIER +# define TCL_LL_MODIFIER "ll" +#endif /* !TCL_LL_MODIFIER */ +#ifndef TCL_Z_MODIFIER +# if defined(__GNUC__) && !defined(_WIN32) +# define TCL_Z_MODIFIER "z" +# else +# define TCL_Z_MODIFIER "" +# endif +#endif /* !TCL_Z_MODIFIER */ +#define Tcl_WideAsLong(val) ((long)((Tcl_WideInt)(val))) +#define Tcl_LongAsWide(val) ((Tcl_WideInt)((long)(val))) +#define Tcl_WideAsDouble(val) ((double)((Tcl_WideInt)(val))) +#define Tcl_DoubleAsWide(val) ((Tcl_WideInt)((double)(val))) #if defined(_WIN32) # ifdef __BORLANDC__ @@ -491,37 +457,15 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; */ typedef struct Tcl_Interp -#ifndef TCL_NO_DEPRECATED +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 { /* TIP #330: Strongly discourage extensions from using the string * result. */ -#ifdef USE_INTERP_RESULT - char *result TCL_DEPRECATED_API("use Tcl_GetStringResult/Tcl_SetResult"); - /* If the last command returned a string - * result, this points to it. */ - void (*freeProc) (char *blockPtr) - TCL_DEPRECATED_API("use Tcl_GetStringResult/Tcl_SetResult"); - /* Zero means the string result is statically - * allocated. TCL_DYNAMIC means it was - * allocated with ckalloc and should be freed - * with ckfree. Other values give the address - * of function to invoke to free the result. - * Tcl_Eval must free it before executing next - * command. */ -#else char *resultDontUse; /* Don't use in extensions! */ void (*freeProcDontUse) (char *); /* Don't use in extensions! */ -#endif -#ifdef USE_INTERP_ERRORLINE - int errorLine TCL_DEPRECATED_API("use Tcl_GetErrorLine/Tcl_SetErrorLine"); - /* When TCL_ERROR is returned, this gives the - * line number within the command where the - * error occurred (1 if first line). */ -#else int errorLineDontUse; /* Don't use in extensions! */ -#endif } -#endif /* TCL_NO_DEPRECATED */ +#endif /* !TCL_NO_DEPRECATED */ Tcl_Interp; typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler; @@ -671,7 +615,9 @@ typedef struct stat *Tcl_OldStat_; #define TCL_BREAK 3 #define TCL_CONTINUE 4 +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 #define TCL_RESULT_SIZE 200 +#endif /* *---------------------------------------------------------------------------- @@ -687,6 +633,7 @@ typedef struct stat *Tcl_OldStat_; * Argument descriptors for math function callbacks in expressions: */ +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 typedef enum { TCL_INT, TCL_DOUBLE, TCL_EITHER, TCL_WIDE_INT } Tcl_ValueType; @@ -698,6 +645,10 @@ typedef struct Tcl_Value { double doubleValue; /* Double-precision floating value. */ Tcl_WideInt wideValue; /* Wide (min. 64-bit) integer value. */ } Tcl_Value; +#else +#define Tcl_ValueType void /* Just enough to prevent compilation error in Tcl */ +#define Tcl_Value void /* Just enough to prevent compilation error in Tcl */ +#endif /* * Forward declaration of Tcl_Obj to prevent an error when the forward @@ -718,10 +669,10 @@ typedef void (Tcl_ChannelProc) (ClientData clientData, int mask); typedef void (Tcl_CloseProc) (ClientData data); typedef void (Tcl_CmdDeleteProc) (ClientData clientData); typedef int (Tcl_CmdProc) (ClientData clientData, Tcl_Interp *interp, - int argc, CONST84 char *argv[]); + int argc, const char *argv[]); typedef void (Tcl_CmdTraceProc) (ClientData clientData, Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *proc, - ClientData cmdClientData, int argc, CONST84 char *argv[]); + ClientData cmdClientData, int argc, const char *argv[]); typedef int (Tcl_CmdObjTraceProc) (ClientData clientData, Tcl_Interp *interp, int level, const char *command, Tcl_Command commandInfo, int objc, struct Tcl_Obj *const *objv); @@ -758,7 +709,7 @@ typedef void (Tcl_TimerProc) (ClientData clientData); typedef int (Tcl_SetFromAnyProc) (Tcl_Interp *interp, struct Tcl_Obj *objPtr); typedef void (Tcl_UpdateStringProc) (struct Tcl_Obj *objPtr); typedef char * (Tcl_VarTraceProc) (ClientData clientData, Tcl_Interp *interp, - CONST84 char *part1, CONST84 char *part2, int flags); + const char *part1, const char *part2, int flags); typedef void (Tcl_CommandTraceProc) (ClientData clientData, Tcl_Interp *interp, const char *oldName, const char *newName, int flags); typedef void (Tcl_CreateFileHandlerProc) (int fd, int mask, Tcl_FileProc *proc, @@ -796,6 +747,29 @@ typedef struct Tcl_ObjType { } Tcl_ObjType; /* + * The following structure stores an internal representation (intrep) for + * a Tcl value. An intrep is associated with an Tcl_ObjType when both + * are stored in the same Tcl_Obj. The routines of the Tcl_ObjType govern + * the handling of the intrep. + */ + +typedef union Tcl_ObjIntRep { /* 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. */ + Tcl_WideInt wideValue; /* - an integer value >= 64bits */ + struct { /* - internal rep as two pointers. */ + void *ptr1; + void *ptr2; + } twoPtrValue; + struct { /* - internal rep as a pointer and a long, */ + void *ptr; /* not used internally any more. */ + unsigned long value; + } ptrAndLongRep; +} Tcl_ObjIntRep; + +/* * One of the following structures exists for each object in the Tcl system. * An object stores a value as either a string, some internal representation, * or both. @@ -820,39 +794,9 @@ typedef struct Tcl_Obj { * corresponds to the type of the object's * internal rep. NULL indicates the object has * no internal rep (has no type). */ - 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. */ - Tcl_WideInt wideValue; /* - a long long value. */ - struct { /* - internal rep as two pointers. - * 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. */ - void *ptr1; - void *ptr2; - } twoPtrValue; - struct { /* - internal rep as a pointer and a long, - not used internally any more. */ - void *ptr; - unsigned long value; - } ptrAndLongRep; - } internalRep; + Tcl_ObjIntRep internalRep; /* The internal representation: */ } Tcl_Obj; -/* - * Macros to increment and decrement a Tcl_Obj's reference count, and to test - * whether an object is shared (i.e. has reference count > 1). Note: clients - * should use Tcl_DecrRefCount() when they are finished using an object, and - * should never call TclFreeObj() directly. TclFreeObj() is only defined and - * made public in tcl.h to support Tcl_DecrRefCount's macro definition. - */ - -void Tcl_IncrRefCount(Tcl_Obj *objPtr); -void Tcl_DecrRefCount(Tcl_Obj *objPtr); -int Tcl_IsShared(Tcl_Obj *objPtr); /* *---------------------------------------------------------------------------- @@ -868,7 +812,7 @@ typedef struct Tcl_SavedResult { char *appendResult; int appendAvl; int appendUsed; - char resultSpace[TCL_RESULT_SIZE+1]; + char resultSpace[200+1]; } Tcl_SavedResult; /* @@ -994,7 +938,9 @@ typedef struct Tcl_DString { #define Tcl_DStringLength(dsPtr) ((dsPtr)->length) #define Tcl_DStringValue(dsPtr) ((dsPtr)->string) -#define Tcl_DStringTrunc Tcl_DStringSetLength +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 +# define Tcl_DStringTrunc Tcl_DStringSetLength +#endif /* !TCL_NO_DEPRECATED */ /* * Definitions for the maximum number of digits of precision that may be @@ -1120,9 +1066,9 @@ typedef struct Tcl_DString { * give the flag) */ -#ifndef TCL_NO_DEPRECATED +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 # define TCL_PARSE_PART1 0x400 -#endif +#endif /* !TCL_NO_DEPRECATED */ /* * Types for linked variables: @@ -1138,10 +1084,17 @@ 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_CHARS 15 +#define TCL_LINK_BINARY 16 #define TCL_LINK_READ_ONLY 0x80 /* @@ -1149,29 +1102,21 @@ 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 unsigned (Tcl_HashKeyProc) (Tcl_HashTable *tablePtr, void *keyPtr); +typedef TCL_HASH_TYPE (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. */ @@ -1180,15 +1125,9 @@ 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: */ @@ -1348,8 +1287,8 @@ typedef struct Tcl_HashSearch { typedef struct { void *next; /* Search position for underlying hash * table. */ - int epoch; /* Epoch marker for dictionary being searched, - * or -1 if search has terminated. */ + unsigned int epoch; /* Epoch marker for dictionary being searched, + * or 0 if search has terminated. */ Tcl_Dict dictionaryPtr; /* Reference to dictionary being searched. */ } Tcl_DictSearch; @@ -1482,14 +1421,14 @@ typedef int (Tcl_DriverClose2Proc) (ClientData instanceData, typedef int (Tcl_DriverInputProc) (ClientData instanceData, char *buf, int toRead, int *errorCodePtr); typedef int (Tcl_DriverOutputProc) (ClientData instanceData, - CONST84 char *buf, int toWrite, int *errorCodePtr); + const char *buf, int toWrite, int *errorCodePtr); typedef int (Tcl_DriverSeekProc) (ClientData instanceData, long offset, int mode, int *errorCodePtr); typedef int (Tcl_DriverSetOptionProc) (ClientData instanceData, Tcl_Interp *interp, const char *optionName, const char *value); typedef int (Tcl_DriverGetOptionProc) (ClientData instanceData, - Tcl_Interp *interp, CONST84 char *optionName, + Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr); typedef void (Tcl_DriverWatchProc) (ClientData instanceData, int mask); typedef int (Tcl_DriverGetHandleProc) (ClientData instanceData, @@ -2196,16 +2135,16 @@ typedef struct Tcl_EncodingType { /* * The maximum number of bytes that are necessary to represent a single - * Unicode character in UTF-8. The valid values should be 3, 4 or 6 - * (or perhaps 1 if we want to support a non-unicode enabled core). If 3 or - * 4, then Tcl_UniChar must be 2-bytes in size (UCS-2) (the default). If 6, + * Unicode character in UTF-8. The valid values are 4 and 6 + * (or perhaps 1 if we want to support a non-unicode enabled core). If 4, + * then Tcl_UniChar must be 2-bytes in size (UCS-2) (the default). If 6, * then Tcl_UniChar must be 4-bytes in size (UCS-4). At this time UCS-2 mode * is the default and recommended mode. UCS-4 is experimental and not * recommended. It works for the core, but most extensions expect UCS-2. */ #ifndef TCL_UTF_MAX -#define TCL_UTF_MAX 3 +#define TCL_UTF_MAX 4 #endif /* @@ -2267,6 +2206,8 @@ typedef struct mp_int mp_int; #define MP_INT_DECLARED typedef unsigned int mp_digit; #define MP_DIGIT_DECLARED +typedef unsigned TCL_WIDE_INT_TYPE mp_word; +#define MP_WORD_DECLARED /* *---------------------------------------------------------------------------- @@ -2377,6 +2318,21 @@ 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) + +/* + * Constants for special int-typed values, see TIP #494 + */ + +#define TCL_IO_FAILURE (-1) +#define TCL_AUTO_LENGTH (-1) +#define TCL_INDEX_NONE (-1) + +/* + *---------------------------------------------------------------------------- * Single public declaration for NRE. */ @@ -2386,13 +2342,10 @@ 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. + * stubs tables. If TCL_UTF_MAX>4 use a different value. */ -#define TCL_STUB_MAGIC ((int) 0xFCA3BACF) +#define TCL_STUB_MAGIC ((int) 0xFCA3BACF + (TCL_UTF_MAX>4)) /* * The following function is required to be defined in all stubs aware @@ -2402,22 +2355,38 @@ typedef int (Tcl_NRPostProc) (ClientData data[], Tcl_Interp *interp, */ const char * Tcl_InitStubs(Tcl_Interp *interp, const char *version, - int exact); + int exact, int magic); const char * TclTomMathInitializeStubs(Tcl_Interp *interp, const char *version, int epoch, int revision); - -/* - * When not using stubs, make it a macro. - */ - -#ifndef USE_TCL_STUBS -#define Tcl_InitStubs(interp, version, exact) \ - Tcl_PkgInitStubsCheck(interp, version, exact) +#if defined(_WIN32) + TCL_NORETURN void Tcl_ConsolePanic(const char *format, ...); +#else +# define Tcl_ConsolePanic ((Tcl_PanicProc *)0) #endif -/* - * TODO - tommath stubs export goes here! - */ +#ifdef USE_TCL_STUBS +#if TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE +# define Tcl_InitStubs(interp, version, exact) \ + (Tcl_InitStubs)(interp, version, \ + (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \ + TCL_STUB_MAGIC) +#else +# define Tcl_InitStubs(interp, version, exact) \ + (Tcl_InitStubs)(interp, TCL_PATCH_LEVEL, \ + 1|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \ + TCL_STUB_MAGIC) +#endif +#else +#if TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE +# define Tcl_InitStubs(interp, version, exact) \ + Tcl_PkgInitStubsCheck(interp, version, \ + (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16)) +#else +# define Tcl_InitStubs(interp, version, exact) \ + Tcl_PkgInitStubsCheck(interp, TCL_PATCH_LEVEL, \ + 1|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16)) +#endif +#endif /* * Public functions that are not accessible via the stubs table. @@ -2425,12 +2394,15 @@ const char * TclTomMathInitializeStubs(Tcl_Interp *interp, */ #define Tcl_Main(argc, argv, proc) Tcl_MainEx(argc, argv, proc, \ - ((Tcl_CreateInterp)())) + ((Tcl_SetPanicProc(Tcl_ConsolePanic), Tcl_CreateInterp)())) EXTERN void Tcl_MainEx(int argc, char **argv, Tcl_AppInitProc *appInitProc, Tcl_Interp *interp); EXTERN const char * Tcl_PkgInitStubsCheck(Tcl_Interp *interp, const char *version, int exact); EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); +#ifndef _WIN32 +EXTERN int TclZipfs_AppHook(int *argc, char ***argv); +#endif /* *---------------------------------------------------------------------------- @@ -2501,26 +2473,39 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); #endif /* !TCL_MEM_DEBUG */ #ifdef TCL_MEM_DEBUG +# undef Tcl_IncrRefCount # define Tcl_IncrRefCount(objPtr) \ Tcl_DbIncrRefCount(objPtr, __FILE__, __LINE__) +# undef Tcl_DecrRefCount # define Tcl_DecrRefCount(objPtr) \ Tcl_DbDecrRefCount(objPtr, __FILE__, __LINE__) +# undef Tcl_IsShared # define Tcl_IsShared(objPtr) \ Tcl_DbIsShared(objPtr, __FILE__, __LINE__) -#else +#elif (!defined(TCL_NO_DEPRECATED) && defined(USE_TCL_STUBS)) +/* + * When compiling stub-enabled extensions without -DTCL_NO_DEPRECATED, + * those extensions are expected to run fine with Tcl 8.6 as well. + * This means we must continue to use macro's for the above 3 functions, + * and the old stub entry for TclFreeObj. All other usage of TclFreeObj() + * is forbidden now, therefore it is changed to be MODULE_SCOPE internal. + */ +# undef Tcl_IncrRefCount # define Tcl_IncrRefCount(objPtr) \ ++(objPtr)->refCount /* * Use do/while0 idiom for optimum correctness without compiler warnings. * http://c2.com/cgi/wiki?TrivialDoWhileLoop */ +# undef Tcl_DecrRefCount # define Tcl_DecrRefCount(objPtr) \ do { \ Tcl_Obj *_objPtr = (objPtr); \ if ((_objPtr)->refCount-- <= 1) { \ - TclFreeObj(_objPtr); \ + TclOldFreeObj(_objPtr); \ } \ } while(0) +# undef Tcl_IsShared # define Tcl_IsShared(objPtr) \ ((objPtr)->refCount > 1) #endif @@ -2537,22 +2522,16 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); Tcl_DbNewBignumObj(val, __FILE__, __LINE__) # undef Tcl_NewBooleanObj # define Tcl_NewBooleanObj(val) \ - Tcl_DbNewBooleanObj(val, __FILE__, __LINE__) + Tcl_DbNewWideIntObj((val)!=0, __FILE__, __LINE__) # undef Tcl_NewByteArrayObj # define Tcl_NewByteArrayObj(bytes, len) \ Tcl_DbNewByteArrayObj(bytes, len, __FILE__, __LINE__) # undef Tcl_NewDoubleObj # define Tcl_NewDoubleObj(val) \ Tcl_DbNewDoubleObj(val, __FILE__, __LINE__) -# undef Tcl_NewIntObj -# define Tcl_NewIntObj(val) \ - Tcl_DbNewLongObj(val, __FILE__, __LINE__) # undef Tcl_NewListObj # define Tcl_NewListObj(objc, objv) \ Tcl_DbNewListObj(objc, objv, __FILE__, __LINE__) -# undef Tcl_NewLongObj -# define Tcl_NewLongObj(val) \ - Tcl_DbNewLongObj(val, __FILE__, __LINE__) # undef Tcl_NewObj # define Tcl_NewObj() \ Tcl_DbNewObj(__FILE__, __LINE__) @@ -2591,31 +2570,10 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); /* *---------------------------------------------------------------------------- - * Macros that eliminate the overhead of the thread synchronization functions - * when compiling without thread support. - */ - -#ifndef TCL_THREADS -#undef Tcl_MutexLock -#define Tcl_MutexLock(mutexPtr) -#undef Tcl_MutexUnlock -#define Tcl_MutexUnlock(mutexPtr) -#undef Tcl_MutexFinalize -#define Tcl_MutexFinalize(mutexPtr) -#undef Tcl_ConditionNotify -#define Tcl_ConditionNotify(condPtr) -#undef Tcl_ConditionWait -#define Tcl_ConditionWait(condPtr, mutexPtr, timePtr) -#undef Tcl_ConditionFinalize -#define Tcl_ConditionFinalize(condPtr) -#endif /* TCL_THREADS */ - -/* - *---------------------------------------------------------------------------- * Deprecated Tcl functions: */ -#ifndef TCL_NO_DEPRECATED +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 /* * These function have been renamed. The old names are deprecated, but we * define these macros for backwards compatibility. @@ -2630,7 +2588,6 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); # define panic Tcl_Panic #endif # define panicVA Tcl_PanicVA -#endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------------- @@ -2641,6 +2598,8 @@ EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); extern Tcl_AppInitProc Tcl_AppInit; +#endif /* !TCL_NO_DEPRECATED */ + #endif /* RC_INVOKED */ /* diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c index cda1f38..bad3d8a 100644 --- a/generic/tclAlloc.c +++ b/generic/tclAlloc.c @@ -22,7 +22,7 @@ */ #include "tclInt.h" -#if !defined(TCL_THREADS) || !defined(USE_THREAD_ALLOC) +#if !TCL_THREADS || !defined(USE_THREAD_ALLOC) #if USE_TCLALLOC @@ -32,7 +32,7 @@ */ #if defined(_MSC_VER) || defined(__MSVCRT__) || defined(__BORLANDC__) -typedef unsigned long caddr_t; +typedef size_t caddr_t; #endif /* @@ -56,7 +56,7 @@ union overhead { unsigned char magic1; /* other magic number */ #ifndef NDEBUG unsigned short rmagic; /* range magic number */ - unsigned long size; /* actual block size */ + size_t size; /* actual block size */ unsigned short unused2; /* padding to 8-byte align */ #endif } ovu; @@ -121,7 +121,7 @@ static struct block bigBlocks={ /* Big blocks aren't suballocated. */ * variable. */ -#ifdef TCL_THREADS +#if TCL_THREADS static Tcl_Mutex *allocMutexPtr; #endif static int allocInit = 0; @@ -133,7 +133,7 @@ static int allocInit = 0; * a given block size. */ -static unsigned int numMallocs[NBUCKETS+1]; +static size_t numMallocs[NBUCKETS+1]; #endif #if !defined(NDEBUG) @@ -148,7 +148,7 @@ static unsigned int numMallocs[NBUCKETS+1]; * Prototypes for functions used only in this file. */ -static void MoreCore(int bucket); +static void MoreCore(size_t bucket); /* *------------------------------------------------------------------------- @@ -171,7 +171,7 @@ TclInitAlloc(void) { if (!allocInit) { allocInit = 1; -#ifdef TCL_THREADS +#if TCL_THREADS allocMutexPtr = Tcl_GetAllocMutex(); #endif } @@ -254,7 +254,7 @@ TclpAlloc( unsigned int numBytes) /* Number of bytes to allocate. */ { register union overhead *overPtr; - register long bucket; + register size_t bucket; register unsigned amount; struct block *bigBlockPtr = NULL; @@ -274,8 +274,8 @@ TclpAlloc( if (numBytes >= MAXMALLOC - OVERHEAD) { if (numBytes <= UINT_MAX - OVERHEAD -sizeof(struct block)) { - bigBlockPtr = (struct block *) TclpSysAlloc((unsigned) - (sizeof(struct block) + OVERHEAD + numBytes), 0); + bigBlockPtr = (struct block *) TclpSysAlloc( + sizeof(struct block) + OVERHEAD + numBytes, 0); } if (bigBlockPtr == NULL) { Tcl_MutexUnlock(allocMutexPtr); @@ -385,12 +385,12 @@ TclpAlloc( static void MoreCore( - int bucket) /* What bucket to allocat to. */ + size_t bucket) /* What bucket to allocate to. */ { register union overhead *overPtr; - register long size; /* size of desired block */ - long amount; /* amount to allocate */ - int numBlocks; /* how many blocks we get */ + register size_t size; /* size of desired block */ + size_t amount; /* amount to allocate */ + size_t numBlocks; /* how many blocks we get */ struct block *blockPtr; /* @@ -398,14 +398,14 @@ MoreCore( * VAX, I think) or for a negative arg. */ - size = 1 << (bucket + 3); + size = ((size_t)1) << (bucket + 3); ASSERT(size > 0); amount = MAXMALLOC; numBlocks = amount / size; ASSERT(numBlocks*size == amount); - blockPtr = (struct block *) TclpSysAlloc((unsigned) + blockPtr = (struct block *) TclpSysAlloc( (sizeof(struct block) + amount), 1); /* no more room! */ if (blockPtr == NULL) { @@ -448,7 +448,7 @@ void TclpFree( char *oldPtr) /* Pointer to memory to free. */ { - register long size; + register size_t size; register union overhead *overPtr; struct block *bigBlockPtr; @@ -518,7 +518,7 @@ TclpRealloc( union overhead *overPtr; struct block *bigBlockPtr; int expensive; - unsigned long maxSize; + size_t maxSize; if (oldPtr == NULL) { return TclpAlloc(numBytes); @@ -604,7 +604,7 @@ TclpRealloc( if (maxSize < numBytes) { numBytes = maxSize; } - memcpy(newPtr, oldPtr, (size_t) numBytes); + memcpy(newPtr, oldPtr, numBytes); TclpFree(oldPtr); return newPtr; } @@ -645,29 +645,29 @@ void mstats( char *s) /* Where to write info. */ { - register int i, j; + register unsigned int i, j; register union overhead *overPtr; - int totalFree = 0, totalUsed = 0; + size_t totalFree = 0, totalUsed = 0; Tcl_MutexLock(allocMutexPtr); fprintf(stderr, "Memory allocation statistics %s\nTclpFree:\t", s); for (i = 0; i < NBUCKETS; i++) { for (j=0, overPtr=nextf[i]; overPtr; overPtr=overPtr->next, j++) { - fprintf(stderr, " %d", j); + fprintf(stderr, " %u", j); } - totalFree += j * (1 << (i + 3)); + totalFree += ((size_t)j) * (1 << (i + 3)); } fprintf(stderr, "\nused:\t"); for (i = 0; i < NBUCKETS; i++) { - fprintf(stderr, " %d", numMallocs[i]); + fprintf(stderr, " %" TCL_Z_MODIFIER "u", numMallocs[i]); totalUsed += numMallocs[i] * (1 << (i + 3)); } - fprintf(stderr, "\n\tTotal small in use: %d, total free: %d\n", - totalUsed, totalFree); - fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %d\n", + fprintf(stderr, "\n\tTotal small in use: %" TCL_Z_MODIFIER "u, total free: %" TCL_Z_MODIFIER "u\n", + totalUsed, totalFree); + fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %" TCL_Z_MODIFIER "u\n", MAXMALLOC, numMallocs[NBUCKETS]); Tcl_MutexUnlock(allocMutexPtr); diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 39930a7..e8ca9ca 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -32,6 +32,7 @@ #include "tclInt.h" #include "tclCompile.h" #include "tclOOInt.h" +#include <assert.h> /* * Structure that represents a range of instructions in the bytecode. @@ -144,6 +145,8 @@ typedef enum TalInstType { * 1 */ ASSEM_DICT_GET, /* 'dict get' and related - consumes N+1 * operands, produces 1, N > 0 */ + ASSEM_DICT_GET_DEF, /* 'dict getwithdefault' - consumes N+2 + * operands, produces 1, N > 0 */ ASSEM_DICT_SET, /* specifies key count and LVT index, consumes * N+1 operands, produces 1, N > 0 */ ASSEM_DICT_UNSET, /* specifies key count and LVT index, consumes @@ -271,15 +274,12 @@ static void CompileEmbeddedScript(AssemblyEnv*, Tcl_Token*, const TalInstDesc*); static int DefineLabel(AssemblyEnv* envPtr, const char* label); static void DeleteMirrorJumpTable(JumptableInfo* jtPtr); -static void DupAssembleCodeInternalRep(Tcl_Obj* src, - Tcl_Obj* dest); static void FillInJumpOffsets(AssemblyEnv*); static int CreateMirrorJumpTable(AssemblyEnv* assemEnvPtr, Tcl_Obj* jumpTable); static int FindLocalVar(AssemblyEnv* envPtr, Tcl_Token** tokenPtrPtr); static int FinishAssembly(AssemblyEnv*); -static void FreeAssembleCodeInternalRep(Tcl_Obj *objPtr); static void FreeAssemblyEnv(AssemblyEnv*); static int GetBooleanOperand(AssemblyEnv*, Tcl_Token**, int*); static int GetListIndexOperand(AssemblyEnv*, Tcl_Token**, int*); @@ -318,6 +318,9 @@ static void UnstackExpiredCatches(CompileEnv*, BasicBlock*, int, * Tcl_ObjType that describes bytecode emitted by the assembler. */ +static Tcl_FreeInternalRepProc FreeAssembleCodeInternalRep; +static Tcl_DupInternalRepProc DupAssembleCodeInternalRep; + static const Tcl_ObjType assembleCodeType = { "assemblecode", FreeAssembleCodeInternalRep, /* freeIntRepProc */ @@ -361,6 +364,7 @@ static const TalInstDesc TalInstructionTable[] = { {"dictExists", ASSEM_DICT_GET, INST_DICT_EXISTS, INT_MIN,1}, {"dictExpand", ASSEM_1BYTE, INST_DICT_EXPAND, 3, 1}, {"dictGet", ASSEM_DICT_GET, INST_DICT_GET, INT_MIN,1}, + {"dictGetDef", ASSEM_DICT_GET_DEF, INST_DICT_GET_DEF, INT_MIN,1}, {"dictIncrImm", ASSEM_SINT4_LVT4, INST_DICT_INCR_IMM, 1, 1}, {"dictLappend", ASSEM_LVT4, INST_DICT_LAPPEND, 2, 1}, @@ -470,8 +474,12 @@ static const TalInstDesc TalInstructionTable[] = { {"strcat", ASSEM_CONCAT1, INST_STR_CONCAT1, INT_MIN,1}, {"streq", ASSEM_1BYTE, INST_STR_EQ, 2, 1}, {"strfind", ASSEM_1BYTE, INST_STR_FIND, 2, 1}, + {"strge", ASSEM_1BYTE, INST_STR_GE, 2, 1}, + {"strgt", ASSEM_1BYTE, INST_STR_GT, 2, 1}, {"strindex", ASSEM_1BYTE, INST_STR_INDEX, 2, 1}, + {"strle", ASSEM_1BYTE, INST_STR_LE, 2, 1}, {"strlen", ASSEM_1BYTE, INST_STR_LEN, 1, 1}, + {"strlt", ASSEM_1BYTE, INST_STR_LT, 2, 1}, {"strmap", ASSEM_1BYTE, INST_STR_MAP, 3, 1}, {"strmatch", ASSEM_BOOL, INST_STR_MATCH, 2, 1}, {"strneq", ASSEM_1BYTE, INST_STR_NEQ, 2, 1}, @@ -498,7 +506,7 @@ static const TalInstDesc TalInstructionTable[] = { {"variable", ASSEM_LVT4, INST_VARIABLE, 1, 0}, {"verifyDict", ASSEM_1BYTE, INST_DICT_VERIFY, 1, 0}, {"yield", ASSEM_1BYTE, INST_YIELD, 1, 1}, - {NULL, 0, 0, 0, 0} + {NULL, ASSEM_1BYTE, 0, 0, 0} }; /* @@ -528,7 +536,8 @@ static const unsigned char NonThrowingByteCodes[] = { INST_STR_TRIM, INST_STR_TRIM_LEFT, INST_STR_TRIM_RIGHT, /* 166-168 */ INST_CONCAT_STK, /* 169 */ INST_STR_UPPER, INST_STR_LOWER, INST_STR_TITLE, /* 170-172 */ - INST_NUM_TYPE /* 180 */ + INST_NUM_TYPE, /* 180 */ + INST_STR_LT, INST_STR_GT, INST_STR_LE, INST_STR_GE /* 191-194 */ }; /* @@ -619,10 +628,14 @@ BBUpdateStackReqs( if (consumed == INT_MIN) { /* - * The instruction is variadic; it consumes 'count' operands. + * The instruction is variadic; it consumes 'count' operands, or + * 'count+1' for ASSEM_DICT_GET_DEF. */ consumed = count; + if (TalInstructionTable[tblIdx].instType == ASSEM_DICT_GET_DEF) { + consumed++; + } } if (produced < 0) { /* @@ -803,7 +816,7 @@ TclNRAssembleObjCmd( Tcl_AddErrorInfo(interp, "\n (\""); Tcl_AppendObjToErrorInfo(interp, objv[0]); Tcl_AddErrorInfo(interp, "\" body, line "); - backtrace = Tcl_NewIntObj(Tcl_GetErrorLine(interp)); + backtrace = Tcl_NewWideIntObj(Tcl_GetErrorLine(interp)); Tcl_AppendObjToErrorInfo(interp, backtrace); Tcl_AddErrorInfo(interp, ")"); return TCL_ERROR; @@ -848,15 +861,15 @@ CompileAssembleObj( const char* source; /* String representation of the source code */ int sourceLen; /* Length of the source code in bytes */ - /* * Get the expression ByteCode from the object. If it exists, make sure it * is valid in the current context. */ - if (objPtr->typePtr == &assembleCodeType) { + ByteCodeGetIntRep(objPtr, &assembleCodeType, codePtr); + + if (codePtr) { namespacePtr = iPtr->varFramePtr->nsPtr; - codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (((Interp *) *codePtr->interpHandle == iPtr) && (codePtr->compileEpoch == iPtr->compileEpoch) && (codePtr->nsPtr == namespacePtr) @@ -870,7 +883,7 @@ CompileAssembleObj( * Not valid, so free it and regenerate. */ - FreeAssembleCodeInternalRep(objPtr); + Tcl_StoreIntRep(objPtr, &assembleCodeType, NULL); } /* @@ -895,15 +908,13 @@ CompileAssembleObj( */ TclEmitOpcode(INST_DONE, &compEnv); - TclInitByteCodeObj(objPtr, &compEnv); - objPtr->typePtr = &assembleCodeType; + codePtr = TclInitByteCodeObj(objPtr, &assembleCodeType, &compEnv); 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++; @@ -1144,9 +1155,9 @@ NewAssemblyEnv( { Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr; /* Tcl interpreter */ - AssemblyEnv* assemEnvPtr = TclStackAlloc(interp, sizeof(AssemblyEnv)); + AssemblyEnv* assemEnvPtr = (AssemblyEnv*)TclStackAlloc(interp, sizeof(AssemblyEnv)); /* Assembler environment under construction */ - Tcl_Parse* parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse)); + Tcl_Parse* parsePtr = (Tcl_Parse*)TclStackAlloc(interp, sizeof(Tcl_Parse)); /* Parse of one line of assembly code */ assemEnvPtr->envPtr = envPtr; @@ -1305,8 +1316,8 @@ AssembleOneLine( if (GetNextOperand(assemEnvPtr, &tokenPtr, &operand1Obj) != TCL_OK) { goto cleanup; } - operand1 = Tcl_GetStringFromObj(operand1Obj, &operand1Len); - litIndex = TclRegisterNewLiteral(envPtr, operand1, operand1Len); + operand1 = TclGetStringFromObj(operand1Obj, &operand1Len); + litIndex = TclRegisterLiteral(envPtr, operand1, operand1Len, 0); BBEmitInst1or4(assemEnvPtr, tblIdx, litIndex, 0); break; @@ -1398,6 +1409,7 @@ AssembleOneLine( break; case ASSEM_DICT_GET: + case ASSEM_DICT_GET_DEF: if (parsePtr->numWords != 2) { Tcl_WrongNumArgs(interp, 1, &instNameObj, "count"); goto cleanup; @@ -1471,8 +1483,8 @@ AssembleOneLine( &operand1Obj) != TCL_OK) { goto cleanup; } else { - operand1 = Tcl_GetStringFromObj(operand1Obj, &operand1Len); - litIndex = TclRegisterNewLiteral(envPtr, operand1, operand1Len); + operand1 = TclGetStringFromObj(operand1Obj, &operand1Len); + litIndex = TclRegisterLiteral(envPtr, operand1, operand1Len, 0); /* * Assumes that PUSH is the first slot! @@ -1534,7 +1546,7 @@ AssembleOneLine( goto cleanup; } - jtPtr = ckalloc(sizeof(JumptableInfo)); + jtPtr = (JumptableInfo*)ckalloc(sizeof(JumptableInfo)); Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS); assemEnvPtr->curr_bb->jumpLine = assemEnvPtr->cmdLine; @@ -1566,7 +1578,7 @@ AssembleOneLine( * Add the (label_name, address) pair to the hash table. */ - if (DefineLabel(assemEnvPtr, Tcl_GetString(operand1Obj)) != TCL_OK) { + if (DefineLabel(assemEnvPtr, TclGetString(operand1Obj)) != TCL_OK) { goto cleanup; } break; @@ -1745,7 +1757,7 @@ AssembleOneLine( default: Tcl_Panic("Instruction \"%s\" could not be found, can't happen\n", - Tcl_GetString(instNameObj)); + TclGetString(instNameObj)); } status = TCL_OK; @@ -1933,7 +1945,7 @@ MoveExceptionRangesToBasicBlock( curr_bb->foreignExceptionBase = savedExceptArrayNext; curr_bb->foreignExceptionCount = exceptionCount; curr_bb->foreignExceptions = - ckalloc(exceptionCount * sizeof(ExceptionRange)); + (ExceptionRange*)ckalloc(exceptionCount * sizeof(ExceptionRange)); memcpy(curr_bb->foreignExceptions, envPtr->exceptArrayPtr + savedExceptArrayNext, exceptionCount * sizeof(ExceptionRange)); @@ -1998,7 +2010,7 @@ CreateMirrorJumpTable( * Allocate the jumptable. */ - jtPtr = ckalloc(sizeof(JumptableInfo)); + jtPtr = (JumptableInfo*)ckalloc(sizeof(JumptableInfo)); jtHashPtr = &jtPtr->hashTable; Tcl_InitHashTable(jtHashPtr, TCL_STRING_KEYS); @@ -2008,15 +2020,15 @@ CreateMirrorJumpTable( DEBUG_PRINT("jump table {\n"); for (i = 0; i < objc; i+=2) { - DEBUG_PRINT(" %s -> %s\n", Tcl_GetString(objv[i]), - Tcl_GetString(objv[i+1])); - hashEntry = Tcl_CreateHashEntry(jtHashPtr, Tcl_GetString(objv[i]), + DEBUG_PRINT(" %s -> %s\n", TclGetString(objv[i]), + TclGetString(objv[i+1])); + hashEntry = Tcl_CreateHashEntry(jtHashPtr, TclGetString(objv[i]), &isNew); if (!isNew) { if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "duplicate entry in jump table for \"%s\"", - Tcl_GetString(objv[i]))); + TclGetString(objv[i]))); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPJUMPTABLEENTRY"); DeleteMirrorJumpTable(jtPtr); return TCL_ERROR; @@ -2058,7 +2070,7 @@ DeleteMirrorJumpTable( for (entry = Tcl_FirstHashEntry(jtHashPtr, &search); entry != NULL; entry = Tcl_NextHashEntry(&search)) { - label = Tcl_GetHashValue(entry); + label = (Tcl_Obj*)Tcl_GetHashValue(entry); Tcl_DecrRefCount(label); Tcl_SetHashValue(entry, NULL); } @@ -2264,7 +2276,7 @@ GetListIndexOperand( * when list size limits grow. */ status = TclIndexEncode(interp, value, - TCL_INDEX_BEFORE,TCL_INDEX_BEFORE, result); + TCL_INDEX_NONE,TCL_INDEX_NONE, result); Tcl_DecrRefCount(value); *tokenPtrPtr = TokenAfter(tokenPtr); @@ -2312,7 +2324,7 @@ FindLocalVar( if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &varNameObj) != TCL_OK) { return -1; } - varNameStr = Tcl_GetStringFromObj(varNameObj, &varNameLen); + varNameStr = TclGetStringFromObj(varNameObj, &varNameLen); if (CheckNamespaceQualifiers(interp, varNameStr, varNameLen)) { Tcl_DecrRefCount(varNameObj); return -1; @@ -2646,7 +2658,7 @@ AllocBB( AssemblyEnv* assemEnvPtr) /* Assembly environment */ { CompileEnv* envPtr = assemEnvPtr->envPtr; - BasicBlock *bb = ckalloc(sizeof(BasicBlock)); + BasicBlock *bb = (BasicBlock*)ckalloc(sizeof(BasicBlock)); bb->originalStartOffset = bb->startOffset = envPtr->codeNext - envPtr->codeStart; @@ -2825,7 +2837,7 @@ CalculateJumpRelocations( if (bbPtr->jumpTarget != NULL) { entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(bbPtr->jumpTarget)); + TclGetString(bbPtr->jumpTarget)); if (entry == NULL) { ReportUndefinedLabel(assemEnvPtr, bbPtr, bbPtr->jumpTarget); @@ -2837,7 +2849,7 @@ CalculateJumpRelocations( * target is out of range. */ - jumpTarget = Tcl_GetHashValue(entry); + jumpTarget = (BasicBlock*)Tcl_GetHashValue(entry); if (bbPtr->flags & BB_JUMP1) { offset = jumpTarget->startOffset - (bbPtr->jumpOffset + motion); @@ -2904,12 +2916,12 @@ CheckJumpTableLabels( for (symEntryPtr = Tcl_FirstHashEntry(symHash, &search); symEntryPtr != NULL; symEntryPtr = Tcl_NextHashEntry(&search)) { - symbolObj = Tcl_GetHashValue(symEntryPtr); + symbolObj = (Tcl_Obj*)Tcl_GetHashValue(symEntryPtr); valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(symbolObj)); + TclGetString(symbolObj)); DEBUG_PRINT(" %s -> %s (%d)\n", (char*) Tcl_GetHashKey(symHash, symEntryPtr), - Tcl_GetString(symbolObj), (valEntryPtr != NULL)); + TclGetString(symbolObj), (valEntryPtr != NULL)); if (valEntryPtr == NULL) { ReportUndefinedLabel(assemEnvPtr, bbPtr, symbolObj); return TCL_ERROR; @@ -2947,9 +2959,9 @@ ReportUndefinedLabel( if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "undefined label \"%s\"", Tcl_GetString(jumpTarget))); + "undefined label \"%s\"", TclGetString(jumpTarget))); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOLABEL", - Tcl_GetString(jumpTarget), NULL); + TclGetString(jumpTarget), NULL); Tcl_SetErrorLine(interp, bbPtr->jumpLine); } } @@ -3032,8 +3044,8 @@ FillInJumpOffsets( bbPtr = bbPtr->successor1) { if (bbPtr->jumpTarget != NULL) { entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(bbPtr->jumpTarget)); - jumpTarget = Tcl_GetHashValue(entry); + TclGetString(bbPtr->jumpTarget)); + jumpTarget = (BasicBlock*)Tcl_GetHashValue(entry); fromOffset = bbPtr->jumpOffset; targetOffset = jumpTarget->startOffset; if (bbPtr->flags & BB_JUMP1) { @@ -3092,7 +3104,7 @@ ResolveJumpTableTargets( auxDataIndex = TclGetInt4AtPtr(envPtr->codeStart + bbPtr->jumpOffset + 1); DEBUG_PRINT("bbPtr = %p jumpOffset = %d auxDataIndex = %d\n", bbPtr, bbPtr->jumpOffset, auxDataIndex); - realJumpTablePtr = TclFetchAuxData(envPtr, auxDataIndex); + realJumpTablePtr = (JumptableInfo*)TclFetchAuxData(envPtr, auxDataIndex); realJumpHashPtr = &realJumpTablePtr->hashTable; /* @@ -3103,18 +3115,18 @@ ResolveJumpTableTargets( for (symEntryPtr = Tcl_FirstHashEntry(symHash, &search); symEntryPtr != NULL; symEntryPtr = Tcl_NextHashEntry(&search)) { - symbolObj = Tcl_GetHashValue(symEntryPtr); - DEBUG_PRINT(" symbol %s\n", Tcl_GetString(symbolObj)); + symbolObj = (Tcl_Obj*)Tcl_GetHashValue(symEntryPtr); + DEBUG_PRINT(" symbol %s\n", TclGetString(symbolObj)); valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(symbolObj)); - jumpTargetBBPtr = Tcl_GetHashValue(valEntryPtr); + TclGetString(symbolObj)); + jumpTargetBBPtr = (BasicBlock*)Tcl_GetHashValue(valEntryPtr); realJumpEntryPtr = Tcl_CreateHashEntry(realJumpHashPtr, Tcl_GetHashKey(symHash, symEntryPtr), &junk); DEBUG_PRINT(" %s -> %s -> bb %p (pc %d) hash entry %p\n", (char*) Tcl_GetHashKey(symHash, symEntryPtr), - Tcl_GetString(symbolObj), jumpTargetBBPtr, + TclGetString(symbolObj), jumpTargetBBPtr, jumpTargetBBPtr->startOffset, realJumpEntryPtr); Tcl_SetHashValue(realJumpEntryPtr, @@ -3486,8 +3498,8 @@ StackCheckBasicBlock( if (result == TCL_OK && blockPtr->jumpTarget != NULL) { entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(blockPtr->jumpTarget)); - jumpTarget = Tcl_GetHashValue(entry); + TclGetString(blockPtr->jumpTarget)); + jumpTarget = (BasicBlock*)Tcl_GetHashValue(entry); result = StackCheckBasicBlock(assemEnvPtr, jumpTarget, blockPtr, stackDepth); } @@ -3501,10 +3513,10 @@ StackCheckBasicBlock( &jtSearch); result == TCL_OK && jtEntry != NULL; jtEntry = Tcl_NextHashEntry(&jtSearch)) { - targetLabel = Tcl_GetHashValue(jtEntry); + targetLabel = (Tcl_Obj*)Tcl_GetHashValue(jtEntry); entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(targetLabel)); - jumpTarget = Tcl_GetHashValue(entry); + TclGetString(targetLabel)); + jumpTarget = (BasicBlock*)Tcl_GetHashValue(entry); result = StackCheckBasicBlock(assemEnvPtr, jumpTarget, blockPtr, stackDepth); } @@ -3565,7 +3577,7 @@ StackCheckExit( * Emit a 'push' of the empty literal. */ - litIndex = TclRegisterNewLiteral(envPtr, "", 0); + litIndex = TclRegisterLiteral(envPtr, "", 0, 0); /* * Assumes that 'push' is at slot 0 in TalInstructionTable. @@ -3808,8 +3820,8 @@ ProcessCatchesInBasicBlock( } if (result == TCL_OK && bbPtr->jumpTarget != NULL) { entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(bbPtr->jumpTarget)); - jumpTarget = Tcl_GetHashValue(entry); + TclGetString(bbPtr->jumpTarget)); + jumpTarget = (BasicBlock*)Tcl_GetHashValue(entry); result = ProcessCatchesInBasicBlock(assemEnvPtr, jumpTarget, jumpEnclosing, jumpState, catchDepth); } @@ -3822,10 +3834,10 @@ ProcessCatchesInBasicBlock( for (jtEntry = Tcl_FirstHashEntry(&bbPtr->jtPtr->hashTable,&jtSearch); result == TCL_OK && jtEntry != NULL; jtEntry = Tcl_NextHashEntry(&jtSearch)) { - targetLabel = Tcl_GetHashValue(jtEntry); + targetLabel = (Tcl_Obj*)Tcl_GetHashValue(jtEntry); entry = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(targetLabel)); - jumpTarget = Tcl_GetHashValue(entry); + TclGetString(targetLabel)); + jumpTarget = (BasicBlock*)Tcl_GetHashValue(entry); result = ProcessCatchesInBasicBlock(assemEnvPtr, jumpTarget, jumpEnclosing, jumpState, catchDepth); } @@ -3924,8 +3936,8 @@ BuildExceptionRanges( * Allocate memory for a stack of active catches. */ - catches = ckalloc(maxCatchDepth * sizeof(BasicBlock*)); - catchIndices = ckalloc(maxCatchDepth * sizeof(int)); + catches = (BasicBlock**)ckalloc(maxCatchDepth * sizeof(BasicBlock*)); + catchIndices = (int *)ckalloc(maxCatchDepth * sizeof(int)); for (i = 0; i < maxCatchDepth; ++i) { catches[i] = NULL; catchIndices[i] = -1; @@ -3993,7 +4005,7 @@ UnstackExpiredCatches( * corresponding to the catch contexts */ { ExceptionRange* range; /* Exception range for a specific catch */ - BasicBlock* catch; /* Catch block being examined */ + BasicBlock* block; /* Catch block being examined */ BasicBlockCatchState catchState; /* State of the code relative to the catch * block being examined ("in catch" or @@ -4021,18 +4033,18 @@ UnstackExpiredCatches( */ catchState = bbPtr->catchState; - catch = bbPtr->enclosingCatch; + block = bbPtr->enclosingCatch; while (catchDepth > 0) { --catchDepth; if (catches[catchDepth] != NULL) { - if (catches[catchDepth] != catch || catchState >= BBCS_CAUGHT) { + if (catches[catchDepth] != block || catchState >= BBCS_CAUGHT) { range = envPtr->exceptArrayPtr + catchIndices[catchDepth]; range->numCodeBytes = bbPtr->startOffset - range->codeOffset; catches[catchDepth] = NULL; catchIndices[catchDepth] = -1; } - catchState = catch->catchState; - catch = catch->enclosingCatch; + catchState = block->catchState; + block = block->enclosingCatch; } } } @@ -4061,19 +4073,19 @@ LookForFreshCatches( BasicBlockCatchState catchState; /* State ("in catch" or "caught") of the * current catch. */ - BasicBlock* catch; /* Current enclosing catch */ + BasicBlock* block; /* Current enclosing catch */ int catchDepth; /* Nesting depth of the current catch */ catchState = bbPtr->catchState; - catch = bbPtr->enclosingCatch; + block = bbPtr->enclosingCatch; catchDepth = bbPtr->catchDepth; while (catchDepth > 0) { --catchDepth; - if (catches[catchDepth] != catch && catchState < BBCS_CAUGHT) { - catches[catchDepth] = catch; + if (catches[catchDepth] != block && catchState < BBCS_CAUGHT) { + catches[catchDepth] = block; } - catchState = catch->catchState; - catch = catch->enclosingCatch; + catchState = block->catchState; + block = block->enclosingCatch; } } @@ -4101,7 +4113,7 @@ StackFreshCatches( CompileEnv* envPtr = assemEnvPtr->envPtr; /* Compilation environment */ ExceptionRange* range; /* Exception range for a specific catch */ - BasicBlock* catch; /* Catch block being examined */ + BasicBlock* block; /* Catch block being examined */ BasicBlock* errorExit; /* Error exit from the catch block */ Tcl_HashEntry* entryPtr; @@ -4118,7 +4130,7 @@ StackFreshCatches( * Create an exception range for a block that needs one. */ - catch = catches[catchDepth]; + block = catches[catchDepth]; catchIndices[catchDepth] = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); range = envPtr->exceptArrayPtr + catchIndices[catchDepth]; @@ -4128,13 +4140,13 @@ StackFreshCatches( range->codeOffset = bbPtr->startOffset; entryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash, - Tcl_GetString(catch->jumpTarget)); + TclGetString(block->jumpTarget)); if (entryPtr == NULL) { Tcl_Panic("undefined label in tclAssembly.c:" "BuildExceptionRanges, can't happen"); } - errorExit = Tcl_GetHashValue(entryPtr); + errorExit = (BasicBlock*)Tcl_GetHashValue(entryPtr); range->catchOffset = errorExit->startOffset; } } @@ -4265,12 +4277,12 @@ AddBasicBlockRangeToErrorInfo( Tcl_Obj* lineNo; /* Line number in the source */ Tcl_AddErrorInfo(interp, "\n in assembly code between lines "); - lineNo = Tcl_NewIntObj(bbPtr->startLine); + lineNo = Tcl_NewWideIntObj(bbPtr->startLine); Tcl_IncrRefCount(lineNo); Tcl_AppendObjToErrorInfo(interp, lineNo); Tcl_AddErrorInfo(interp, " and "); if (bbPtr->successor1 != NULL) { - Tcl_SetIntObj(lineNo, bbPtr->successor1->startLine); + TclSetIntObj(lineNo, bbPtr->successor1->startLine); Tcl_AppendObjToErrorInfo(interp, lineNo); } else { Tcl_AddErrorInfo(interp, "end of assembly code"); @@ -4335,13 +4347,12 @@ static void FreeAssembleCodeInternalRep( Tcl_Obj *objPtr) { - ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; + ByteCode *codePtr; - codePtr->refCount--; - if (codePtr->refCount <= 0) { - TclCleanupByteCode(codePtr); - } - objPtr->typePtr = NULL; + ByteCodeGetIntRep(objPtr, &assembleCodeType, codePtr); + assert(codePtr != NULL); + + TclReleaseByteCode(codePtr); } /* diff --git a/generic/tclAsync.c b/generic/tclAsync.c index 14804e4..c432e4f 100644 --- a/generic/tclAsync.c +++ b/generic/tclAsync.c @@ -118,7 +118,7 @@ Tcl_AsyncCreate( AsyncHandler *asyncPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - asyncPtr = ckalloc(sizeof(AsyncHandler)); + asyncPtr = (AsyncHandler*)ckalloc(sizeof(AsyncHandler)); asyncPtr->ready = 0; asyncPtr->nextPtr = NULL; asyncPtr->proc = proc; diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 62e7e04..f3a75bb 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -24,6 +24,46 @@ #include <math.h> #include <assert.h> +/* + * TCL_FPCLASSIFY_MODE: + * 0 - fpclassify + * 1 - _fpclass + * 2 - simulate + * 3 - __builtin_fpclassify + */ + +#ifndef TCL_FPCLASSIFY_MODE +#if defined(__MINGW32__) && defined(_X86_) /* mingw 32-bit */ +/* + * MINGW x86 (tested up to gcc 8.1) seems to have a bug in fpclassify, + * [fpclassify 1e-314], x86 => normal, x64 => subnormal, so switch to using a + * version using a compiler built-in. + */ +#define TCL_FPCLASSIFY_MODE 1 +#elif defined(fpclassify) /* fpclassify */ +/* + * This is the C99 standard. + */ +#include <float.h> +#define TCL_FPCLASSIFY_MODE 0 +#elif defined(_FPCLASS_NN) /* _fpclass */ +/* + * This case handles newer MSVC on Windows, which doesn't have the standard + * operation but does have something that can tell us the same thing. + */ +#define TCL_FPCLASSIFY_MODE 1 +#else /* !fpclassify && !_fpclass (older MSVC), simulate */ +/* + * Older MSVC on Windows. So broken that we just have to do it our way. This + * assumes that we're on x86 (or at least a system with classic little-endian + * double layout and a 32-bit 'int' type). + */ +#define TCL_FPCLASSIFY_MODE 2 +#endif /* !fpclassify */ +/* actually there is no fallback to builtin fpclassify */ +#endif /* !TCL_FPCLASSIFY_MODE */ + + #define INTERP_STACK_INITIAL_SIZE 2000 #define CORO_STACK_INITIAL_SIZE 200 @@ -71,7 +111,18 @@ typedef struct { } CancelInfo; static Tcl_HashTable cancelTable; static int cancelTableInitialized = 0; /* 0 means not yet initialized. */ -TCL_DECLARE_MUTEX(cancelLock) +TCL_DECLARE_MUTEX(cancelLock); + +/* + * Table used to map command implementation functions to a human-readable type + * name, for [info type]. The keys in the table are function addresses, and + * the values in the table are static char* containing strings in Tcl's + * internal encoding (almost UTF-8). + */ + +static Tcl_HashTable commandTypeTable; +static int commandTypeInit = 0; +TCL_DECLARE_MUTEX(commandTypeLock); /* * Declarations for managing contexts for non-recursive coroutines. Contexts @@ -94,6 +145,7 @@ TCL_DECLARE_MUTEX(cancelLock) * Static functions in this file: */ +static Tcl_ObjCmdProc BadEnsembleSubcommand; static char * CallCommandTraces(Interp *iPtr, Command *cmdPtr, const char *oldName, const char *newName, int flags); @@ -114,24 +166,34 @@ static Tcl_ObjCmdProc ExprBinaryFunc; static Tcl_ObjCmdProc ExprBoolFunc; static Tcl_ObjCmdProc ExprCeilFunc; static Tcl_ObjCmdProc ExprDoubleFunc; -static Tcl_ObjCmdProc ExprEntierFunc; static Tcl_ObjCmdProc ExprFloorFunc; static Tcl_ObjCmdProc ExprIntFunc; static Tcl_ObjCmdProc ExprIsqrtFunc; +static Tcl_ObjCmdProc ExprIsFiniteFunc; +static Tcl_ObjCmdProc ExprIsInfinityFunc; +static Tcl_ObjCmdProc ExprIsNaNFunc; +static Tcl_ObjCmdProc ExprIsNormalFunc; +static Tcl_ObjCmdProc ExprIsSubnormalFunc; +static Tcl_ObjCmdProc ExprIsUnorderedFunc; +static Tcl_ObjCmdProc ExprMaxFunc; +static Tcl_ObjCmdProc ExprMinFunc; static Tcl_ObjCmdProc ExprRandFunc; static Tcl_ObjCmdProc ExprRoundFunc; static Tcl_ObjCmdProc ExprSqrtFunc; static Tcl_ObjCmdProc ExprSrandFunc; static Tcl_ObjCmdProc ExprUnaryFunc; static Tcl_ObjCmdProc ExprWideFunc; +static Tcl_ObjCmdProc FloatClassifyObjCmd; static void MathFuncWrongNumArgs(Tcl_Interp *interp, int expected, int actual, Tcl_Obj *const *objv); static Tcl_NRPostProc NRCoroutineCallerCallback; static Tcl_NRPostProc NRCoroutineExitCallback; static Tcl_NRPostProc NRCommand; +#if !defined(TCL_NO_DEPRECATED) static Tcl_ObjCmdProc OldMathFuncProc; static void OldMathFuncDeleteProc(ClientData clientData); +#endif /* !defined(TCL_NO_DEPRECATED) */ static void ProcessUnexpectedResult(Tcl_Interp *interp, int returnCode); static int RewindCoroutine(CoroutineData *corPtr, int result); @@ -156,9 +218,13 @@ static Tcl_NRPostProc TEOV_RunLeaveTraces; static Tcl_NRPostProc EvalObjvCore; static Tcl_NRPostProc Dispatch; -static Tcl_ObjCmdProc NRCoroInjectObjCmd; +static Tcl_ObjCmdProc NRInjectObjCmd; static Tcl_NRPostProc NRPostInvoke; static Tcl_ObjCmdProc CoroTypeObjCmd; +static Tcl_ObjCmdProc TclNRCoroInjectObjCmd; +static Tcl_ObjCmdProc TclNRCoroProbeObjCmd; +static Tcl_NRPostProc InjectHandler; +static Tcl_NRPostProc InjectHandlerPostCall; MODULE_SCOPE const TclStubs tclStubs; @@ -193,6 +259,24 @@ typedef struct { * it for it. Defined in tclInt.h. */ /* + * The following struct states that the command it talks about (a subcommand + * of one of Tcl's built-in ensembles) is unsafe and must be hidden when an + * interpreter is made safe. (TclHideUnsafeCommands accesses an array of these + * structs.) Alas, we can't sensibly just store the information directly in + * the commands. + */ + +typedef struct { + const char *ensembleNsName; /* The ensemble's name within ::tcl. NULL for + * the end of the list of commands to hide. */ + const char *commandName; /* The name of the command within the + * ensemble. If this is NULL, we want to also + * make the overall command be hidden, an ugly + * hack because it is expected by security + * policies in the wild. */ +} UnsafeEnsembleInfo; + +/* * The built-in commands, and the functions that implement them: */ @@ -204,12 +288,14 @@ static const CmdInfo builtInCmds[] = { {"append", Tcl_AppendObjCmd, TclCompileAppendCmd, NULL, CMD_IS_SAFE}, {"apply", Tcl_ApplyObjCmd, NULL, TclNRApplyObjCmd, CMD_IS_SAFE}, {"break", Tcl_BreakObjCmd, TclCompileBreakCmd, NULL, CMD_IS_SAFE}, -#ifndef EXCLUDE_OBSOLETE_COMMANDS +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 {"case", Tcl_CaseObjCmd, NULL, NULL, CMD_IS_SAFE}, #endif {"catch", Tcl_CatchObjCmd, TclCompileCatchCmd, TclNRCatchObjCmd, CMD_IS_SAFE}, {"concat", Tcl_ConcatObjCmd, TclCompileConcatCmd, NULL, CMD_IS_SAFE}, {"continue", Tcl_ContinueObjCmd, TclCompileContinueCmd, NULL, CMD_IS_SAFE}, + {"coroinject", NULL, NULL, TclNRCoroInjectObjCmd, CMD_IS_SAFE}, + {"coroprobe", NULL, NULL, TclNRCoroProbeObjCmd, CMD_IS_SAFE}, {"coroutine", NULL, NULL, TclNRCoroutineObjCmd, CMD_IS_SAFE}, {"error", Tcl_ErrorObjCmd, TclCompileErrorCmd, NULL, CMD_IS_SAFE}, {"eval", Tcl_EvalObjCmd, NULL, TclNREvalObjCmd, CMD_IS_SAFE}, @@ -217,6 +303,7 @@ static const CmdInfo builtInCmds[] = { {"for", Tcl_ForObjCmd, TclCompileForCmd, TclNRForObjCmd, CMD_IS_SAFE}, {"foreach", Tcl_ForeachObjCmd, TclCompileForeachCmd, TclNRForeachCmd, CMD_IS_SAFE}, {"format", Tcl_FormatObjCmd, TclCompileFormatCmd, NULL, CMD_IS_SAFE}, + {"fpclassify", FloatClassifyObjCmd, NULL, NULL, CMD_IS_SAFE}, {"global", Tcl_GlobalObjCmd, TclCompileGlobalCmd, NULL, CMD_IS_SAFE}, {"if", Tcl_IfObjCmd, TclCompileIfCmd, TclNRIfObjCmd, CMD_IS_SAFE}, {"incr", Tcl_IncrObjCmd, TclCompileIncrCmd, NULL, CMD_IS_SAFE}, @@ -228,7 +315,9 @@ static const CmdInfo builtInCmds[] = { {"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, CMD_IS_SAFE|CMD_COMPILES_EXPANDED}, {"llength", Tcl_LlengthObjCmd, TclCompileLlengthCmd, NULL, CMD_IS_SAFE}, {"lmap", Tcl_LmapObjCmd, TclCompileLmapCmd, TclNRLmapCmd, CMD_IS_SAFE}, + {"lpop", Tcl_LpopObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lrange", Tcl_LrangeObjCmd, TclCompileLrangeCmd, NULL, CMD_IS_SAFE}, + {"lremove", Tcl_LremoveObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lrepeat", Tcl_LrepeatObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lreplace", Tcl_LreplaceObjCmd, TclCompileLreplaceCmd, NULL, CMD_IS_SAFE}, {"lreverse", Tcl_LreverseObjCmd, NULL, NULL, CMD_IS_SAFE}, @@ -286,9 +375,7 @@ static const CmdInfo builtInCmds[] = { {"source", Tcl_SourceObjCmd, NULL, TclNRSourceObjCmd, 0}, {"tell", Tcl_TellObjCmd, NULL, NULL, CMD_IS_SAFE}, {"time", Tcl_TimeObjCmd, NULL, NULL, CMD_IS_SAFE}, -#ifdef TCL_TIMERATE {"timerate", Tcl_TimeRateObjCmd, NULL, NULL, CMD_IS_SAFE}, -#endif {"unload", Tcl_UnloadObjCmd, NULL, NULL, 0}, {"update", Tcl_UpdateObjCmd, NULL, NULL, CMD_IS_SAFE}, {"vwait", Tcl_VwaitObjCmd, NULL, NULL, CMD_IS_SAFE}, @@ -296,6 +383,69 @@ static const CmdInfo builtInCmds[] = { }; /* + * Information about which pieces of ensembles to hide when making an + * interpreter safe: + */ + +static const UnsafeEnsembleInfo unsafeEnsembleCommands[] = { + /* [encoding] has two unsafe commands. Assumed by older security policies + * to be overall unsafe; it isn't but... */ + {"encoding", NULL}, + {"encoding", "dirs"}, + {"encoding", "system"}, + /* [file] has MANY unsafe commands! Assumed by older security policies to + * be overall unsafe; it isn't but... */ + {"file", NULL}, + {"file", "atime"}, + {"file", "attributes"}, + {"file", "copy"}, + {"file", "delete"}, + {"file", "dirname"}, + {"file", "executable"}, + {"file", "exists"}, + {"file", "extension"}, + {"file", "isdirectory"}, + {"file", "isfile"}, + {"file", "link"}, + {"file", "lstat"}, + {"file", "mtime"}, + {"file", "mkdir"}, + {"file", "nativename"}, + {"file", "normalize"}, + {"file", "owned"}, + {"file", "readable"}, + {"file", "readlink"}, + {"file", "rename"}, + {"file", "rootname"}, + {"file", "size"}, + {"file", "stat"}, + {"file", "tail"}, + {"file", "tempdir"}, + {"file", "tempfile"}, + {"file", "type"}, + {"file", "volumes"}, + {"file", "writable"}, + /* [info] has two unsafe commands */ + {"info", "cmdtype"}, + {"info", "nameofexecutable"}, + /* [tcl::process] has ONLY unsafe commands! */ + {"process", "list"}, + {"process", "status"}, + {"process", "purge"}, + {"process", "autopurge"}, + /* [zipfs] has MANY unsafe commands! */ + {"zipfs", "lmkimg"}, + {"zipfs", "lmkzip"}, + {"zipfs", "mkimg"}, + {"zipfs", "mkkey"}, + {"zipfs", "mkzip"}, + {"zipfs", "mount"}, + {"zipfs", "mount_data"}, + {"zipfs", "unmount"}, + {NULL, NULL} +}; + +/* * Math functions. All are safe. */ @@ -316,15 +466,23 @@ static const BuiltinFuncDef BuiltinFuncTable[] = { { "cos", ExprUnaryFunc, (ClientData) cos }, { "cosh", ExprUnaryFunc, (ClientData) cosh }, { "double", ExprDoubleFunc, NULL }, - { "entier", ExprEntierFunc, NULL }, + { "entier", ExprIntFunc, NULL }, { "exp", ExprUnaryFunc, (ClientData) exp }, { "floor", ExprFloorFunc, NULL }, { "fmod", ExprBinaryFunc, (ClientData) fmod }, { "hypot", ExprBinaryFunc, (ClientData) hypot }, { "int", ExprIntFunc, NULL }, + { "isfinite", ExprIsFiniteFunc, NULL }, + { "isinf", ExprIsInfinityFunc, NULL }, + { "isnan", ExprIsNaNFunc, NULL }, + { "isnormal", ExprIsNormalFunc, NULL }, { "isqrt", ExprIsqrtFunc, NULL }, + { "issubnormal", ExprIsSubnormalFunc, NULL, }, + { "isunordered", ExprIsUnorderedFunc, NULL, }, { "log", ExprUnaryFunc, (ClientData) log }, { "log10", ExprUnaryFunc, (ClientData) log10 }, + { "max", ExprMaxFunc, NULL }, + { "min", ExprMinFunc, NULL }, { "pow", ExprBinaryFunc, (ClientData) pow }, { "rand", ExprRandFunc, NULL }, { "round", ExprRoundFunc, NULL }, @@ -400,6 +558,14 @@ static const OpCmdInfo mathOpCmds[] = { /* unused */ {0}, NULL}, { "eq", TclSortingOpCmd, TclCompileStreqOpCmd, /* unused */ {0}, NULL}, + { "lt", TclSortingOpCmd, TclCompileStrLtOpCmd, + /* unused */ {0}, NULL}, + { "le", TclSortingOpCmd, TclCompileStrLeOpCmd, + /* unused */ {0}, NULL}, + { "gt", TclSortingOpCmd, TclCompileStrGtOpCmd, + /* unused */ {0}, NULL}, + { "ge", TclSortingOpCmd, TclCompileStrGeOpCmd, + /* unused */ {0}, NULL}, { NULL, NULL, NULL, {0}, NULL} }; @@ -429,6 +595,13 @@ TclFinalizeEvaluation(void) cancelTableInitialized = 0; } Tcl_MutexUnlock(&cancelLock); + + Tcl_MutexLock(&commandTypeLock); + if (commandTypeInit) { + Tcl_DeleteHashTable(&commandTypeTable); + commandTypeInit = 0; + } + Tcl_MutexUnlock(&commandTypeLock); } /* @@ -497,8 +670,8 @@ Tcl_CreateInterp(void) /*NOTREACHED*/ Tcl_Panic("<time.h> is not compatible with MSVC"); } - if ((TclOffset(Tcl_StatBuf,st_atime) != 32) - || (TclOffset(Tcl_StatBuf,st_ctime) != 40)) { + if ((offsetof(Tcl_StatBuf,st_atime) != 32) + || (offsetof(Tcl_StatBuf,st_ctime) != 40)) { /*NOTREACHED*/ Tcl_Panic("<sys/stat.h> is not compatible with MSVC"); } @@ -510,9 +683,23 @@ Tcl_CreateInterp(void) Tcl_InitHashTable(&cancelTable, TCL_ONE_WORD_KEYS); cancelTableInitialized = 1; } + Tcl_MutexUnlock(&cancelLock); } + if (commandTypeInit == 0) { + TclRegisterCommandTypeName(TclObjInterpProc, "proc"); + TclRegisterCommandTypeName(TclEnsembleImplementationCmd, "ensemble"); + TclRegisterCommandTypeName(TclAliasObjCmd, "alias"); + TclRegisterCommandTypeName(TclLocalAliasObjCmd, "alias"); + TclRegisterCommandTypeName(TclSlaveObjCmd, "slave"); + TclRegisterCommandTypeName(TclInvokeImportedCmd, "import"); + TclRegisterCommandTypeName(TclOOPublicObjectCmd, "object"); + TclRegisterCommandTypeName(TclOOPrivateObjectCmd, "privateObject"); + TclRegisterCommandTypeName(TclOOMyClassObjCmd, "privateClass"); + TclRegisterCommandTypeName(TclNRInterpCoroutine, "coroutine"); + } + /* * Initialize support for namespaces and create the global namespace * (whose name is ""; an alias is "::"). This also initializes the Tcl @@ -522,7 +709,11 @@ Tcl_CreateInterp(void) iPtr = ckalloc(sizeof(Interp)); interp = (Tcl_Interp *) iPtr; +#ifdef TCL_NO_DEPRECATED + iPtr->result = &tclEmptyString; +#else iPtr->result = iPtr->resultSpace; +#endif iPtr->freeProc = NULL; iPtr->errorLine = 0; iPtr->objResultPtr = Tcl_NewObj(); @@ -582,23 +773,26 @@ Tcl_CreateInterp(void) iPtr->rootFramePtr = NULL; /* Initialise as soon as :: is available */ iPtr->lookupNsPtr = NULL; +#ifndef TCL_NO_DEPRECATED iPtr->appendResult = NULL; iPtr->appendAvl = 0; iPtr->appendUsed = 0; +#endif Tcl_InitHashTable(&iPtr->packageTable, TCL_STRING_KEYS); iPtr->packageUnknown = NULL; /* TIP #268 */ +#if (TCL_RELEASE_LEVEL == TCL_FINAL_RELEASE) if (getenv("TCL_PKG_PREFER_LATEST") == NULL) { iPtr->packagePrefer = PKG_PREFER_STABLE; - } else { + } else +#endif iPtr->packagePrefer = PKG_PREFER_LATEST; - } iPtr->cmdCount = 0; TclInitLiteralTable(&iPtr->literalTable); - iPtr->compileEpoch = 0; + iPtr->compileEpoch = 1; iPtr->compiledProcPtr = NULL; iPtr->resolverPtr = NULL; iPtr->evalFlags = 0; @@ -613,7 +807,9 @@ Tcl_CreateInterp(void) iPtr->emptyObjPtr = Tcl_NewObj(); /* Another empty object. */ Tcl_IncrRefCount(iPtr->emptyObjPtr); +#ifndef TCL_NO_DEPRECATED iPtr->resultSpace[0] = 0; +#endif iPtr->threadId = Tcl_GetCurrentThread(); /* TIP #378 */ @@ -746,7 +942,7 @@ Tcl_CreateInterp(void) * cache was already initialised by the call to alloc the interp struct. */ -#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) +#if TCL_THREADS && defined(USE_THREAD_ALLOC) iPtr->allocCache = TclpGetAllocCache(); #else iPtr->allocCache = NULL; @@ -816,6 +1012,7 @@ Tcl_CreateInterp(void) TclInitNamespaceCmd(interp); TclInitStringCmd(interp); TclInitPrefixCmd(interp); + TclInitProcessCmd(interp); /* * Register "clock" subcommands. These *do* go through @@ -856,14 +1053,10 @@ Tcl_CreateInterp(void) /* Coroutine monkeybusiness */ Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL, - NRCoroInjectObjCmd, NULL, NULL); + NRInjectObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "::tcl::unsupported::corotype", CoroTypeObjCmd, NULL, NULL); - /* Create an unsupported command for timerate */ - Tcl_CreateObjCommand(interp, "::tcl::unsupported::timerate", - Tcl_TimeRateObjCmd, NULL, NULL); - /* Export unsupported commands */ nsPtr = Tcl_FindNamespace(interp, "::tcl::unsupported", NULL, 0); if (nsPtr) { @@ -955,24 +1148,26 @@ Tcl_CreateInterp(void) TCL_GLOBAL_ONLY); Tcl_SetVar2Ex(interp, "tcl_platform", "wordSize", - Tcl_NewLongObj((long) sizeof(long)), TCL_GLOBAL_ONLY); + Tcl_NewWideIntObj(sizeof(long)), TCL_GLOBAL_ONLY); /* TIP #291 */ Tcl_SetVar2Ex(interp, "tcl_platform", "pointerSize", - Tcl_NewLongObj((long) sizeof(void *)), TCL_GLOBAL_ONLY); + Tcl_NewWideIntObj(sizeof(void *)), TCL_GLOBAL_ONLY); /* * Set up other variables such as tcl_version and tcl_library */ - Tcl_SetVar(interp, "tcl_patchLevel", TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY); - Tcl_SetVar(interp, "tcl_version", TCL_VERSION, TCL_GLOBAL_ONLY); + Tcl_SetVar2(interp, "tcl_patchLevel", NULL, TCL_PATCH_LEVEL, TCL_GLOBAL_ONLY); + Tcl_SetVar2(interp, "tcl_version", NULL, TCL_VERSION, TCL_GLOBAL_ONLY); +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 Tcl_TraceVar2(interp, "tcl_precision", NULL, TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, TclPrecTraceProc, NULL); +#endif /* !TCL_NO_DEPRECATED */ TclpSetVariables(interp); -#ifdef TCL_THREADS +#if TCL_THREADS /* * The existence of the "threaded" element of the tcl_platform array * indicates that this particular Tcl shell has been compiled with threads @@ -991,11 +1186,11 @@ Tcl_CreateInterp(void) Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs); if (TclTommath_Init(interp) != TCL_OK) { - Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); + Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp))); } if (TclOOInit(interp) != TCL_OK) { - Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); + Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp))); } /* @@ -1005,6 +1200,9 @@ Tcl_CreateInterp(void) #ifdef HAVE_ZLIB if (TclZlibInit(interp) != TCL_OK) { + Tcl_Panic("%s", TclGetString(Tcl_GetObjResult(interp))); + } + if (TclZipfs_Init(interp) != TCL_OK) { Tcl_Panic("%s", Tcl_GetString(Tcl_GetObjResult(interp))); } #endif @@ -1023,6 +1221,71 @@ DeleteOpCmdClientData( } /* + * --------------------------------------------------------------------- + * + * TclRegisterCommandTypeName, TclGetCommandTypeName -- + * + * Command type registration and lookup mechanism. Everything is keyed by + * the Tcl_ObjCmdProc for the command, and that is used as the *key* into + * the hash table that maps to constant strings that are names. (It is + * recommended that those names be ASCII.) + * + * --------------------------------------------------------------------- + */ + +void +TclRegisterCommandTypeName( + Tcl_ObjCmdProc *implementationProc, + const char *nameStr) +{ + Tcl_HashEntry *hPtr; + + Tcl_MutexLock(&commandTypeLock); + if (commandTypeInit == 0) { + Tcl_InitHashTable(&commandTypeTable, TCL_ONE_WORD_KEYS); + commandTypeInit = 1; + } + if (nameStr != NULL) { + int isNew; + + hPtr = Tcl_CreateHashEntry(&commandTypeTable, + (void *) implementationProc, &isNew); + Tcl_SetHashValue(hPtr, (void *) nameStr); + } else { + hPtr = Tcl_FindHashEntry(&commandTypeTable, + (void *) implementationProc); + if (hPtr != NULL) { + Tcl_DeleteHashEntry(hPtr); + } + } + Tcl_MutexUnlock(&commandTypeLock); +} + +const char * +TclGetCommandTypeName( + Tcl_Command command) +{ + Command *cmdPtr = (Command *) command; + void *procPtr = cmdPtr->objProc; + const char *name = "native"; + + if (procPtr == NULL) { + procPtr = cmdPtr->nreProc; + } + Tcl_MutexLock(&commandTypeLock); + if (commandTypeInit) { + Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&commandTypeTable, procPtr); + + if (hPtr && Tcl_GetHashValue(hPtr)) { + name = (const char *) Tcl_GetHashValue(hPtr); + } + } + Tcl_MutexUnlock(&commandTypeLock); + + return name; +} + +/* *---------------------------------------------------------------------- * * TclHideUnsafeCommands -- @@ -1043,6 +1306,7 @@ TclHideUnsafeCommands( Tcl_Interp *interp) /* Hide commands in this interpreter. */ { register const CmdInfo *cmdInfoPtr; + register const UnsafeEnsembleInfo *unsafePtr; if (interp == NULL) { return TCL_ERROR; @@ -1052,12 +1316,83 @@ TclHideUnsafeCommands( Tcl_HideCommand(interp, cmdInfoPtr->name, cmdInfoPtr->name); } } - TclMakeEncodingCommandSafe(interp); /* Ugh! */ - TclMakeFileCommandSafe(interp); /* Ugh! */ + + for (unsafePtr = unsafeEnsembleCommands; + unsafePtr->ensembleNsName; unsafePtr++) { + if (unsafePtr->commandName) { + /* + * Hide an ensemble subcommand. + */ + + Tcl_Obj *cmdName = Tcl_ObjPrintf("::tcl::%s::%s", + unsafePtr->ensembleNsName, unsafePtr->commandName); + Tcl_Obj *hideName = Tcl_ObjPrintf("tcl:%s:%s", + unsafePtr->ensembleNsName, unsafePtr->commandName); + + if (TclRenameCommand(interp, TclGetString(cmdName), + "___tmp") != TCL_OK + || Tcl_HideCommand(interp, "___tmp", + TclGetString(hideName)) != TCL_OK) { + Tcl_Panic("problem making '%s %s' safe: %s", + unsafePtr->ensembleNsName, unsafePtr->commandName, + Tcl_GetString(Tcl_GetObjResult(interp))); + } + Tcl_CreateObjCommand(interp, TclGetString(cmdName), + BadEnsembleSubcommand, (ClientData) unsafePtr, NULL); + TclDecrRefCount(cmdName); + TclDecrRefCount(hideName); + } else { + /* + * Hide an ensemble main command (for compatibility). + */ + + if (Tcl_HideCommand(interp, unsafePtr->ensembleNsName, + unsafePtr->ensembleNsName) != TCL_OK) { + Tcl_Panic("problem making '%s' safe: %s", + unsafePtr->ensembleNsName, + Tcl_GetString(Tcl_GetObjResult(interp))); + } + } + } + return TCL_OK; } /* + *---------------------------------------------------------------------- + * + * BadEnsembleSubcommand -- + * + * Command used to act as a backstop implementation when subcommands of + * ensembles are unsafe (the real implementations of the subcommands are + * hidden). The clientData is description of what was hidden. + * + * Results: + * A standard Tcl result (always a TCL_ERROR). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +BadEnsembleSubcommand( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + const UnsafeEnsembleInfo *infoPtr = clientData; + + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "not allowed to invoke subcommand %s of %s", + infoPtr->commandName, infoPtr->ensembleNsName)); + Tcl_SetErrorCode(interp, "TCL", "SAFE", "SUBCOMMAND", NULL); + return TCL_ERROR; +} + +/* *-------------------------------------------------------------- * * Tcl_CallWhenDeleted -- @@ -1088,7 +1423,7 @@ Tcl_CallWhenDeleted( Interp *iPtr = (Interp *) interp; static Tcl_ThreadDataKey assocDataCounterKey; int *assocDataCounterPtr = - Tcl_GetThreadData(&assocDataCounterKey, (int)sizeof(int)); + Tcl_GetThreadData(&assocDataCounterKey, sizeof(int)); int isNew; char buffer[32 + TCL_INTEGER_SPACE]; AssocData *dPtr = ckalloc(sizeof(AssocData)); @@ -1560,10 +1895,12 @@ DeleteInterpProc( if (iPtr->returnOpts) { Tcl_DecrRefCount(iPtr->returnOpts); } +#ifndef TCL_NO_DEPRECATED if (iPtr->appendResult != NULL) { ckfree(iPtr->appendResult); iPtr->appendResult = NULL; } +#endif TclFreePackageInfo(iPtr); while (iPtr->tracePtr != NULL) { Tcl_DeleteTrace((Tcl_Interp *) iPtr, (Tcl_Trace) iPtr->tracePtr); @@ -1661,7 +1998,7 @@ DeleteInterpProc( } Tcl_DeleteHashTable(iPtr->lineLAPtr); - ckfree((char *) iPtr->lineLAPtr); + ckfree(iPtr->lineLAPtr); iPtr->lineLAPtr = NULL; if (iPtr->lineLABCPtr->numEntries && !TclInExit()) { @@ -2302,30 +2639,33 @@ Tcl_CreateObjCommand( } Tcl_Command -TclCreateObjCommandInNs ( +TclCreateObjCommandInNs( Tcl_Interp *interp, - const char *cmdName, /* Name of command, without any namespace components */ - Tcl_Namespace *namespace, /* The namespace to create the command in */ + const char *cmdName, /* Name of command, without any namespace + * components. */ + Tcl_Namespace *namesp, /* The namespace to create the command in */ Tcl_ObjCmdProc *proc, /* Object-based function to associate with * name. */ ClientData clientData, /* Arbitrary value to pass to object * function. */ - Tcl_CmdDeleteProc *deleteProc + Tcl_CmdDeleteProc *deleteProc) /* If not NULL, gives a function to call when * this command is deleted. */ -) { +{ int deleted = 0, isNew = 0; Command *cmdPtr; ImportRef *oldRefPtr = NULL; ImportedCmdData *dataPtr; Tcl_HashEntry *hPtr; - Namespace *nsPtr = (Namespace *) namespace; + Namespace *nsPtr = (Namespace *) namesp; + /* - * If the command name we seek to create already exists, we need to - * delete that first. That can be tricky in the presence of traces. - * Loop until we no longer find an existing command in the way, or - * until we've deleted one command and that didn't finish the job. + * If the command name we seek to create already exists, we need to delete + * that first. That can be tricky in the presence of traces. Loop until we + * no longer find an existing command in the way, or until we've deleted + * one command and that didn't finish the job. */ + while (1) { hPtr = Tcl_CreateHashEntry(&nsPtr->cmdTable, cmdName, &isNew); @@ -2380,7 +2720,7 @@ TclCreateObjCommandInNs ( Tcl_DeleteCommandFromToken(interp, (Tcl_Command) cmdPtr); nsPtr = (Namespace *) TclEnsureNamespace(interp, - (Tcl_Namespace *)cmdPtr->nsPtr); + (Tcl_Namespace *) cmdPtr->nsPtr); TclNsDecrRefCount(cmdPtr->nsPtr); if (cmdPtr->flags & CMD_REDEF_IN_PROGRESS) { @@ -2392,9 +2732,9 @@ TclCreateObjCommandInNs ( } if (!isNew) { /* - * If the deletion callback recreated the command, just throw away - * the new command (if we try to delete it again, we could get - * stuck in an infinite loop). + * If the deletion callback recreated the command, just throw away the + * new command (if we try to delete it again, we could get stuck in an + * infinite loop). */ ckfree(Tcl_GetHashValue(hPtr)); @@ -2449,6 +2789,7 @@ TclCreateObjCommandInNs ( cmdPtr->importRefPtr = oldRefPtr; while (oldRefPtr != NULL) { Command *refCmdPtr = oldRefPtr->importedCmdPtr; + dataPtr = refCmdPtr->objClientData; dataPtr->realCmdPtr = cmdPtr; oldRefPtr = oldRefPtr->nextPtr; @@ -2497,10 +2838,10 @@ TclInvokeStringCommand( Command *cmdPtr = clientData; int i, result; const char **argv = - TclStackAlloc(interp, (unsigned)(objc + 1) * sizeof(char *)); + TclStackAlloc(interp, (objc + 1) * sizeof(char *)); for (i = 0; i < objc; i++) { - argv[i] = Tcl_GetString(objv[i]); + argv[i] = TclGetString(objv[i]); } argv[objc] = 0; @@ -2526,7 +2867,7 @@ TclInvokeStringCommand( * in the Command structure. * * Results: - * A standard Tcl string result value. + * A standard Tcl result value. * * Side effects: * Besides those side effects of the called Tcl_ObjCmdProc, @@ -2546,7 +2887,7 @@ TclInvokeObjectCommand( Tcl_Obj *objPtr; int i, length, result; Tcl_Obj **objv = - TclStackAlloc(interp, (unsigned)(argc * sizeof(Tcl_Obj *))); + TclStackAlloc(interp, (argc * sizeof(Tcl_Obj *))); for (i = 0; i < argc; i++) { length = strlen(argv[i]); @@ -2754,7 +3095,7 @@ TclRenameCommand( } Tcl_DStringAppend(&newFullName, newTail, -1); cmdPtr->refCount++; - CallCommandTraces(iPtr, cmdPtr, Tcl_GetString(oldFullName), + CallCommandTraces(iPtr, cmdPtr, TclGetString(oldFullName), Tcl_DStringValue(&newFullName), TCL_TRACE_RENAME); Tcl_DStringFree(&newFullName); @@ -3121,13 +3462,6 @@ Tcl_DeleteCommandFromToken( Tcl_Command importCmd; /* - * Bump the command epoch counter. This will invalidate all cached - * references that point to this command. - */ - - cmdPtr->cmdEpoch++; - - /* * The code here is tricky. We can't delete the hash table entry before * invoking the deletion callback because there are cases where the * deletion callback needs to invoke the command (e.g. object systems such @@ -3149,6 +3483,14 @@ Tcl_DeleteCommandFromToken( Tcl_DeleteHashEntry(cmdPtr->hPtr); cmdPtr->hPtr = NULL; } + + /* + * Bump the command epoch counter. This will invalidate all cached + * references that point to this command. + */ + + cmdPtr->cmdEpoch++; + return 0; } @@ -3254,6 +3596,13 @@ Tcl_DeleteCommandFromToken( if (cmdPtr->hPtr != NULL) { Tcl_DeleteHashEntry(cmdPtr->hPtr); cmdPtr->hPtr = NULL; + + /* + * Bump the command epoch counter. This will invalidate all cached + * references that point to this command. + */ + + cmdPtr->cmdEpoch++; } /* @@ -3500,8 +3849,7 @@ TclCleanupCommand( register Command *cmdPtr) /* Points to the Command structure to * be freed. */ { - cmdPtr->refCount--; - if (cmdPtr->refCount <= 0) { + if (cmdPtr->refCount-- <= 1) { ckfree(cmdPtr); } } @@ -3528,6 +3876,7 @@ TclCleanupCommand( *---------------------------------------------------------------------- */ +#if !defined(TCL_NO_DEPRECATED) void Tcl_CreateMathFunc( Tcl_Interp *interp, /* Interpreter in which function is to be @@ -3578,7 +3927,7 @@ Tcl_CreateMathFunc( static int OldMathFuncProc( - ClientData clientData, /* Ponter to OldMathFuncData describing the + ClientData clientData, /* Pointer to OldMathFuncData describing the * function being called */ Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Actual parameter count */ @@ -3610,9 +3959,14 @@ OldMathFuncProc( valuePtr = objv[j]; result = Tcl_GetDoubleFromObj(NULL, valuePtr, &d); #ifdef ACCEPT_NAN - if ((result != TCL_OK) && (valuePtr->typePtr == &tclDoubleType)) { - d = valuePtr->internalRep.doubleValue; - result = TCL_OK; + if (result != TCL_OK) { + const Tcl_ObjIntRep *irPtr + = TclFetchIntRep(valuePtr, &tclDoubleType); + + if (irPtr) { + d = irPtr->doubleValue; + result = TCL_OK; + } } #endif if (result != TCL_OK) { @@ -3623,7 +3977,7 @@ OldMathFuncProc( Tcl_SetObjResult(interp, Tcl_NewStringObj( "argument to math function didn't have numeric value", -1)); - TclCheckBadOctal(interp, Tcl_GetString(valuePtr)); + TclCheckBadOctal(interp, TclGetString(valuePtr)); ckfree(args); return TCL_ERROR; } @@ -3691,7 +4045,7 @@ OldMathFuncProc( */ if (funcResult.type == TCL_INT) { - TclNewLongObj(valuePtr, funcResult.intValue); + TclNewIntObj(valuePtr, funcResult.intValue); } else if (funcResult.type == TCL_WIDE_INT) { valuePtr = Tcl_NewWideIntObj(funcResult.wideValue); } else { @@ -3859,6 +4213,7 @@ Tcl_ListMathFuncs( return result; } +#endif /* !defined(TCL_NO_DEPRECATED) */ /* *---------------------------------------------------------------------- @@ -4043,7 +4398,7 @@ Tcl_Canceled( */ if (iPtr->asyncCancelMsg != NULL) { - message = Tcl_GetStringFromObj(iPtr->asyncCancelMsg, &length); + message = TclGetStringFromObj(iPtr->asyncCancelMsg, &length); } else { length = 0; } @@ -4142,9 +4497,9 @@ Tcl_CancelEval( */ if (resultObjPtr != NULL) { - result = Tcl_GetStringFromObj(resultObjPtr, &cancelInfo->length); + result = TclGetStringFromObj(resultObjPtr, &cancelInfo->length); cancelInfo->result = ckrealloc(cancelInfo->result,cancelInfo->length); - memcpy(cancelInfo->result, result, (size_t) cancelInfo->length); + memcpy(cancelInfo->result, result, cancelInfo->length); TclDecrRefCount(resultObjPtr); /* Discard their result object. */ } else { cancelInfo->result = NULL; @@ -4470,7 +4825,9 @@ TclNRRunCallbacks( /* All callbacks down to rootPtr not inclusive * are to be run. */ { +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 Interp *iPtr = (Interp *) interp; +#endif /* !defined(TCL_NO_DEPRECATED) */ /* * If the interpreter has a non-empty string result, the result object is @@ -4482,9 +4839,11 @@ TclNRRunCallbacks( * are for NR function calls, and those are Tcl_Obj based. */ +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 if (*(iPtr->result) != 0) { (void) Tcl_GetObjResult(interp); } +#endif /* !defined(TCL_NO_DEPRECATED) */ /* * This is the trampoline. @@ -4653,7 +5012,7 @@ TEOV_Error( int objc = PTR2INT(data[0]); Tcl_Obj **objv = data[1]; - if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)){ + if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { /* * If there was an error, a command string will be needed for the * error log: get it out of the itemPtr. The details depend on the @@ -4661,7 +5020,7 @@ TEOV_Error( */ listPtr = Tcl_NewListObj(objc, objv); - cmdString = Tcl_GetStringFromObj(listPtr, &cmdLen); + cmdString = TclGetStringFromObj(listPtr, &cmdLen); Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen); Tcl_DecrRefCount(listPtr); } @@ -4713,7 +5072,7 @@ TEOV_NotFound( Tcl_ListObjGetElements(NULL, currNsPtr->unknownHandlerPtr, &handlerObjc, &handlerObjv); newObjc = objc + handlerObjc; - newObjv = TclStackAlloc(interp, (int) sizeof(Tcl_Obj *) * newObjc); + newObjv = TclStackAlloc(interp, sizeof(Tcl_Obj *) * newObjc); /* * Copy command prefix from unknown handler and add on the real command's @@ -4725,7 +5084,7 @@ TEOV_NotFound( newObjv[i] = handlerObjv[i]; Tcl_IncrRefCount(newObjv[i]); } - memcpy(newObjv+handlerObjc, objv, sizeof(Tcl_Obj *) * (unsigned)objc); + memcpy(newObjv+handlerObjc, objv, sizeof(Tcl_Obj *) * objc); /* * Look up and invoke the handler (by recursive call to this function). If @@ -4805,9 +5164,9 @@ TEOV_RunEnterTraces( { Interp *iPtr = (Interp *) interp; Command *cmdPtr = *cmdPtrPtr; - int newEpoch, cmdEpoch = cmdPtr->cmdEpoch; + unsigned int newEpoch, cmdEpoch = cmdPtr->cmdEpoch; int length, traceCode = TCL_OK; - const char *command = Tcl_GetStringFromObj(commandPtr, &length); + const char *command = TclGetStringFromObj(commandPtr, &length); /* * Call trace functions. @@ -4859,10 +5218,10 @@ TEOV_RunLeaveTraces( Command *cmdPtr = data[2]; Tcl_Obj **objv = data[3]; int length; - const char *command = Tcl_GetStringFromObj(commandPtr, &length); + const char *command = TclGetStringFromObj(commandPtr, &length); if (!(cmdPtr->flags & CMD_IS_DELETED)) { - if (cmdPtr->flags & CMD_HAS_EXEC_TRACES){ + if (cmdPtr->flags & CMD_HAS_EXEC_TRACES) { traceCode = TclCheckExecutionTraces(interp, command, length, cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv); } @@ -4948,6 +5307,7 @@ Tcl_EvalTokensStandard( NULL, NULL); } +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 /* *---------------------------------------------------------------------- * @@ -4995,6 +5355,7 @@ Tcl_EvalTokens( Tcl_ResetResult(interp); return resPtr; } +#endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -5606,7 +5967,7 @@ TclArgumentEnter( CmdFrame *cfPtr) { Interp *iPtr = (Interp *) interp; - int new, i; + int isNew, i; Tcl_HashEntry *hPtr; CFWord *cfwPtr; @@ -5622,8 +5983,8 @@ TclArgumentEnter( if (cfPtr->line[i] < 0) { continue; } - hPtr = Tcl_CreateHashEntry(iPtr->lineLAPtr, objv[i], &new); - if (new) { + hPtr = Tcl_CreateHashEntry(iPtr->lineLAPtr, objv[i], &isNew); + if (isNew) { /* * The word is not on the stack yet, remember the current location * and initialize references. @@ -5685,8 +6046,7 @@ TclArgumentRelease( } cfwPtr = Tcl_GetHashValue(hPtr); - cfwPtr->refCount--; - if (cfwPtr->refCount > 0) { + if (cfwPtr->refCount-- > 1) { continue; } @@ -5893,7 +6253,7 @@ TclArgumentGet( * up by the caller. It knows better than us. */ - if ((obj->bytes == NULL) || TclListObjIsCanonical(obj)) { + if (!TclHasStringRep(obj) || TclListObjIsCanonical(obj)) { return; } @@ -5951,6 +6311,7 @@ TclArgumentGet( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_Eval int Tcl_Eval( @@ -6003,6 +6364,7 @@ Tcl_GlobalEvalObj( { return Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL); } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -6156,7 +6518,7 @@ TclNREvalObjEx( TclNRAddCallback(interp, TEOEx_ListCallback, listPtr, eoFramePtr, objPtr, NULL); - ListObjGetElements(listPtr, objc, objv); + TclListObjGetElements(NULL, listPtr, &objc, &objv); return TclNREvalObjv(interp, objc, objv, flags, NULL); } @@ -6224,7 +6586,7 @@ TclNREvalObjEx( Tcl_IncrRefCount(objPtr); - script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); + script = TclGetStringFromObj(objPtr, &numSrcBytes); result = Tcl_EvalEx(interp, script, numSrcBytes, flags); TclDecrRefCount(objPtr); @@ -6255,7 +6617,7 @@ TEOEx_ByteCodeCallback( ProcessUnexpectedResult(interp, result); result = TCL_ERROR; - script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); + script = TclGetStringFromObj(objPtr, &numSrcBytes); Tcl_LogCommandInfo(interp, script, script, numSrcBytes); } @@ -6512,8 +6874,7 @@ Tcl_ExprLongObj( resultPtr = Tcl_NewBignumObj(&big); /* FALLTHROUGH */ } - case TCL_NUMBER_LONG: - case TCL_NUMBER_WIDE: + case TCL_NUMBER_INT: case TCL_NUMBER_BIG: result = TclGetLongFromObj(interp, resultPtr, ptr); break; @@ -6759,7 +7120,7 @@ Tcl_ExprString( * An empty string. Just set the interpreter's result to 0. */ - Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0)); } else { Tcl_Obj *resultPtr, *exprObj = Tcl_NewStringObj(expr, -1); @@ -6806,11 +7167,10 @@ Tcl_AppendObjToErrorInfo( * pertains. */ Tcl_Obj *objPtr) /* Message to record. */ { - int length; - const char *message = TclGetStringFromObj(objPtr, &length); + const char *message = TclGetString(objPtr); Tcl_IncrRefCount(objPtr); - Tcl_AddObjErrorInfo(interp, message, length); + Tcl_AddObjErrorInfo(interp, message, objPtr->length); Tcl_DecrRefCount(objPtr); } @@ -6833,6 +7193,7 @@ Tcl_AppendObjToErrorInfo( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_AddErrorInfo void Tcl_AddErrorInfo( @@ -6842,6 +7203,7 @@ Tcl_AddErrorInfo( { Tcl_AddObjErrorInfo(interp, message, -1); } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -6882,7 +7244,8 @@ Tcl_AddObjErrorInfo( iPtr->flags |= ERR_LEGACY_COPY; if (iPtr->errorInfo == NULL) { - if (iPtr->result[0] != 0) { +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 + if (*(iPtr->result) != 0) { /* * The interp's string result is set, apparently by some extension * making a deprecated direct write to it. That extension may @@ -6892,9 +7255,9 @@ Tcl_AddObjErrorInfo( */ iPtr->errorInfo = Tcl_NewStringObj(iPtr->result, -1); - } else { + } else +#endif /* !defined(TCL_NO_DEPRECATED) */ iPtr->errorInfo = iPtr->objResultPtr; - } Tcl_IncrRefCount(iPtr->errorInfo); if (!iPtr->errorCode) { Tcl_SetErrorCode(interp, "NONE", NULL); @@ -6957,7 +7320,7 @@ Tcl_VarEvalVA( Tcl_DStringAppend(&buf, string, -1); } - result = Tcl_Eval(interp, Tcl_DStringValue(&buf)); + result = Tcl_EvalEx(interp, Tcl_DStringValue(&buf), -1, 0); Tcl_DStringFree(&buf); return result; } @@ -7014,6 +7377,7 @@ Tcl_VarEval( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_GlobalEval int Tcl_GlobalEval( @@ -7027,10 +7391,11 @@ Tcl_GlobalEval( savedVarFramePtr = iPtr->varFramePtr; iPtr->varFramePtr = iPtr->rootFramePtr; - result = Tcl_Eval(interp, command); + result = Tcl_EvalEx(interp, command, -1, 0); iPtr->varFramePtr = savedVarFramePtr; return result; } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -7168,9 +7533,13 @@ ExprCeilFunc( } code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN - if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { - Tcl_SetObjResult(interp, objv[1]); - return TCL_OK; + if (code != TCL_OK) { + const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objv[1], &tclDoubleType); + + if (irPtr) { + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; + } } #endif if (code != TCL_OK) { @@ -7204,9 +7573,13 @@ ExprFloorFunc( } code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN - if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { - Tcl_SetObjResult(interp, objv[1]); - return TCL_OK; + if (code != TCL_OK) { + const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objv[1], &tclDoubleType); + + if (irPtr) { + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; + } } #endif if (code != TCL_OK) { @@ -7278,7 +7651,7 @@ ExprIsqrtFunc( if (Tcl_GetBignumFromObj(interp, objv[1], &big) != TCL_OK) { return TCL_ERROR; } - if (big.sign) { + if (big.sign != MP_ZPOS) { mp_clear(&big); goto negarg; } @@ -7340,9 +7713,13 @@ ExprSqrtFunc( } code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN - if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { - Tcl_SetObjResult(interp, objv[1]); - return TCL_OK; + if (code != TCL_OK) { + const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objv[1], &tclDoubleType); + + if (irPtr) { + Tcl_SetObjResult(interp, objv[1]); + return TCL_OK; + } } #endif if (code != TCL_OK) { @@ -7383,10 +7760,14 @@ ExprUnaryFunc( } code = Tcl_GetDoubleFromObj(interp, objv[1], &d); #ifdef ACCEPT_NAN - if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { - d = objv[1]->internalRep.doubleValue; - Tcl_ResetResult(interp); - code = TCL_OK; + if (code != TCL_OK) { + const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objv[1], &tclDoubleType); + + if (irPtr) { + d = irPtr->doubleValue; + Tcl_ResetResult(interp); + code = TCL_OK; + } } #endif if (code != TCL_OK) { @@ -7443,10 +7824,14 @@ ExprBinaryFunc( } code = Tcl_GetDoubleFromObj(interp, objv[1], &d1); #ifdef ACCEPT_NAN - if ((code != TCL_OK) && (objv[1]->typePtr == &tclDoubleType)) { - d1 = objv[1]->internalRep.doubleValue; - Tcl_ResetResult(interp); - code = TCL_OK; + if (code != TCL_OK) { + const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objv[1], &tclDoubleType); + + if (irPtr) { + d1 = irPtr->doubleValue; + Tcl_ResetResult(interp); + code = TCL_OK; + } } #endif if (code != TCL_OK) { @@ -7454,10 +7839,14 @@ ExprBinaryFunc( } code = Tcl_GetDoubleFromObj(interp, objv[2], &d2); #ifdef ACCEPT_NAN - if ((code != TCL_OK) && (objv[2]->typePtr == &tclDoubleType)) { - d2 = objv[2]->internalRep.doubleValue; - Tcl_ResetResult(interp); - code = TCL_OK; + if (code != TCL_OK) { + const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objv[1], &tclDoubleType); + + if (irPtr) { + d2 = irPtr->doubleValue; + Tcl_ResetResult(interp); + code = TCL_OK; + } } #endif if (code != TCL_OK) { @@ -7488,28 +7877,30 @@ ExprAbsFunc( return TCL_ERROR; } - if (type == TCL_NUMBER_LONG) { - long l = *((const long *) ptr); + if (type == TCL_NUMBER_INT) { + Tcl_WideInt l = *((const Tcl_WideInt *) ptr); - if (l > (long)0) { + if (l > 0) { goto unChanged; - } else if (l == (long)0) { - const char *string = objv[1]->bytes; - if (string) { - while (*string != '0') { - if (*string == '-') { - Tcl_SetObjResult(interp, Tcl_NewLongObj(0)); + } else if (l == 0) { + if (TclHasStringRep(objv[1])) { + int numBytes; + const char *bytes = TclGetStringFromObj(objv[1], &numBytes); + + while (numBytes) { + if (*bytes == '-') { + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0)); return TCL_OK; } - string++; + bytes++; numBytes--; } } goto unChanged; - } else if (l == LONG_MIN) { - TclBNInitBignumFromLong(&big, l); + } else if (l == WIDE_MIN) { + TclInitBignumFromWideInt(&big, l); goto tooLarge; } - Tcl_SetObjResult(interp, Tcl_NewLongObj(-l)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-l)); return TCL_OK; } @@ -7533,24 +7924,8 @@ ExprAbsFunc( return TCL_OK; } -#ifndef TCL_WIDE_INT_IS_LONG - if (type == TCL_NUMBER_WIDE) { - Tcl_WideInt w = *((const Tcl_WideInt *) ptr); - - if (w >= (Tcl_WideInt)0) { - goto unChanged; - } - if (w == LLONG_MIN) { - TclBNInitBignumFromWideInt(&big, w); - goto tooLarge; - } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-w)); - return TCL_OK; - } -#endif - if (type == TCL_NUMBER_BIG) { - if (mp_cmp_d((const mp_int *) ptr, 0) == MP_LT) { + if (((const mp_int *) ptr)->sign != MP_ZPOS) { Tcl_GetBignumFromObj(NULL, objv[1], &big); tooLarge: mp_neg(&big, &big); @@ -7613,7 +7988,7 @@ ExprDoubleFunc( } if (Tcl_GetDoubleFromObj(interp, objv[1], &dResult) != TCL_OK) { #ifdef ACCEPT_NAN - if (objv[1]->typePtr == &tclDoubleType) { + if (TclHasIntRep(objv[1], &tclDoubleType)) { Tcl_SetObjResult(interp, objv[1]); return TCL_OK; } @@ -7625,7 +8000,7 @@ ExprDoubleFunc( } static int -ExprEntierFunc( +ExprIntFunc( ClientData clientData, /* Ignored. */ Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ @@ -7646,19 +8021,7 @@ ExprEntierFunc( if (type == TCL_NUMBER_DOUBLE) { d = *((const double *) ptr); - if ((d < (double)LONG_MAX) && (d > (double)LONG_MIN)) { - long result = (long) d; - - Tcl_SetObjResult(interp, Tcl_NewLongObj(result)); - return TCL_OK; -#ifndef TCL_WIDE_INT_IS_LONG - } else if ((d < (double)LLONG_MAX) && (d > (double)LLONG_MIN)) { - Tcl_WideInt result = (Tcl_WideInt) d; - - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result)); - return TCL_OK; -#endif - } else { + if ((d >= (double)WIDE_MAX) || (d <= (double)WIDE_MIN)) { mp_int big; if (Tcl_InitBignumFromDouble(interp, d, &big) != TCL_OK) { @@ -7667,6 +8030,11 @@ ExprEntierFunc( } Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big)); return TCL_OK; + } else { + Tcl_WideInt result = (Tcl_WideInt) d; + + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result)); + return TCL_OK; } } @@ -7688,71 +8056,89 @@ ExprEntierFunc( } static int -ExprIntFunc( +ExprWideFunc( ClientData clientData, /* Ignored. */ Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count. */ Tcl_Obj *const *objv) /* Actual parameter vector. */ { - long iResult; - Tcl_Obj *objPtr; - if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) { - return TCL_ERROR; - } - objPtr = Tcl_GetObjResult(interp); - if (TclGetLongFromObj(NULL, objPtr, &iResult) != TCL_OK) { - /* - * Truncate the bignum; keep only bits in long range. - */ - - mp_int big; + Tcl_WideInt wResult; - Tcl_GetBignumFromObj(NULL, objPtr, &big); - mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big); - objPtr = Tcl_NewBignumObj(&big); - Tcl_IncrRefCount(objPtr); - TclGetLongFromObj(NULL, objPtr, &iResult); - Tcl_DecrRefCount(objPtr); + if (ExprIntFunc(NULL, interp, objc, objv) != TCL_OK) { + return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewLongObj(iResult)); + TclGetWideBitsFromObj(NULL, Tcl_GetObjResult(interp), &wResult); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(wResult)); return TCL_OK; } +/* + * Common implmentation of max() and min(). + */ static int -ExprWideFunc( +ExprMaxMinFunc( ClientData clientData, /* Ignored. */ Tcl_Interp *interp, /* The interpreter in which to execute the * function. */ int objc, /* Actual parameter count. */ - Tcl_Obj *const *objv) /* Actual parameter vector. */ + Tcl_Obj *const *objv, /* Actual parameter vector. */ + int op) /* Comparison direction */ { - Tcl_WideInt wResult; - Tcl_Obj *objPtr; + Tcl_Obj *res; + double d; + int type, i; + ClientData ptr; - if (ExprEntierFunc(NULL, interp, objc, objv) != TCL_OK) { + if (objc < 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); return TCL_ERROR; } - objPtr = Tcl_GetObjResult(interp); - if (TclGetWideIntFromObj(NULL, objPtr, &wResult) != TCL_OK) { - /* - * Truncate the bignum; keep only bits in wide int range. - */ - - mp_int big; + res = objv[1]; + for (i = 1; i < objc; i++) { + if (TclGetNumberFromObj(interp, objv[i], &ptr, &type) != TCL_OK) { + return TCL_ERROR; + } + if (type == TCL_NUMBER_NAN) { + /* + * Get the error message for NaN. + */ - Tcl_GetBignumFromObj(NULL, objPtr, &big); - mp_mod_2d(&big, (int) CHAR_BIT * sizeof(Tcl_WideInt), &big); - objPtr = Tcl_NewBignumObj(&big); - Tcl_IncrRefCount(objPtr); - TclGetWideIntFromObj(NULL, objPtr, &wResult); - Tcl_DecrRefCount(objPtr); + Tcl_GetDoubleFromObj(interp, objv[i], &d); + return TCL_ERROR; + } + if (TclCompareTwoNumbers(objv[i], res) == op) { + res = objv[i]; + } } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(wResult)); + + Tcl_SetObjResult(interp, res); return TCL_OK; } static int +ExprMaxFunc( + ClientData clientData, /* Ignored. */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Actual parameter vector. */ +{ + return ExprMaxMinFunc(clientData, interp, objc, objv, MP_GT); +} + +static int +ExprMinFunc( + ClientData clientData, /* Ignored. */ + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count. */ + Tcl_Obj *const *objv) /* Actual parameter vector. */ +{ + return ExprMaxMinFunc(clientData, interp, objc, objv, MP_LT); +} + +static int ExprRandFunc( ClientData clientData, /* Ignored. */ Tcl_Interp *interp, /* The interpreter in which to execute the @@ -7785,7 +8171,7 @@ ExprRandFunc( * Make sure 1 <= randSeed <= (2^31) - 2. See below. */ - iPtr->randSeed &= (unsigned long) 0x7fffffff; + iPtr->randSeed &= 0x7fffffff; if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) { iPtr->randSeed ^= 123459876; } @@ -7868,7 +8254,7 @@ ExprRoundFunc( if (type == TCL_NUMBER_DOUBLE) { double fractPart, intPart; - long max = LONG_MAX, min = LONG_MIN; + Tcl_WideInt max = WIDE_MAX, min = WIDE_MIN; fractPart = modf(*((const double *) ptr), &intPart); if (fractPart <= -0.5) { @@ -7891,14 +8277,14 @@ ExprRoundFunc( Tcl_SetObjResult(interp, Tcl_NewBignumObj(&big)); return TCL_OK; } else { - long result = (long)intPart; + Tcl_WideInt result = (Tcl_WideInt)intPart; if (fractPart <= -0.5) { result--; } else if (fractPart >= 0.5) { result++; } - Tcl_SetObjResult(interp, Tcl_NewLongObj(result)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result)); return TCL_OK; } } @@ -7929,7 +8315,7 @@ ExprSrandFunc( Tcl_Obj *const *objv) /* Parameter vector. */ { Interp *iPtr = (Interp *) interp; - long i = 0; /* Initialized to avoid compiler warning. */ + Tcl_WideInt w = 0; /* Initialized to avoid compiler warning. */ /* * Convert argument and use it to reset the seed. @@ -7940,20 +8326,8 @@ ExprSrandFunc( return TCL_ERROR; } - if (TclGetLongFromObj(NULL, objv[1], &i) != TCL_OK) { - Tcl_Obj *objPtr; - mp_int big; - - if (Tcl_GetBignumFromObj(interp, objv[1], &big) != TCL_OK) { - /* TODO: more ::errorInfo here? or in caller? */ - return TCL_ERROR; - } - - mp_mod_2d(&big, (int) CHAR_BIT * sizeof(long), &big); - objPtr = Tcl_NewBignumObj(&big); - Tcl_IncrRefCount(objPtr); - TclGetLongFromObj(NULL, objPtr, &i); - Tcl_DecrRefCount(objPtr); + if (TclGetWideBitsFromObj(NULL, objv[1], &w) != TCL_OK) { + return TCL_ERROR; } /* @@ -7962,8 +8336,7 @@ ExprSrandFunc( */ iPtr->flags |= RAND_SEED_INITIALIZED; - iPtr->randSeed = i; - iPtr->randSeed &= (unsigned long) 0x7fffffff; + iPtr->randSeed = (long) w & 0x7fffffff; if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) { iPtr->randSeed ^= 123459876; } @@ -7980,6 +8353,395 @@ ExprSrandFunc( /* *---------------------------------------------------------------------- * + * Double Classification Functions -- + * + * This page contains the functions that implement all of the built-in + * math functions for classifying IEEE doubles. + * + * These have to be a little bit careful while Tcl_GetDoubleFromObj() + * rejects NaN values, which these functions *explicitly* accept. + * + * Results: + * Each function returns TCL_OK if it succeeds and pushes an Tcl object + * holding the result. If it fails it returns TCL_ERROR and leaves an + * error message in the interpreter's result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + * + * Older MSVC is supported by Tcl, but doesn't have fpclassify(). Of course. + * But it does sometimes have _fpclass() which does almost the same job; if + * even that is absent, we grobble around directly in the platform's binary + * representation of double. + * + * The ClassifyDouble() function makes all that conform to a common API + * (effectively the C99 standard API renamed), and just delegates to the + * standard macro on platforms that do it correctly. + */ + +static inline int +ClassifyDouble( + double d) +{ +#if TCL_FPCLASSIFY_MODE == 0 + return fpclassify(d); +#else /* TCL_FPCLASSIFY_MODE != 0 */ + /* + * If we don't have fpclassify(), we also don't have the values it returns. + * Hence we define those here. + */ +#ifndef FP_NAN +# define FP_NAN 1 /* Value is NaN */ +# define FP_INFINITE 2 /* Value is an infinity */ +# define FP_ZERO 3 /* Value is a zero */ +# define FP_NORMAL 4 /* Value is a normal float */ +# define FP_SUBNORMAL 5 /* Value has lost accuracy */ +#endif /* !FP_NAN */ + +#if TCL_FPCLASSIFY_MODE == 3 + return __builtin_fpclassify( + FP_NAN, FP_INFINITE, FP_NORMAL, FP_SUBNORMAL, FP_ZERO, d); +#elif TCL_FPCLASSIFY_MODE == 2 + /* + * We assume this hack is only needed on little-endian systems. + * Specifically, x86 running Windows. It's fairly easy to enable for + * others if they need it (because their libc/libm is broken) but we'll + * jump that hurdle when requred. We can solve the word ordering then. + */ + + union { + double d; /* Interpret as double */ + struct { + unsigned int low; /* Lower 32 bits */ + unsigned int high; /* Upper 32 bits */ + } w; /* Interpret as unsigned integer words */ + } doubleMeaning; /* So we can look at the representation of a + * double directly. Platform (i.e., processor) + * specific; this is for x86 (and most other + * little-endian processors, but those are + * untested). */ + unsigned int exponent, mantissaLow, mantissaHigh; + /* The pieces extracted from the double. */ + int zeroMantissa; /* Was the mantissa zero? That's special. */ + + /* + * Shifts and masks to use with the doubleMeaning variable above. + */ + +#define EXPONENT_MASK 0x7ff /* 11 bits (after shifting) */ +#define EXPONENT_SHIFT 20 /* Moves exponent to bottom of word */ +#define MANTISSA_MASK 0xfffff /* 20 bits (plus 32 from other word) */ + + /* + * Extract the exponent (11 bits) and mantissa (52 bits). Note that we + * totally ignore the sign bit. + */ + + doubleMeaning.d = d; + exponent = (doubleMeaning.w.high >> EXPONENT_SHIFT) & EXPONENT_MASK; + mantissaLow = doubleMeaning.w.low; + mantissaHigh = doubleMeaning.w.high & MANTISSA_MASK; + zeroMantissa = (mantissaHigh == 0 && mantissaLow == 0); + + /* + * Look for the special cases of exponent. + */ + + switch (exponent) { + case 0: + /* + * When the exponent is all zeros, it's a ZERO or a SUBNORMAL. + */ + + return zeroMantissa ? FP_ZERO : FP_SUBNORMAL; + case EXPONENT_MASK: + /* + * When the exponent is all ones, it's an INF or a NAN. + */ + + return zeroMantissa ? FP_INFINITE : FP_NAN; + default: + /* + * Everything else is a NORMAL double precision float. + */ + + return FP_NORMAL; + } +#elif TCL_FPCLASSIFY_MODE == 1 + switch (_fpclass(d)) { + case _FPCLASS_NZ: + case _FPCLASS_PZ: + return FP_ZERO; + case _FPCLASS_NN: + case _FPCLASS_PN: + return FP_NORMAL; + case _FPCLASS_ND: + case _FPCLASS_PD: + return FP_SUBNORMAL; + case _FPCLASS_NINF: + case _FPCLASS_PINF: + return FP_INFINITE; + default: + Tcl_Panic("result of _fpclass() outside documented range!"); + case _FPCLASS_QNAN: + case _FPCLASS_SNAN: + return FP_NAN; + } +#else /* TCL_FPCLASSIFY_MODE not in (0..3) */ +#error "unknown or unexpected TCL_FPCLASSIFY_MODE" +#endif /* TCL_FPCLASSIFY_MODE */ +#endif /* !fpclassify */ +} + +static int +ExprIsFiniteFunc( + ClientData ignored, + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count */ + Tcl_Obj *const *objv) /* Actual parameter list */ +{ + double d; + ClientData ptr; + int type, result = 0; + + if (objc != 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + + if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { + return TCL_ERROR; + } + if (type != TCL_NUMBER_NAN) { + if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) { + return TCL_ERROR; + } + type = ClassifyDouble(d); + result = (type != FP_INFINITE && type != FP_NAN); + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); + return TCL_OK; +} + +static int +ExprIsInfinityFunc( + ClientData ignored, + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count */ + Tcl_Obj *const *objv) /* Actual parameter list */ +{ + double d; + ClientData ptr; + int type, result = 0; + + if (objc != 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + + if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { + return TCL_ERROR; + } + if (type != TCL_NUMBER_NAN) { + if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) { + return TCL_ERROR; + } + result = (ClassifyDouble(d) == FP_INFINITE); + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); + return TCL_OK; +} + +static int +ExprIsNaNFunc( + ClientData ignored, + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count */ + Tcl_Obj *const *objv) /* Actual parameter list */ +{ + double d; + ClientData ptr; + int type, result = 1; + + if (objc != 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + + if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { + return TCL_ERROR; + } + if (type != TCL_NUMBER_NAN) { + if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) { + return TCL_ERROR; + } + result = (ClassifyDouble(d) == FP_NAN); + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); + return TCL_OK; +} + +static int +ExprIsNormalFunc( + ClientData ignored, + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count */ + Tcl_Obj *const *objv) /* Actual parameter list */ +{ + double d; + ClientData ptr; + int type, result = 0; + + if (objc != 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + + if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { + return TCL_ERROR; + } + if (type != TCL_NUMBER_NAN) { + if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) { + return TCL_ERROR; + } + result = (ClassifyDouble(d) == FP_NORMAL); + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); + return TCL_OK; +} + +static int +ExprIsSubnormalFunc( + ClientData ignored, + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count */ + Tcl_Obj *const *objv) /* Actual parameter list */ +{ + double d; + ClientData ptr; + int type, result = 0; + + if (objc != 2) { + MathFuncWrongNumArgs(interp, 2, objc, objv); + return TCL_ERROR; + } + + if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { + return TCL_ERROR; + } + if (type != TCL_NUMBER_NAN) { + if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) { + return TCL_ERROR; + } + result = (ClassifyDouble(d) == FP_SUBNORMAL); + } + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); + return TCL_OK; +} + +static int +ExprIsUnorderedFunc( + ClientData ignored, + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count */ + Tcl_Obj *const *objv) /* Actual parameter list */ +{ + double d; + ClientData ptr; + int type, result = 0; + + if (objc != 3) { + MathFuncWrongNumArgs(interp, 3, objc, objv); + return TCL_ERROR; + } + + if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { + return TCL_ERROR; + } + if (type == TCL_NUMBER_NAN) { + result = 1; + } else { + d = *((const double *) ptr); + result = (ClassifyDouble(d) == FP_NAN); + } + + if (TclGetNumberFromObj(interp, objv[2], &ptr, &type) != TCL_OK) { + return TCL_ERROR; + } + if (type == TCL_NUMBER_NAN) { + result |= 1; + } else { + d = *((const double *) ptr); + result |= (ClassifyDouble(d) == FP_NAN); + } + + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); + return TCL_OK; +} + +static int +FloatClassifyObjCmd( + ClientData ignored, + Tcl_Interp *interp, /* The interpreter in which to execute the + * function. */ + int objc, /* Actual parameter count */ + Tcl_Obj *const *objv) /* Actual parameter list */ +{ + double d; + Tcl_Obj *objPtr; + ClientData ptr; + int type; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "floatValue"); + return TCL_ERROR; + } + + if (TclGetNumberFromObj(interp, objv[1], &ptr, &type) != TCL_OK) { + return TCL_ERROR; + } + if (type == TCL_NUMBER_NAN) { + goto gotNaN; + } else if (Tcl_GetDoubleFromObj(interp, objv[1], &d) != TCL_OK) { + return TCL_ERROR; + } + switch (ClassifyDouble(d)) { + case FP_INFINITE: + TclNewLiteralStringObj(objPtr, "infinite"); + break; + case FP_NAN: + gotNaN: + TclNewLiteralStringObj(objPtr, "nan"); + break; + case FP_NORMAL: + TclNewLiteralStringObj(objPtr, "normal"); + break; + case FP_SUBNORMAL: + TclNewLiteralStringObj(objPtr, "subnormal"); + break; + case FP_ZERO: + TclNewLiteralStringObj(objPtr, "zero"); + break; + default: + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unable to classify number: %f", d)); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, objPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * MathFuncWrongNumArgs -- * * Generate an error message when a math function presents the wrong @@ -8001,7 +8763,7 @@ MathFuncWrongNumArgs( int found, /* Actual parameter count. */ Tcl_Obj *const *objv) /* Actual parameter vector. */ { - const char *name = Tcl_GetString(objv[0]); + const char *name = TclGetString(objv[0]); const char *tail = name + strlen(name); while (tail > name+1) { @@ -8243,23 +9005,26 @@ Tcl_NRCreateCommand( * this command is deleted. */ { Command *cmdPtr = (Command *) - Tcl_CreateObjCommand(interp,cmdName,proc,clientData,deleteProc); + Tcl_CreateObjCommand(interp, cmdName, proc, clientData, + deleteProc); cmdPtr->nreProc = nreProc; return (Tcl_Command) cmdPtr; } Tcl_Command -TclNRCreateCommandInNs ( +TclNRCreateCommandInNs( Tcl_Interp *interp, const char *cmdName, Tcl_Namespace *nsPtr, Tcl_ObjCmdProc *proc, Tcl_ObjCmdProc *nreProc, ClientData clientData, - Tcl_CmdDeleteProc *deleteProc) { + Tcl_CmdDeleteProc *deleteProc) +{ Command *cmdPtr = (Command *) - TclCreateObjCommandInNs(interp,cmdName,nsPtr,proc,clientData,deleteProc); + TclCreateObjCommandInNs(interp, cmdName, nsPtr, proc, clientData, + deleteProc); cmdPtr->nreProc = nreProc; return (Tcl_Command) cmdPtr; @@ -8363,7 +9128,6 @@ TclPushTailcallPoint( TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL); ((Interp *) interp)->numLevels++; } - /* *---------------------------------------------------------------------- @@ -8399,7 +9163,6 @@ TclSetTailcall( } runPtr->data[1] = listPtr; } - /* *---------------------------------------------------------------------- @@ -8471,7 +9234,6 @@ TclNRTailcallObjCmd( } return TCL_RETURN; } - /* *---------------------------------------------------------------------- @@ -8539,7 +9301,6 @@ TclNRReleaseValues( } return result; } - void Tcl_NRAddCallback( @@ -8983,27 +9744,47 @@ CoroTypeObjCmd( /* *---------------------------------------------------------------------- * - * NRCoroInjectObjCmd -- + * TclNRCoroInjectObjCmd, TclNRCoroProbeObjCmd -- * - * Implementation of [::tcl::unsupported::inject] command. + * Implementation of [coroinject] and [coroprobe] commands. * *---------------------------------------------------------------------- */ +static inline CoroutineData * +GetCoroutineFromObj( + Tcl_Interp *interp, + Tcl_Obj *objPtr, + const char *errMsg) +{ + /* + * How to get a coroutine from its handle. + */ + + Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objPtr); + + if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, -1)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE", + TclGetString(objPtr), NULL); + return NULL; + } + return cmdPtr->objClientData; +} + static int -NRCoroInjectObjCmd( +TclNRCoroInjectObjCmd( ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { - Command *cmdPtr; CoroutineData *corPtr; ExecEnv *savedEEPtr = iPtr->execEnvPtr; /* * Usage more or less like tailcall: - * inject coroName cmd ?arg1 arg2 ...? + * coroinject coroName cmd ?arg1 arg2 ...? */ if (objc < 3) { @@ -9011,16 +9792,249 @@ NRCoroInjectObjCmd( return TCL_ERROR; } - cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]); - if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) { + corPtr = GetCoroutineFromObj(interp, objv[1], + "can only inject a command into a coroutine"); + if (!corPtr) { + return TCL_ERROR; + } + if (!COR_IS_SUSPENDED(corPtr)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can only inject a command into a coroutine", -1)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE", - TclGetString(objv[1]), NULL); + "can only inject a command into a suspended coroutine", -1)); + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", NULL); return TCL_ERROR; } - corPtr = cmdPtr->objClientData; + /* + * Add the callback to the coro's execEnv, so that it is the first thing + * to happen when the coro is resumed. + */ + + iPtr->execEnvPtr = corPtr->eePtr; + TclNRAddCallback(interp, InjectHandler, corPtr, + Tcl_NewListObj(objc - 2, objv + 2), INT2PTR(corPtr->nargs), NULL); + iPtr->execEnvPtr = savedEEPtr; + + return TCL_OK; +} + +static int +TclNRCoroProbeObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + CoroutineData *corPtr; + ExecEnv *savedEEPtr = iPtr->execEnvPtr; + int numLevels, unused; + int *stackLevel = &unused; + + /* + * Usage more or less like tailcall: + * coroprobe coroName cmd ?arg1 arg2 ...? + */ + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "coroName cmd ?arg1 arg2 ...?"); + return TCL_ERROR; + } + + corPtr = GetCoroutineFromObj(interp, objv[1], + "can only inject a probe command into a coroutine"); + if (!corPtr) { + return TCL_ERROR; + } + if (!COR_IS_SUSPENDED(corPtr)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "can only inject a probe command into a suspended coroutine", + -1)); + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", NULL); + return TCL_ERROR; + } + + /* + * Add the callback to the coro's execEnv, so that it is the first thing + * to happen when the coro is resumed. + */ + + iPtr->execEnvPtr = corPtr->eePtr; + TclNRAddCallback(interp, InjectHandler, corPtr, + Tcl_NewListObj(objc - 2, objv + 2), INT2PTR(corPtr->nargs), corPtr); + iPtr->execEnvPtr = savedEEPtr; + + /* + * Now we immediately transfer control to the coroutine to run our probe. + * TRICKY STUFF copied from the [yield] implementation. + * + * Push the callback to restore the caller's context on yield back. + */ + + TclNRAddCallback(interp, NRCoroutineCallerCallback, corPtr, + NULL, NULL, NULL); + + /* + * Record the stackLevel at which the resume is happening, then swap + * the interp's environment to make it suitable to run this coroutine. + */ + + corPtr->stackLevel = stackLevel; + numLevels = corPtr->auxNumLevels; + corPtr->auxNumLevels = iPtr->numLevels; + + /* + * Do the actual stack swap. + */ + + SAVE_CONTEXT(corPtr->caller); + corPtr->callerEEPtr = iPtr->execEnvPtr; + RESTORE_CONTEXT(corPtr->running); + iPtr->execEnvPtr = corPtr->eePtr; + iPtr->numLevels += numLevels; + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * InjectHandler, InjectHandlerPostProc -- + * + * Part of the implementation of [coroinject] and [coroprobe]. These are + * run inside the context of the coroutine being injected/probed into. + * + * InjectHandler runs a script (possibly adding arguments) in the context + * of the coroutine. The script is specified as a one-shot list (with + * reference count equal to 1) in data[1]. This function also arranges + * for InjectHandlerPostProc to be the part that runs after the script + * completes. + * + * InjectHandlerPostProc cleans up after InjectHandler (deleting the + * list) and, for the [coroprobe] command *only*, yields back to the + * caller context (i.e., where [coroprobe] was run). + *s + *---------------------------------------------------------------------- + */ + +static int +InjectHandler( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + CoroutineData *corPtr = data[0]; + Tcl_Obj *listPtr = data[1]; + int nargs = PTR2INT(data[2]); + ClientData isProbe = data[3]; + int objc; + Tcl_Obj **objv; + + if (!isProbe) { + /* + * If this is [coroinject], add the extra arguments now. + */ + + if (nargs == COROUTINE_ARGUMENTS_SINGLE_OPTIONAL) { + Tcl_ListObjAppendElement(NULL, listPtr, + Tcl_NewStringObj("yield", -1)); + } else if (nargs == COROUTINE_ARGUMENTS_ARBITRARY) { + Tcl_ListObjAppendElement(NULL, listPtr, + Tcl_NewStringObj("yieldto", -1)); + } else { + /* + * I don't think this is reachable... + */ + + Tcl_ListObjAppendElement(NULL, listPtr, Tcl_NewIntObj(nargs)); + } + Tcl_ListObjAppendElement(NULL, listPtr, Tcl_GetObjResult(interp)); + } + + /* + * Call the user's script; we're in the right place. + */ + + Tcl_IncrRefCount(listPtr); + TclMarkTailcall(interp); + TclNRAddCallback(interp, InjectHandlerPostCall, corPtr, listPtr, + INT2PTR(nargs), isProbe); + TclListObjGetElements(NULL, listPtr, &objc, &objv); + return TclNREvalObjv(interp, objc, objv, 0, NULL); +} + +static int +InjectHandlerPostCall( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + CoroutineData *corPtr = data[0]; + Tcl_Obj *listPtr = data[1]; + int nargs = PTR2INT(data[2]); + ClientData isProbe = data[3]; + int numLevels; + + /* + * Delete the command words for what we just executed. + */ + + Tcl_DecrRefCount(listPtr); + + /* + * If we were doing a probe, splice ourselves back out of the stack + * cleanly here. General injection should instead just look after itself. + * + * Code from guts of [yield] implementation. + */ + + if (isProbe) { + if (result == TCL_ERROR) { + Tcl_AddErrorInfo(interp, + "\n (injected coroutine probe command)"); + } + corPtr->nargs = nargs; + corPtr->stackLevel = NULL; + numLevels = iPtr->numLevels; + iPtr->numLevels = corPtr->auxNumLevels; + corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels; + iPtr->execEnvPtr = corPtr->callerEEPtr; + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * NRInjectObjCmd -- + * + * Implementation of [::tcl::unsupported::inject] command. + * + *---------------------------------------------------------------------- + */ + +static int +NRInjectObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + CoroutineData *corPtr; + ExecEnv *savedEEPtr = iPtr->execEnvPtr; + + /* + * Usage more or less like tailcall: + * inject coroName cmd ?arg1 arg2 ...? + */ + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "coroName cmd ?arg1 arg2 ...?"); + return TCL_ERROR; + } + + corPtr = GetCoroutineFromObj(interp, objv[1], + "can only inject a command into a coroutine"); + if (!corPtr) { + return TCL_ERROR; + } if (!COR_IS_SUSPENDED(corPtr)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "can only inject a command into a suspended coroutine", -1)); @@ -9053,7 +10067,7 @@ TclNRInterpCoroutine( if (!COR_IS_SUSPENDED(corPtr)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "coroutine \"%s\" is already running", - Tcl_GetString(objv[0]))); + TclGetString(objv[0]))); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BUSY", NULL); return TCL_ERROR; } diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 8bd65a8..d8b9ae9 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -15,6 +15,7 @@ #include "tommath.h" #include <math.h> +#include <assert.h> /* * The following constants are used by GetFormatSpec to indicate various @@ -56,9 +57,12 @@ static void DupByteArrayInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); +static void DupProperByteArrayInternalRep(Tcl_Obj *srcPtr, + Tcl_Obj *copyPtr); static int FormatNumber(Tcl_Interp *interp, int type, Tcl_Obj *src, unsigned char **cursorPtr); static void FreeByteArrayInternalRep(Tcl_Obj *objPtr); +static void FreeProperByteArrayInternalRep(Tcl_Obj *objPtr); static int GetFormatSpec(const char **formatPtr, char *cmdPtr, int *countPtr, int *flagsPtr); static Tcl_Obj * ScanNumber(unsigned char *buffer, int type, @@ -155,35 +159,103 @@ static const EnsembleImplMap decodeMap[] = { }; /* - * The following object type represents an array of bytes. An array of bytes - * is not equivalent to an internationalized string. Conceptually, a string is - * an array of 16-bit quantities organized as a sequence of properly formed - * UTF-8 characters, while a ByteArray is an array of 8-bit quantities. - * Accessor functions are provided to convert a ByteArray to a String or a - * String to a ByteArray. Two or more consecutive bytes in an array of bytes - * may look like a single UTF-8 character if the array is casually treated as - * a string. But obtaining the String from a ByteArray is guaranteed to - * produced properly formed UTF-8 sequences so that there is a one-to-one map - * between bytes and characters. - * - * Converting a ByteArray to a String proceeds by casting each byte in the - * array to a 16-bit quantity, treating that number as a Unicode character, - * and storing the UTF-8 version of that Unicode character in the String. For - * ByteArrays consisting entirely of values 1..127, the corresponding String - * representation is the same as the ByteArray representation. - * - * Converting a String to a ByteArray proceeds by getting the Unicode - * representation of each character in the String, casting it to a byte by - * truncating the upper 8 bits, and then storing the byte in the ByteArray. - * Converting from ByteArray to String and back to ByteArray is not lossy, but - * converting an arbitrary String to a ByteArray may be. + * The following object types represent an array of bytes. The intent is to + * allow arbitrary binary data to pass through Tcl as a Tcl value without loss + * or damage. Such values are useful for things like encoded strings or Tk + * images to name just two. + * + * It's strange to have two Tcl_ObjTypes in place for this task when one would + * do, so a bit of detail and history how we got to this point and where we + * might go from here. + * + * A bytearray is an ordered sequence of bytes. Each byte is an integer value + * in the range [0-255]. To be a Tcl value type, we need a way to encode each + * value in the value set as a Tcl string. The simplest encoding is to + * represent each byte value as the same codepoint value. A bytearray of N + * bytes is encoded into a Tcl string of N characters where the codepoint of + * each character is the value of corresponding byte. This approach creates a + * one-to-one map between all bytearray values and a subset of Tcl string + * values. + * + * When converting a Tcl string value to the bytearray internal rep, the + * question arises what to do with strings outside that subset? That is, + * those Tcl strings containing at least one codepoint greater than 255? The + * obviously correct answer is to raise an error! That string value does not + * represent any valid bytearray value. Full Stop. The setFromAnyProc + * signature has a completion code return value for just this reason, to + * reject invalid inputs. + * + * Unfortunately this was not the path taken by the authors of the original + * tclByteArrayType. They chose to accept all Tcl string values as acceptable + * string encodings of the bytearray values that result from masking away the + * high bits of any codepoint value at all. This meant that every bytearray + * value had multiple accepted string representations. + * + * The implications of this choice are truly ugly. When a Tcl value has a + * string representation, we are required to accept that as the true value. + * Bytearray values that possess a string representation cannot be processed + * as bytearrays because we cannot know which true value that bytearray + * represents. The consequence is that we drag around an internal rep that we + * cannot make any use of. This painful price is extracted at any point after + * a string rep happens to be generated for the value. This happens even when + * the troublesome codepoints outside the byte range never show up. This + * happens rather routinely in normal Tcl operations unless we burden the + * script writer with the cognitive burden of avoiding it. The price is also + * paid by callers of the C interface. The routine + * + * unsigned char *Tcl_GetByteArrayFromObj(objPtr, lenPtr) + * + * has a guarantee to always return a non-NULL value, but that value points to + * a byte sequence that cannot be used by the caller to process the Tcl value + * absent some sideband testing that objPtr is "pure". Tcl offers no public + * interface to perform this test, so callers either break encapsulation or + * are unavoidably buggy. Tcl has defined a public interface that cannot be + * used correctly. The Tcl source code itself suffers the same problem, and + * has been buggy, but progressively less so as more and more portions of the + * code have been retrofitted with the required "purity testing". The set of + * values able to pass the purity test can be increased via the introduction + * of a "canonical" flag marker, but the only way the broken interface itself + * can be discarded is to start over and define the Tcl_ObjType properly. + * Bytearrays should simply be usable as bytearrays without a kabuki dance of + * testing. + * + * The Tcl_ObjType "properByteArrayType" is (nearly) a correct implementation + * of bytearrays. Any Tcl value with the type properByteArrayType can have + * its bytearray value fetched and used with confidence that acting on that + * value is equivalent to acting on the true Tcl string value. This still + * implies a side testing burden -- past mistakes will not let us avoid that + * immediately, but it is at least a conventional test of type, and can be + * implemented entirely by examining the objPtr fields, with no need to query + * the intrep, as a canonical flag would require. + * + * Until Tcl_GetByteArrayFromObj() and Tcl_SetByteArrayLength() can be revised + * to admit the possibility of returning NULL when the true value is not a + * valid bytearray, we need a mechanism to retain compatibility with the + * deployed callers of the broken interface. That's what the retained + * "tclByteArrayType" provides. In those unusual circumstances where we + * convert an invalid bytearray value to a bytearray type, it is to this + * legacy type. Essentially any time this legacy type gets used, it's a + * signal of a bug being ignored. A TIP should be drafted to remove this + * connection to the broken past so that Tcl 9 will no longer have any trace + * of it. Prescribing a migration path will be the key element of that work. + * The internal changes now in place are the limit of what can be done short + * of interface repair. They provide a great expansion of the histories over + * which bytearray values can be useful in the meanwhile. */ +static const Tcl_ObjType properByteArrayType = { + "bytearray", + FreeProperByteArrayInternalRep, + DupProperByteArrayInternalRep, + UpdateStringOfByteArray, + NULL +}; + const Tcl_ObjType tclByteArrayType = { "bytearray", FreeByteArrayInternalRep, DupByteArrayInternalRep, - UpdateStringOfByteArray, + NULL, SetByteArrayFromAny }; @@ -195,9 +267,9 @@ const Tcl_ObjType tclByteArrayType = { */ typedef struct ByteArray { - int used; /* The number of bytes used in the byte + unsigned int used; /* The number of bytes used in the byte * array. */ - int allocated; /* The amount of space actually allocated + unsigned int allocated; /* The amount of space actually allocated * minus 1 byte. */ unsigned char bytes[1]; /* The array of bytes. The actual size of this * field depends on the 'allocated' field @@ -205,12 +277,17 @@ typedef struct ByteArray { } ByteArray; #define BYTEARRAY_SIZE(len) \ - ((unsigned) (TclOffset(ByteArray, bytes) + (len))) -#define GET_BYTEARRAY(objPtr) \ - ((ByteArray *) (objPtr)->internalRep.twoPtrValue.ptr1) -#define SET_BYTEARRAY(objPtr, baPtr) \ - (objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (baPtr) + (offsetof(ByteArray, bytes) + (len)) +#define GET_BYTEARRAY(irPtr) ((ByteArray *) (irPtr)->twoPtrValue.ptr1) +#define SET_BYTEARRAY(irPtr, baPtr) \ + (irPtr)->twoPtrValue.ptr1 = (void *) (baPtr) +int +TclIsPureByteArray( + Tcl_Obj * objPtr) +{ + return TclHasIntRep(objPtr, &properByteArrayType); +} /* *---------------------------------------------------------------------- @@ -324,11 +401,11 @@ Tcl_SetByteArrayObj( * be >= 0. */ { ByteArray *byteArrayPtr; + Tcl_ObjIntRep ir; if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayObj"); } - TclFreeIntRep(objPtr); TclInvalidateStringRep(objPtr); if (length < 0) { @@ -339,10 +416,11 @@ Tcl_SetByteArrayObj( byteArrayPtr->allocated = length; if ((bytes != NULL) && (length > 0)) { - memcpy(byteArrayPtr->bytes, bytes, (size_t) length); + memcpy(byteArrayPtr->bytes, bytes, length); } - objPtr->typePtr = &tclByteArrayType; - SET_BYTEARRAY(objPtr, byteArrayPtr); + SET_BYTEARRAY(&ir, byteArrayPtr); + + Tcl_StoreIntRep(objPtr, &properByteArrayType, &ir); } /* @@ -370,16 +448,24 @@ Tcl_GetByteArrayFromObj( * array of bytes in the ByteArray object. */ { ByteArray *baPtr; + const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objPtr, &properByteArrayType); - if (objPtr->typePtr != &tclByteArrayType) { - SetByteArrayFromAny(NULL, objPtr); + if (irPtr == NULL) { + irPtr = TclFetchIntRep(objPtr, &tclByteArrayType); + if (irPtr == NULL) { + SetByteArrayFromAny(NULL, objPtr); + irPtr = TclFetchIntRep(objPtr, &properByteArrayType); + if (irPtr == NULL) { + irPtr = TclFetchIntRep(objPtr, &tclByteArrayType); + } + } } - baPtr = GET_BYTEARRAY(objPtr); + baPtr = GET_BYTEARRAY(irPtr); if (lengthPtr != NULL) { *lengthPtr = baPtr->used; } - return (unsigned char *) baPtr->bytes; + return baPtr->bytes; } /* @@ -410,22 +496,36 @@ Tcl_SetByteArrayLength( int length) /* New length for internal byte array. */ { ByteArray *byteArrayPtr; + unsigned newLength; + Tcl_ObjIntRep *irPtr; + + assert(length >= 0); + newLength = (unsigned int)length; if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayLength"); } - if (objPtr->typePtr != &tclByteArrayType) { - SetByteArrayFromAny(NULL, objPtr); + + irPtr = TclFetchIntRep(objPtr, &properByteArrayType); + if (irPtr == NULL) { + irPtr = TclFetchIntRep(objPtr, &tclByteArrayType); + if (irPtr == NULL) { + SetByteArrayFromAny(NULL, objPtr); + irPtr = TclFetchIntRep(objPtr, &properByteArrayType); + if (irPtr == NULL) { + irPtr = TclFetchIntRep(objPtr, &tclByteArrayType); + } + } } - byteArrayPtr = GET_BYTEARRAY(objPtr); - if (length > byteArrayPtr->allocated) { - byteArrayPtr = ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(length)); - byteArrayPtr->allocated = length; - SET_BYTEARRAY(objPtr, byteArrayPtr); + byteArrayPtr = GET_BYTEARRAY(irPtr); + if (newLength > byteArrayPtr->allocated) { + byteArrayPtr = ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(newLength)); + byteArrayPtr->allocated = newLength; + SET_BYTEARRAY(irPtr, byteArrayPtr); } TclInvalidateStringRep(objPtr); - byteArrayPtr->used = length; + byteArrayPtr->used = newLength; return byteArrayPtr->bytes; } @@ -450,29 +550,38 @@ SetByteArrayFromAny( Tcl_Interp *interp, /* Not used. */ Tcl_Obj *objPtr) /* The object to convert to type ByteArray. */ { - int length; + size_t length; + int improper = 0; const char *src, *srcEnd; unsigned char *dst; - ByteArray *byteArrayPtr; Tcl_UniChar ch = 0; + ByteArray *byteArrayPtr; + Tcl_ObjIntRep ir; - if (objPtr->typePtr != &tclByteArrayType) { - src = TclGetStringFromObj(objPtr, &length); - srcEnd = src + length; - - byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length)); - for (dst = byteArrayPtr->bytes; src < srcEnd; ) { - src += TclUtfToUniChar(src, &ch); - *dst++ = UCHAR(ch); - } + if (TclHasIntRep(objPtr, &properByteArrayType)) { + return TCL_OK; + } + if (TclHasIntRep(objPtr, &tclByteArrayType)) { + return TCL_OK; + } - byteArrayPtr->used = dst - byteArrayPtr->bytes; - byteArrayPtr->allocated = length; + src = TclGetString(objPtr); + length = objPtr->length; + srcEnd = src + length; - TclFreeIntRep(objPtr); - objPtr->typePtr = &tclByteArrayType; - SET_BYTEARRAY(objPtr, byteArrayPtr); + byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length)); + for (dst = byteArrayPtr->bytes; src < srcEnd; ) { + src += TclUtfToUniChar(src, &ch); + improper = improper || (ch > 255); + *dst++ = UCHAR(ch); } + + byteArrayPtr->used = dst - byteArrayPtr->bytes; + byteArrayPtr->allocated = length; + + SET_BYTEARRAY(&ir, byteArrayPtr); + Tcl_StoreIntRep(objPtr, + improper ? &tclByteArrayType : &properByteArrayType, &ir); return TCL_OK; } @@ -497,8 +606,14 @@ static void FreeByteArrayInternalRep( Tcl_Obj *objPtr) /* Object with internal rep to free. */ { - ckfree(GET_BYTEARRAY(objPtr)); - objPtr->typePtr = NULL; + ckfree(GET_BYTEARRAY(TclFetchIntRep(objPtr, &tclByteArrayType))); +} + +static void +FreeProperByteArrayInternalRep( + Tcl_Obj *objPtr) /* Object with internal rep to free. */ +{ + ckfree(GET_BYTEARRAY(TclFetchIntRep(objPtr, &properByteArrayType))); } /* @@ -523,19 +638,41 @@ DupByteArrayInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - int length; + unsigned int length; + ByteArray *srcArrayPtr, *copyArrayPtr; + Tcl_ObjIntRep ir; + + srcArrayPtr = GET_BYTEARRAY(TclFetchIntRep(srcPtr, &tclByteArrayType)); + length = srcArrayPtr->used; + + copyArrayPtr = ckalloc(BYTEARRAY_SIZE(length)); + copyArrayPtr->used = length; + copyArrayPtr->allocated = length; + memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, length); + + SET_BYTEARRAY(&ir, copyArrayPtr); + Tcl_StoreIntRep(copyPtr, &tclByteArrayType, &ir); +} + +static void +DupProperByteArrayInternalRep( + Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ + Tcl_Obj *copyPtr) /* Object with internal rep to set. */ +{ + unsigned int length; ByteArray *srcArrayPtr, *copyArrayPtr; + Tcl_ObjIntRep ir; - srcArrayPtr = GET_BYTEARRAY(srcPtr); + srcArrayPtr = GET_BYTEARRAY(TclFetchIntRep(srcPtr, &properByteArrayType)); length = srcArrayPtr->used; copyArrayPtr = ckalloc(BYTEARRAY_SIZE(length)); copyArrayPtr->used = length; copyArrayPtr->allocated = length; - memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, (size_t) length); - SET_BYTEARRAY(copyPtr, copyArrayPtr); + memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, length); - copyPtr->typePtr = &tclByteArrayType; + SET_BYTEARRAY(&ir, copyArrayPtr); + Tcl_StoreIntRep(copyPtr, &properByteArrayType, &ir); } /* @@ -543,9 +680,7 @@ DupByteArrayInternalRep( * * UpdateStringOfByteArray -- * - * Update the string representation for a ByteArray data object. Note: - * This procedure does not invalidate an existing old string rep so - * storage will be lost if this has not already been done. + * Update the string representation for a ByteArray data object. * * Results: * None. @@ -554,9 +689,6 @@ DupByteArrayInternalRep( * The object's string is set to a valid string that results from the * ByteArray-to-string conversion. * - * The object becomes a string object -- the internal rep is discarded - * and the typePtr becomes NULL. - * *---------------------------------------------------------------------- */ @@ -565,41 +697,37 @@ UpdateStringOfByteArray( Tcl_Obj *objPtr) /* ByteArray object whose string rep to * update. */ { - int i, length, size; - unsigned char *src; - char *dst; - ByteArray *byteArrayPtr; - - byteArrayPtr = GET_BYTEARRAY(objPtr); - src = byteArrayPtr->bytes; - length = byteArrayPtr->used; + const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objPtr, &properByteArrayType); + ByteArray *byteArrayPtr = GET_BYTEARRAY(irPtr); + unsigned char *src = byteArrayPtr->bytes; + unsigned int i, length = byteArrayPtr->used; + unsigned int size = length; /* * How much space will string rep need? */ - size = length; - for (i = 0; i < length && size >= 0; i++) { + for (i = 0; i < length && size <= INT_MAX; i++) { if ((src[i] == 0) || (src[i] > 127)) { size++; } } - if (size < 0) { + if (size > INT_MAX) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } - dst = ckalloc(size + 1); - objPtr->bytes = dst; - objPtr->length = size; - if (size == length) { - memcpy(dst, src, (size_t) size); - dst[size] = '\0'; + char *dst = Tcl_InitStringRep(objPtr, (char *)src, size); + + TclOOM(dst, size); } else { + char *dst = Tcl_InitStringRep(objPtr, NULL, size); + + TclOOM(dst, size); for (i = 0; i < length; i++) { dst += Tcl_UniCharToUtf(src[i], dst); } - *dst = '\0'; + (void) Tcl_InitStringRep(objPtr, NULL, size); } } @@ -629,7 +757,8 @@ TclAppendBytesToByteArray( int len) { ByteArray *byteArrayPtr; - int needed; + unsigned int length, needed; + Tcl_ObjIntRep *irPtr; if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object","TclAppendBytesToByteArray"); @@ -645,23 +774,34 @@ TclAppendBytesToByteArray( return; } - if (objPtr->typePtr != &tclByteArrayType) { - SetByteArrayFromAny(NULL, objPtr); + + length = (unsigned int) len; + + irPtr = TclFetchIntRep(objPtr, &properByteArrayType); + if (irPtr == NULL) { + irPtr = TclFetchIntRep(objPtr, &tclByteArrayType); + if (irPtr == NULL) { + SetByteArrayFromAny(NULL, objPtr); + irPtr = TclFetchIntRep(objPtr, &properByteArrayType); + if (irPtr == NULL) { + irPtr = TclFetchIntRep(objPtr, &tclByteArrayType); + } + } } - byteArrayPtr = GET_BYTEARRAY(objPtr); + byteArrayPtr = GET_BYTEARRAY(irPtr); - if (len > INT_MAX - byteArrayPtr->used) { + if (length > INT_MAX - byteArrayPtr->used) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } - needed = byteArrayPtr->used + len; + needed = byteArrayPtr->used + length; /* * If we need to, resize the allocated space in the byte array. */ if (needed > byteArrayPtr->allocated) { ByteArray *ptr = NULL; - int attempt; + unsigned int attempt; if (needed <= INT_MAX/2) { /* @@ -677,7 +817,7 @@ TclAppendBytesToByteArray( */ unsigned int limit = INT_MAX - needed; - unsigned int extra = len + TCL_MIN_GROWTH; + unsigned int extra = length + TCL_MIN_GROWTH; int growth = (int) ((extra > limit) ? limit : extra); attempt = needed + growth; @@ -693,13 +833,13 @@ TclAppendBytesToByteArray( } byteArrayPtr = ptr; byteArrayPtr->allocated = attempt; - SET_BYTEARRAY(objPtr, byteArrayPtr); + SET_BYTEARRAY(irPtr, byteArrayPtr); } if (bytes) { - memcpy(byteArrayPtr->bytes + byteArrayPtr->used, bytes, len); + memcpy(byteArrayPtr->bytes + byteArrayPtr->used, bytes, length); } - byteArrayPtr->used += len; + byteArrayPtr->used += length; TclInvalidateStringRep(objPtr); } @@ -945,7 +1085,7 @@ BinaryFormatCmd( resultPtr = Tcl_NewObj(); buffer = Tcl_SetByteArrayLength(resultPtr, length); - memset(buffer, 0, (size_t) length); + memset(buffer, 0, length); /* * Pack the data into the result object. Note that we can skip the error @@ -982,10 +1122,10 @@ BinaryFormatCmd( count = 1; } if (length >= count) { - memcpy(cursor, bytes, (size_t) count); + memcpy(cursor, bytes, count); } else { - memcpy(cursor, bytes, (size_t) length); - memset(cursor + length, pad, (size_t) (count - length)); + memcpy(cursor, bytes, length); + memset(cursor + length, pad, count - length); } cursor += count; break; @@ -1174,7 +1314,7 @@ BinaryFormatCmd( if (count == BINARY_NOCOUNT) { count = 1; } - memset(cursor, 0, (size_t) count); + memset(cursor, 0, count); cursor += count; break; case 'X': @@ -1577,7 +1717,7 @@ BinaryScanCmd( */ done: - Tcl_SetObjResult(interp, Tcl_NewLongObj(arg - 3)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(arg - 3)); DeleteScanNumberCache(numberCachePtr); return TCL_OK; @@ -1885,7 +2025,6 @@ FormatNumber( Tcl_Obj *src, /* Number to format. */ unsigned char **cursorPtr) /* Pointer to index into destination buffer. */ { - long value; double dvalue; Tcl_WideInt wvalue; float fvalue; @@ -1901,10 +2040,11 @@ FormatNumber( */ if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) { - if (src->typePtr != &tclDoubleType) { + const Tcl_ObjIntRep *irPtr = TclFetchIntRep(src, &tclDoubleType); + if (irPtr == NULL) { return TCL_ERROR; } - dvalue = src->internalRep.doubleValue; + dvalue = irPtr->doubleValue; } CopyNumber(&dvalue, *cursorPtr, sizeof(double), type); *cursorPtr += sizeof(double); @@ -1920,10 +2060,12 @@ FormatNumber( */ if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) { - if (src->typePtr != &tclDoubleType) { + const Tcl_ObjIntRep *irPtr = TclFetchIntRep(src, &tclDoubleType); + + if (irPtr == NULL) { return TCL_ERROR; } - dvalue = src->internalRep.doubleValue; + dvalue = irPtr->doubleValue; } /* @@ -1947,7 +2089,7 @@ FormatNumber( case 'w': case 'W': case 'm': - if (Tcl_GetWideIntFromObj(interp, src, &wvalue) != TCL_OK) { + if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) { return TCL_ERROR; } if (NeedReversing(type)) { @@ -1977,19 +2119,19 @@ FormatNumber( case 'i': case 'I': case 'n': - if (TclGetLongFromObj(interp, src, &value) != TCL_OK) { + if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) { return TCL_ERROR; } if (NeedReversing(type)) { - *(*cursorPtr)++ = UCHAR(value); - *(*cursorPtr)++ = UCHAR(value >> 8); - *(*cursorPtr)++ = UCHAR(value >> 16); - *(*cursorPtr)++ = UCHAR(value >> 24); + *(*cursorPtr)++ = UCHAR(wvalue); + *(*cursorPtr)++ = UCHAR(wvalue >> 8); + *(*cursorPtr)++ = UCHAR(wvalue >> 16); + *(*cursorPtr)++ = UCHAR(wvalue >> 24); } else { - *(*cursorPtr)++ = UCHAR(value >> 24); - *(*cursorPtr)++ = UCHAR(value >> 16); - *(*cursorPtr)++ = UCHAR(value >> 8); - *(*cursorPtr)++ = UCHAR(value); + *(*cursorPtr)++ = UCHAR(wvalue >> 24); + *(*cursorPtr)++ = UCHAR(wvalue >> 16); + *(*cursorPtr)++ = UCHAR(wvalue >> 8); + *(*cursorPtr)++ = UCHAR(wvalue); } return TCL_OK; @@ -1999,15 +2141,15 @@ FormatNumber( case 's': case 'S': case 't': - if (TclGetLongFromObj(interp, src, &value) != TCL_OK) { + if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) { return TCL_ERROR; } if (NeedReversing(type)) { - *(*cursorPtr)++ = UCHAR(value); - *(*cursorPtr)++ = UCHAR(value >> 8); + *(*cursorPtr)++ = UCHAR(wvalue); + *(*cursorPtr)++ = UCHAR(wvalue >> 8); } else { - *(*cursorPtr)++ = UCHAR(value >> 8); - *(*cursorPtr)++ = UCHAR(value); + *(*cursorPtr)++ = UCHAR(wvalue >> 8); + *(*cursorPtr)++ = UCHAR(wvalue); } return TCL_OK; @@ -2015,10 +2157,10 @@ FormatNumber( * 8-bit integer values. */ case 'c': - if (TclGetLongFromObj(interp, src, &value) != TCL_OK) { + if (TclGetWideBitsFromObj(interp, src, &wvalue) != TCL_OK) { return TCL_ERROR; } - *(*cursorPtr)++ = UCHAR(value); + *(*cursorPtr)++ = UCHAR(wvalue); return TCL_OK; default: @@ -2144,7 +2286,7 @@ ScanNumber( returnNumericObject: if (*numberCachePtrPtr == NULL) { - return Tcl_NewLongObj(value); + return Tcl_NewWideIntObj(value); } else { register Tcl_HashTable *tablePtr = *numberCachePtrPtr; register Tcl_HashEntry *hPtr; @@ -2155,7 +2297,7 @@ ScanNumber( return Tcl_GetHashValue(hPtr); } if (tablePtr->numEntries <= BINARY_SCAN_MAX_CACHE) { - register Tcl_Obj *objPtr = Tcl_NewLongObj(value); + register Tcl_Obj *objPtr = Tcl_NewWideIntObj(value); Tcl_IncrRefCount(objPtr); Tcl_SetHashValue(hPtr, objPtr); @@ -2173,7 +2315,7 @@ ScanNumber( DeleteScanNumberCache(tablePtr); *numberCachePtrPtr = NULL; - return Tcl_NewLongObj(value); + return Tcl_NewWideIntObj(value); } /* @@ -2207,7 +2349,7 @@ ScanNumber( Tcl_Obj *bigObj = NULL; mp_int big; - TclBNInitBignumFromWideUInt(&big, uwvalue); + TclInitBignumFromWideUInt(&big, uwvalue); bigObj = Tcl_NewBignumObj(&big); return bigObj; } @@ -2407,7 +2549,7 @@ BinaryDecodeHex( } c = *data++; - if (!isxdigit((int) c)) { + if (!isxdigit(UCHAR(c))) { if (strict || !TclIsSpaceProc(c)) { goto badChar; } @@ -2521,7 +2663,7 @@ BinaryEncode64( } break; case OPT_WRAPCHAR: - wrapchar = Tcl_GetStringFromObj(objv[i + 1], &wrapcharlen); + wrapchar = TclGetStringFromObj(objv[i + 1], &wrapcharlen); if (wrapcharlen == 0) { maxlen = 0; } diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index 70e64f0..d60633b 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -34,14 +34,14 @@ */ typedef struct MemTag { - int refCount; /* Number of mem_headers referencing this + size_t refCount; /* Number of mem_headers referencing this * tag. */ char string[1]; /* Actual size of string will be as large as * needed for actual tag. This must be the * last field in the structure. */ } MemTag; -#define TAG_SIZE(bytesInString) ((unsigned) ((TclOffset(MemTag, string) + 1) + bytesInString)) +#define TAG_SIZE(bytesInString) ((offsetof(MemTag, string) + 1) + bytesInString) static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers (set * by "memory tag" command). */ @@ -52,14 +52,14 @@ static MemTag *curTagPtr = NULL;/* Tag to use in all future mem_headers (set * to help detect chunk under-runs. */ -#define LOW_GUARD_SIZE (8 + (32 - (sizeof(long) + sizeof(int)))%8) +#define LOW_GUARD_SIZE (8 + (32 - (sizeof(size_t) + sizeof(int)))%8) struct mem_header { struct mem_header *flink; struct mem_header *blink; MemTag *tagPtr; /* Tag from "memory tag" command; may be * NULL. */ const char *file; - long length; + size_t length; int line; unsigned char low_guard[LOW_GUARD_SIZE]; /* Aligns body on 8-byte boundary, plus @@ -89,14 +89,14 @@ static struct mem_header *allocHead = NULL; /* List of allocated structures */ #define BODY_OFFSET \ ((size_t) (&((struct mem_header *) 0)->body)) -static int total_mallocs = 0; -static int total_frees = 0; +static unsigned int total_mallocs = 0; +static unsigned int total_frees = 0; static size_t current_bytes_malloced = 0; static size_t maximum_bytes_malloced = 0; -static int current_malloc_packets = 0; -static int maximum_malloc_packets = 0; -static int break_on_malloc = 0; -static int trace_on_at_malloc = 0; +static unsigned int current_malloc_packets = 0; +static unsigned int maximum_malloc_packets = 0; +static unsigned int break_on_malloc = 0; +static unsigned int trace_on_at_malloc = 0; static int alloc_tracing = FALSE; static int init_malloced_bodies = TRUE; #ifdef MEM_VALIDATE @@ -156,7 +156,7 @@ TclInitDbCkalloc(void) if (!ckallocInit) { ckallocInit = 1; ckallocMutexPtr = Tcl_GetAllocMutex(); -#ifndef TCL_THREADS +#if !TCL_THREADS /* Silence compiler warning */ (void)ckallocMutexPtr; #endif @@ -184,18 +184,18 @@ TclDumpMemoryInfo( return 0; } sprintf(buf, - "total mallocs %10d\n" - "total frees %10d\n" - "current packets allocated %10d\n" - "current bytes allocated %10lu\n" - "maximum packets allocated %10d\n" - "maximum bytes allocated %10lu\n", + "total mallocs %10u\n" + "total frees %10u\n" + "current packets allocated %10u\n" + "current bytes allocated %10" TCL_Z_MODIFIER "u\n" + "maximum packets allocated %10u\n" + "maximum bytes allocated %10" TCL_Z_MODIFIER "u\n", total_mallocs, total_frees, current_malloc_packets, - (unsigned long)current_bytes_malloced, + current_bytes_malloced, maximum_malloc_packets, - (unsigned long)maximum_bytes_malloced); + maximum_bytes_malloced); if (flags == 0) { fprintf((FILE *)clientData, "%s", buf); } else { @@ -251,10 +251,10 @@ ValidateMemory( } if (guard_failed) { TclDumpMemoryInfo((ClientData) stderr, 0); - fprintf(stderr, "low guard failed at %lx, %s %d\n", - (long unsigned) memHeaderP->body, file, line); + fprintf(stderr, "low guard failed at %p, %s %d\n", + memHeaderP->body, file, line); fflush(stderr); /* In case name pointer is bad. */ - fprintf(stderr, "%ld bytes allocated at (%s %d)\n", memHeaderP->length, + fprintf(stderr, "%" TCL_Z_MODIFIER "u bytes allocated at (%s %d)\n", memHeaderP->length, memHeaderP->file, memHeaderP->line); Tcl_Panic("Memory validation failure"); } @@ -273,10 +273,10 @@ ValidateMemory( if (guard_failed) { TclDumpMemoryInfo((ClientData) stderr, 0); - fprintf(stderr, "high guard failed at %lx, %s %d\n", - (long unsigned) memHeaderP->body, file, line); + fprintf(stderr, "high guard failed at %p, %s %d\n", + memHeaderP->body, file, line); fflush(stderr); /* In case name pointer is bad. */ - fprintf(stderr, "%ld bytes allocated at (%s %d)\n", + fprintf(stderr, "%" TCL_Z_MODIFIER "u bytes allocated at (%s %d)\n", memHeaderP->length, memHeaderP->file, memHeaderP->line); Tcl_Panic("Memory validation failure"); @@ -359,9 +359,8 @@ Tcl_DumpActiveMemory( Tcl_MutexLock(ckallocMutexPtr); for (memScanP = allocHead; memScanP != NULL; memScanP = memScanP->flink) { address = &memScanP->body[0]; - fprintf(fileP, "%8lx - %8lx %7ld @ %s %d %s", - (long unsigned) address, - (long unsigned) address + memScanP->length - 1, + fprintf(fileP, "%p - %p %" TCL_Z_MODIFIER "u @ %s %d %s", + address, address + memScanP->length - 1, memScanP->length, memScanP->file, memScanP->line, (memScanP->tagPtr == NULL) ? "" : memScanP->tagPtr->string); (void) fputc('\n', fileP); @@ -406,7 +405,7 @@ Tcl_DbCkalloc( /* Don't let size argument to TclpAlloc overflow */ if (size <= UINT_MAX - HIGH_GUARD_SIZE -sizeof(struct mem_header)) { - result = (struct mem_header *) TclpAlloc((unsigned)size + + result = (struct mem_header *) TclpAlloc(size + sizeof(struct mem_header) + HIGH_GUARD_SIZE); } if (result == NULL) { @@ -450,7 +449,7 @@ Tcl_DbCkalloc( total_mallocs++; if (trace_on_at_malloc && (total_mallocs >= trace_on_at_malloc)) { (void) fflush(stdout); - fprintf(stderr, "reached malloc trace enable point (%d)\n", + fprintf(stderr, "reached malloc trace enable point (%u)\n", total_mallocs); fflush(stderr); alloc_tracing = TRUE; @@ -458,14 +457,14 @@ Tcl_DbCkalloc( } if (alloc_tracing) { - fprintf(stderr,"ckalloc %lx %u %s %d\n", - (long unsigned int) result->body, size, file, line); + fprintf(stderr,"ckalloc %p %u %s %d\n", + result->body, size, file, line); } if (break_on_malloc && (total_mallocs >= break_on_malloc)) { break_on_malloc = 0; (void) fflush(stdout); - Tcl_Panic("reached malloc break limit (%d)", total_mallocs); + Tcl_Panic("reached malloc break limit (%u)", total_mallocs); } current_malloc_packets++; @@ -496,7 +495,7 @@ Tcl_AttemptDbCkalloc( /* Don't let size argument to TclpAlloc overflow */ if (size <= UINT_MAX - HIGH_GUARD_SIZE - sizeof(struct mem_header)) { - result = (struct mem_header *) TclpAlloc((unsigned)size + + result = (struct mem_header *) TclpAlloc(size + sizeof(struct mem_header) + HIGH_GUARD_SIZE); } if (result == NULL) { @@ -547,8 +546,8 @@ Tcl_AttemptDbCkalloc( } if (alloc_tracing) { - fprintf(stderr,"ckalloc %lx %u %s %d\n", - (long unsigned int) result->body, size, file, line); + fprintf(stderr,"ckalloc %p %u %s %d\n", + result->body, size, file, line); } if (break_on_malloc && (total_mallocs >= break_on_malloc)) { @@ -612,8 +611,8 @@ Tcl_DbCkfree( memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET); if (alloc_tracing) { - fprintf(stderr, "ckfree %lx %ld %s %d\n", - (long unsigned int) memp->body, memp->length, file, line); + fprintf(stderr, "ckfree %p %" TCL_Z_MODIFIER "u %s %d\n", + memp->body, memp->length, file, line); } if (validate_memory) { @@ -623,7 +622,7 @@ Tcl_DbCkfree( Tcl_MutexLock(ckallocMutexPtr); ValidateMemory(memp, file, line, TRUE); if (init_malloced_bodies) { - memset(ptr, GUARD_VALUE, (size_t) memp->length); + memset(ptr, GUARD_VALUE, memp->length); } total_frees++; @@ -631,8 +630,7 @@ Tcl_DbCkfree( current_bytes_malloced -= memp->length; if (memp->tagPtr != NULL) { - memp->tagPtr->refCount--; - if ((memp->tagPtr->refCount == 0) && (curTagPtr != memp->tagPtr)) { + if ((memp->tagPtr->refCount-- <= 1) && (curTagPtr != memp->tagPtr)) { TclpFree((char *) memp->tagPtr); } } @@ -675,7 +673,7 @@ Tcl_DbCkrealloc( int line) { char *newPtr; - unsigned int copySize; + size_t copySize; struct mem_header *memp; if (ptr == NULL) { @@ -689,11 +687,11 @@ Tcl_DbCkrealloc( memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET); copySize = size; - if (copySize > (unsigned int) memp->length) { + if (copySize > memp->length) { copySize = memp->length; } newPtr = Tcl_DbCkalloc(size, file, line); - memcpy(newPtr, ptr, (size_t) copySize); + memcpy(newPtr, ptr, copySize); Tcl_DbCkfree(ptr, file, line); return newPtr; } @@ -706,7 +704,7 @@ Tcl_AttemptDbCkrealloc( int line) { char *newPtr; - unsigned int copySize; + size_t copySize; struct mem_header *memp; if (ptr == NULL) { @@ -720,14 +718,14 @@ Tcl_AttemptDbCkrealloc( memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET); copySize = size; - if (copySize > (unsigned int) memp->length) { + if (copySize > memp->length) { copySize = memp->length; } newPtr = Tcl_AttemptDbCkalloc(size, file, line); if (newPtr == NULL) { return NULL; } - memcpy(newPtr, ptr, (size_t) copySize); + memcpy(newPtr, ptr, copySize); Tcl_DbCkfree(ptr, file, line); return newPtr; } @@ -849,22 +847,24 @@ MemoryCmd( return TCL_OK; } if (strcmp(argv[1],"break_on_malloc") == 0) { + int value; if (argc != 3) { goto argError; } - if (Tcl_GetInt(interp, argv[2], &break_on_malloc) != TCL_OK) { + if (Tcl_GetInt(interp, argv[2], &value) != TCL_OK) { return TCL_ERROR; } + break_on_malloc = (unsigned int) value; return TCL_OK; } if (strcmp(argv[1],"info") == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%-25s %10d\n%-25s %10d\n%-25s %10d\n%-25s %10lu\n%-25s %10d\n%-25s %10lu\n", + "%-25s %10u\n%-25s %10u\n%-25s %10u\n%-25s %10" TCL_Z_MODIFIER"u\n%-25s %10u\n%-25s %10" TCL_Z_MODIFIER "u\n", "total mallocs", total_mallocs, "total frees", total_frees, "current packets allocated", current_malloc_packets, - "current bytes allocated", (unsigned long)current_bytes_malloced, + "current bytes allocated", current_bytes_malloced, "maximum packets allocated", maximum_malloc_packets, - "maximum bytes allocated", (unsigned long)maximum_bytes_malloced)); + "maximum bytes allocated", maximum_bytes_malloced)); return TCL_OK; } if (strcmp(argv[1], "init") == 0) { @@ -935,12 +935,14 @@ MemoryCmd( } if (strcmp(argv[1],"trace_on_at_malloc") == 0) { + int value; if (argc != 3) { goto argError; } - if (Tcl_GetInt(interp, argv[2], &trace_on_at_malloc) != TCL_OK) { + if (Tcl_GetInt(interp, argv[2], &value) != TCL_OK) { return TCL_ERROR; } + trace_on_at_malloc = value; return TCL_OK; } if (strcmp(argv[1],"validate") == 0) { diff --git a/generic/tclClock.c b/generic/tclClock.c index 9ed970c..aeff164 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -452,7 +452,7 @@ ClockGetdatefieldsObjCmd( * that it isn't. */ - if (objv[1]->typePtr == &tclBignumType) { + if (TclHasIntRep(objv[1], &tclBignumType)) { Tcl_SetObjResult(interp, literals[LIT_INTEGER_VALUE_TOO_LARGE]); return TCL_ERROR; } @@ -488,27 +488,27 @@ ClockGetdatefieldsObjCmd( Tcl_DictObjPut(NULL, dict, literals[LIT_TZNAME], fields.tzName); Tcl_DecrRefCount(fields.tzName); Tcl_DictObjPut(NULL, dict, literals[LIT_TZOFFSET], - Tcl_NewIntObj(fields.tzOffset)); + Tcl_NewWideIntObj(fields.tzOffset)); Tcl_DictObjPut(NULL, dict, literals[LIT_JULIANDAY], - Tcl_NewIntObj(fields.julianDay)); + Tcl_NewWideIntObj(fields.julianDay)); Tcl_DictObjPut(NULL, dict, literals[LIT_GREGORIAN], - Tcl_NewIntObj(fields.gregorian)); + Tcl_NewWideIntObj(fields.gregorian)); Tcl_DictObjPut(NULL, dict, literals[LIT_ERA], literals[fields.era ? LIT_BCE : LIT_CE]); Tcl_DictObjPut(NULL, dict, literals[LIT_YEAR], - Tcl_NewIntObj(fields.year)); + Tcl_NewWideIntObj(fields.year)); Tcl_DictObjPut(NULL, dict, literals[LIT_DAYOFYEAR], - Tcl_NewIntObj(fields.dayOfYear)); + Tcl_NewWideIntObj(fields.dayOfYear)); Tcl_DictObjPut(NULL, dict, literals[LIT_MONTH], - Tcl_NewIntObj(fields.month)); + Tcl_NewWideIntObj(fields.month)); Tcl_DictObjPut(NULL, dict, literals[LIT_DAYOFMONTH], - Tcl_NewIntObj(fields.dayOfMonth)); + Tcl_NewWideIntObj(fields.dayOfMonth)); Tcl_DictObjPut(NULL, dict, literals[LIT_ISO8601YEAR], - Tcl_NewIntObj(fields.iso8601Year)); + Tcl_NewWideIntObj(fields.iso8601Year)); Tcl_DictObjPut(NULL, dict, literals[LIT_ISO8601WEEK], - Tcl_NewIntObj(fields.iso8601Week)); + Tcl_NewWideIntObj(fields.iso8601Week)); Tcl_DictObjPut(NULL, dict, literals[LIT_DAYOFWEEK], - Tcl_NewIntObj(fields.dayOfWeek)); + Tcl_NewWideIntObj(fields.dayOfWeek)); Tcl_SetObjResult(interp, dict); return TCL_OK; @@ -628,7 +628,7 @@ ClockGetjuliandayfromerayearmonthdayObjCmd( copied = 1; } status = Tcl_DictObjPut(interp, dict, literals[LIT_JULIANDAY], - Tcl_NewIntObj(fields.julianDay)); + Tcl_NewWideIntObj(fields.julianDay)); if (status == TCL_OK) { Tcl_SetObjResult(interp, dict); } @@ -712,7 +712,7 @@ ClockGetjuliandayfromerayearweekdayObjCmd( copied = 1; } status = Tcl_DictObjPut(interp, dict, literals[LIT_JULIANDAY], - Tcl_NewIntObj(fields.julianDay)); + Tcl_NewWideIntObj(fields.julianDay)); if (status == TCL_OK) { Tcl_SetObjResult(interp, dict); } diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 40a10ba..c7ec4f9 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -15,7 +15,6 @@ #ifdef _WIN32 # include "tclWinInt.h" #endif -#include <locale.h> /* * The state structure used by [foreach]. Note that the actual structure has @@ -46,9 +45,6 @@ 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[]); @@ -84,7 +80,6 @@ static Tcl_NRPostProc ForPostNextCallback; static Tcl_NRPostProc ForeachLoopStep; static Tcl_NRPostProc EvalCmdErrMsg; -static Tcl_ObjCmdProc BadFileSubcommand; static Tcl_ObjCmdProc FileAttrAccessTimeCmd; static Tcl_ObjCmdProc FileAttrIsDirectoryCmd; static Tcl_ObjCmdProc FileAttrIsExecutableCmd; @@ -164,7 +159,7 @@ Tcl_BreakObjCmd( * *---------------------------------------------------------------------- */ - +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 /* ARGSUSED */ int Tcl_CaseObjCmd( @@ -282,6 +277,7 @@ Tcl_CaseObjCmd( return TCL_OK; } +#endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -385,7 +381,7 @@ CatchObjCmdCallback( } Tcl_ResetResult(interp); - Tcl_SetObjResult(interp, Tcl_NewIntObj(result)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(result)); return TCL_OK; } @@ -535,9 +531,9 @@ TclInitEncodingCmd( static const EnsembleImplMap encodingImplMap[] = { {"convertfrom", EncodingConvertfromObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {"convertto", EncodingConverttoObjCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, - {"dirs", EncodingDirsObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"dirs", EncodingDirsObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, {"names", EncodingNamesObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, - {"system", EncodingSystemObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, + {"system", EncodingSystemObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, {NULL, NULL, NULL, NULL, NULL, 0} }; @@ -545,113 +541,6 @@ TclInitEncodingCmd( } /* - *----------------------------------------------------------------------------- - * - * 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} - }; - - int i; - Tcl_DString oldBuf, newBuf; - - 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); - - /* - * 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))); - } - 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 -- @@ -1042,7 +931,7 @@ Tcl_ExitObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int value; + Tcl_WideInt value; if ((objc != 1) && (objc != 2)) { Tcl_WrongNumArgs(interp, 1, objv, "?returnCode?"); @@ -1051,10 +940,10 @@ Tcl_ExitObjCmd( if (objc == 1) { value = 0; - } else if (Tcl_GetIntFromObj(interp, objv[1], &value) != TCL_OK) { + } else if (TclGetWideBitsFromObj(interp, objv[1], &value) != TCL_OK) { return TCL_ERROR; } - Tcl_Exit(value); + Tcl_Exit((int)value); /*NOTREACHED*/ return TCL_OK; /* Better not ever reach this! */ } @@ -1173,40 +1062,41 @@ TclInitFileCmd( */ static const EnsembleImplMap initMap[] = { - {"atime", FileAttrAccessTimeCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, - {"attributes", TclFileAttrsCmd, NULL, NULL, NULL, 0}, + {"atime", FileAttrAccessTimeCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 1}, + {"attributes", TclFileAttrsCmd, NULL, NULL, NULL, 1}, {"channels", TclChannelNamesCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, - {"copy", TclFileCopyCmd, NULL, NULL, NULL, 0}, - {"delete", TclFileDeleteCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0}, - {"dirname", PathDirNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"executable", FileAttrIsExecutableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"exists", FileAttrIsExistingCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"extension", PathExtensionCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"isdirectory", FileAttrIsDirectoryCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"isfile", FileAttrIsFileCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"copy", TclFileCopyCmd, NULL, NULL, NULL, 1}, + {"delete", TclFileDeleteCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 1}, + {"dirname", PathDirNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, + {"executable", FileAttrIsExecutableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, + {"exists", FileAttrIsExistingCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, + {"extension", PathExtensionCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, + {"isdirectory", FileAttrIsDirectoryCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, + {"isfile", FileAttrIsFileCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {"join", PathJoinCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0}, - {"link", TclFileLinkCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, - {"lstat", FileAttrLinkStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, - {"mtime", FileAttrModifyTimeCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, - {"mkdir", TclFileMakeDirsCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 0}, - {"nativename", PathNativeNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"normalize", PathNormalizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"owned", FileAttrIsOwnedCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"link", TclFileLinkCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 1}, + {"lstat", FileAttrLinkStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 1}, + {"mtime", FileAttrModifyTimeCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 1}, + {"mkdir", TclFileMakeDirsCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 1}, + {"nativename", PathNativeNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, + {"normalize", PathNormalizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, + {"owned", FileAttrIsOwnedCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {"pathtype", PathTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"readable", FileAttrIsReadableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"readlink", TclFileReadLinkCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"rename", TclFileRenameCmd, NULL, NULL, NULL, 0}, - {"rootname", PathRootNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"readable", FileAttrIsReadableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, + {"readlink", TclFileReadLinkCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, + {"rename", TclFileRenameCmd, NULL, NULL, NULL, 1}, + {"rootname", PathRootNameCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {"separator", FilesystemSeparatorCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, - {"size", FileAttrSizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"size", FileAttrSizeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {"split", PathSplitCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"stat", FileAttrStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, + {"stat", FileAttrStatCmd, TclCompileBasic2ArgCmd, NULL, NULL, 1}, {"system", PathFilesystemCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, - {"tail", PathTailCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"tempfile", TclFileTemporaryCmd, TclCompileBasic0To2ArgCmd, NULL, NULL, 0}, - {"type", FileAttrTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"volumes", FilesystemVolumesCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, - {"writable", FileAttrIsWritableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"tail", PathTailCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, + {"tempdir", TclFileTempDirCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, + {"tempfile", TclFileTemporaryCmd, TclCompileBasic0To2ArgCmd, NULL, NULL, 1}, + {"type", FileAttrTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, + {"volumes", FilesystemVolumesCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1}, + {"writable", FileAttrIsWritableCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {NULL, NULL, NULL, NULL, NULL, 0} }; return TclMakeEnsemble(interp, "file", initMap); @@ -1215,141 +1105,6 @@ TclInitFileCmd( /* *---------------------------------------------------------------------- * - * TclMakeFileCommandSafe -- - * - * This function hides the unsafe subcommands of the "file" Tcl command - * ensemble. It must only be called from TclHideUnsafeCommands. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * Adds commands to the table of hidden commands. - * - *---------------------------------------------------------------------- - */ - -int -TclMakeFileCommandSafe( - Tcl_Interp *interp) -{ - static const struct { - const char *cmdName; - int unsafe; - } unsafeInfo[] = { - {"atime", 1}, - {"attributes", 1}, - {"channels", 0}, - {"copy", 1}, - {"delete", 1}, - {"dirname", 1}, - {"executable", 1}, - {"exists", 1}, - {"extension", 1}, - {"isdirectory", 1}, - {"isfile", 1}, - {"join", 0}, - {"link", 1}, - {"lstat", 1}, - {"mtime", 1}, - {"mkdir", 1}, - {"nativename", 1}, - {"normalize", 1}, - {"owned", 1}, - {"pathtype", 0}, - {"readable", 1}, - {"readlink", 1}, - {"rename", 1}, - {"rootname", 1}, - {"separator", 0}, - {"size", 1}, - {"split", 0}, - {"stat", 1}, - {"system", 0}, - {"tail", 1}, - {"tempfile", 1}, - {"type", 1}, - {"volumes", 1}, - {"writable", 1}, - {NULL, 0} - }; - int i; - Tcl_DString oldBuf, newBuf; - - Tcl_DStringInit(&oldBuf); - TclDStringAppendLiteral(&oldBuf, "::tcl::file::"); - Tcl_DStringInit(&newBuf); - TclDStringAppendLiteral(&newBuf, "tcl:file:"); - for (i=0 ; unsafeInfo[i].cmdName != NULL ; i++) { - if (unsafeInfo[i].unsafe) { - const char *oldName, *newName; - - Tcl_DStringSetLength(&oldBuf, 13); - oldName = Tcl_DStringAppend(&oldBuf, unsafeInfo[i].cmdName, -1); - Tcl_DStringSetLength(&newBuf, 9); - 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 'file %s' safe: %s", - unsafeInfo[i].cmdName, - Tcl_GetString(Tcl_GetObjResult(interp))); - } - Tcl_CreateObjCommand(interp, oldName, BadFileSubcommand, - (ClientData) unsafeInfo[i].cmdName, NULL); - } - } - Tcl_DStringFree(&oldBuf); - Tcl_DStringFree(&newBuf); - - /* - * Ugh. The [file] command is now actually safe, but it is assumed by - * scripts that it is not, which messes up security policies. [Bug - * 3211758] - */ - - if (Tcl_HideCommand(interp, "file", "file") != TCL_OK) { - Tcl_Panic("problem making 'file' safe: %s", - Tcl_GetString(Tcl_GetObjResult(interp))); - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * BadFileSubcommand -- - * - * Command used to act as a backstop implementation when subcommands of - * "file" 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 -BadFileSubcommand( - 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 file", subcommandName)); - Tcl_SetErrorCode(interp, "TCL", "SAFE", "SUBCOMMAND", NULL); - return TCL_ERROR; -} - -/* - *---------------------------------------------------------------------- - * * FileAttrAccessTimeCmd -- * * This function is invoked to process the "file atime" Tcl command. See @@ -1392,9 +1147,14 @@ FileAttrAccessTimeCmd( #endif if (objc == 3) { + /* + * Need separate variable for reading longs from an object on 64-bit + * platforms. [Bug 698146] + */ + Tcl_WideInt newTime; - if (Tcl_GetWideIntFromObj(interp, objv[2], &newTime) != TCL_OK) { + if (TclGetWideIntFromObj(interp, objv[2], &newTime) != TCL_OK) { return TCL_ERROR; } @@ -1475,7 +1235,7 @@ FileAttrModifyTimeCmd( Tcl_WideInt newTime; - if (Tcl_GetWideIntFromObj(interp, objv[2], &newTime) != TCL_OK) { + if (TclGetWideIntFromObj(interp, objv[2], &newTime) != TCL_OK) { return TCL_ERROR; } @@ -2518,23 +2278,23 @@ StoreStatData( * cast might fail when there isn't a real arithmetic 'long long' type... */ - STORE_ARY("dev", Tcl_NewLongObj((long)statPtr->st_dev)); + STORE_ARY("dev", Tcl_NewWideIntObj((long)statPtr->st_dev)); STORE_ARY("ino", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_ino)); - STORE_ARY("nlink", Tcl_NewLongObj((long)statPtr->st_nlink)); - STORE_ARY("uid", Tcl_NewLongObj((long)statPtr->st_uid)); - STORE_ARY("gid", Tcl_NewLongObj((long)statPtr->st_gid)); + STORE_ARY("nlink", Tcl_NewWideIntObj((long)statPtr->st_nlink)); + STORE_ARY("uid", Tcl_NewWideIntObj((long)statPtr->st_uid)); + STORE_ARY("gid", Tcl_NewWideIntObj((long)statPtr->st_gid)); STORE_ARY("size", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_size)); #ifdef HAVE_STRUCT_STAT_ST_BLOCKS STORE_ARY("blocks", Tcl_NewWideIntObj((Tcl_WideInt)statPtr->st_blocks)); #endif #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE - STORE_ARY("blksize", Tcl_NewLongObj((long)statPtr->st_blksize)); + STORE_ARY("blksize", Tcl_NewWideIntObj((long)statPtr->st_blksize)); #endif STORE_ARY("atime", Tcl_NewWideIntObj(Tcl_GetAccessTimeFromStat(statPtr))); STORE_ARY("mtime", Tcl_NewWideIntObj(Tcl_GetModificationTimeFromStat(statPtr))); STORE_ARY("ctime", Tcl_NewWideIntObj(Tcl_GetChangeTimeFromStat(statPtr))); mode = (unsigned short) statPtr->st_mode; - STORE_ARY("mode", Tcl_NewIntObj(mode)); + STORE_ARY("mode", Tcl_NewWideIntObj(mode)); STORE_ARY("type", Tcl_NewStringObj(GetTypeFromMode(mode), -1)); #undef STORE_ARY diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index 94c5413..cbb40c6 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -56,7 +56,7 @@ typedef int (*SortMemCmpFn_t) (const void *, const void *, size_t); * The following structure is used to pass this information. */ -typedef struct SortInfo { +typedef struct { int isIncreasing; /* Nonzero means sort in increasing order. */ int sortMode; /* The sort mode. One of SORTMODE_* values * defined below. */ @@ -138,6 +138,8 @@ static int InfoScriptCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int InfoSharedlibCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +static int InfoCmdTypeCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); static int InfoTclVersionCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static SortElement * MergeLists(SortElement *leftPtr, SortElement *rightPtr, @@ -156,6 +158,7 @@ static const EnsembleImplMap defaultInfoMap[] = { {"args", InfoArgsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"body", InfoBodyCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"cmdcount", InfoCmdCountCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, + {"cmdtype", InfoCmdTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {"commands", InfoCommandsCmd, TclCompileInfoCommandsCmd, NULL, NULL, 0}, {"complete", InfoCompleteCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"coroutine", TclInfoCoroutineCmd, TclCompileInfoCoroutineCmd, NULL, NULL, 0}, @@ -170,7 +173,7 @@ static const EnsembleImplMap defaultInfoMap[] = { {"library", InfoLibraryCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, {"loaded", InfoLoadedCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {"locals", TclInfoLocalsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, - {"nameofexecutable", InfoNameOfExecutableCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, + {"nameofexecutable", InfoNameOfExecutableCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1}, {"patchlevel", InfoPatchLevelCmd, TclCompileBasic0ArgCmd, NULL, NULL, 0}, {"procs", InfoProcsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {"script", InfoScriptCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, @@ -401,7 +404,7 @@ Tcl_IncrObjCmd( if (objc == 3) { incrPtr = objv[2]; } else { - incrPtr = Tcl_NewIntObj(1); + incrPtr = Tcl_NewWideIntObj(1); } Tcl_IncrRefCount(incrPtr); newValuePtr = TclIncrObjVar2(interp, objv[1], NULL, @@ -536,9 +539,9 @@ InfoBodyCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { register Interp *iPtr = (Interp *) interp; - const char *name; + const char *name, *bytes; Proc *procPtr; - Tcl_Obj *bodyPtr, *resultPtr; + int numBytes; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "procname"); @@ -563,18 +566,8 @@ InfoBodyCmd( * the object do not invalidate the internal rep. */ - bodyPtr = procPtr->bodyPtr; - if (bodyPtr->bytes == NULL) { - /* - * The string rep might not be valid if the procedure has never been - * run before. [Bug #545644] - */ - - TclGetString(bodyPtr); - } - resultPtr = Tcl_NewStringObj(bodyPtr->bytes, bodyPtr->length); - - Tcl_SetObjResult(interp, resultPtr); + bytes = TclGetStringFromObj(procPtr->bodyPtr, &numBytes); + Tcl_SetObjResult(interp, Tcl_NewStringObj(bytes, numBytes)); return TCL_OK; } @@ -613,7 +606,7 @@ InfoCmdCountCmd( return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewIntObj(iPtr->cmdCount)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(iPtr->cmdCount)); return TCL_OK; } @@ -995,7 +988,7 @@ InfoDefaultCmd( if (valueObjPtr == NULL) { return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewIntObj(1)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(1)); } else { Tcl_Obj *nullObjPtr = Tcl_NewObj(); @@ -1004,7 +997,7 @@ InfoDefaultCmd( if (valueObjPtr == NULL) { return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0)); } return TCL_OK; } @@ -1054,7 +1047,7 @@ InfoErrorStackCmd( target = interp; if (objc == 2) { - target = Tcl_GetSlave(interp, Tcl_GetString(objv[1])); + target = Tcl_GetSlave(interp, TclGetString(objv[1])); if (target == NULL) { return TCL_ERROR; } @@ -1178,7 +1171,7 @@ InfoFrameCmd( * Just "info frame". */ - Tcl_SetObjResult(interp, Tcl_NewIntObj(topLevel)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(topLevel)); goto done; } @@ -1300,9 +1293,9 @@ TclInfoFrame( ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1)); if (framePtr->line) { - ADD_PAIR("line", Tcl_NewIntObj(framePtr->line[0])); + ADD_PAIR("line", Tcl_NewWideIntObj(framePtr->line[0])); } else { - ADD_PAIR("line", Tcl_NewIntObj(1)); + ADD_PAIR("line", Tcl_NewWideIntObj(1)); } ADD_PAIR("cmd", TclGetSourceFromFrame(framePtr, 0, NULL)); break; @@ -1339,7 +1332,7 @@ TclInfoFrame( ADD_PAIR("type", Tcl_NewStringObj(typeString[fPtr->type], -1)); if (fPtr->line) { - ADD_PAIR("line", Tcl_NewIntObj(fPtr->line[0])); + ADD_PAIR("line", Tcl_NewWideIntObj(fPtr->line[0])); } if (fPtr->type == TCL_LOCATION_SOURCE) { @@ -1366,7 +1359,7 @@ TclInfoFrame( */ ADD_PAIR("type", Tcl_NewStringObj(typeString[framePtr->type], -1)); - ADD_PAIR("line", Tcl_NewIntObj(framePtr->line[0])); + ADD_PAIR("line", Tcl_NewWideIntObj(framePtr->line[0])); ADD_PAIR("file", framePtr->data.eval.path); /* @@ -1437,7 +1430,7 @@ TclInfoFrame( int c = framePtr->framePtr->level; int t = iPtr->varFramePtr->level; - ADD_PAIR("level", Tcl_NewIntObj(t - c)); + ADD_PAIR("level", Tcl_NewWideIntObj(t - c)); break; } } @@ -1592,7 +1585,7 @@ InfoLevelCmd( Interp *iPtr = (Interp *) interp; if (objc == 1) { /* Just "info level" */ - Tcl_SetObjResult(interp, Tcl_NewIntObj(iPtr->varFramePtr->level)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(iPtr->varFramePtr->level)); return TCL_OK; } @@ -1670,7 +1663,7 @@ InfoLibraryCmd( return TCL_ERROR; } - libDirName = Tcl_GetVar(interp, "tcl_library", TCL_GLOBAL_ONLY); + libDirName = Tcl_GetVar2(interp, "tcl_library", NULL, TCL_GLOBAL_ONLY); if (libDirName != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj(libDirName, -1)); return TCL_OK; @@ -1710,19 +1703,24 @@ InfoLoadedCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - const char *interpName; + const char *interpName, *packageName; - if ((objc != 1) && (objc != 2)) { - Tcl_WrongNumArgs(interp, 1, objv, "?interp?"); + if (objc > 3) { + Tcl_WrongNumArgs(interp, 1, objv, "?interp? ?packageName?"); return TCL_ERROR; } - if (objc == 1) { /* Get loaded pkgs in all interpreters. */ + if (objc < 2) { /* Get loaded pkgs in all interpreters. */ interpName = NULL; } else { /* Get pkgs just in specified interp. */ interpName = TclGetString(objv[1]); } - return TclGetLoadedPackages(interp, interpName); + if (objc < 3) { /* Get loaded files in all packages. */ + packageName = NULL; + } else { /* Get pkgs just in specified interp. */ + packageName = TclGetString(objv[2]); + } + return TclGetLoadedPackagesEx(interp, interpName, packageName); } /* @@ -1796,7 +1794,7 @@ InfoPatchLevelCmd( return TCL_ERROR; } - patchlevel = Tcl_GetVar(interp, "tcl_patchLevel", + patchlevel = Tcl_GetVar2(interp, "tcl_patchLevel", NULL, (TCL_GLOBAL_ONLY | TCL_LEAVE_ERR_MSG)); if (patchlevel != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj(patchlevel, -1)); @@ -2127,6 +2125,60 @@ InfoTclVersionCmd( /* *---------------------------------------------------------------------- * + * InfoCmdTypeCmd -- + * + * Called to implement the "info cmdtype" command that returns the type + * of a given command. Handles the following syntax: + * + * info cmdtype cmdName + * + * Results: + * Returns TCL_OK if successful and TCL_ERROR if there is an error. + * + * Side effects: + * Returns a type name. If there is an error, the result is an error + * message. + * + *---------------------------------------------------------------------- + */ + +static int +InfoCmdTypeCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Command command; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "commandName"); + return TCL_ERROR; + } + command = Tcl_FindCommand(interp, TclGetString(objv[1]), NULL, + TCL_LEAVE_ERR_MSG); + if (command == NULL) { + return TCL_ERROR; + } + + /* + * There's one special case: safe slave interpreters can't see aliases as + * aliases as they're part of the security mechanisms. + */ + + if (Tcl_IsSafe(interp) + && (((Command *) command)->objProc == TclAliasObjCmd)) { + Tcl_AppendResult(interp, "native", NULL); + } else { + Tcl_SetObjResult(interp, + Tcl_NewStringObj(TclGetCommandTypeName(command), -1)); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_JoinObjCmd -- * * This procedure is invoked to process the "join" Tcl command. See the @@ -2148,8 +2200,8 @@ Tcl_JoinObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { - int listLen, i; - Tcl_Obj *resObjPtr, *joinObjPtr, **elemPtrs; + int length, listLen; + Tcl_Obj *resObjPtr = NULL, *joinObjPtr, **elemPtrs; if ((objc < 2) || (objc > 3)) { Tcl_WrongNumArgs(interp, 1, objv, "list ?joinString?"); @@ -2166,27 +2218,47 @@ Tcl_JoinObjCmd( return TCL_ERROR; } + if (listLen == 0) { + /* No elements to join; default empty result is correct. */ + return TCL_OK; + } + if (listLen == 1) { + /* One element; return it */ + Tcl_SetObjResult(interp, elemPtrs[0]); + return TCL_OK; + } + joinObjPtr = (objc == 2) ? Tcl_NewStringObj(" ", 1) : objv[2]; Tcl_IncrRefCount(joinObjPtr); - resObjPtr = Tcl_NewObj(); - for (i = 0; i < listLen; i++) { - if (i > 0) { + (void) TclGetStringFromObj(joinObjPtr, &length); + if (length == 0) { + resObjPtr = TclStringCat(interp, listLen, elemPtrs, 0); + } else { + int i; - /* - * 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. - */ + resObjPtr = Tcl_NewObj(); + for (i = 0; i < listLen; i++) { + if (i > 0) { + + /* + * NOTE: This code is relying on Tcl_AppendObjToObj() **NOT** + * to shimmer joinObjPtr. If it did, then the case where + * objv[1] and objv[2] are the same value would not be safe. + * Accessing elemPtrs would crash. + */ - Tcl_AppendObjToObj(resObjPtr, joinObjPtr); + Tcl_AppendObjToObj(resObjPtr, joinObjPtr); + } + Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]); } - Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]); } Tcl_DecrRefCount(joinObjPtr); - Tcl_SetObjResult(interp, resObjPtr); - return TCL_OK; + if (resObjPtr) { + Tcl_SetObjResult(interp, resObjPtr); + return TCL_OK; + } + return TCL_ERROR; } /* @@ -2482,7 +2554,100 @@ Tcl_LlengthObjCmd( * length. */ - Tcl_SetObjResult(interp, Tcl_NewIntObj(listLen)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(listLen)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LpopObjCmd -- + * + * This procedure is invoked to process the "lpop" Tcl command. See the + * user documentation for details on what it does. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_LpopObjCmd( + ClientData notUsed, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + register Tcl_Obj *const objv[]) + /* Argument objects. */ +{ + int listLen, result; + Tcl_Obj *elemPtr, *stored; + Tcl_Obj *listPtr, **elemPtrs; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "listvar ?index?"); + return TCL_ERROR; + } + + listPtr = Tcl_ObjGetVar2(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG); + if (listPtr == NULL) { + return TCL_ERROR; + } + + result = TclListObjGetElements(interp, listPtr, &listLen, &elemPtrs); + if (result != TCL_OK) { + return result; + } + + /* + * First, extract the element to be returned. + * TclLindexFlat adds a ref count which is handled. + */ + + if (objc == 2) { + elemPtr = elemPtrs[listLen - 1]; + Tcl_IncrRefCount(elemPtr); + } else { + elemPtr = TclLindexFlat(interp, listPtr, objc-2, objv+2); + + if (elemPtr == NULL) { + return TCL_ERROR; + } + } + Tcl_SetObjResult(interp, elemPtr); + Tcl_DecrRefCount(elemPtr); + + /* + * Second, remove the element. + * TclLsetFlat adds a ref count which is handled. + */ + + if (objc == 2) { + if (Tcl_IsShared(listPtr)) { + listPtr = TclListObjCopy(NULL, listPtr); + } + result = Tcl_ListObjReplace(interp, listPtr, listLen - 1, 1, 0, NULL); + if (result != TCL_OK) { + return result; + } + Tcl_IncrRefCount(listPtr); + } else { + listPtr = TclLsetFlat(interp, listPtr, objc-2, objv+2, NULL); + + if (listPtr == NULL) { + return TCL_ERROR; + } + } + + stored = Tcl_ObjSetVar2(interp, objv[1], NULL, listPtr, TCL_LEAVE_ERR_MSG); + Tcl_DecrRefCount(listPtr); + if (stored == NULL) { + return TCL_ERROR; + } + return TCL_OK; } @@ -2511,7 +2676,6 @@ Tcl_LrangeObjCmd( register Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Obj **elemPtrs; int listLen, first, last, result; if (objc != 4) { @@ -2529,55 +2693,148 @@ Tcl_LrangeObjCmd( if (result != TCL_OK) { return result; } - if (first < 0) { - first = 0; - } result = TclGetIntForIndexM(interp, objv[3], /*endValue*/ listLen - 1, &last); if (result != TCL_OK) { return result; } - if (last >= listLen) { - last = listLen - 1; + + Tcl_SetObjResult(interp, TclListObjRange(objv[1], first, last)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LremoveObjCmd -- + * + * This procedure is invoked to process the "lremove" Tcl command. See the + * user documentation for details on what it does. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +LremoveIndexCompare( + const void *el1Ptr, + const void *el2Ptr) +{ + int idx1 = *((const int *) el1Ptr); + int idx2 = *((const int *) el2Ptr); + + /* + * This will put the larger element first. + */ + + return (idx1 < idx2) ? 1 : (idx1 > idx2) ? -1 : 0; +} + +int +Tcl_LremoveObjCmd( + ClientData notUsed, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int i, idxc; + int listLen, *idxv, prevIdx, first, num; + Tcl_Obj *listObj; + + /* + * Parse the arguments. + */ + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "list ?index ...?"); + return TCL_ERROR; } - if (first > last) { - /* - * Returning an empty list is easy. - */ + listObj = objv[1]; + if (TclListObjLength(interp, listObj, &listLen) != TCL_OK) { + return TCL_ERROR; + } + idxc = objc - 2; + if (idxc == 0) { + Tcl_SetObjResult(interp, listObj); return TCL_OK; } + idxv = ckalloc((objc - 2) * sizeof(int)); + for (i = 2; i < objc; i++) { + if (TclGetIntForIndexM(interp, objv[i], /*endValue*/ listLen - 1, + &idxv[i - 2]) != TCL_OK) { + ckfree(idxv); + return TCL_ERROR; + } + } - result = TclListObjGetElements(interp, objv[1], &listLen, &elemPtrs); - if (result != TCL_OK) { - return result; + /* + * Sort the indices, large to small so that when we remove an index we + * don't change the indices still to be processed. + */ + + if (idxc > 1) { + qsort(idxv, idxc, sizeof(int), LremoveIndexCompare); } - if (Tcl_IsShared(objv[1]) || - ((ListRepPtr(objv[1])->refCount > 1))) { - Tcl_SetObjResult(interp, Tcl_NewListObj(last - first + 1, - &elemPtrs[first])); - } else { + /* + * Make our working copy, then do the actual removes piecemeal. + */ + + if (Tcl_IsShared(listObj)) { + listObj = TclListObjCopy(NULL, listObj); + } + num = 0; + first = listLen; + for (i = 0, prevIdx = -1 ; i < idxc ; i++) { + int idx = idxv[i]; + /* - * In-place is possible. + * Repeated index and sanity check. */ - if (last < (listLen - 1)) { - Tcl_ListObjReplace(interp, objv[1], last + 1, listLen - 1 - last, - 0, NULL); + if (idx == prevIdx) { + continue; + } + prevIdx = idx; + if (idx < 0 || idx >= listLen) { + continue; } /* - * This one is not conditioned on (first > 0) in order to preserve the - * string-canonizing effect of [lrange 0 end]. + * Coalesce adjacent removes to reduce the number of copies. */ - Tcl_ListObjReplace(interp, objv[1], 0, first, 0, NULL); - Tcl_SetObjResult(interp, objv[1]); - } + if (num == 0) { + num = 1; + first = idx; + } else if (idx + 1 == first) { + num++; + first = idx; + } else { + /* + * Note that this operation can't fail now; we know we have a list + * and we're only ever contracting that list. + */ + (void) Tcl_ListObjReplace(interp, listObj, first, num, 0, NULL); + listLen -= num; + num = 1; + first = idx; + } + } + if (num != 0) { + (void) Tcl_ListObjReplace(interp, listObj, first, num, 0, NULL); + } + ckfree(idxv); + Tcl_SetObjResult(interp, listObj); return TCL_OK; } @@ -2744,7 +3001,7 @@ Tcl_LreplaceObjCmd( return result; } - if (first < 0) { + if (first == TCL_INDEX_NONE) { first = 0; } if (first > listLen) { @@ -2896,19 +3153,20 @@ Tcl_LsearchObjCmd( { const char *bytes, *patternBytes; int i, match, index, result=TCL_OK, listc, length, elemLen, bisect; - int dataType, isIncreasing, lower, upper, offset; + int allocatedIndexVector = 0; + int dataType, isIncreasing, lower, upper, start, groupSize, groupOffset; Tcl_WideInt patWide, objWide; int allMatches, inlineReturn, negatedMatch, returnSubindices, noCase; double patDouble, objDouble; SortInfo sortInfo; Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr; - SortStrCmpFn_t strCmpFn = strcmp; + SortStrCmpFn_t strCmpFn = TclUtfCmp; Tcl_RegExp regexp = NULL; static const char *const options[] = { "-all", "-ascii", "-bisect", "-decreasing", "-dictionary", "-exact", "-glob", "-increasing", "-index", "-inline", "-integer", "-nocase", "-not", - "-real", "-regexp", "-sorted", "-start", + "-real", "-regexp", "-sorted", "-start", "-stride", "-subindices", NULL }; enum options { @@ -2916,7 +3174,7 @@ Tcl_LsearchObjCmd( LSEARCH_DICTIONARY, LSEARCH_EXACT, LSEARCH_GLOB, LSEARCH_INCREASING, LSEARCH_INDEX, LSEARCH_INLINE, LSEARCH_INTEGER, LSEARCH_NOCASE, LSEARCH_NOT, LSEARCH_REAL, LSEARCH_REGEXP, LSEARCH_SORTED, - LSEARCH_START, LSEARCH_SUBINDICES + LSEARCH_START, LSEARCH_STRIDE, LSEARCH_SUBINDICES }; enum datatypes { ASCII, DICTIONARY, INTEGER, REAL @@ -2936,7 +3194,9 @@ Tcl_LsearchObjCmd( bisect = 0; listPtr = NULL; startPtr = NULL; - offset = 0; + groupSize = 1; + groupOffset = 0; + start = 0; noCase = 0; sortInfo.compareCmdPtr = NULL; sortInfo.isIncreasing = 1; @@ -2954,9 +3214,6 @@ Tcl_LsearchObjCmd( for (i = 1; i < objc-2; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) != TCL_OK) { - if (startPtr != NULL) { - Tcl_DecrRefCount(startPtr); - } result = TCL_ERROR; goto done; } @@ -3021,6 +3278,7 @@ Tcl_LsearchObjCmd( if (startPtr != NULL) { Tcl_DecrRefCount(startPtr); + startPtr = NULL; } if (i > objc-4) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -3041,25 +3299,47 @@ Tcl_LsearchObjCmd( startPtr = Tcl_DuplicateObj(objv[i]); } else { startPtr = objv[i]; - Tcl_IncrRefCount(startPtr); } + Tcl_IncrRefCount(startPtr); + break; + case LSEARCH_STRIDE: /* -stride */ + if (i > objc-4) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "\"-stride\" option must be " + "followed by stride length", -1)); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); + result = TCL_ERROR; + goto done; + } + if (Tcl_GetIntFromObj(interp, objv[i+1], &groupSize) != TCL_OK) { + result = TCL_ERROR; + goto done; + } + if (groupSize < 1) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "stride length must be at least 1", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", + "BADSTRIDE", NULL); + result = TCL_ERROR; + goto done; + } + i++; break; case LSEARCH_INDEX: { /* -index */ Tcl_Obj **indices; int j; - if (sortInfo.indexc > 1) { + if (allocatedIndexVector) { TclStackFree(interp, sortInfo.indexv); + allocatedIndexVector = 0; } if (i > objc-4) { - if (startPtr != NULL) { - Tcl_DecrRefCount(startPtr); - } Tcl_SetObjResult(interp, Tcl_NewStringObj( "\"-index\" option must be followed by list index", -1)); Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL); - return TCL_ERROR; + result = TCL_ERROR; + goto done; } /* @@ -3071,10 +3351,8 @@ Tcl_LsearchObjCmd( i++; if (TclListObjGetElements(interp, objv[i], &sortInfo.indexc, &indices) != TCL_OK) { - if (startPtr != NULL) { - Tcl_DecrRefCount(startPtr); - } - return TCL_ERROR; + result = TCL_ERROR; + goto done; } switch (sortInfo.indexc) { case 0: @@ -3086,6 +3364,8 @@ Tcl_LsearchObjCmd( default: sortInfo.indexv = TclStackAlloc(interp, sizeof(int) * sortInfo.indexc); + allocatedIndexVector = 1; /* Cannot use indexc field, as it + * might be decreased by 1 later. */ } /* @@ -3096,15 +3376,14 @@ Tcl_LsearchObjCmd( for (j=0 ; j<sortInfo.indexc ; j++) { int encoded = 0; - if (TclIndexEncode(interp, indices[j], TCL_INDEX_BEFORE, - TCL_INDEX_AFTER, &encoded) != TCL_OK) { + if (TclIndexEncode(interp, indices[j], TCL_INDEX_NONE, + TCL_INDEX_NONE, &encoded) != TCL_OK) { result = TCL_ERROR; } - if ((encoded == TCL_INDEX_BEFORE) - || (encoded == TCL_INDEX_AFTER)) { + if (encoded == (int)TCL_INDEX_NONE) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "index \"%s\" cannot select an element " - "from any list", Tcl_GetString(indices[j]))); + "from any list", TclGetString(indices[j]))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX" "OUTOFRANGE", NULL); result = TCL_ERROR; @@ -3126,14 +3405,12 @@ Tcl_LsearchObjCmd( */ if (returnSubindices && sortInfo.indexc==0) { - if (startPtr != NULL) { - Tcl_DecrRefCount(startPtr); - } Tcl_SetObjResult(interp, Tcl_NewStringObj( "-subindices cannot be used without -index option", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", "BAD_OPTION_MIX", NULL); - return TCL_ERROR; + result = TCL_ERROR; + goto done; } if (bisect && (allMatches || negatedMatch)) { @@ -3141,7 +3418,8 @@ Tcl_LsearchObjCmd( "-bisect is not compatible with -all or -not", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", "BAD_OPTION_MIX", NULL); - return TCL_ERROR; + result = TCL_ERROR; + goto done; } if (mode == REGEXP) { @@ -3167,9 +3445,6 @@ Tcl_LsearchObjCmd( } if (regexp == NULL) { - if (startPtr != NULL) { - Tcl_DecrRefCount(startPtr); - } result = TCL_ERROR; goto done; } @@ -3182,24 +3457,64 @@ Tcl_LsearchObjCmd( result = TclListObjGetElements(interp, objv[objc - 2], &listc, &listv); if (result != TCL_OK) { - if (startPtr != NULL) { - Tcl_DecrRefCount(startPtr); - } goto done; } /* + * Check for sanity when grouping elements of the overall list together + * because of the -stride option. [TIP #351] + */ + + if (groupSize > 1) { + if (listc % groupSize) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "list size must be a multiple of the stride length", + -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", "BADSTRIDE", + NULL); + result = TCL_ERROR; + goto done; + } + if (sortInfo.indexc > 0) { + /* + * Use the first value in the list supplied to -index as the + * offset of the element within each group by which to sort. + */ + + groupOffset = TclIndexDecode(sortInfo.indexv[0], groupSize - 1); + if (groupOffset < 0 || groupOffset >= groupSize) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "when used with \"-stride\", the leading \"-index\"" + " value must be within the group", -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", + "BADINDEX", NULL); + result = TCL_ERROR; + goto done; + } + if (sortInfo.indexc == 1) { + sortInfo.indexc = 0; + sortInfo.indexv = NULL; + } else { + sortInfo.indexc--; + + for (i = 0; i < sortInfo.indexc; i++) { + sortInfo.indexv[i] = sortInfo.indexv[i+1]; + } + } + } + } + + /* * Get the user-specified start offset. */ if (startPtr) { - result = TclGetIntForIndexM(interp, startPtr, listc-1, &offset); - Tcl_DecrRefCount(startPtr); + result = TclGetIntForIndexM(interp, startPtr, listc-1, &start); if (result != TCL_OK) { goto done; } - if (offset < 0) { - offset = 0; + if (start == TCL_INDEX_NONE) { + start = TCL_INDEX_START; } /* @@ -3207,16 +3522,21 @@ Tcl_LsearchObjCmd( * "did not match anything at all" result straight away. [Bug 1374778] */ - if (offset > listc-1) { - if (sortInfo.indexc > 1) { - TclStackFree(interp, sortInfo.indexv); - } + if (start > listc-1) { if (allMatches || inlineReturn) { Tcl_ResetResult(interp); } else { - Tcl_SetObjResult(interp, Tcl_NewIntObj(-1)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-1)); } - return TCL_OK; + goto done; + } + + /* + * If start points within a group, it points to the start of the group. + */ + + if (groupSize > 1) { + start -= (start % groupSize); } } @@ -3275,18 +3595,23 @@ Tcl_LsearchObjCmd( * sense in doing this when the match sense is inverted. */ - lower = offset - 1; + /* + * With -stride, lower, upper and i are kept as multiples of groupSize. + */ + + lower = start - groupSize; upper = listc; - while (lower + 1 != upper && sortInfo.resultCode == TCL_OK) { + while (lower + groupSize != upper && sortInfo.resultCode == TCL_OK) { i = (lower + upper)/2; + i -= i % groupSize; if (sortInfo.indexc != 0) { - itemPtr = SelectObjFromSublist(listv[i], &sortInfo); + itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo); if (sortInfo.resultCode != TCL_OK) { result = sortInfo.resultCode; goto done; } } else { - itemPtr = listv[i]; + itemPtr = listv[i+groupOffset]; } switch ((enum datatypes) dataType) { case ASCII: @@ -3375,10 +3700,10 @@ Tcl_LsearchObjCmd( if (allMatches) { listPtr = Tcl_NewListObj(0, NULL); } - for (i = offset; i < listc; i++) { + for (i = start; i < listc; i += groupSize) { match = 0; if (sortInfo.indexc != 0) { - itemPtr = SelectObjFromSublist(listv[i], &sortInfo); + itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo); if (sortInfo.resultCode != TCL_OK) { if (listPtr != NULL) { Tcl_DecrRefCount(listPtr); @@ -3387,7 +3712,7 @@ Tcl_LsearchObjCmd( goto done; } } else { - itemPtr = listv[i]; + itemPtr = listv[i+groupOffset]; } switch (mode) { @@ -3477,22 +3802,27 @@ Tcl_LsearchObjCmd( */ if (returnSubindices && (sortInfo.indexc != 0)) { - itemPtr = SelectObjFromSublist(listv[i], &sortInfo); + itemPtr = SelectObjFromSublist(listv[i+groupOffset], + &sortInfo); + Tcl_ListObjAppendElement(interp, listPtr, itemPtr); + } else if (groupSize > 1) { + Tcl_ListObjReplace(interp, listPtr, LIST_MAX, 0, + groupSize, &listv[i]); } else { itemPtr = listv[i]; + Tcl_ListObjAppendElement(interp, listPtr, itemPtr); } - Tcl_ListObjAppendElement(interp, listPtr, itemPtr); } else if (returnSubindices) { int j; - itemPtr = Tcl_NewIntObj(i); + itemPtr = Tcl_NewWideIntObj(i+groupOffset); for (j=0 ; j<sortInfo.indexc ; j++) { - Tcl_ListObjAppendElement(interp, itemPtr, Tcl_NewIntObj( + Tcl_ListObjAppendElement(interp, itemPtr, Tcl_NewWideIntObj( TclIndexDecode(sortInfo.indexv[j], listc))); } Tcl_ListObjAppendElement(interp, listPtr, itemPtr); } else { - Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewIntObj(i)); + Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewWideIntObj(i)); } } } @@ -3507,14 +3837,14 @@ Tcl_LsearchObjCmd( if (returnSubindices) { int j; - itemPtr = Tcl_NewIntObj(index); + itemPtr = Tcl_NewWideIntObj(index+groupOffset); for (j=0 ; j<sortInfo.indexc ; j++) { - Tcl_ListObjAppendElement(interp, itemPtr, Tcl_NewIntObj( + Tcl_ListObjAppendElement(interp, itemPtr, Tcl_NewWideIntObj( TclIndexDecode(sortInfo.indexv[j], listc))); } Tcl_SetObjResult(interp, itemPtr); } else { - Tcl_SetObjResult(interp, Tcl_NewIntObj(index)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(index)); } } else if (index < 0) { /* @@ -3524,7 +3854,14 @@ Tcl_LsearchObjCmd( Tcl_SetObjResult(interp, Tcl_NewObj()); } else { - Tcl_SetObjResult(interp, listv[index]); + if (returnSubindices) { + Tcl_SetObjResult(interp, SelectObjFromSublist(listv[i+groupOffset], + &sortInfo)); + } else if (groupSize > 1) { + Tcl_SetObjResult(interp, Tcl_NewListObj(groupSize, &listv[index])); + } else { + Tcl_SetObjResult(interp, listv[index]); + } } result = TCL_OK; @@ -3533,7 +3870,10 @@ Tcl_LsearchObjCmd( */ done: - if (sortInfo.indexc > 1) { + if (startPtr != NULL) { + Tcl_DecrRefCount(startPtr); + } + if (allocatedIndexVector) { TclStackFree(interp, sortInfo.indexv); } return result; @@ -3755,13 +4095,12 @@ Tcl_LsortObjCmd( for (j=0 ; j<indexc ; j++) { int encoded = 0; int result = TclIndexEncode(interp, indexv[j], - TCL_INDEX_BEFORE, TCL_INDEX_AFTER, &encoded); + TCL_INDEX_NONE, TCL_INDEX_NONE, &encoded); - if ((result == TCL_OK) && ((encoded == TCL_INDEX_BEFORE) - || (encoded == TCL_INDEX_AFTER))) { + if ((result == TCL_OK) && (encoded == (int)TCL_INDEX_NONE)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "index \"%s\" cannot select an element " - "from any list", Tcl_GetString(indexv[j]))); + "from any list", TclGetString(indexv[j]))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX" "OUTOFRANGE", NULL); result = TCL_ERROR; @@ -3847,7 +4186,8 @@ Tcl_LsortObjCmd( } for (j=0 ; j<sortInfo.indexc ; j++) { /* Prescreened values, no errors or out of range possible */ - TclIndexEncode(NULL, indexv[j], 0, 0, &sortInfo.indexv[j]); + TclIndexEncode(NULL, indexv[j], TCL_INDEX_NONE, + TCL_INDEX_NONE, &sortInfo.indexv[j]); } } @@ -3979,7 +4319,7 @@ Tcl_LsortObjCmd( elementArray = ckalloc(length * sizeof(SortElement)); - for (i=0; i < length; i++){ + for (i=0; i < length; i++) { idx = groupSize * i + groupOffset; if (indexc) { /* @@ -4073,7 +4413,7 @@ Tcl_LsortObjCmd( idx = elementPtr->payload.index; for (j = 0; j < groupSize; j++) { if (indices) { - objPtr = Tcl_NewIntObj(idx + j - groupOffset); + objPtr = Tcl_NewWideIntObj(idx + j - groupOffset); newArray[i++] = objPtr; Tcl_IncrRefCount(objPtr); } else { @@ -4085,7 +4425,7 @@ Tcl_LsortObjCmd( } } else if (indices) { for (i=0; elementPtr != NULL ; elementPtr = elementPtr->nextPtr) { - objPtr = Tcl_NewIntObj(elementPtr->payload.index); + objPtr = Tcl_NewWideIntObj(elementPtr->payload.index); newArray[i++] = objPtr; Tcl_IncrRefCount(objPtr); } @@ -4245,7 +4585,7 @@ SortCompare( int order = 0; if (infoPtr->sortMode == SORTMODE_ASCII) { - order = strcmp(elemPtr1->collationKey.strValuePtr, + order = TclUtfCmp(elemPtr1->collationKey.strValuePtr, elemPtr2->collationKey.strValuePtr); } else if (infoPtr->sortMode == SORTMODE_ASCII_NC) { order = TclUtfCasecmp(elemPtr1->collationKey.strValuePtr, @@ -4517,9 +4857,16 @@ SelectObjFromSublist( return NULL; } if (currentObj == NULL) { - Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf( - "element %d missing from sublist \"%s\"", - index, TclGetString(objPtr))); + if (index == (int)TCL_INDEX_NONE) { + index = TCL_INDEX_END - infoPtr->indexv[i]; + Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf( + "element end-%d missing from sublist \"%s\"", + index, TclGetString(objPtr))); + } else { + Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf( + "element %d missing from sublist \"%s\"", + index, TclGetString(objPtr))); + } Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT", "INDEXFAILED", NULL); infoPtr->resultCode = TCL_ERROR; diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index ae10e74..a754a09 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -259,7 +259,7 @@ Tcl_RegexpObjCmd( stringLength = Tcl_GetCharLength(objPtr); if (startIndex) { - TclGetIntForIndexM(NULL, startIndex, stringLength, &offset); + TclGetIntForIndexM(interp, startIndex, stringLength, &offset); Tcl_DecrRefCount(startIndex); if (offset < 0) { offset = 0; @@ -324,7 +324,7 @@ Tcl_RegexpObjCmd( if (match == 0) { /* - * We want to set the value of the intepreter result only when + * We want to set the value of the interpreter result only when * this is the first time through the loop. */ @@ -336,7 +336,7 @@ Tcl_RegexpObjCmd( */ if (!doinline) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0)); } return TCL_OK; } @@ -389,8 +389,8 @@ Tcl_RegexpObjCmd( end = -1; } - objs[0] = Tcl_NewLongObj(start); - objs[1] = Tcl_NewLongObj(end); + objs[0] = Tcl_NewWideIntObj(start); + objs[1] = Tcl_NewWideIntObj(end); newPtr = Tcl_NewListObj(2, objs); } else { @@ -458,7 +458,7 @@ Tcl_RegexpObjCmd( if (doinline) { Tcl_SetObjResult(interp, resultPtr); } else { - Tcl_SetObjResult(interp, Tcl_NewIntObj(all ? all-1 : 1)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(all ? all-1 : 1)); } return TCL_OK; } @@ -488,26 +488,27 @@ Tcl_RegsubObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { int idx, result, cflags, all, wlen, wsublen, numMatches, offset; - int start, end, subStart, subEnd, match; + int start, end, subStart, subEnd, match, command, numParts; Tcl_RegExp regExpr; Tcl_RegExpInfo info; Tcl_Obj *resultPtr, *subPtr, *objPtr, *startIndex = NULL; - Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec, *wend; + Tcl_UniChar ch, *wsrc, *wfirstChar, *wstring, *wsubspec = 0, *wend; static const char *const options[] = { - "-all", "-nocase", "-expanded", - "-line", "-linestop", "-lineanchor", "-start", + "-all", "-command", "-expanded", "-line", + "-linestop", "-lineanchor", "-nocase", "-start", "--", NULL }; enum options { - REGSUB_ALL, REGSUB_NOCASE, REGSUB_EXPANDED, - REGSUB_LINE, REGSUB_LINESTOP, REGSUB_LINEANCHOR, REGSUB_START, + REGSUB_ALL, REGSUB_COMMAND, REGSUB_EXPANDED, REGSUB_LINE, + REGSUB_LINESTOP, REGSUB_LINEANCHOR, REGSUB_NOCASE, REGSUB_START, REGSUB_LAST }; cflags = TCL_REG_ADVANCED; all = 0; offset = 0; + command = 0; resultPtr = NULL; for (idx = 1; idx < objc; idx++) { @@ -529,6 +530,9 @@ Tcl_RegsubObjCmd( case REGSUB_NOCASE: cflags |= TCL_REG_NOCASE; break; + case REGSUB_COMMAND: + command = 1; + break; case REGSUB_EXPANDED: cflags |= TCL_REG_EXPANDED; break; @@ -579,14 +583,14 @@ Tcl_RegsubObjCmd( if (startIndex) { int stringLength = Tcl_GetCharLength(objv[1]); - TclGetIntForIndexM(NULL, startIndex, stringLength, &offset); + TclGetIntForIndexM(interp, startIndex, stringLength, &offset); Tcl_DecrRefCount(startIndex); if (offset < 0) { offset = 0; } } - if (all && (offset == 0) + if (all && (offset == 0) && (command == 0) && (strpbrk(TclGetString(objv[2]), "&\\") == NULL) && (strpbrk(TclGetString(objv[0]), "*+?{}()[].\\|^$") == NULL)) { /* @@ -594,9 +598,9 @@ Tcl_RegsubObjCmd( * slightly modified version of the one pair STR_MAP code. */ - int slen, nocase; + int slen, nocase, wsrclc; int (*strCmpFn)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long); - Tcl_UniChar *p, wsrclc; + Tcl_UniChar *p; numMatches = 0; nocase = (cflags & TCL_REG_NOCASE); @@ -662,6 +666,28 @@ Tcl_RegsubObjCmd( return TCL_ERROR; } + if (command) { + /* + * In command-prefix mode, we require that the third non-option + * argument be a list, so we enforce that here. Afterwards, we fetch + * the RE compilation again in case objv[0] and objv[2] are the same + * object. (If they aren't, that's cheap to do.) + */ + + if (Tcl_ListObjLength(interp, objv[2], &numParts) != TCL_OK) { + return TCL_ERROR; + } + if (numParts < 1) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "command prefix must be a list of at least one element", + -1)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "REGSUB", + "CMDEMPTY", NULL); + return TCL_ERROR; + } + regExpr = Tcl_GetRegExpFromObj(interp, objv[0], cflags); + } + /* * Make sure to avoid problems where the objects are shared. This can * cause RegExpObj <> UnicodeObj shimmering that causes data corruption. @@ -679,7 +705,9 @@ Tcl_RegsubObjCmd( } else { subPtr = objv[2]; } - wsubspec = Tcl_GetUnicodeFromObj(subPtr, &wsublen); + if (!command) { + wsubspec = Tcl_GetUnicodeFromObj(subPtr, &wsublen); + } result = TCL_OK; @@ -738,6 +766,90 @@ Tcl_RegsubObjCmd( Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, start); /* + * In command-prefix mode, the substitutions are added as quoted + * arguments to the subSpec to form a command, that is then executed + * and the result used as the string to substitute in. Actually, + * everything is passed through Tcl_EvalObjv, as that's much faster. + */ + + if (command) { + Tcl_Obj **args = NULL, **parts; + int numArgs; + + Tcl_ListObjGetElements(interp, subPtr, &numParts, &parts); + numArgs = numParts + info.nsubs + 1; + args = ckalloc(sizeof(Tcl_Obj*) * numArgs); + memcpy(args, parts, sizeof(Tcl_Obj*) * numParts); + + for (idx = 0 ; idx <= info.nsubs ; idx++) { + subStart = info.matches[idx].start; + subEnd = info.matches[idx].end; + if ((subStart >= 0) && (subEnd >= 0)) { + args[idx + numParts] = Tcl_NewUnicodeObj( + wstring + offset + subStart, subEnd - subStart); + } else { + args[idx + numParts] = Tcl_NewObj(); + } + Tcl_IncrRefCount(args[idx + numParts]); + } + + /* + * At this point, we're locally holding the references to the + * argument words we added for this time round the loop, and the + * subPtr is holding the references to the words that the user + * supplied directly. None are zero-refcount, which is important + * because Tcl_EvalObjv is "hairy monster" in terms of refcount + * handling, being able to optionally add references to any of its + * argument words. We'll drop the local refs immediately + * afterwards; subPtr is handled in the main exit stanza. + */ + + result = Tcl_EvalObjv(interp, numArgs, args, 0); + for (idx = 0 ; idx <= info.nsubs ; idx++) { + TclDecrRefCount(args[idx + numParts]); + } + ckfree(args); + if (result != TCL_OK) { + if (result == TCL_ERROR) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (%s substitution computation script)", + options[REGSUB_COMMAND])); + } + goto done; + } + + Tcl_AppendObjToObj(resultPtr, Tcl_GetObjResult(interp)); + Tcl_ResetResult(interp); + + /* + * Refetch the unicode, in case the representation was smashed by + * the user code. + */ + + wstring = Tcl_GetUnicodeFromObj(objPtr, &wlen); + + offset += end; + if (end == 0 || start == end) { + /* + * Always consume at least one character of the input string + * in order to prevent infinite loops, even when we + * technically matched the empty string; we must not match + * again at the same spot. + */ + + if (offset < wlen) { + Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); + } + offset++; + } + if (all) { + continue; + } else { + break; + } + } + + /* * Append the subSpec argument to the variable, making appropriate * substitutions. This code is a bit hairy because of the backslash * conventions and because the code saves up ranges of characters in @@ -848,7 +960,7 @@ Tcl_RegsubObjCmd( * holding the number of matches. */ - Tcl_SetObjResult(interp, Tcl_NewIntObj(numMatches)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(numMatches)); } } else { /* @@ -990,8 +1102,11 @@ TclNRSourceObjCmd( { const char *encodingName = NULL; Tcl_Obj *fileName; + int result; + void **pkgFiles = NULL; + void *names = NULL; - if (objc != 2 && objc !=4) { + if (objc < 2 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "?-encoding name? fileName"); return TCL_ERROR; } @@ -1009,9 +1124,30 @@ TclNRSourceObjCmd( return TCL_ERROR; } encodingName = TclGetString(objv[2]); - } + } else if (objc == 3) { + /* Handle undocumented -nopkg option. This should only be + * used by the internal ::tcl::Pkg::source utility function. */ + static const char *const nopkgoptions[] = { + "-nopkg", NULL + }; + int index; - return TclNREvalFile(interp, fileName, encodingName); + if (TCL_ERROR == Tcl_GetIndexFromObj(interp, objv[1], nopkgoptions, + "option", TCL_EXACT, &index)) { + return TCL_ERROR; + } + pkgFiles = Tcl_GetAssocData(interp, "tclPkgFiles", NULL); + /* Make sure that during the following TclNREvalFile no filenames + * are recorded for inclusion in the "package files" command */ + names = *pkgFiles; + *pkgFiles = NULL; + } + result = TclNREvalFile(interp, fileName, encodingName); + if (pkgFiles) { + /* restore "tclPkgFiles" assocdata to how it was. */ + *pkgFiles = names; + } + return result; } /* @@ -1085,7 +1221,7 @@ Tcl_SplitObjCmd( len = TclUtfToUniChar(stringPtr, &ch); fullchar = ch; -#if TCL_UTF_MAX == 4 +#if TCL_UTF_MAX <= 4 if ((ch >= 0xD800) && (len < 3)) { len += TclUtfToUniChar(stringPtr + len, &ch); fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; @@ -1186,8 +1322,7 @@ StringFirstCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_UniChar *needleStr, *haystackStr; - int match, start, needleLen, haystackLen; + int start = 0; if (objc < 3 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, @@ -1195,82 +1330,15 @@ StringFirstCmd( return TCL_ERROR; } - /* - * We are searching haystackStr for the sequence needleStr. - */ - - match = -1; - start = 0; - haystackLen = -1; - - needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen); - haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen); - if (objc == 4) { - /* - * If a startIndex is specified, we will need to fast forward to that - * point in the string before we think about a match. - */ + int size = Tcl_GetCharLength(objv[2]); - if (TclGetIntForIndexM(interp, objv[3], haystackLen-1, - &start) != TCL_OK){ + if (TCL_OK != TclGetIntForIndexM(interp, objv[3], size - 1, &start)) { return TCL_ERROR; } - - /* - * Reread to prevent shimmering problems. - */ - - needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen); - haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen); - - if (start >= haystackLen) { - goto str_first_done; - } else if (start > 0) { - haystackStr += start; - haystackLen -= start; - } else if (start < 0) { - /* - * Invalid start index mapped to string start; Bug #423581 - */ - - start = 0; - } - } - - /* - * If the length of the needle is more than the length of the haystack, it - * cannot be contained in there so we can avoid searching. [Bug 2960021] - */ - - if (needleLen > 0 && needleLen <= haystackLen) { - register Tcl_UniChar *p, *end; - - end = haystackStr + haystackLen - needleLen + 1; - for (p = haystackStr; p < end; p++) { - /* - * Scan forward to find the first character. - */ - - if ((*p == *needleStr) && (TclUniCharNcmp(needleStr, p, - (unsigned long) needleLen) == 0)) { - match = p - haystackStr; - break; - } - } - } - - /* - * Compute the character index of the matching string by counting the - * number of characters before the match. - */ - - if ((match != -1) && (objc == 4)) { - match += start; } - - str_first_done: - Tcl_SetObjResult(interp, Tcl_NewIntObj(match)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(TclStringFirst(objv[1], + objv[2], start))); return TCL_OK; } @@ -1299,76 +1367,23 @@ StringLastCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_UniChar *needleStr, *haystackStr, *p; - int match, start, needleLen, haystackLen; + int last = INT_MAX - 1; if (objc < 3 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, - "needleString haystackString ?startIndex?"); + "needleString haystackString ?lastIndex?"); return TCL_ERROR; } - /* - * We are searching haystackString for the sequence needleString. - */ - - match = -1; - start = 0; - haystackLen = -1; - - needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen); - haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen); - if (objc == 4) { - /* - * If a startIndex is specified, we will need to restrict the string - * range to that char index in the string - */ + int size = Tcl_GetCharLength(objv[2]); - if (TclGetIntForIndexM(interp, objv[3], haystackLen-1, - &start) != TCL_OK){ + if (TCL_OK != TclGetIntForIndexM(interp, objv[3], size - 1, &last)) { return TCL_ERROR; } - - /* - * Reread to prevent shimmering problems. - */ - - needleStr = Tcl_GetUnicodeFromObj(objv[1], &needleLen); - haystackStr = Tcl_GetUnicodeFromObj(objv[2], &haystackLen); - - if (start < 0) { - goto str_last_done; - } else if (start < haystackLen) { - p = haystackStr + start + 1 - needleLen; - } else { - p = haystackStr + haystackLen - needleLen; - } - } 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; - } - } - } - - str_last_done: - Tcl_SetObjResult(interp, Tcl_NewIntObj(match)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(TclStringLast(objv[1], + objv[2], last))); return TCL_OK; } @@ -1405,7 +1420,7 @@ StringIndexCmd( } /* - * Get the char length to calulate what 'end' means. + * Get the char length to calculate what 'end' means. */ length = Tcl_GetCharLength(objv[1]); @@ -1414,7 +1429,11 @@ StringIndexCmd( } if ((index >= 0) && (index < length)) { - Tcl_UniChar ch = Tcl_GetUniChar(objv[1], index); + int ch = Tcl_GetUniChar(objv[1], index); + + if (ch == -1) { + return TCL_OK; + } /* * If we have a ByteArray object, we're careful to generate a new @@ -1426,14 +1445,12 @@ StringIndexCmd( Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(&uch, 1)); } else { - char buf[TCL_UTF_MAX] = ""; + char buf[4] = ""; length = Tcl_UniCharToUtf(ch, buf); -#if TCL_UTF_MAX > 3 if ((ch >= 0xD800) && (length < 3)) { length += Tcl_UniCharToUtf(-1, buf + length); } -#endif Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, length)); } } @@ -1443,6 +1460,63 @@ StringIndexCmd( /* *---------------------------------------------------------------------- * + * StringInsertCmd -- + * + * This procedure is invoked to process the "string insert" Tcl command. + * See the user documentation for details on what it does. Note that this + * command only functions correctly on properly formed Tcl UTF strings. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +StringInsertCmd( + ClientData dummy, /* Not used */ + Tcl_Interp *interp, /* Current interpreter */ + int objc, /* Number of arguments */ + Tcl_Obj *const objv[]) /* Argument objects */ +{ + int length; /* String length */ + int index; /* Insert index */ + Tcl_Obj *outObj; /* Output object */ + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "string index insertString"); + return TCL_ERROR; + } + + length = Tcl_GetCharLength(objv[1]); + if (TclGetIntForIndexM(interp, objv[2], length, &index) != TCL_OK) { + return TCL_ERROR; + } + + if (index < 0) { + index = 0; + } + if (index > length) { + index = length; + } + + outObj = TclStringReplace(interp, objv[1], index, 0, objv[3], + TCL_STRING_IN_PLACE); + + if (outObj != NULL) { + Tcl_SetObjResult(interp, outObj); + return TCL_OK; + } + + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * * StringIsCmd -- * * This procedure is invoked to process the "string is" Tcl command. See @@ -1474,19 +1548,19 @@ StringIsCmd( static const char *const isClasses[] = { "alnum", "alpha", "ascii", "control", - "boolean", "digit", "double", "entier", - "false", "graph", "integer", "list", - "lower", "print", "punct", "space", - "true", "upper", "wideinteger", "wordchar", - "xdigit", NULL + "boolean", "dict", "digit", "double", + "entier", "false", "graph", "integer", + "list", "lower", "print", "punct", + "space", "true", "upper", "wideinteger", + "wordchar", "xdigit", NULL }; enum isClasses { STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL, - STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_ENTIER, - STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT, STR_IS_LIST, - STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE, - STR_IS_TRUE, STR_IS_UPPER, STR_IS_WIDE, STR_IS_WORD, - STR_IS_XDIGIT + STR_IS_BOOL, STR_IS_DICT, STR_IS_DIGIT, STR_IS_DOUBLE, + STR_IS_ENTIER, STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT, + STR_IS_LIST, STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT, + STR_IS_SPACE, STR_IS_TRUE, STR_IS_UPPER, STR_IS_WIDE, + STR_IS_WORD, STR_IS_XDIGIT }; static const char *const isOptions[] = { "-strict", "-failindex", NULL @@ -1555,7 +1629,7 @@ StringIsCmd( case STR_IS_BOOL: case STR_IS_TRUE: case STR_IS_FALSE: - if ((objPtr->typePtr != &tclBooleanType) + if (!TclHasIntRep(objPtr, &tclBooleanType) && (TCL_OK != TclSetBooleanFromAny(NULL, objPtr))) { if (strict) { result = 0; @@ -1563,26 +1637,71 @@ StringIsCmd( string1 = TclGetStringFromObj(objPtr, &length1); result = length1 == 0; } - } else if (((index == STR_IS_TRUE) && - objPtr->internalRep.longValue == 0) - || ((index == STR_IS_FALSE) && - objPtr->internalRep.longValue != 0)) { - result = 0; + } else if (index != STR_IS_BOOL) { + TclGetBooleanFromObj(NULL, objPtr, &i); + if ((index == STR_IS_TRUE) ^ i) { + result = 0; + } } break; case STR_IS_CONTROL: chcomp = Tcl_UniCharIsControl; break; + case STR_IS_DICT: { + int dresult, dsize; + + dresult = Tcl_DictObjSize(interp, objPtr, &dsize); + Tcl_ResetResult(interp); + result = (dresult == TCL_OK) ? 1 : 0; + if (dresult != TCL_OK && failVarObj != NULL) { + /* + * Need to figure out where the list parsing failed, which is + * fairly expensive. This is adapted from the core of + * SetDictFromAny(). + */ + + const char *elemStart, *nextElem; + int lenRemain, elemSize; + register const char *p; + + string1 = TclGetStringFromObj(objPtr, &length1); + end = string1 + length1; + failat = -1; + for (p=string1, lenRemain=length1; lenRemain > 0; + p=nextElem, lenRemain=end-nextElem) { + if (TCL_ERROR == TclFindElement(NULL, p, lenRemain, + &elemStart, &nextElem, &elemSize, NULL)) { + Tcl_Obj *tmpStr; + + /* + * This is the simplest way of getting the number of + * characters parsed. Note that this is not the same as + * the number of bytes when parsing strings with non-ASCII + * characters in them. + * + * Skip leading spaces first. This is only really an issue + * if it is the first "element" that has the failure. + */ + + while (TclIsSpaceProc(*p)) { + p++; + } + TclNewStringObj(tmpStr, string1, p-string1); + failat = Tcl_GetCharLength(tmpStr); + TclDecrRefCount(tmpStr); + break; + } + } + } + break; + } case STR_IS_DIGIT: chcomp = Tcl_UniCharIsDigit; break; case STR_IS_DOUBLE: { - if ((objPtr->typePtr == &tclDoubleType) || - (objPtr->typePtr == &tclIntType) || -#ifndef TCL_WIDE_INT_IS_LONG - (objPtr->typePtr == &tclWideIntType) || -#endif - (objPtr->typePtr == &tclBignumType)) { + if (TclHasIntRep(objPtr, &tclDoubleType) || + TclHasIntRep(objPtr, &tclIntType) || + TclHasIntRep(objPtr, &tclBignumType)) { break; } string1 = TclGetStringFromObj(objPtr, &length1); @@ -1610,16 +1729,9 @@ StringIsCmd( chcomp = Tcl_UniCharIsGraph; break; case STR_IS_INT: - if (TCL_OK == TclGetIntFromObj(NULL, objPtr, &i)) { - break; - } - goto failedIntParse; case STR_IS_ENTIER: - if ((objPtr->typePtr == &tclIntType) || -#ifndef TCL_WIDE_INT_IS_LONG - (objPtr->typePtr == &tclWideIntType) || -#endif - (objPtr->typePtr == &tclBignumType)) { + if (TclHasIntRep(objPtr, &tclIntType) || + TclHasIntRep(objPtr, &tclBignumType)) { break; } string1 = TclGetStringFromObj(objPtr, &length1); @@ -1664,7 +1776,6 @@ StringIsCmd( break; } - failedIntParse: string1 = TclGetStringFromObj(objPtr, &length1); if (length1 == 0) { if (strict) { @@ -1800,7 +1911,7 @@ StringIsCmd( int fullchar; length2 = TclUtfToUniChar(string1, &ch); fullchar = ch; -#if TCL_UTF_MAX == 4 +#if TCL_UTF_MAX <= 4 if ((ch >= 0xD800) && (length2 < 3)) { length2 += TclUtfToUniChar(string1 + length2, &ch); fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; @@ -1820,7 +1931,7 @@ StringIsCmd( str_is_done: if ((result == 0) && (failVarObj != NULL) && - Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewIntObj(failat), + Tcl_ObjSetVar2(interp, failVarObj, NULL, Tcl_NewWideIntObj(failat), TCL_LEAVE_ERR_MSG) == NULL) { return TCL_ERROR; } @@ -1839,7 +1950,7 @@ static int UniCharIsHexDigit( int character) { - return (character >= 0) && (character < 0x80) && isxdigit(character); + return (character >= 0) && (character < 0x80) && isxdigit(UCHAR(character)); } /* @@ -1895,10 +2006,11 @@ StringMapCmd( /* * This test is tricky, but has to be that way or you get other strange - * inconsistencies (see test string-10.20 for illustration why!) + * inconsistencies (see test string-10.20.1 for illustration why!) */ - if (objv[objc-2]->typePtr == &tclDictType && objv[objc-2]->bytes == NULL){ + if (!TclHasStringRep(objv[objc-2]) + && TclHasIntRep(objv[objc-2], &tclDictType)) { int i, done; Tcl_DictSearch search; @@ -1994,8 +2106,8 @@ StringMapCmd( * larger strings. */ - int mapLen; - Tcl_UniChar *mapString, u2lc; + int mapLen, u2lc; + Tcl_UniChar *mapString; ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2); p = ustring1; @@ -2026,8 +2138,8 @@ StringMapCmd( } } } else { - Tcl_UniChar **mapStrings, *u2lc = NULL; - int *mapLens; + Tcl_UniChar **mapStrings; + int *mapLens, *u2lc = NULL; /* * Precompute pointers to the unicode string and length. This saves us @@ -2039,7 +2151,7 @@ StringMapCmd( mapStrings = TclStackAlloc(interp, mapElemc*2*sizeof(Tcl_UniChar *)); mapLens = TclStackAlloc(interp, mapElemc * 2 * sizeof(int)); if (nocase) { - u2lc = TclStackAlloc(interp, mapElemc * sizeof(Tcl_UniChar)); + u2lc = TclStackAlloc(interp, mapElemc * sizeof(int)); } for (index = 0; index < mapElemc; index++) { mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index], @@ -2060,7 +2172,7 @@ StringMapCmd( (Tcl_UniCharToLower(*ustring1) == u2lc[index/2]))) && /* Restrict max compare length. */ (end-ustring1 >= length2) && ((length2 == 1) || - !strCmpFn(ustring2, ustring1, (unsigned) length2))) { + !strCmpFn(ustring2, ustring1, length2))) { if (p != ustring1) { /* * Put the skipped chars onto the result first. @@ -2245,9 +2357,7 @@ StringReptCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - const char *string1; - char *string2; - int count, index, length1, length2; + int count; Tcl_Obj *resultPtr; if (objc != 3) { @@ -2265,71 +2375,17 @@ StringReptCmd( if (count == 1) { Tcl_SetObjResult(interp, objv[1]); - goto done; + return TCL_OK; } else if (count < 1) { - goto done; - } - string1 = TclGetStringFromObj(objv[1], &length1); - if (length1 <= 0) { - goto done; - } - - /* - * Only build up a string that has data. Instead of building it up with - * repeated appends, we just allocate the necessary space once and copy - * the string value in. - * - * We have to worry about overflow [Bugs 714106, 2561746]. - * At this point we know 1 <= length1 <= INT_MAX and 2 <= count <= INT_MAX. - * We need to keep 2 <= length2 <= INT_MAX. - */ - - if (count > INT_MAX/length1) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "result exceeds max size for a Tcl value (%d bytes)", - INT_MAX)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); - return TCL_ERROR; + return TCL_OK; } - length2 = length1 * count; - /* - * Include space for the NUL. - */ - - string2 = attemptckalloc((unsigned) length2 + 1); - if (string2 == NULL) { - /* - * Alloc failed. Note that in this case we try to do an error message - * since this is a case that's most likely when the alloc is large and - * that's easy to do with this API. Note that if we fail allocating a - * short string, this will likely keel over too (and fatally). - */ - - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "string size overflow, out of memory allocating %u bytes", - length2 + 1)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); - return TCL_ERROR; - } - for (index = 0; index < count; index++) { - memcpy(string2 + (length1 * index), string1, (size_t) length1); + resultPtr = TclStringRepeat(interp, objv[1], count, TCL_STRING_IN_PLACE); + if (resultPtr) { + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; } - 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; + return TCL_ERROR; } /* @@ -2357,7 +2413,6 @@ StringRplcCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_UniChar *ustring; int first, last, length, end; if (objc < 4 || objc > 5) { @@ -2365,19 +2420,20 @@ StringRplcCmd( return TCL_ERROR; } - ustring = Tcl_GetUnicodeFromObj(objv[1], &length); + length = Tcl_GetCharLength(objv[1]); end = length - 1; if (TclGetIntForIndexM(interp, objv[2], end, &first) != TCL_OK || - TclGetIntForIndexM(interp, objv[3], end, &last) != TCL_OK){ + TclGetIntForIndexM(interp, objv[3], end, &last) != TCL_OK) { return TCL_ERROR; } /* - * The following test screens out most empty substrings as - * candidates for replacement. When they are detected, no - * replacement is done, and the result is the original string, + * The following test screens out most empty substrings as candidates for + * replacement. When they are detected, no replacement is done, and the + * result is the original string. */ + if ((last < 0) || /* Range ends before start of string */ (first > end) || /* Range begins after end of string */ (last < first)) { /* Range begins after it starts */ @@ -2387,30 +2443,22 @@ StringRplcCmd( * have (first <= end < 0 <= last) and an empty string is permitted * to be replaced. */ + Tcl_SetObjResult(interp, objv[1]); } else { Tcl_Obj *resultPtr; - /* - * We are re-fetching in case the string argument is same value as - * an index argument, and shimmering cost us our ustring. - */ - - ustring = Tcl_GetUnicodeFromObj(objv[1], &length); - end = length-1; - if (first < 0) { first = 0; } - - resultPtr = Tcl_NewUnicodeObj(ustring, first); - if (objc == 5) { - Tcl_AppendObjToObj(resultPtr, objv[4]); - } - if (last < end) { - Tcl_AppendUnicodeToObj(resultPtr, ustring + last + 1, - end - last); + if (last > end) { + last = end; } + + resultPtr = TclStringReplace(interp, objv[1], first, + last + 1 - first, (objc == 5) ? objv[4] : NULL, + TCL_STRING_IN_PLACE); + Tcl_SetObjResult(interp, resultPtr); } return TCL_OK; @@ -2446,7 +2494,7 @@ StringRevCmd( return TCL_ERROR; } - Tcl_SetObjResult(interp, TclStringObjReverse(objv[1])); + Tcl_SetObjResult(interp, TclStringReverse(objv[1], TCL_STRING_IN_PLACE)); return TCL_OK; } @@ -2508,7 +2556,7 @@ StringStartCmd( cur += 1; } } - Tcl_SetObjResult(interp, Tcl_NewIntObj(cur)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(cur)); return TCL_OK; } @@ -2570,7 +2618,7 @@ StringEndCmd( } else { cur = numChars; } - Tcl_SetObjResult(interp, Tcl_NewIntObj(cur)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(cur)); return TCL_OK; } @@ -2606,7 +2654,7 @@ StringEqualCmd( */ const char *string2; - int length2, i, match, nocase = 0, reqlength = -1; + int length, i, match, nocase = 0, reqlength = -1; if (objc < 3 || objc > 6) { str_cmp_args: @@ -2616,11 +2664,11 @@ StringEqualCmd( } for (i = 1; i < objc-2; i++) { - string2 = TclGetStringFromObj(objv[i], &length2); - if ((length2 > 1) && !strncmp(string2, "-nocase", length2)) { + string2 = TclGetStringFromObj(objv[i], &length); + if ((length > 1) && !strncmp(string2, "-nocase", length)) { nocase = 1; - } else if ((length2 > 1) - && !strncmp(string2, "-length", length2)) { + } else if ((length > 1) + && !strncmp(string2, "-length", length)) { if (i+1 >= objc-2) { goto str_cmp_args; } @@ -2689,191 +2737,12 @@ StringCmpCmd( objv += objc-2; match = TclStringCmp(objv[0], objv[1], 0, nocase, reqlength); - Tcl_SetObjResult(interp, Tcl_NewIntObj(match)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(match)); return TCL_OK; } -/* - *---------------------------------------------------------------------- - * - * TclStringCmp -- - * - * This is the core of Tcl's string comparison. It only handles byte - * arrays, UNICODE strings and UTF-8 strings correctly. - * - * Results: - * -1 if value1Ptr is less than value2Ptr, 0 if they are equal, or 1 if - * value1Ptr is greater. - * - * Side effects: - * May cause string representations of objects to be allocated. - * - *---------------------------------------------------------------------- - */ - int -TclStringCmp( - Tcl_Obj *value1Ptr, - Tcl_Obj *value2Ptr, - int checkEq, /* comparison is only for equality */ - int nocase, /* comparison is not case sensitive */ - int reqlength) /* requested length; -1 to compare whole - * strings */ -{ - const char *s1, *s2; - int empty, length, match, s1len, s2len; - memCmpFn_t memCmpFn; - - if ((reqlength == 0) || (value1Ptr == value2Ptr)) { - /* - * Always match at 0 chars or if it is the same obj. - */ - return 0; - } - - if (!nocase && TclIsPureByteArray(value1Ptr) - && TclIsPureByteArray(value2Ptr)) { - /* - * Use binary versions of comparisons since that won't cause undue - * type conversions and it is much faster. Only do this if we're - * case-sensitive (which is all that really makes sense with byte - * arrays anyway, and we have no memcasecmp() for some reason... :^) - */ - - s1 = (char *) Tcl_GetByteArrayFromObj(value1Ptr, &s1len); - s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len); - memCmpFn = memcmp; - } else if ((value1Ptr->typePtr == &tclStringType) - && (value2Ptr->typePtr == &tclStringType)) { - /* - * Do a unicode-specific comparison if both of the args are of String - * type. If the char length == byte length, we can do a memcmp. In - * benchmark testing this proved the most efficient check between the - * unicode and string comparison operations. - */ - - if (nocase) { - s1 = (char *) Tcl_GetUnicodeFromObj(value1Ptr, &s1len); - s2 = (char *) Tcl_GetUnicodeFromObj(value2Ptr, &s2len); - memCmpFn = (memCmpFn_t)Tcl_UniCharNcasecmp; - } else { - s1len = Tcl_GetCharLength(value1Ptr); - s2len = Tcl_GetCharLength(value2Ptr); - if ((s1len == value1Ptr->length) - && (value1Ptr->bytes != NULL) - && (s2len == value2Ptr->length) - && (value2Ptr->bytes != NULL)) { - s1 = value1Ptr->bytes; - s2 = value2Ptr->bytes; - memCmpFn = memcmp; - } else { - s1 = (char *) Tcl_GetUnicode(value1Ptr); - s2 = (char *) Tcl_GetUnicode(value2Ptr); - if ( -#ifdef WORDS_BIGENDIAN - 1 -#else - checkEq -#endif /* WORDS_BIGENDIAN */ - ) { - memCmpFn = memcmp; - s1len *= sizeof(Tcl_UniChar); - s2len *= sizeof(Tcl_UniChar); - } else { - memCmpFn = (memCmpFn_t) Tcl_UniCharNcmp; - } - } - } - } else { - /* - * Get the string representations, being careful in case we have - * special empty string objects about. - */ - - empty = TclCheckEmptyString(value1Ptr); - if (empty > 0) { - switch (TclCheckEmptyString(value2Ptr)) { - case -1: - s1 = ""; - s1len = 0; - s2 = TclGetStringFromObj(value2Ptr, &s2len); - break; - case 0: - return -1; - default: /* avoid warn: `s2` may be used uninitialized */ - return 0; - } - } else if (TclCheckEmptyString(value2Ptr) > 0) { - switch (empty) { - case -1: - s2 = ""; - s2len = 0; - s1 = TclGetStringFromObj(value1Ptr, &s1len); - break; - case 0: - return 1; - default: /* avoid warn: `s1` may be used uninitialized */ - return 0; - } - } else { - s1 = TclGetStringFromObj(value1Ptr, &s1len); - s2 = TclGetStringFromObj(value2Ptr, &s2len); - } - - if (!nocase && checkEq) { - /* - * When we have equal-length we can check only for (in)equality. - * We can use memcmp() in all (n)eq cases because we don't need to - * worry about lexical LE/BE variance. - */ - memCmpFn = memcmp; - } else { - /* - * As a catch-all we will work with UTF-8. We cannot use memcmp() - * as that is unsafe with any string containing NUL (\xC0\x80 in - * Tcl's utf rep). We can use the more efficient TclpUtfNcmp2 if - * we are case-sensitive and no specific length was requested. - */ - - if ((reqlength < 0) && !nocase) { - memCmpFn = (memCmpFn_t) TclpUtfNcmp2; - } else { - s1len = Tcl_NumUtfChars(s1, s1len); - s2len = Tcl_NumUtfChars(s2, s2len); - memCmpFn = (memCmpFn_t) - (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp); - } - } - } - - length = (s1len < s2len) ? s1len : s2len; - if (reqlength > 0 && reqlength < length) { - length = reqlength; - } else if (reqlength < 0) { - /* - * The requested length is negative, so we ignore it by setting it to - * length + 1 so we correct the match var. - */ - - reqlength = length + 1; - } - - if (checkEq && (s1len != s2len)) { - match = 1; /* This will be reversed below. */ - } else { - /* - * The comparison function should compare up to the minimum byte - * length only. - */ - match = memCmpFn(s1, s2, (size_t) length); - } - if ((match == 0) && (reqlength > length)) { - match = s1len - s2len; - } - return (match > 0) ? 1 : (match < 0) ? -1 : 0; -} - -int TclStringCmpOpts( +TclStringCmpOpts( Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[], /* Argument objects. */ @@ -2941,7 +2810,6 @@ StringCatCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int i; Tcl_Obj *objResultPtr; if (objc < 2) { @@ -2951,23 +2819,15 @@ StringCatCmd( */ return TCL_OK; } - if (objc == 2) { - /* - * Other trivial case, single arg, just return it. - */ - Tcl_SetObjResult(interp, objv[1]); + + objResultPtr = TclStringCat(interp, objc-1, objv+1, TCL_STRING_IN_PLACE); + + if (objResultPtr) { + 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 TCL_OK; + return TCL_ERROR; } /* @@ -2988,7 +2848,6 @@ StringCatCmd( * *---------------------------------------------------------------------- */ - static int StringBytesCmd( ClientData dummy, /* Not used. */ @@ -3004,7 +2863,7 @@ StringBytesCmd( } (void) TclGetStringFromObj(objv[1], &length); - Tcl_SetObjResult(interp, Tcl_NewIntObj(length)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(length)); return TCL_OK; } @@ -3038,7 +2897,7 @@ StringLenCmd( return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_GetCharLength(objv[1]))); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_GetCharLength(objv[1]))); return TCL_OK; } @@ -3469,6 +3328,7 @@ TclInitStringCmd( {"equal", StringEqualCmd, TclCompileStringEqualCmd, NULL, NULL, 0}, {"first", StringFirstCmd, TclCompileStringFirstCmd, NULL, NULL, 0}, {"index", StringIndexCmd, TclCompileStringIndexCmd, NULL, NULL, 0}, + {"insert", StringInsertCmd, TclCompileStringInsertCmd, NULL, NULL, 0}, {"is", StringIsCmd, TclCompileStringIsCmd, NULL, NULL, 0}, {"last", StringLastCmd, TclCompileStringLastCmd, NULL, NULL, 0}, {"length", StringLenCmd, TclCompileStringLenCmd, NULL, NULL, 0}, @@ -3641,7 +3501,7 @@ TclNRSwitchObjCmd( OPT_LAST }; typedef int (*strCmpFn_t)(const char *, const char *); - strCmpFn_t strCmpFn = strcmp; + strCmpFn_t strCmpFn = TclUtfCmp; mode = OPT_EXACT; foundmode = 0; @@ -3765,7 +3625,7 @@ TclNRSwitchObjCmd( Tcl_Obj **listv; blist = objv[0]; - if (TclListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK){ + if (TclListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) { return TCL_ERROR; } @@ -3927,10 +3787,10 @@ TclNRSwitchObjCmd( Tcl_Obj *rangeObjAry[2]; if (info.matches[j].end > 0) { - rangeObjAry[0] = Tcl_NewLongObj(info.matches[j].start); - rangeObjAry[1] = Tcl_NewLongObj(info.matches[j].end-1); + rangeObjAry[0] = Tcl_NewWideIntObj(info.matches[j].start); + rangeObjAry[1] = Tcl_NewWideIntObj(info.matches[j].end-1); } else { - rangeObjAry[0] = rangeObjAry[1] = Tcl_NewIntObj(-1); + rangeObjAry[0] = rangeObjAry[1] = Tcl_NewWideIntObj(-1); } /* @@ -4414,7 +4274,7 @@ Tcl_TimeRateObjCmd( * calibration cycle. */ - TclNewLongObj(clobjv[i], 100); + TclNewIntObj(clobjv[i], 100); Tcl_IncrRefCount(clobjv[i]); result = Tcl_TimeRateObjCmd(NULL, interp, i + 1, clobjv); Tcl_DecrRefCount(clobjv[i]); @@ -4439,7 +4299,7 @@ Tcl_TimeRateObjCmd( maxms = -1000; do { lastMeasureOverhead = measureOverhead; - TclNewLongObj(clobjv[i], (int) maxms); + TclNewIntObj(clobjv[i], (int) maxms); Tcl_IncrRefCount(clobjv[i]); result = Tcl_TimeRateObjCmd(NULL, interp, i + 1, clobjv); Tcl_DecrRefCount(clobjv[i]); diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index d8f0aeb..c015204 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -912,7 +912,7 @@ TclCompileConcatCmd( Tcl_ListObjGetElements(NULL, listObj, &len, &objs); objPtr = Tcl_ConcatObj(len, objs); Tcl_DecrRefCount(listObj); - bytes = Tcl_GetStringFromObj(objPtr, &len); + bytes = TclGetStringFromObj(objPtr, &len); PushLiteral(envPtr, bytes, len); Tcl_DecrRefCount(objPtr); return TCL_OK; @@ -1177,6 +1177,38 @@ TclCompileDictGetCmd( } int +TclCompileDictGetWithDefaultCmd( + Tcl_Interp *interp, /* Used for looking up stuff. */ + 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; + int i; + DefineLineInformation; /* TIP #280 */ + + /* + * There must be at least three arguments after the command. + */ + + /* TODO: Consider support for compiling expanded args. */ + if (parsePtr->numWords < 4) { + return TCL_ERROR; + } + tokenPtr = TokenAfter(parsePtr->tokenPtr); + + for (i=1 ; i<parsePtr->numWords ; i++) { + CompileWord(envPtr, tokenPtr, interp, i); + tokenPtr = TokenAfter(tokenPtr); + } + TclEmitInstInt4(INST_DICT_GET_DEF, parsePtr->numWords-3, envPtr); + TclAdjustStackDepth(-2, envPtr); + return TCL_OK; +} + +int TclCompileDictExistsCmd( Tcl_Interp *interp, /* Used for looking up stuff. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command @@ -1320,7 +1352,7 @@ TclCompileDictCreateCmd( * We did! Excellent. The "verifyDict" is to do type forcing. */ - bytes = Tcl_GetStringFromObj(dictObj, &len); + bytes = TclGetStringFromObj(dictObj, &len); PushLiteral(envPtr, bytes, len); TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_DICT_VERIFY, envPtr); @@ -2761,7 +2793,7 @@ CompileEachloopCmd( int numBytes, varIndex; Tcl_ListObjIndex(NULL, varListObj, j, &varNameObj); - bytes = Tcl_GetStringFromObj(varNameObj, &numBytes); + bytes = TclGetStringFromObj(varNameObj, &numBytes); varIndex = LocalScalar(bytes, numBytes, envPtr); if (varIndex < 0) { code = TCL_ERROR; @@ -3142,7 +3174,7 @@ TclCompileFormatCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = parsePtr->tokenPtr; Tcl_Obj **objv, *formatObj, *tmpObj; - char *bytes, *start; + const char *bytes, *start; int i, j, len; /* @@ -3198,7 +3230,7 @@ TclCompileFormatCmd( * literal. Job done. */ - bytes = Tcl_GetStringFromObj(tmpObj, &len); + bytes = TclGetStringFromObj(tmpObj, &len); PushLiteral(envPtr, bytes, len); Tcl_DecrRefCount(tmpObj); return TCL_OK; @@ -3269,7 +3301,7 @@ TclCompileFormatCmd( if (*++bytes == '%') { Tcl_AppendToObj(tmpObj, "%", 1); } else { - char *b = Tcl_GetStringFromObj(tmpObj, &len); + const char *b = TclGetStringFromObj(tmpObj, &len); /* * If there is a non-empty literal from the format string, @@ -3303,7 +3335,7 @@ TclCompileFormatCmd( */ Tcl_AppendToObj(tmpObj, start, bytes - start); - bytes = Tcl_GetStringFromObj(tmpObj, &len); + bytes = TclGetStringFromObj(tmpObj, &len); if (len > 0) { PushLiteral(envPtr, bytes, len); i++; diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 324db41..3c8a156 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -27,7 +27,6 @@ static void CompileReturnInternal(CompileEnv *envPtr, Tcl_Obj *returnOpts); static int IndexTailVarIfKnown(Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr); - /* *---------------------------------------------------------------------- @@ -127,9 +126,12 @@ TclCompileGlobalCmd( return TCL_ERROR; } - /* TODO: Consider what value can pass through the - * IndexTailVarIfKnown() screen. Full CompileWord() - * likely does not apply here. Push known value instead. */ + /* + * TODO: Consider what value can pass through the + * IndexTailVarIfKnown() screen. Full CompileWord() likely does not + * apply here. Push known value instead. + */ + CompileWord(envPtr, varTokenPtr, interp, i); TclEmitInstInt4( INST_NSUPVAR, localIndex, envPtr); } @@ -270,7 +272,7 @@ TclCompileIfCmd( jumpIndex = jumpFalseFixupArray.next; jumpFalseFixupArray.next++; TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, - jumpFalseFixupArray.fixup+jumpIndex); + jumpFalseFixupArray.fixup + jumpIndex); } code = TCL_OK; } @@ -317,7 +319,7 @@ TclCompileIfCmd( } jumpEndFixupArray.next++; TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - jumpEndFixupArray.fixup+jumpIndex); + jumpEndFixupArray.fixup + jumpIndex); /* * Fix the target of the jumpFalse after the test. Generate a 4 @@ -329,7 +331,7 @@ TclCompileIfCmd( TclAdjustStackDepth(-1, envPtr); if (TclFixupForwardJumpToHere(envPtr, - jumpFalseFixupArray.fixup+jumpIndex, 120)) { + jumpFalseFixupArray.fixup + jumpIndex, 120)) { /* * Adjust the code offset for the proceeding jump to the end * of the "if" command. @@ -412,7 +414,7 @@ TclCompileIfCmd( for (j = jumpEndFixupArray.next; j > 0; j--) { jumpIndex = (j - 1); /* i.e. process the closest jump first. */ if (TclFixupForwardJumpToHere(envPtr, - jumpEndFixupArray.fixup+jumpIndex, 127)) { + jumpEndFixupArray.fixup + jumpIndex, 127)) { /* * Adjust the immediately preceeding "ifFalse" jump. We moved it's * target (just after this jump) down three bytes. @@ -431,7 +433,7 @@ TclCompileIfCmd( jumpFalseDist += 3; TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1)); } else { - Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", (int) opCode); + Tcl_Panic("TclCompileIfCmd: unexpected opcode \"%d\" updating ifFalse jump", opCode); } } } @@ -587,7 +589,7 @@ TclCompileInfoCommandsCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; Tcl_Obj *objPtr; - char *bytes; + const char *bytes; /* * We require one compile-time known argument for the case we can compile. @@ -604,7 +606,7 @@ TclCompileInfoCommandsCmd( if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) { goto notCompilable; } - bytes = Tcl_GetString(objPtr); + bytes = TclGetString(objPtr); /* * We require that the argument start with "::" and not have any of "*\[?" @@ -920,7 +922,7 @@ TclCompileLappendCmd( CompileWord(envPtr, valueTokenPtr, interp, i); valueTokenPtr = TokenAfter(valueTokenPtr); } - TclEmitInstInt4( INST_LIST, numWords-2, envPtr); + TclEmitInstInt4( INST_LIST, numWords - 2, envPtr); if (isScalar) { if (localIndex < 0) { TclEmitOpcode( INST_LAPPEND_LIST_STK, envPtr); @@ -997,7 +999,7 @@ TclCompileLassignCmd( */ PushVarNameWord(interp, tokenPtr, envPtr, 0, &localIndex, - &isScalar, idx+2); + &isScalar, idx + 2); /* * Emit instructions to get the idx'th item out of the list value on @@ -1036,7 +1038,7 @@ TclCompileLassignCmd( */ TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr); - TclEmitInt4( TCL_INDEX_END, envPtr); + TclEmitInt4( (int)TCL_INDEX_END, envPtr); return TCL_OK; } @@ -1087,8 +1089,8 @@ TclCompileLindexCmd( } idxTokenPtr = TokenAfter(valTokenPtr); - if (TclGetIndexFromToken(idxTokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_BEFORE, - &idx) == TCL_OK) { + if (TclGetIndexFromToken(idxTokenPtr, TCL_INDEX_NONE, + TCL_INDEX_NONE, &idx) == TCL_OK) { /* * The idxTokenPtr parsed as a valid index value and was * encoded as expected by INST_LIST_INDEX_IMM. @@ -1241,7 +1243,7 @@ TclCompileListCmd( if (concat && numWords == 2) { TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); - TclEmitInt4( TCL_INDEX_END, envPtr); + TclEmitInt4( (int)TCL_INDEX_END, envPtr); } return TCL_OK; } @@ -1316,8 +1318,8 @@ TclCompileLrangeCmd( listTokenPtr = TokenAfter(parsePtr->tokenPtr); tokenPtr = TokenAfter(listTokenPtr); - if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_AFTER, - &idx1) != TCL_OK) { + if ((TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_NONE, + &idx1) != TCL_OK) || (idx1 == (int)TCL_INDEX_NONE)) { return TCL_ERROR; } /* @@ -1326,7 +1328,7 @@ TclCompileLrangeCmd( */ tokenPtr = TokenAfter(tokenPtr); - if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_END, + if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_NONE, TCL_INDEX_END, &idx2) != TCL_OK) { return TCL_ERROR; } @@ -1406,7 +1408,7 @@ TclCompileLinsertCmd( CompileWord(envPtr, listTokenPtr, interp, 1); if (parsePtr->numWords == 3) { TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); - TclEmitInt4( TCL_INDEX_END, envPtr); + TclEmitInt4( (int)TCL_INDEX_END, envPtr); return TCL_OK; } @@ -1414,12 +1416,12 @@ TclCompileLinsertCmd( tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, i); } - TclEmitInstInt4( INST_LIST, i-3, envPtr); + TclEmitInstInt4( INST_LIST, i - 3, envPtr); - if (idx == TCL_INDEX_START) { + if (idx == (int)TCL_INDEX_START) { TclEmitInstInt4( INST_REVERSE, 2, envPtr); TclEmitOpcode( INST_LIST_CONCAT, envPtr); - } else if (idx == TCL_INDEX_END) { + } else if (idx == (int)TCL_INDEX_END) { TclEmitOpcode( INST_LIST_CONCAT, envPtr); } else { /* @@ -1434,15 +1436,15 @@ TclCompileLinsertCmd( * differ in their interpretation of the "end" index. */ - if (idx < TCL_INDEX_END) { + if (idx < (int)TCL_INDEX_END) { idx++; } TclEmitInstInt4( INST_OVER, 1, envPtr); TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); - TclEmitInt4( idx-1, envPtr); + TclEmitInt4( idx - 1, envPtr); TclEmitInstInt4( INST_REVERSE, 3, envPtr); TclEmitInstInt4( INST_LIST_RANGE_IMM, idx, envPtr); - TclEmitInt4( TCL_INDEX_END, envPtr); + TclEmitInt4( (int)TCL_INDEX_END, envPtr); TclEmitOpcode( INST_LIST_CONCAT, envPtr); TclEmitOpcode( INST_LIST_CONCAT, envPtr); } @@ -1481,13 +1483,13 @@ TclCompileLreplaceCmd( listTokenPtr = TokenAfter(parsePtr->tokenPtr); tokenPtr = TokenAfter(listTokenPtr); - if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_AFTER, + if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_NONE, &idx1) != TCL_OK) { return TCL_ERROR; } tokenPtr = TokenAfter(tokenPtr); - if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_END, + if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_NONE, TCL_INDEX_END, &idx2) != TCL_OK) { return TCL_ERROR; } @@ -1503,14 +1505,14 @@ TclCompileLreplaceCmd( * we must defer to direct evaluation. */ - if (idx1 == TCL_INDEX_AFTER) { - suffixStart = idx1; - } else if (idx2 == TCL_INDEX_BEFORE) { + if (idx1 == (int)TCL_INDEX_NONE) { + suffixStart = (int)TCL_INDEX_NONE; + } else if (idx2 == (int)TCL_INDEX_NONE) { suffixStart = idx1; - } else if (idx2 == TCL_INDEX_END) { - suffixStart = TCL_INDEX_AFTER; - } else if (((idx2 < TCL_INDEX_END) && (idx1 <= TCL_INDEX_END)) - || ((idx2 >= TCL_INDEX_START) && (idx1 >= TCL_INDEX_START))) { + } else if (idx2 == (int)TCL_INDEX_END) { + suffixStart = (int)TCL_INDEX_NONE; + } else if (((idx2 < (int)TCL_INDEX_END) && (idx1 <= (int)TCL_INDEX_END)) + || ((idx2 >= (int)TCL_INDEX_START) && (idx1 >= (int)TCL_INDEX_START))) { suffixStart = (idx1 > idx2 + 1) ? idx1 : idx2 + 1; } else { return TCL_ERROR; @@ -1544,11 +1546,11 @@ TclCompileLreplaceCmd( * and canonicalization side effects. */ TclEmitInstInt4( INST_LIST_RANGE_IMM, 0, envPtr); - TclEmitInt4( TCL_INDEX_END, envPtr); + TclEmitInt4( (int)TCL_INDEX_END, envPtr); return TCL_OK; } - if (idx1 != TCL_INDEX_START) { + if (idx1 != (int)TCL_INDEX_START) { /* Prefix may not be empty; generate bytecode to push it */ if (emptyPrefix) { TclEmitOpcode( INST_DUP, envPtr); @@ -1568,7 +1570,7 @@ TclCompileLreplaceCmd( TclEmitInstInt4( INST_REVERSE, 2, envPtr); } - if (suffixStart == TCL_INDEX_AFTER) { + if (suffixStart == (int)TCL_INDEX_NONE) { TclEmitOpcode( INST_POP, envPtr); if (emptyPrefix) { PushStringLiteral(envPtr, ""); @@ -1576,7 +1578,7 @@ TclCompileLreplaceCmd( } else { /* Suffix may not be empty; generate bytecode to push it */ TclEmitInstInt4( INST_LIST_RANGE_IMM, suffixStart, envPtr); - TclEmitInt4( TCL_INDEX_END, envPtr); + TclEmitInt4( (int)TCL_INDEX_END, envPtr); if (!emptyPrefix) { TclEmitOpcode( INST_LIST_CONCAT, envPtr); } @@ -2119,7 +2121,7 @@ TclCompileRegexpCmd( sawLast++; i++; break; - } else if ((len > 1) && (strncmp(str,"-nocase",(unsigned)len) == 0)) { + } else if ((len > 1) && (strncmp(str, "-nocase", len) == 0)) { nocase = 1; } else { /* @@ -2183,7 +2185,7 @@ TclCompileRegexpCmd( } if (!simple) { - CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-2); + CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords - 2); } /* @@ -2191,7 +2193,7 @@ TclCompileRegexpCmd( */ varTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords-1); + CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords - 1); if (simple) { if (exact && !nocase) { @@ -2293,8 +2295,8 @@ TclCompileRegsubCmd( if (!TclWordKnownAtCompileTime(tokenPtr, patternObj)) { goto done; } - if (Tcl_GetString(patternObj)[0] == '-') { - if (strcmp(Tcl_GetString(patternObj), "--") != 0 + if (TclGetString(patternObj)[0] == '-') { + if (strcmp(TclGetString(patternObj), "--") != 0 || parsePtr->numWords == 5) { goto done; } @@ -2325,7 +2327,7 @@ TclCompileRegsubCmd( * replacement "simple"? */ - bytes = Tcl_GetStringFromObj(patternObj, &len); + bytes = TclGetStringFromObj(patternObj, &len); if (TclReToGlob(NULL, bytes, len, &pattern, &exact, &quantified) != TCL_OK || exact || quantified) { goto done; @@ -2359,7 +2361,7 @@ TclCompileRegsubCmd( bytes++; } isSimpleGlob: - for (bytes = Tcl_GetString(replacementObj); *bytes; bytes++) { + for (bytes = TclGetString(replacementObj); *bytes; bytes++) { switch (*bytes) { case '\\': case '&': goto done; @@ -2373,9 +2375,9 @@ TclCompileRegsubCmd( result = TCL_OK; bytes = Tcl_DStringValue(&pattern) + 1; PushLiteral(envPtr, bytes, len); - bytes = Tcl_GetStringFromObj(replacementObj, &len); + bytes = TclGetStringFromObj(replacementObj, &len); PushLiteral(envPtr, bytes, len); - CompileWord(envPtr, stringTokenPtr, interp, parsePtr->numWords-2); + CompileWord(envPtr, stringTokenPtr, interp, parsePtr->numWords - 2); TclEmitOpcode( INST_STR_MAP, envPtr); done: @@ -2504,7 +2506,7 @@ TclCompileReturnCmd( */ if (explicitResult) { - CompileWord(envPtr, wordTokenPtr, interp, numWords-1); + CompileWord(envPtr, wordTokenPtr, interp, numWords - 1); } else { /* * No explict result argument, so default result is empty string. @@ -2582,7 +2584,7 @@ TclCompileReturnCmd( */ if (explicitResult) { - CompileWord(envPtr, wordTokenPtr, interp, numWords-1); + CompileWord(envPtr, wordTokenPtr, interp, numWords - 1); } else { PushStringLiteral(envPtr, ""); } @@ -2635,7 +2637,7 @@ TclCompileSyntaxError( const char *bytes = TclGetStringFromObj(msg, &numBytes); TclErrorStackResetIf(interp, bytes, numBytes); - TclEmitPush(TclRegisterNewLiteral(envPtr, bytes, numBytes), envPtr); + TclEmitPush(TclRegisterLiteral(envPtr, bytes, numBytes, 0), envPtr); CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0, TclNoErrorStack(interp, Tcl_GetReturnOptions(interp, TCL_ERROR))); Tcl_ResetResult(interp); @@ -2813,12 +2815,12 @@ TclCompileVariableCmd( CompileWord(envPtr, varTokenPtr, interp, i); TclEmitInstInt4( INST_VARIABLE, localIndex, envPtr); - if (i+1 < numWords) { + if (i + 1 < numWords) { /* * A value has been given: set the variable, pop the value */ - CompileWord(envPtr, valueTokenPtr, interp, i+1); + CompileWord(envPtr, valueTokenPtr, interp, i + 1); Emit14Inst( INST_STORE_SCALAR, localIndex, envPtr); TclEmitOpcode( INST_POP, envPtr); } @@ -2894,7 +2896,7 @@ IndexTailVarIfKnown( tailName = TclGetStringFromObj(tailPtr, &len); if (len) { - if (*(tailName+len-1) == ')') { + if (*(tailName + len - 1) == ')') { /* * Possible array: bail out */ @@ -2908,7 +2910,7 @@ IndexTailVarIfKnown( */ for (p = tailName + len -1; p > tailName; p--) { - if ((*p == ':') && (*(p-1) == ':')) { + if ((*p == ':') && (*(p - 1) == ':')) { p++; break; } diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 1d59cc6..f0bf5ca 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -260,7 +260,7 @@ TclCompileStringCatCmd( Tcl_DecrRefCount(obj); if (folded) { int len; - const char *bytes = Tcl_GetStringFromObj(folded, &len); + const char *bytes = TclGetStringFromObj(folded, &len); PushLiteral(envPtr, bytes, len); Tcl_DecrRefCount(folded); @@ -278,7 +278,7 @@ TclCompileStringCatCmd( } if (folded) { int len; - const char *bytes = Tcl_GetStringFromObj(folded, &len); + const char *bytes = TclGetStringFromObj(folded, &len); PushLiteral(envPtr, bytes, len); Tcl_DecrRefCount(folded); @@ -449,6 +449,63 @@ TclCompileStringIndexCmd( } int +TclCompileStringInsertCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + 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; + DefineLineInformation; /* TIP #280 */ + int idx; + + if (parsePtr->numWords != 4) { + return TCL_ERROR; + } + + /* Compute and push the string in which to insert */ + tokenPtr = TokenAfter(parsePtr->tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 1); + + /* See what can be discovered about index at compile time */ + tokenPtr = TokenAfter(tokenPtr); + if (TCL_OK != TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, + TCL_INDEX_END, &idx)) { + + /* Nothing useful knowable - cease compile; let it direct eval */ + return TCL_OK; + } + + /* Compute and push the string to be inserted */ + tokenPtr = TokenAfter(tokenPtr); + CompileWord(envPtr, tokenPtr, interp, 3); + + if (idx == (int)TCL_INDEX_START) { + /* Prepend the insertion string */ + OP4( REVERSE, 2); + OP1( STR_CONCAT1, 2); + } else if (idx == (int)TCL_INDEX_END) { + /* Append the insertion string */ + OP1( STR_CONCAT1, 2); + } else { + /* Prefix + insertion + suffix */ + if (idx < (int)TCL_INDEX_END) { + /* See comments in compiler for [linsert]. */ + idx++; + } + OP4( OVER, 1); + OP44( STR_RANGE_IMM, 0, idx-1); + OP4( REVERSE, 3); + OP44( STR_RANGE_IMM, idx, TCL_INDEX_END); + OP1( STR_CONCAT1, 3); + } + + return TCL_OK; +} + +int TclCompileStringIsCmd( Tcl_Interp *interp, /* Used for error reporting. */ Tcl_Parse *parsePtr, /* Points to a parse structure for the command @@ -461,7 +518,7 @@ TclCompileStringIsCmd( Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); static const char *const isClasses[] = { "alnum", "alpha", "ascii", "control", - "boolean", "digit", "double", "entier", + "boolean", "dict", "digit", "double", "entier", "false", "graph", "integer", "list", "lower", "print", "punct", "space", "true", "upper", "wideinteger", "wordchar", @@ -469,7 +526,7 @@ TclCompileStringIsCmd( }; enum isClasses { STR_IS_ALNUM, STR_IS_ALPHA, STR_IS_ASCII, STR_IS_CONTROL, - STR_IS_BOOL, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_ENTIER, + STR_IS_BOOL, STR_IS_DICT, STR_IS_DIGIT, STR_IS_DOUBLE, STR_IS_ENTIER, STR_IS_FALSE, STR_IS_GRAPH, STR_IS_INT, STR_IS_LIST, STR_IS_LOWER, STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE, STR_IS_TRUE, STR_IS_UPPER, STR_IS_WIDE, STR_IS_WORD, @@ -691,14 +748,11 @@ TclCompileStringIsCmd( } switch (t) { - case STR_IS_INT: - PUSH( "1"); - OP( EQ); - break; case STR_IS_WIDE: PUSH( "2"); OP( LE); break; + case STR_IS_INT: case STR_IS_ENTIER: PUSH( "3"); OP( LE); @@ -706,7 +760,19 @@ TclCompileStringIsCmd( } FIXJUMP1( end); return TCL_OK; - + case STR_IS_DICT: + range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); + OP4( BEGIN_CATCH4, range); + ExceptionRangeStarts(envPtr, range); + OP( DUP); + OP( DICT_VERIFY); + ExceptionRangeEnds(envPtr, range); + ExceptionRangeTarget(envPtr, range, catchOffset); + OP( POP); + OP( PUSH_RETURN_CODE); + OP( END_CATCH); + OP( LNOT); + return TCL_OK; case STR_IS_LIST: range = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); OP4( BEGIN_CATCH4, range); @@ -755,7 +821,7 @@ TclCompileStringMatchCmd( } str = tokenPtr[1].start; length = tokenPtr[1].size; - if ((length <= 1) || strncmp(str, "-nocase", (size_t) length)) { + if ((length <= 1) || strncmp(str, "-nocase", length)) { /* * Fail at run time, not in compilation. */ @@ -859,7 +925,7 @@ TclCompileStringMapCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *mapTokenPtr, *stringTokenPtr; Tcl_Obj *mapObj, **objv; - char *bytes; + const char *bytes; int len; /* @@ -896,12 +962,12 @@ TclCompileStringMapCmd( * correct semantics for mapping. */ - bytes = Tcl_GetStringFromObj(objv[0], &len); + bytes = TclGetStringFromObj(objv[0], &len); if (len == 0) { CompileWord(envPtr, stringTokenPtr, interp, 2); } else { PushLiteral(envPtr, bytes, len); - bytes = Tcl_GetStringFromObj(objv[1], &len); + bytes = TclGetStringFromObj(objv[1], &len); PushLiteral(envPtr, bytes, len); CompileWord(envPtr, stringTokenPtr, interp, 2); OP(STR_MAP); @@ -937,7 +1003,7 @@ TclCompileStringRangeCmd( * Parse the two indices. */ - if (TclGetIndexFromToken(fromTokenPtr, TCL_INDEX_START, TCL_INDEX_AFTER, + if (TclGetIndexFromToken(fromTokenPtr, TCL_INDEX_START, TCL_INDEX_NONE, &idx1) != TCL_OK) { goto nonConstantIndices; } @@ -946,14 +1012,14 @@ TclCompileStringRangeCmd( * the string the same as the start of the string. */ - if (idx1 == TCL_INDEX_AFTER) { + if (idx1 == (int)TCL_INDEX_NONE) { /* [string range $s end+1 $last] must be empty string */ OP( POP); PUSH( ""); return TCL_OK; } - if (TclGetIndexFromToken(toTokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_END, + if (TclGetIndexFromToken(toTokenPtr, TCL_INDEX_NONE, TCL_INDEX_END, &idx2) != TCL_OK) { goto nonConstantIndices; } @@ -961,7 +1027,7 @@ TclCompileStringRangeCmd( * Token parsed as an index expression. We treat all indices after * the string the same as the end of the string. */ - if (idx2 == TCL_INDEX_BEFORE) { + if (idx2 == (int)TCL_INDEX_NONE) { /* [string range $s $first -1] must be empty string */ OP( POP); PUSH( ""); @@ -1011,7 +1077,7 @@ TclCompileStringReplaceCmd( * Check for first index known and useful at compile time. */ tokenPtr = TokenAfter(valueTokenPtr); - if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_AFTER, + if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_START, TCL_INDEX_NONE, &first) != TCL_OK) { goto genericReplace; } @@ -1020,7 +1086,7 @@ TclCompileStringReplaceCmd( * Check for last index known and useful at compile time. */ tokenPtr = TokenAfter(tokenPtr); - if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_BEFORE, TCL_INDEX_AFTER, + if (TclGetIndexFromToken(tokenPtr, TCL_INDEX_NONE, TCL_INDEX_END, &last) != TCL_OK) { goto genericReplace; } @@ -1039,8 +1105,8 @@ TclCompileStringReplaceCmd( * compile direct to bytecode implementing the no-op. */ - if ((last == TCL_INDEX_BEFORE) /* Know (last < 0) */ - || (first == TCL_INDEX_AFTER) /* Know (first > end) */ + if ((last == (int)TCL_INDEX_NONE) /* Know (last < 0) */ + || (first == (int)TCL_INDEX_NONE) /* Know (first > end) */ /* * Tricky to determine when runtime (last < first) can be @@ -1048,24 +1114,21 @@ TclCompileStringReplaceCmd( * cases... * * (first <= TCL_INDEX_END) && - * (last == TCL_INDEX_AFTER) => cannot tell REJECT * (last <= TCL_INDEX END) && (last < first) => ACCEPT * else => cannot tell REJECT */ - || ((first <= TCL_INDEX_END) && (last <= TCL_INDEX_END) + || ((first <= (int)TCL_INDEX_END) && (last <= (int)TCL_INDEX_END) && (last < first)) /* Know (last < first) */ /* - * (first == TCL_INDEX_BEFORE) && - * (last == TCL_INDEX_AFTER) => (first < last) REJECT + * (first == TCL_INDEX_NONE) && * (last <= TCL_INDEX_END) => cannot tell REJECT * else => (first < last) REJECT * * else [[first >= TCL_INDEX_START]] && - * (last == TCL_INDEX_AFTER) => cannot tell REJECT * (last <= TCL_INDEX_END) => cannot tell REJECT * else [[last >= TCL_INDEX START]] && (last < first) => ACCEPT */ - || ((first >= TCL_INDEX_START) && (last >= TCL_INDEX_START) + || ((first >= (int)TCL_INDEX_START) && (last >= (int)TCL_INDEX_START) && (last < first))) { /* Know (last < first) */ if (parsePtr->numWords == 5) { tokenPtr = TokenAfter(tokenPtr); @@ -1094,43 +1157,43 @@ TclCompileStringReplaceCmd( * (first <= end) * * The encoded indices (first <= TCL_INDEX END) and - * (first == TCL_INDEX_BEFORE) always meets this condition, but + * (first == TCL_INDEX_NONE) always meets this condition, but * any other encoded first index has some list for which it fails. * * We also need, second: * * (last >= 0) * - * The encoded indices (last >= TCL_INDEX_START) and - * (last == TCL_INDEX_AFTER) always meet this condition but any - * other encoded last index has some list for which it fails. + * The encoded index (last >= TCL_INDEX_START) always meet this + * condition but any other encoded last index has some list for + * which it fails. * * Finally we need, third: * * (first <= last) * * Considered in combination with the constraints we already have, - * we see that we can proceed when (first == TCL_INDEX_BEFORE) - * or (last == TCL_INDEX_AFTER). These also permit simplification - * of the prefix|replace|suffix construction. The other constraints, - * though, interfere with getting a guarantee that first <= last. + * we see that we can proceed when (first == TCL_INDEX_NONE). + * These also permit simplification of the prefix|replace|suffix + * construction. The other constraints, though, interfere with + * getting a guarantee that first <= last. */ - if ((first == TCL_INDEX_BEFORE) && (last >= TCL_INDEX_START)) { + if ((first == (int)TCL_INDEX_START) && (last >= (int)TCL_INDEX_START)) { /* empty prefix */ tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 4); OP4( REVERSE, 2); - if (last == TCL_INDEX_AFTER) { + if (last == INT_MAX) { OP( POP); /* Pop original */ } else { - OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END); + OP44( STR_RANGE_IMM, last + 1, (int)TCL_INDEX_END); OP1( STR_CONCAT1, 2); } return TCL_OK; } - if ((last == TCL_INDEX_AFTER) && (first <= TCL_INDEX_END)) { + if ((last == (int)TCL_INDEX_NONE) && (first <= (int)TCL_INDEX_END)) { OP44( STR_RANGE_IMM, 0, first-1); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, 4); @@ -1147,19 +1210,19 @@ TclCompileStringReplaceCmd( * are harmless when they are replaced by another empty string. */ - if ((first == TCL_INDEX_BEFORE) || (first == TCL_INDEX_START)) { + if (first == (int)TCL_INDEX_START) { /* empty prefix - build suffix only */ - if ((last == TCL_INDEX_END) || (last == TCL_INDEX_AFTER)) { + if (last == (int)TCL_INDEX_END) { /* empty suffix too => empty result */ OP( POP); /* Pop original */ PUSH ( ""); return TCL_OK; } - OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END); + OP44( STR_RANGE_IMM, last + 1, (int)TCL_INDEX_END); return TCL_OK; } else { - if ((last == TCL_INDEX_END) || (last == TCL_INDEX_AFTER)) { + if (last == (int)TCL_INDEX_END) { /* empty suffix - build prefix only */ OP44( STR_RANGE_IMM, 0, first-1); return TCL_OK; @@ -1167,7 +1230,7 @@ TclCompileStringReplaceCmd( OP( DUP); OP44( STR_RANGE_IMM, 0, first-1); OP4( REVERSE, 2); - OP44( STR_RANGE_IMM, last + 1, TCL_INDEX_END); + OP44( STR_RANGE_IMM, last + 1, (int)TCL_INDEX_END); OP1( STR_CONCAT1, 2); return TCL_OK; } @@ -1353,7 +1416,7 @@ static int UniCharIsHexDigit( int character) { - return (character >= 0) && (character < 0x80) && isxdigit(character); + return (character >= 0) && (character < 0x80) && isxdigit(UCHAR(character)); } StringClassDesc const tclStringClassTable[] = { @@ -1496,14 +1559,14 @@ TclSubstCompile( for (endTokenPtr = tokenPtr + parse.numTokens; tokenPtr < endTokenPtr; tokenPtr = TokenAfter(tokenPtr)) { int length, literal, catchRange, breakJump; - char buf[TCL_UTF_MAX] = ""; + char buf[4] = ""; JumpFixup startFixup, okFixup, returnFixup, breakFixup; JumpFixup continueFixup, otherFixup, endFixup; switch (tokenPtr->type) { case TCL_TOKEN_TEXT: - literal = TclRegisterNewLiteral(envPtr, - tokenPtr->start, tokenPtr->size); + literal = TclRegisterLiteral(envPtr, + tokenPtr->start, tokenPtr->size, 0); TclEmitPush(literal, envPtr); TclAdvanceLines(&bline, tokenPtr->start, tokenPtr->start + tokenPtr->size); @@ -1512,7 +1575,7 @@ TclSubstCompile( case TCL_TOKEN_BS: length = TclParseBackslash(tokenPtr->start, tokenPtr->size, NULL, buf); - literal = TclRegisterNewLiteral(envPtr, buf, length); + literal = TclRegisterLiteral(envPtr, buf, length, 0); TclEmitPush(literal, envPtr); count++; continue; @@ -1948,10 +2011,10 @@ TclCompileSwitchCmd( } if (numWords % 2) { abort: - ckfree((char *) bodyToken); - ckfree((char *) bodyTokenArray); - ckfree((char *) bodyLines); - ckfree((char *) bodyContLines); + ckfree(bodyToken); + ckfree(bodyTokenArray); + ckfree(bodyLines); + ckfree(bodyContLines); return TCL_ERROR; } } else if (numWords % 2 || numWords == 0) { @@ -2871,7 +2934,7 @@ TclCompileTryCmd( } if (objc > 0) { int len; - const char *varname = Tcl_GetStringFromObj(objv[0], &len); + const char *varname = TclGetStringFromObj(objv[0], &len); resultVarIndices[i] = LocalScalar(varname, len, envPtr); if (resultVarIndices[i] < 0) { @@ -2883,7 +2946,7 @@ TclCompileTryCmd( } if (objc == 2) { int len; - const char *varname = Tcl_GetStringFromObj(objv[1], &len); + const char *varname = TclGetStringFromObj(objv[1], &len); optionVarIndices[i] = LocalScalar(varname, len, envPtr); if (optionVarIndices[i] < 0) { @@ -3086,7 +3149,7 @@ IssueTryClausesInstructions( OP4( DICT_GET, 1); TclAdjustStackDepth(-1, envPtr); OP44( LIST_RANGE_IMM, 0, len-1); - p = Tcl_GetStringFromObj(matchClauses[i], &len); + p = TclGetStringFromObj(matchClauses[i], &len); PushLiteral(envPtr, p, len); OP( STR_EQ); JUMP4( JUMP_FALSE, notECJumpSource); @@ -3297,7 +3360,7 @@ IssueTryClausesFinallyInstructions( OP4( DICT_GET, 1); TclAdjustStackDepth(-1, envPtr); OP44( LIST_RANGE_IMM, 0, len-1); - p = Tcl_GetStringFromObj(matchClauses[i], &len); + p = TclGetStringFromObj(matchClauses[i], &len); PushLiteral(envPtr, p, len); OP( STR_EQ); JUMP4( JUMP_FALSE, notECJumpSource); @@ -3625,7 +3688,7 @@ TclCompileUnsetCmd( const char *bytes; int len; - bytes = Tcl_GetStringFromObj(leadingWord, &len); + bytes = TclGetStringFromObj(leadingWord, &len); if (i == 1 && len == 11 && !strncmp("-nocomplain", bytes, 11)) { flags = 0; haveFlags++; @@ -4430,6 +4493,50 @@ TclCompileStreqOpCmd( { return CompileComparisonOpCmd(interp, parsePtr, INST_STR_EQ, envPtr); } + +int +TclCompileStrLtOpCmd( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) +{ + return CompileComparisonOpCmd(interp, parsePtr, INST_STR_LT, envPtr); +} + +int +TclCompileStrLeOpCmd( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) +{ + return CompileComparisonOpCmd(interp, parsePtr, INST_STR_LE, envPtr); +} + +int +TclCompileStrGtOpCmd( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) +{ + return CompileComparisonOpCmd(interp, parsePtr, INST_STR_GT, envPtr); +} + +int +TclCompileStrGeOpCmd( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) +{ + return CompileComparisonOpCmd(interp, parsePtr, INST_STR_GE, envPtr); +} int TclCompileMinusOpCmd( diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 9c7ab8d..a6ac797 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -281,7 +281,11 @@ enum Marks { * parse tree. The sub-expression between * parens becomes the single argument of the * matching OPEN_PAREN unary operator. */ -#define END (BINARY | 28) +#define STR_LT (BINARY | 28) +#define STR_GT (BINARY | 29) +#define STR_LEQ (BINARY | 30) +#define STR_GEQ (BINARY | 31) +#define END (BINARY | 32) /* This lexeme represents the end of the * string being parsed. Treating it as a * binary operator follows the same logic as @@ -360,12 +364,14 @@ static const unsigned char prec[] = { PREC_EQUAL, /* IN_LIST */ PREC_EQUAL, /* NOT_IN_LIST */ PREC_CLOSE_PAREN, /* CLOSE_PAREN */ + PREC_COMPARE, /* STR_LT */ + PREC_COMPARE, /* STR_GT */ + PREC_COMPARE, /* STR_LEQ */ + PREC_COMPARE, /* STR_GEQ */ PREC_END, /* END */ /* Expansion room for more binary operators */ - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, /* Unary operator lexemes */ PREC_UNARY, /* UNARY_PLUS */ PREC_UNARY, /* UNARY_MINUS */ @@ -415,12 +421,14 @@ static const unsigned char instruction[] = { INST_LIST_IN, /* IN_LIST */ INST_LIST_NOT_IN, /* NOT_IN_LIST */ 0, /* CLOSE_PAREN */ + INST_STR_LT, /* STR_LT */ + INST_STR_GT, /* STR_GT */ + INST_STR_LE, /* STR_LEQ */ + INST_STR_GE, /* STR_GEQ */ 0, /* END */ /* Expansion room for more binary operators */ - 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, - 0, /* Unary operator lexemes */ INST_UPLUS, /* UNARY_PLUS */ INST_UMINUS, /* UNARY_MINUS */ @@ -1759,7 +1767,7 @@ ConvertTreeToTokens( /* * All the Tcl_Tokens allocated and filled belong to - * this subexpresion. The first token is the leading + * this subexpression. The first token is the leading * TCL_TOKEN_SUB_EXPR token, and all the rest (one fewer) * are its components. */ @@ -2001,6 +2009,35 @@ ParseLexeme( return 2; } } + break; + + case 'l': + if ((numBytes > 1) + && ((numBytes == 2) || start[2] & 0x80 || !isalpha(UCHAR(start[2])))) { + switch (start[1]) { + case 't': + *lexemePtr = STR_LT; + return 2; + case 'e': + *lexemePtr = STR_LEQ; + return 2; + } + } + break; + + case 'g': + if ((numBytes > 1) + && ((numBytes == 2) || start[2] & 0x80 || !isalpha(UCHAR(start[2])))) { + switch (start[1]) { + case 't': + *lexemePtr = STR_GT; + return 2; + case 'e': + *lexemePtr = STR_GEQ; + return 2; + } + } + break; } literal = Tcl_NewObj(); @@ -2027,7 +2064,7 @@ ParseLexeme( * Example: Inf + luence + () becomes a valid function call. * [Bug 3401704] */ - if (literal->typePtr == &tclDoubleType) { + if (TclHasIntRep(literal, &tclDoubleType)) { const char *p = start; while (p < end) { @@ -2066,9 +2103,9 @@ ParseLexeme( if (Tcl_UtfCharComplete(start, numBytes)) { scanned = TclUtfToUniChar(start, &ch); } else { - char utfBytes[TCL_UTF_MAX]; + char utfBytes[4]; - memcpy(utfBytes, start, (size_t) numBytes); + memcpy(utfBytes, start, numBytes); utfBytes[numBytes] = '\0'; scanned = TclUtfToUniChar(utfBytes, &ch); } @@ -2181,7 +2218,6 @@ ExecConstantExprTree( CompileEnv *envPtr; ByteCode *byteCodePtr; int code; - Tcl_Obj *byteCodeObj = Tcl_NewObj(); NRE_callback *rootPtr = TOP_CB(interp); /* @@ -2195,14 +2231,12 @@ ExecConstantExprTree( CompileExprTree(interp, nodes, index, litObjvPtr, NULL, NULL, envPtr, 0 /* optimize */); TclEmitOpcode(INST_DONE, envPtr); - Tcl_IncrRefCount(byteCodeObj); - TclInitByteCodeObj(byteCodeObj, envPtr); + byteCodePtr = TclInitByteCode(envPtr); TclFreeCompileEnv(envPtr); TclStackFree(interp, envPtr); - byteCodePtr = byteCodeObj->internalRep.twoPtrValue.ptr1; TclNRExecuteByteCode(interp, byteCodePtr); code = TclNRRunCallbacks(interp, TCL_OK, rootPtr); - Tcl_DecrRefCount(byteCodeObj); + TclReleaseByteCode(byteCodePtr); return code; } @@ -2270,9 +2304,9 @@ CompileExprTree( p = TclGetStringFromObj(*funcObjv, &length); funcObjv++; Tcl_DStringAppend(&cmdName, p, length); - TclEmitPush(TclRegisterNewCmdLiteral(envPtr, + TclEmitPush(TclRegisterLiteral(envPtr, Tcl_DStringValue(&cmdName), - Tcl_DStringLength(&cmdName)), envPtr); + Tcl_DStringLength(&cmdName), LITERAL_CMD_NAME), envPtr); Tcl_DStringFree(&cmdName); /* @@ -2379,8 +2413,8 @@ CompileExprTree( pc1 = CurrentOffset(envPtr); TclEmitInstInt1((nodePtr->lexeme == AND) ? INST_JUMP_FALSE1 : INST_JUMP_TRUE1, 0, envPtr); - TclEmitPush(TclRegisterNewLiteral(envPtr, - (nodePtr->lexeme == AND) ? "1" : "0", 1), envPtr); + TclEmitPush(TclRegisterLiteral(envPtr, + (nodePtr->lexeme == AND) ? "1" : "0", 1, 0), envPtr); pc2 = CurrentOffset(envPtr); TclEmitInstInt1(INST_JUMP1, 0, envPtr); TclAdjustStackDepth(-1, envPtr); @@ -2389,8 +2423,8 @@ CompileExprTree( if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) { pc2 += 3; } - TclEmitPush(TclRegisterNewLiteral(envPtr, - (nodePtr->lexeme == AND) ? "0" : "1", 1), envPtr); + TclEmitPush(TclRegisterLiteral(envPtr, + (nodePtr->lexeme == AND) ? "0" : "1", 1, 0), envPtr); TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc2, envPtr->codeStart + pc2 + 1); convert = 0; @@ -2424,7 +2458,7 @@ CompileExprTree( if (optimize) { int length; const char *bytes = TclGetStringFromObj(literal, &length); - int index = TclRegisterNewLiteral(envPtr, bytes, length); + int index = TclRegisterLiteral(envPtr, bytes, length, 0); Tcl_Obj *objPtr = TclFetchLiteral(envPtr, index); if ((objPtr->typePtr == NULL) && (literal->typePtr != NULL)) { @@ -2479,11 +2513,13 @@ CompileExprTree( * already, then use it to share via the literal table. */ - if (objPtr->bytes) { + if (TclHasStringRep(objPtr)) { Tcl_Obj *tableValue; + int numBytes; + const char *bytes + = Tcl_GetStringFromObj(objPtr, &numBytes); - index = TclRegisterNewLiteral(envPtr, objPtr->bytes, - objPtr->length); + index = TclRegisterLiteral(envPtr, bytes, numBytes, 0); tableValue = TclFetchLiteral(envPtr, index); if ((tableValue->typePtr == NULL) && (objPtr->typePtr != NULL)) { @@ -2569,7 +2605,7 @@ TclSingleOpCmd( * * TclSortingOpCmd -- * Implements the commands: - * <, <=, >, >=, ==, eq + * <, <=, >, >=, ==, eq, lt, le, gt, ge * in the ::tcl::mathop namespace. These commands are defined for * arbitrary number of arguments by computing the AND of the base * operator applied to all neighbor argument pairs. diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 6f90072..c10e3ee 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -659,6 +659,23 @@ InstructionDesc const tclInstructionTable[] = { * 0=clicks, 1=microseconds, 2=milliseconds, 3=seconds. * Stack: ... => ... time */ + {"dictGetDef", 5, INT_MIN, 1, {OPERAND_UINT4}}, + /* The top word is the default, the next op4 words (min 1) are a key + * path into the dictionary just below the keys on the stack, and all + * those values are replaced by the value read out of that key-path + * (like [dict get]) except if there is no such key, when instead the + * default is pushed instead. + * Stack: ... dict key1 ... keyN default => ... value */ + + {"strlt", 1, -1, 0, {OPERAND_NONE}}, + /* String Less: push (stknext < stktop) */ + {"strgt", 1, -1, 0, {OPERAND_NONE}}, + /* String Greater: push (stknext > stktop) */ + {"strle", 1, -1, 0, {OPERAND_NONE}}, + /* String Less or equal: push (stknext <= stktop) */ + {"strge", 1, -1, 0, {OPERAND_NONE}}, + /* String Greater or equal: push (stknext >= stktop) */ + {NULL, 0, 0, 0, {OPERAND_NONE}} }; @@ -666,6 +683,7 @@ 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, @@ -681,6 +699,7 @@ 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 */ @@ -723,13 +742,14 @@ static const Tcl_ObjType substCodeType = { NULL, /* updateStringProc */ NULL, /* setFromAnyProc */ }; +#define SubstFlags(objPtr) (objPtr)->internalRep.twoPtrValue.ptr2 /* * Helper macros. */ #define TclIncrUInt4AtPtr(ptr, delta) \ - TclStoreInt4AtPtr(TclGetUInt4AtPtr(ptr)+(delta), (ptr)); + TclStoreInt4AtPtr(TclGetUInt4AtPtr(ptr)+(delta), (ptr)) /* *---------------------------------------------------------------------- @@ -768,7 +788,8 @@ TclSetByteCodeFromAny( Interp *iPtr = (Interp *) interp; CompileEnv compEnv; /* Compilation environment structure allocated * in frame. */ - int length, result = TCL_OK; + size_t length; + int result = TCL_OK; const char *stringPtr; Proc *procPtr = iPtr->compiledProcPtr; ContLineLoc *clLocPtr; @@ -783,7 +804,8 @@ TclSetByteCodeFromAny( } #endif - stringPtr = TclGetStringFromObj(objPtr, &length); + stringPtr = TclGetString(objPtr); + length = objPtr->length; /* * TIP #280: Pick up the CmdFrame in which the BC compiler was invoked and @@ -871,7 +893,7 @@ TclSetByteCodeFromAny( #endif /*TCL_COMPILE_DEBUG*/ if (result == TCL_OK) { - TclInitByteCodeObj(objPtr, &compEnv); + (void) TclInitByteCodeObj(objPtr, &tclByteCodeType, &compEnv); #ifdef TCL_COMPILE_DEBUG if (tclTraceCompile >= 2) { TclPrintByteCodeObj(interp, objPtr); @@ -970,18 +992,18 @@ static void FreeByteCodeInternalRep( register Tcl_Obj *objPtr) /* Object whose internal rep to free. */ { - register ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; + ByteCode *codePtr; - objPtr->typePtr = NULL; - if (codePtr->refCount-- <= 1) { - TclCleanupByteCode(codePtr); - } + ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr); + assert(codePtr != NULL); + + TclReleaseByteCode(codePtr); } /* *---------------------------------------------------------------------- * - * TclCleanupByteCode -- + * TclReleaseByteCode -- * * This procedure does all the real work of freeing up a bytecode * object's ByteCode structure. It's called only when the structure's @@ -998,7 +1020,26 @@ FreeByteCodeInternalRep( */ void -TclCleanupByteCode( +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( register ByteCode *codePtr) /* Points to the ByteCode to free. */ { Tcl_Interp *interp = (Tcl_Interp *) *codePtr->interpHandle; @@ -1265,8 +1306,6 @@ 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 @@ -1286,24 +1325,26 @@ CompileSubstObj( Interp *iPtr = (Interp *) interp; ByteCode *codePtr = NULL; - if (objPtr->typePtr == &substCodeType) { + ByteCodeGetIntRep(objPtr, &substCodeType, codePtr); + + if (codePtr != NULL) { Namespace *nsPtr = iPtr->varFramePtr->nsPtr; - codePtr = objPtr->internalRep.twoPtrValue.ptr1; - if (flags != PTR2INT(objPtr->internalRep.twoPtrValue.ptr2) + if (flags != PTR2INT(SubstFlags(objPtr)) || ((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != nsPtr) || (codePtr->nsEpoch != nsPtr->resolverEpoch) || (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) { - FreeSubstCodeInternalRep(objPtr); + Tcl_StoreIntRep(objPtr, &substCodeType, NULL); + codePtr = NULL; } } - if (objPtr->typePtr != &substCodeType) { + if (codePtr == NULL) { CompileEnv compEnv; int numBytes; - const char *bytes = Tcl_GetStringFromObj(objPtr, &numBytes); + const char *bytes = TclGetStringFromObj(objPtr, &numBytes); /* TODO: Check for more TIP 280 */ TclInitCompileEnv(interp, &compEnv, bytes, numBytes, NULL, 0); @@ -1311,13 +1352,10 @@ CompileSubstObj( TclSubstCompile(interp, bytes, numBytes, flags, 1, &compEnv); TclEmitOpcode(INST_DONE, &compEnv); - TclInitByteCodeObj(objPtr, &compEnv); - objPtr->typePtr = &substCodeType; + codePtr = TclInitByteCodeObj(objPtr, &substCodeType, &compEnv); TclFreeCompileEnv(&compEnv); - codePtr = objPtr->internalRep.twoPtrValue.ptr1; - objPtr->internalRep.twoPtrValue.ptr1 = codePtr; - objPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(flags); + SubstFlags(objPtr) = INT2PTR(flags); if (iPtr->varFramePtr->localCachePtr) { codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; @@ -1356,12 +1394,12 @@ static void FreeSubstCodeInternalRep( register Tcl_Obj *objPtr) /* Object whose internal rep to free. */ { - register ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; + register ByteCode *codePtr; - objPtr->typePtr = NULL; - if (codePtr->refCount-- <= 1) { - TclCleanupByteCode(codePtr); - } + ByteCodeGetIntRep(objPtr, &substCodeType, codePtr); + assert(codePtr != NULL); + + TclReleaseByteCode(codePtr); } static void @@ -1374,14 +1412,14 @@ ReleaseCmdWordData( Tcl_DecrRefCount(eclPtr->path); } for (i=0 ; i<eclPtr->nuloc ; i++) { - ckfree((char *) eclPtr->loc[i].line); + ckfree(eclPtr->loc[i].line); } if (eclPtr->loc != NULL) { - ckfree((char *) eclPtr->loc); + ckfree(eclPtr->loc); } - ckfree((char *) eclPtr); + ckfree(eclPtr); } /* @@ -1723,7 +1761,7 @@ TclWordKnownAtCompileTime( case TCL_TOKEN_BS: if (tempPtr != NULL) { - char utfBuf[TCL_UTF_MAX] = ""; + char utfBuf[4] = ""; int length = TclParseBackslash(tokenPtr->start, tokenPtr->size, NULL, utfBuf); @@ -1795,8 +1833,8 @@ CompileCmdLiteral( extraLiteralFlags |= LITERAL_UNSHARED; } - bytes = Tcl_GetStringFromObj(cmdObj, &numBytes); - cmdLitIdx = TclRegisterLiteral(envPtr, (char *)bytes, numBytes, extraLiteralFlags); + bytes = TclGetStringFromObj(cmdObj, &numBytes); + cmdLitIdx = TclRegisterLiteral(envPtr, bytes, numBytes, extraLiteralFlags); if (cmdPtr) { TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr); @@ -1831,8 +1869,8 @@ TclCompileInvocation( continue; } - objIdx = TclRegisterNewLiteral(envPtr, - tokenPtr[1].start, tokenPtr[1].size); + objIdx = TclRegisterLiteral(envPtr, + tokenPtr[1].start, tokenPtr[1].size, 0); if (envPtr->clNext) { TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), tokenPtr[1].start - envPtr->source, envPtr->clNext); @@ -1881,8 +1919,8 @@ CompileExpanded( continue; } - objIdx = TclRegisterNewLiteral(envPtr, - tokenPtr[1].start, tokenPtr[1].size); + objIdx = TclRegisterLiteral(envPtr, + tokenPtr[1].start, tokenPtr[1].size, 0); if (envPtr->clNext) { TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), tokenPtr[1].start - envPtr->source, envPtr->clNext); @@ -2337,7 +2375,7 @@ TclCompileTokens( { Tcl_DString textBuffer; /* Holds concatenated chars from adjacent * TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */ - char buffer[TCL_UTF_MAX] = ""; + char buffer[4] = ""; int i, numObjsToConcat, length, adjust; unsigned char *entryCodeNext = envPtr->codeNext; #define NUM_STATIC_POS 20 @@ -2710,11 +2748,40 @@ TclCompileNoOp( *---------------------------------------------------------------------- */ -void -TclInitByteCodeObj( - Tcl_Obj *objPtr, /* Points object that should be initialized, - * and whose string rep contains the source - * code. */ +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( register CompileEnv *envPtr)/* Points to the CompileEnv structure from * which to create a ByteCode structure. */ { @@ -2765,7 +2832,8 @@ TclInitByteCodeObj( codePtr->compileEpoch = iPtr->compileEpoch; codePtr->nsPtr = namespacePtr; codePtr->nsEpoch = namespacePtr->resolverEpoch; - codePtr->refCount = 1; + codePtr->refCount = 0; + TclPreserveByteCode(codePtr); if (namespacePtr->compiledVarResProc || iPtr->resolverPtr) { codePtr->flags = TCL_BYTECODE_RESOLVE_VARS; } else { @@ -2786,40 +2854,18 @@ TclInitByteCodeObj( p += sizeof(ByteCode); codePtr->codeStart = p; - memcpy(p, envPtr->codeStart, (size_t) codeBytes); + memcpy(p, envPtr->codeStart, codeBytes); p += TCL_ALIGN(codeBytes); /* align object array */ codePtr->objArrayPtr = (Tcl_Obj **) p; for (i = 0; i < numLitObjects; 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; - } + codePtr->objArrayPtr[i] = TclFetchLiteral(envPtr, i); } p += TCL_ALIGN(objArrayBytes); /* align exception range array */ if (exceptArrayBytes > 0) { codePtr->exceptArrayPtr = (ExceptionRange *) p; - memcpy(p, envPtr->exceptArrayPtr, (size_t) exceptArrayBytes); + memcpy(p, envPtr->exceptArrayPtr, exceptArrayBytes); } else { codePtr->exceptArrayPtr = NULL; } @@ -2827,7 +2873,7 @@ TclInitByteCodeObj( p += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */ if (auxDataArrayBytes > 0) { codePtr->auxDataArrayPtr = (AuxData *) p; - memcpy(p, envPtr->auxDataArrayPtr, (size_t) auxDataArrayBytes); + memcpy(p, envPtr->auxDataArrayPtr, auxDataArrayBytes); } else { codePtr->auxDataArrayPtr = NULL; } @@ -2856,15 +2902,6 @@ TclInitByteCodeObj( #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. */ @@ -2877,6 +2914,31 @@ TclInitByteCodeObj( 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. + */ + + ByteCodeSetIntRep(objPtr, typePtr, codePtr); + return codePtr; } /* @@ -2944,7 +3006,8 @@ TclFindCompiledLocal( varNamePtr = &cachePtr->varName0; for (i=0; i < cachePtr->numVars; varNamePtr++, i++) { if (*varNamePtr) { - localName = Tcl_GetStringFromObj(*varNamePtr, &len); + localName = TclGetString(*varNamePtr); + len = (*varNamePtr)->length; if ((len == nameBytes) && !strncmp(name, localName, len)) { return i; } @@ -2962,7 +3025,7 @@ TclFindCompiledLocal( char *localName = localPtr->name; if ((nameBytes == localPtr->nameLength) && - (strncmp(name,localName,(unsigned)nameBytes) == 0)) { + (strncmp(name, localName, nameBytes) == 0)) { return i; } } @@ -2976,7 +3039,7 @@ TclFindCompiledLocal( if (create || (name == NULL)) { localVar = procPtr->numCompiledLocals; - localPtr = ckalloc(TclOffset(CompiledLocal, name) + nameBytes + 1); + localPtr = ckalloc(offsetof(CompiledLocal, name) + nameBytes + 1); if (procPtr->firstLocalPtr == NULL) { procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; } else { @@ -2994,7 +3057,7 @@ TclFindCompiledLocal( localPtr->resolveInfo = NULL; if (name != NULL) { - memcpy(localPtr->name, name, (size_t) nameBytes); + memcpy(localPtr->name, name, nameBytes); } localPtr->name[nameBytes] = '\0'; procPtr->numCompiledLocals++; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index aa6d247..5e39a21 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -266,7 +266,7 @@ typedef struct AuxDataType { typedef struct AuxData { const AuxDataType *type; /* Pointer to the AuxData type associated with * this ClientData. */ - ClientData clientData; /* The compilation data itself. */ + void *clientData; /* The compilation data itself. */ } AuxData; /* @@ -417,7 +417,7 @@ typedef struct ByteCode { * procs are specific to an interpreter so the * code emitted will depend on the * interpreter. */ - int compileEpoch; /* Value of iPtr->compileEpoch when this + unsigned int compileEpoch; /* Value of iPtr->compileEpoch when this * ByteCode was compiled. Used to invalidate * code when, e.g., commands with compile * procs are redefined. */ @@ -425,11 +425,11 @@ typedef struct ByteCode { * compiled. If the code is executed if a * different namespace, it must be * recompiled. */ - int nsEpoch; /* Value of nsPtr->resolverEpoch when this + unsigned int nsEpoch; /* Value of nsPtr->resolverEpoch when this * ByteCode was compiled. Used to invalidate * code when new namespace resolution rules * are put into effect. */ - int refCount; /* Reference count: set 1 when created plus 1 + unsigned int refCount; /* Reference count: set 1 when created plus 1 * for each execution of the code currently * active. This structure can be freed when * refCount becomes zero. */ @@ -514,6 +514,23 @@ typedef struct ByteCode { * created. */ #endif /* TCL_COMPILE_STATS */ } ByteCode; + +#define ByteCodeSetIntRep(objPtr, typePtr, codePtr) \ + do { \ + Tcl_ObjIntRep ir; \ + ir.twoPtrValue.ptr1 = (codePtr); \ + ir.twoPtrValue.ptr2 = NULL; \ + Tcl_StoreIntRep((objPtr), (typePtr), &ir); \ + } while (0) + + + +#define ByteCodeGetIntRep(objPtr, typePtr, codePtr) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = TclFetchIntRep((objPtr), (typePtr)); \ + (codePtr) = irPtr ? (ByteCode*)irPtr->twoPtrValue.ptr1 : NULL; \ + } while (0) /* * Opcodes for the Tcl bytecode instructions. These must correspond to the @@ -823,8 +840,16 @@ typedef struct ByteCode { #define INST_CLOCK_READ 189 +#define INST_DICT_GET_DEF 190 + +/* TIP 461 */ +#define INST_STR_LT 191 +#define INST_STR_GT 192 +#define INST_STR_LE 193 +#define INST_STR_GE 194 + /* The last opcode */ -#define LAST_INST_OPCODE 189 +#define LAST_INST_OPCODE 194 /* * Table describing the Tcl bytecode instructions: their name (for displaying @@ -1069,7 +1094,6 @@ 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, @@ -1098,7 +1122,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, char *bytes, +MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, const char *bytes, int length, unsigned int hash, int *newPtr, Namespace *nsPtr, int flags, LiteralEntry **globalPtrPtr); @@ -1123,8 +1147,9 @@ MODULE_SCOPE void TclFreeCompileEnv(CompileEnv *envPtr); MODULE_SCOPE void TclFreeJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE int TclGetIndexFromToken(Tcl_Token *tokenPtr, int before, int after, int *indexPtr); -MODULE_SCOPE void TclInitByteCodeObj(Tcl_Obj *objPtr, - CompileEnv *envPtr); +MODULE_SCOPE ByteCode * TclInitByteCode(CompileEnv *envPtr); +MODULE_SCOPE ByteCode * TclInitByteCodeObj(Tcl_Obj *objPtr, + const Tcl_ObjType *typePtr, CompileEnv *envPtr); MODULE_SCOPE void TclInitCompileEnv(Tcl_Interp *interp, CompileEnv *envPtr, const char *string, int numBytes, const CmdFrame *invoker, int word); @@ -1161,25 +1186,8 @@ MODULE_SCOPE void TclPushVarName(Tcl_Interp *interp, Tcl_Token *varTokenPtr, CompileEnv *envPtr, int flags, int *localIndexPtr, int *isScalarPtr); - -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 TclPreserveByteCode(ByteCode *codePtr); +MODULE_SCOPE void TclReleaseByteCode(ByteCode *codePtr); MODULE_SCOPE void TclReleaseLiteral(Tcl_Interp *interp, Tcl_Obj *objPtr); MODULE_SCOPE void TclInvalidateCmdLiteral(Tcl_Interp *interp, const char *name, Namespace *nsPtr); @@ -1209,7 +1217,7 @@ MODULE_SCOPE Tcl_Obj *TclGetInnerContext(Tcl_Interp *interp, const unsigned char *pc, Tcl_Obj **tosPtr); MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData, - register Tcl_Interp *interp, int objc, + Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int isLambda); @@ -1234,29 +1242,6 @@ 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. @@ -1420,7 +1405,7 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData, #define TclEmitPush(objIndex, envPtr) \ do { \ - register int _objIndexCopy = (objIndex); \ + int _objIndexCopy = (objIndex); \ if (_objIndexCopy <= 255) { \ TclEmitInstInt1(INST_PUSH1, _objIndexCopy, (envPtr)); \ } else { \ @@ -1571,9 +1556,9 @@ MODULE_SCOPE int TclPushProcCallFrame(ClientData clientData, */ #define PushLiteral(envPtr, string, length) \ - TclEmitPush(TclRegisterNewLiteral((envPtr), (string), (length)), (envPtr)) + TclEmitPush(TclRegisterLiteral(envPtr, string, length, 0), (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 2fb3e92..eb6807c 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -232,7 +232,7 @@ QueryConfigObjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj("package not known", -1)); Tcl_SetErrorCode(interp, "TCL", "FATAL", "PKGCFG_BASE", - Tcl_GetString(pkgName), NULL); + TclGetString(pkgName), NULL); return TCL_ERROR; } @@ -247,7 +247,7 @@ QueryConfigObjCmd( || val == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("key not known", -1)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONFIG", - Tcl_GetString(objv[2]), NULL); + TclGetString(objv[2]), NULL); return TCL_ERROR; } @@ -333,9 +333,9 @@ QueryConfigDelete( Tcl_DictObjRemove(NULL, pDB, pkgName); Tcl_DecrRefCount(pkgName); if (cdPtr->encoding) { - ckfree((char *)cdPtr->encoding); + ckfree(cdPtr->encoding); } - ckfree((char *)cdPtr); + ckfree(cdPtr); } /* diff --git a/generic/tclDate.c b/generic/tclDate.c index 717a1b3..32c71de 100644 --- a/generic/tclDate.c +++ b/generic/tclDate.c @@ -1,14 +1,13 @@ -/* A Bison parser, made by GNU Bison 2.3. */ +/* A Bison parser, made by GNU Bison 3.1. */ -/* Skeleton implementation for Bison's Yacc-like parsers in C +/* Bison implementation for Yacc-like parsers in C - Copyright (C) 1984, 1989, 1990, 2000, 2001, 2002, 2003, 2004, 2005, 2006 - Free Software Foundation, Inc. + Copyright (C) 1984, 1989-1990, 2000-2015, 2018 Free Software Foundation, Inc. - This program is free software; you can redistribute it and/or modify + This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 2, or (at your option) - any later version. + the Free Software Foundation, either version 3 of the License, or + (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of @@ -16,9 +15,7 @@ GNU General Public License for more details. You should have received a copy of the GNU General Public License - along with this program; if not, write to the Free Software - Foundation, Inc., 51 Franklin Street, Fifth Floor, - Boston, MA 02110-1301, USA. */ + along with this program. If not, see <http://www.gnu.org/licenses/>. */ /* As a special exception, you may create a larger work that contains part or all of the Bison parser skeleton and distribute that work @@ -47,7 +44,7 @@ #define YYBISON 1 /* Bison version. */ -#define YYBISON_VERSION "2.3" +#define YYBISON_VERSION "3.1" /* Skeleton name. */ #define YYSKELETON_NAME "yacc.c" @@ -55,64 +52,19 @@ /* Pure parsers. */ #define YYPURE 1 -/* Using locations. */ -#define YYLSP_NEEDED 1 +/* Push parsers. */ +#define YYPUSH 0 -/* Substitute the variable and function names. */ -#define yyparse TclDateparse -#define yylex TclDatelex -#define yyerror TclDateerror -#define yylval TclDatelval -#define yychar TclDatechar -#define yydebug TclDatedebug -#define yynerrs TclDatenerrs -#define yylloc TclDatelloc - -/* Tokens. */ -#ifndef YYTOKENTYPE -# define YYTOKENTYPE - /* Put the tokens into the symbol table, so that GDB and other debuggers - know about them. */ - enum yytokentype { - tAGO = 258, - tDAY = 259, - tDAYZONE = 260, - tID = 261, - tMERIDIAN = 262, - tMONTH = 263, - tMONTH_UNIT = 264, - tSTARDATE = 265, - tSEC_UNIT = 266, - tSNUMBER = 267, - tUNUMBER = 268, - tZONE = 269, - tEPOCH = 270, - tDST = 271, - tISOBASE = 272, - tDAY_UNIT = 273, - tNEXT = 274 - }; -#endif -/* Tokens. */ -#define tAGO 258 -#define tDAY 259 -#define tDAYZONE 260 -#define tID 261 -#define tMERIDIAN 262 -#define tMONTH 263 -#define tMONTH_UNIT 264 -#define tSTARDATE 265 -#define tSEC_UNIT 266 -#define tSNUMBER 267 -#define tUNUMBER 268 -#define tZONE 269 -#define tEPOCH 270 -#define tDST 271 -#define tISOBASE 272 -#define tDAY_UNIT 273 -#define tNEXT 274 +/* Pull parsers. */ +#define YYPULL 1 +/* Substitute the variable and function names. */ +#define yyparse TclDateparse +#define yylex TclDatelex +#define yyerror TclDateerror +#define yydebug TclDatedebug +#define yynerrs TclDatenerrs /* Copy the first part of user declarations. */ @@ -129,6 +81,7 @@ * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. + * */ #include "tclInt.h" @@ -256,10 +209,14 @@ typedef enum _MERIDIAN { -/* Enabling traces. */ -#ifndef YYDEBUG -# define YYDEBUG 0 -#endif + +# ifndef YY_NULLPTR +# if defined __cplusplus && 201103L <= __cplusplus +# define YY_NULLPTR nullptr +# else +# define YY_NULLPTR 0 +# endif +# endif /* Enabling verbose error messages. */ #ifdef YYERROR_VERBOSE @@ -269,40 +226,78 @@ typedef enum _MERIDIAN { # define YYERROR_VERBOSE 0 #endif -/* Enabling the token table. */ -#ifndef YYTOKEN_TABLE -# define YYTOKEN_TABLE 0 + +/* Debug traces. */ +#ifndef YYDEBUG +# define YYDEBUG 0 +#endif +#if YYDEBUG +extern int TclDatedebug; #endif +/* Token type. */ +#ifndef YYTOKENTYPE +# define YYTOKENTYPE + enum yytokentype + { + tAGO = 258, + tDAY = 259, + tDAYZONE = 260, + tID = 261, + tMERIDIAN = 262, + tMONTH = 263, + tMONTH_UNIT = 264, + tSTARDATE = 265, + tSEC_UNIT = 266, + tSNUMBER = 267, + tUNUMBER = 268, + tZONE = 269, + tEPOCH = 270, + tDST = 271, + tISOBASE = 272, + tDAY_UNIT = 273, + tNEXT = 274 + }; +#endif + +/* Value type. */ #if ! defined YYSTYPE && ! defined YYSTYPE_IS_DECLARED -typedef union YYSTYPE +union YYSTYPE { + + time_t Number; enum _MERIDIAN Meridian; -} -/* Line 187 of yacc.c. */ - YYSTYPE; -# define yystype YYSTYPE /* obsolescent; will be withdrawn */ -# define YYSTYPE_IS_DECLARED 1 + +}; + +typedef union YYSTYPE YYSTYPE; # define YYSTYPE_IS_TRIVIAL 1 +# define YYSTYPE_IS_DECLARED 1 #endif +/* Location type. */ #if ! defined YYLTYPE && ! defined YYLTYPE_IS_DECLARED -typedef struct YYLTYPE +typedef struct YYLTYPE YYLTYPE; +struct YYLTYPE { int first_line; int first_column; int last_line; int last_column; -} YYLTYPE; -# define yyltype YYLTYPE /* obsolescent; will be withdrawn */ +}; # define YYLTYPE_IS_DECLARED 1 # define YYLTYPE_IS_TRIVIAL 1 #endif + +int TclDateparse (DateInfo* info); + + + /* Copy the second part of user declarations. */ @@ -322,8 +317,6 @@ MODULE_SCOPE int yyparse(DateInfo*); -/* Line 216 of yacc.c. */ - #ifdef short # undef short @@ -337,72 +330,103 @@ typedef unsigned char yytype_uint8; #ifdef YYTYPE_INT8 typedef YYTYPE_INT8 yytype_int8; -#elif (defined __STDC__ || defined __C99__FUNC__ \ - || defined __cplusplus || defined _MSC_VER) -typedef signed char yytype_int8; #else -typedef short int yytype_int8; +typedef signed char yytype_int8; #endif #ifdef YYTYPE_UINT16 typedef YYTYPE_UINT16 yytype_uint16; #else -typedef unsigned short int yytype_uint16; +typedef unsigned short yytype_uint16; #endif #ifdef YYTYPE_INT16 typedef YYTYPE_INT16 yytype_int16; #else -typedef short int yytype_int16; +typedef short yytype_int16; #endif #ifndef YYSIZE_T # ifdef __SIZE_TYPE__ # define YYSIZE_T __SIZE_TYPE__ -# else +# elif defined size_t # define YYSIZE_T size_t +# elif ! defined YYSIZE_T +# include <stddef.h> /* INFRINGES ON USER NAME SPACE */ +# define YYSIZE_T size_t +# else +# define YYSIZE_T unsigned # endif #endif #define YYSIZE_MAXIMUM ((YYSIZE_T) -1) #ifndef YY_ -# if YYENABLE_NLS +# if defined YYENABLE_NLS && YYENABLE_NLS # if ENABLE_NLS # include <libintl.h> /* INFRINGES ON USER NAME SPACE */ -# define YY_(msgid) dgettext ("bison-runtime", msgid) +# define YY_(Msgid) dgettext ("bison-runtime", Msgid) # endif # endif # ifndef YY_ -# define YY_(msgid) msgid +# define YY_(Msgid) Msgid +# endif +#endif + +#ifndef YY_ATTRIBUTE +# if (defined __GNUC__ \ + && (2 < __GNUC__ || (__GNUC__ == 2 && 96 <= __GNUC_MINOR__))) \ + || defined __SUNPRO_C && 0x5110 <= __SUNPRO_C +# define YY_ATTRIBUTE(Spec) __attribute__(Spec) +# else +# define YY_ATTRIBUTE(Spec) /* empty */ +# endif +#endif + +#ifndef YY_ATTRIBUTE_PURE +# define YY_ATTRIBUTE_PURE YY_ATTRIBUTE ((__pure__)) +#endif + +#ifndef YY_ATTRIBUTE_UNUSED +# define YY_ATTRIBUTE_UNUSED YY_ATTRIBUTE ((__unused__)) +#endif + +#if !defined _Noreturn \ + && (!defined __STDC_VERSION__ || __STDC_VERSION__ < 201112) +# if defined _MSC_VER && 1200 <= _MSC_VER +# define _Noreturn __declspec (noreturn) +# else +# define _Noreturn YY_ATTRIBUTE ((__noreturn__)) # endif #endif /* Suppress unused-variable warnings by "using" E. */ #if ! defined lint || defined __GNUC__ -# define YYUSE(e) ((void) (e)) +# define YYUSE(E) ((void) (E)) #else -# define YYUSE(e) /* empty */ +# define YYUSE(E) /* empty */ #endif -/* Identity function, used to suppress warnings about constant conditions. */ -#ifndef lint -# define YYID(n) (n) -#else -#if (defined __STDC__ || defined __C99__FUNC__ \ - || defined __cplusplus || defined _MSC_VER) -static int -YYID (int i) +#if defined __GNUC__ && ! defined __ICC && 407 <= __GNUC__ * 100 + __GNUC_MINOR__ +/* Suppress an incorrect diagnostic about yylval being uninitialized. */ +# define YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN \ + _Pragma ("GCC diagnostic push") \ + _Pragma ("GCC diagnostic ignored \"-Wuninitialized\"")\ + _Pragma ("GCC diagnostic ignored \"-Wmaybe-uninitialized\"") +# define YY_IGNORE_MAYBE_UNINITIALIZED_END \ + _Pragma ("GCC diagnostic pop") #else -static int -YYID (i) - int i; +# define YY_INITIAL_VALUE(Value) Value #endif -{ - return i; -} +#ifndef YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN +# define YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN +# define YY_IGNORE_MAYBE_UNINITIALIZED_END +#endif +#ifndef YY_INITIAL_VALUE +# define YY_INITIAL_VALUE(Value) /* Nothing. */ #endif + #if ! defined yyoverflow || YYERROR_VERBOSE /* The parser invokes alloca or malloc; define the necessary symbols. */ @@ -420,11 +444,11 @@ YYID (i) # define alloca _alloca # else # define YYSTACK_ALLOC alloca -# if ! defined _ALLOCA_H && ! defined _STDLIB_H && (defined __STDC__ || defined __C99__FUNC__ \ - || defined __cplusplus || defined _MSC_VER) +# if ! defined _ALLOCA_H && ! defined EXIT_SUCCESS # include <stdlib.h> /* INFRINGES ON USER NAME SPACE */ -# ifndef _STDLIB_H -# define _STDLIB_H 1 + /* Use EXIT_SUCCESS as a witness for stdlib.h. */ +# ifndef EXIT_SUCCESS +# define EXIT_SUCCESS 0 # endif # endif # endif @@ -432,8 +456,8 @@ YYID (i) # endif # ifdef YYSTACK_ALLOC - /* Pacify GCC's `empty if-body' warning. */ -# define YYSTACK_FREE(Ptr) do { /* empty */; } while (YYID (0)) + /* Pacify GCC's 'empty if-body' warning. */ +# define YYSTACK_FREE(Ptr) do { /* empty */; } while (0) # ifndef YYSTACK_ALLOC_MAXIMUM /* The OS might guarantee only one guard page at the bottom of the stack, and a page size can be as small as 4096 bytes. So we cannot safely @@ -447,25 +471,23 @@ YYID (i) # ifndef YYSTACK_ALLOC_MAXIMUM # define YYSTACK_ALLOC_MAXIMUM YYSIZE_MAXIMUM # endif -# if (defined __cplusplus && ! defined _STDLIB_H \ +# if (defined __cplusplus && ! defined EXIT_SUCCESS \ && ! ((defined YYMALLOC || defined malloc) \ - && (defined YYFREE || defined free))) + && (defined YYFREE || defined free))) # include <stdlib.h> /* INFRINGES ON USER NAME SPACE */ -# ifndef _STDLIB_H -# define _STDLIB_H 1 +# ifndef EXIT_SUCCESS +# define EXIT_SUCCESS 0 # endif # endif # ifndef YYMALLOC # define YYMALLOC malloc -# if ! defined malloc && ! defined _STDLIB_H && (defined __STDC__ || defined __C99__FUNC__ \ - || defined __cplusplus || defined _MSC_VER) +# if ! defined malloc && ! defined EXIT_SUCCESS void *malloc (YYSIZE_T); /* INFRINGES ON USER NAME SPACE */ # endif # endif # ifndef YYFREE # define YYFREE free -# if ! defined free && ! defined _STDLIB_H && (defined __STDC__ || defined __C99__FUNC__ \ - || defined __cplusplus || defined _MSC_VER) +# if ! defined free && ! defined EXIT_SUCCESS void free (void *); /* INFRINGES ON USER NAME SPACE */ # endif # endif @@ -475,15 +497,15 @@ void free (void *); /* INFRINGES ON USER NAME SPACE */ #if (! defined yyoverflow \ && (! defined __cplusplus \ - || (defined YYLTYPE_IS_TRIVIAL && YYLTYPE_IS_TRIVIAL \ - && defined YYSTYPE_IS_TRIVIAL && YYSTYPE_IS_TRIVIAL))) + || (defined YYLTYPE_IS_TRIVIAL && YYLTYPE_IS_TRIVIAL \ + && defined YYSTYPE_IS_TRIVIAL && YYSTYPE_IS_TRIVIAL))) /* A type that is properly aligned for any stack member. */ union yyalloc { - yytype_int16 yyss; - YYSTYPE yyvs; - YYLTYPE yyls; + yytype_int16 yyss_alloc; + YYSTYPE yyvs_alloc; + YYLTYPE yyls_alloc; }; /* The size of the maximum gap between one aligned stack and the next. */ @@ -495,42 +517,46 @@ union yyalloc ((N) * (sizeof (yytype_int16) + sizeof (YYSTYPE) + sizeof (YYLTYPE)) \ + 2 * YYSTACK_GAP_MAXIMUM) -/* Copy COUNT objects from FROM to TO. The source and destination do - not overlap. */ -# ifndef YYCOPY -# if defined __GNUC__ && 1 < __GNUC__ -# define YYCOPY(To, From, Count) \ - __builtin_memcpy (To, From, (Count) * sizeof (*(From))) -# else -# define YYCOPY(To, From, Count) \ - do \ - { \ - YYSIZE_T yyi; \ - for (yyi = 0; yyi < (Count); yyi++) \ - (To)[yyi] = (From)[yyi]; \ - } \ - while (YYID (0)) -# endif -# endif +# define YYCOPY_NEEDED 1 /* Relocate STACK from its old location to the new one. The local variables YYSIZE and YYSTACKSIZE give the old and new number of elements in the stack, and YYPTR gives the new location of the stack. Advance YYPTR to a properly aligned location for the next stack. */ -# define YYSTACK_RELOCATE(Stack) \ - do \ - { \ - YYSIZE_T yynewbytes; \ - YYCOPY (&yyptr->Stack, Stack, yysize); \ - Stack = &yyptr->Stack; \ - yynewbytes = yystacksize * sizeof (*Stack) + YYSTACK_GAP_MAXIMUM; \ - yyptr += yynewbytes / sizeof (*yyptr); \ - } \ - while (YYID (0)) +# define YYSTACK_RELOCATE(Stack_alloc, Stack) \ + do \ + { \ + YYSIZE_T yynewbytes; \ + YYCOPY (&yyptr->Stack_alloc, Stack, yysize); \ + Stack = &yyptr->Stack_alloc; \ + yynewbytes = yystacksize * sizeof (*Stack) + YYSTACK_GAP_MAXIMUM; \ + yyptr += yynewbytes / sizeof (*yyptr); \ + } \ + while (0) #endif +#if defined YYCOPY_NEEDED && YYCOPY_NEEDED +/* Copy COUNT objects from SRC to DST. The source and destination do + not overlap. */ +# ifndef YYCOPY +# if defined __GNUC__ && 1 < __GNUC__ +# define YYCOPY(Dst, Src, Count) \ + __builtin_memcpy (Dst, Src, (Count) * sizeof (*(Src))) +# else +# define YYCOPY(Dst, Src, Count) \ + do \ + { \ + YYSIZE_T yyi; \ + for (yyi = 0; yyi < (Count); yyi++) \ + (Dst)[yyi] = (Src)[yyi]; \ + } \ + while (0) +# endif +# endif +#endif /* !YYCOPY_NEEDED */ + /* YYFINAL -- State number of the termination state. */ #define YYFINAL 2 /* YYLAST -- Last index in YYTABLE. */ @@ -542,17 +568,19 @@ union yyalloc #define YYNNTS 16 /* YYNRULES -- Number of rules. */ #define YYNRULES 56 -/* YYNRULES -- Number of states. */ +/* YYNSTATES -- Number of states. */ #define YYNSTATES 83 -/* YYTRANSLATE(YYLEX) -- Bison symbol number corresponding to YYLEX. */ +/* YYTRANSLATE[YYX] -- Symbol number corresponding to YYX as returned + by yylex, with out-of-bounds checking. */ #define YYUNDEFTOK 2 #define YYMAXUTOK 274 -#define YYTRANSLATE(YYX) \ - ((unsigned int) (YYX) <= YYMAXUTOK ? yytranslate[YYX] : YYUNDEFTOK) +#define YYTRANSLATE(YYX) \ + ((unsigned) (YYX) <= YYMAXUTOK ? yytranslate[YYX] : YYUNDEFTOK) -/* YYTRANSLATE[YYLEX] -- Bison symbol number corresponding to YYLEX. */ +/* YYTRANSLATE[TOKEN-NUM] -- Symbol number corresponding to TOKEN-NUM + as returned by yylex, without out-of-bounds checking. */ static const yytype_uint8 yytranslate[] = { 0, 2, 2, 2, 2, 2, 2, 2, 2, 2, @@ -586,54 +614,19 @@ static const yytype_uint8 yytranslate[] = }; #if YYDEBUG -/* YYPRHS[YYN] -- Index of the first RHS symbol of rule number YYN in - YYRHS. */ -static const yytype_uint8 yyprhs[] = -{ - 0, 0, 3, 4, 7, 9, 11, 13, 15, 17, - 19, 21, 23, 25, 28, 33, 39, 46, 54, 57, - 59, 61, 63, 66, 69, 73, 76, 80, 86, 88, - 94, 100, 103, 108, 111, 113, 117, 120, 124, 128, - 136, 139, 144, 147, 149, 153, 156, 159, 163, 165, - 167, 169, 171, 173, 175, 177, 178 -}; - -/* YYRHS -- A `-1'-separated list of the rules' RHS. */ -static const yytype_int8 yyrhs[] = -{ - 27, 0, -1, -1, 27, 28, -1, 29, -1, 30, - -1, 32, -1, 33, -1, 31, -1, 36, -1, 34, - -1, 35, -1, 40, -1, 13, 7, -1, 13, 20, - 13, 41, -1, 13, 20, 13, 21, 13, -1, 13, - 20, 13, 20, 13, 41, -1, 13, 20, 13, 20, - 13, 21, 13, -1, 14, 16, -1, 14, -1, 5, - -1, 4, -1, 4, 22, -1, 13, 4, -1, 38, - 13, 4, -1, 19, 4, -1, 13, 23, 13, -1, - 13, 23, 13, 23, 13, -1, 17, -1, 13, 21, - 8, 21, 13, -1, 13, 21, 13, 21, 13, -1, - 8, 13, -1, 8, 13, 22, 13, -1, 13, 8, - -1, 15, -1, 13, 8, 13, -1, 19, 8, -1, - 19, 13, 8, -1, 17, 14, 17, -1, 17, 14, - 13, 20, 13, 20, 13, -1, 17, 17, -1, 10, - 13, 24, 13, -1, 37, 3, -1, 37, -1, 38, - 13, 39, -1, 13, 39, -1, 19, 39, -1, 19, - 13, 39, -1, 39, -1, 21, -1, 25, -1, 11, - -1, 18, -1, 9, -1, 13, -1, -1, 7, -1 -}; - -/* YYRLINE[YYN] -- source line where rule number YYN was defined. */ + /* YYRLINE[YYN] -- Source line where rule number YYN was defined. */ static const yytype_uint16 yyrline[] = { - 0, 225, 225, 226, 229, 232, 235, 238, 241, 244, - 247, 251, 256, 259, 265, 271, 279, 285, 296, 300, - 304, 310, 314, 318, 322, 326, 332, 336, 341, 346, - 351, 356, 360, 365, 369, 374, 381, 385, 391, 400, - 409, 419, 433, 438, 441, 444, 447, 450, 453, 458, - 461, 466, 470, 474, 480, 498, 501 + 0, 223, 223, 224, 227, 230, 233, 236, 239, 242, + 245, 249, 254, 257, 263, 269, 277, 283, 294, 298, + 302, 308, 312, 316, 320, 324, 330, 334, 339, 344, + 349, 354, 358, 363, 367, 372, 379, 383, 389, 398, + 407, 417, 431, 436, 439, 442, 445, 448, 451, 456, + 459, 464, 468, 472, 478, 496, 499 }; #endif -#if YYDEBUG || YYERROR_VERBOSE || YYTOKEN_TABLE +#if YYDEBUG || YYERROR_VERBOSE || 0 /* YYTNAME[SYMBOL-NUM] -- String name of the symbol SYMBOL-NUM. First, the terminals, then, starting at YYNTOKENS, nonterminals. */ static const char *const yytname[] = @@ -644,13 +637,13 @@ static const char *const yytname[] = "tDAY_UNIT", "tNEXT", "':'", "'-'", "','", "'/'", "'.'", "'+'", "$accept", "spec", "item", "time", "zone", "day", "date", "ordMonth", "iso", "trek", "relspec", "relunits", "sign", "unit", "number", - "o_merid", 0 + "o_merid", YY_NULLPTR }; #endif # ifdef YYPRINT -/* YYTOKNUM[YYLEX-NUM] -- Internal token number corresponding to - token YYLEX-NUM. */ +/* YYTOKNUM[NUM] -- (External) token number corresponding to the + (internal) symbol number NUM (which must be that of a token). */ static const yytype_uint16 yytoknum[] = { 0, 256, 257, 258, 259, 260, 261, 262, 263, 264, @@ -659,54 +652,18 @@ static const yytype_uint16 yytoknum[] = }; # endif -/* YYR1[YYN] -- Symbol number of symbol that rule YYN derives. */ -static const yytype_uint8 yyr1[] = -{ - 0, 26, 27, 27, 28, 28, 28, 28, 28, 28, - 28, 28, 28, 29, 29, 29, 29, 29, 30, 30, - 30, 31, 31, 31, 31, 31, 32, 32, 32, 32, - 32, 32, 32, 32, 32, 32, 33, 33, 34, 34, - 34, 35, 36, 36, 37, 37, 37, 37, 37, 38, - 38, 39, 39, 39, 40, 41, 41 -}; +#define YYPACT_NINF -22 -/* YYR2[YYN] -- Number of symbols composing right hand side of rule YYN. */ -static const yytype_uint8 yyr2[] = -{ - 0, 2, 0, 2, 1, 1, 1, 1, 1, 1, - 1, 1, 1, 2, 4, 5, 6, 7, 2, 1, - 1, 1, 2, 2, 3, 2, 3, 5, 1, 5, - 5, 2, 4, 2, 1, 3, 2, 3, 3, 7, - 2, 4, 2, 1, 3, 2, 2, 3, 1, 1, - 1, 1, 1, 1, 1, 0, 1 -}; +#define yypact_value_is_default(Yystate) \ + (!!((Yystate) == (-22))) -/* YYDEFACT[STATE-NAME] -- Default rule to reduce with in state - STATE-NUM when YYTABLE doesn't specify something else to do. Zero - means the default is an error. */ -static const yytype_uint8 yydefact[] = -{ - 2, 0, 1, 21, 20, 0, 53, 0, 51, 54, - 19, 34, 28, 52, 0, 49, 50, 3, 4, 5, - 8, 6, 7, 10, 11, 9, 43, 0, 48, 12, - 22, 31, 0, 23, 13, 33, 0, 0, 0, 45, - 18, 0, 40, 25, 36, 0, 46, 42, 0, 0, - 0, 35, 55, 0, 0, 26, 0, 38, 37, 47, - 24, 44, 32, 41, 56, 0, 0, 14, 0, 0, - 0, 0, 55, 15, 29, 30, 27, 0, 0, 16, - 0, 17, 39 -}; +#define YYTABLE_NINF -1 -/* YYDEFGOTO[NTERM-NUM]. */ -static const yytype_int8 yydefgoto[] = -{ - -1, 1, 17, 18, 19, 20, 21, 22, 23, 24, - 25, 26, 27, 28, 29, 67 -}; +#define yytable_value_is_error(Yytable_value) \ + 0 -/* YYPACT[STATE-NUM] -- Index in YYTABLE of the portion describing - STATE-NUM. */ -#define YYPACT_NINF -22 + /* YYPACT[STATE-NUM] -- Index in YYTABLE of the portion describing + STATE-NUM. */ static const yytype_int8 yypact[] = { -22, 2, -22, -21, -22, -4, -22, 1, -22, 22, @@ -720,18 +677,39 @@ static const yytype_int8 yypact[] = 64, -22, -22 }; -/* YYPGOTO[NTERM-NUM]. */ + /* YYDEFACT[STATE-NUM] -- Default reduction number in state STATE-NUM. + Performed when YYTABLE does not specify something else to do. Zero + means the default is an error. */ +static const yytype_uint8 yydefact[] = +{ + 2, 0, 1, 21, 20, 0, 53, 0, 51, 54, + 19, 34, 28, 52, 0, 49, 50, 3, 4, 5, + 8, 6, 7, 10, 11, 9, 43, 0, 48, 12, + 22, 31, 0, 23, 13, 33, 0, 0, 0, 45, + 18, 0, 40, 25, 36, 0, 46, 42, 0, 0, + 0, 35, 55, 0, 0, 26, 0, 38, 37, 47, + 24, 44, 32, 41, 56, 0, 0, 14, 0, 0, + 0, 0, 55, 15, 29, 30, 27, 0, 0, 16, + 0, 17, 39 +}; + + /* YYPGOTO[NTERM-NUM]. */ static const yytype_int8 yypgoto[] = { -22, -22, -22, -22, -22, -22, -22, -22, -22, -22, -22, -22, -22, -9, -22, 6 }; -/* YYTABLE[YYPACT[STATE-NUM]]. What to do in state STATE-NUM. If - positive, shift that token. If negative, reduce the rule which - number is the opposite. If zero, do what YYDEFACT says. - If YYTABLE_NINF, syntax error. */ -#define YYTABLE_NINF -1 + /* YYDEFGOTO[NTERM-NUM]. */ +static const yytype_int8 yydefgoto[] = +{ + -1, 1, 17, 18, 19, 20, 21, 22, 23, 24, + 25, 26, 27, 28, 29, 67 +}; + + /* YYTABLE[YYPACT[STATE-NUM]] -- What to do in state STATE-NUM. If + positive, shift that token. If negative, reduce the rule whose + number is the opposite. If YYTABLE_NINF, syntax error. */ static const yytype_uint8 yytable[] = { 39, 30, 2, 53, 64, 46, 3, 4, 54, 31, @@ -756,8 +734,8 @@ static const yytype_uint8 yycheck[] = 13, 13, 20, 13, 13, 13, 13, 13, 72, 20 }; -/* YYSTOS[STATE-NUM] -- The (internal number of the) accessing - symbol of state STATE-NUM. */ + /* YYSTOS[STATE-NUM] -- The (internal number of the) accessing + symbol of state STATE-NUM. */ static const yytype_uint8 yystos[] = { 0, 27, 0, 4, 5, 8, 9, 10, 11, 13, @@ -771,156 +749,179 @@ static const yytype_uint8 yystos[] = 20, 13, 13 }; -#define yyerrok (yyerrstatus = 0) -#define yyclearin (yychar = YYEMPTY) -#define YYEMPTY (-2) -#define YYEOF 0 + /* YYR1[YYN] -- Symbol number of symbol that rule YYN derives. */ +static const yytype_uint8 yyr1[] = +{ + 0, 26, 27, 27, 28, 28, 28, 28, 28, 28, + 28, 28, 28, 29, 29, 29, 29, 29, 30, 30, + 30, 31, 31, 31, 31, 31, 32, 32, 32, 32, + 32, 32, 32, 32, 32, 32, 33, 33, 34, 34, + 34, 35, 36, 36, 37, 37, 37, 37, 37, 38, + 38, 39, 39, 39, 40, 41, 41 +}; + + /* YYR2[YYN] -- Number of symbols on the right hand side of rule YYN. */ +static const yytype_uint8 yyr2[] = +{ + 0, 2, 0, 2, 1, 1, 1, 1, 1, 1, + 1, 1, 1, 2, 4, 5, 6, 7, 2, 1, + 1, 1, 2, 2, 3, 2, 3, 5, 1, 5, + 5, 2, 4, 2, 1, 3, 2, 3, 3, 7, + 2, 4, 2, 1, 3, 2, 2, 3, 1, 1, + 1, 1, 1, 1, 1, 0, 1 +}; -#define YYACCEPT goto yyacceptlab -#define YYABORT goto yyabortlab -#define YYERROR goto yyerrorlab +#define yyerrok (yyerrstatus = 0) +#define yyclearin (yychar = YYEMPTY) +#define YYEMPTY (-2) +#define YYEOF 0 -/* Like YYERROR except do call yyerror. This remains here temporarily - to ease the transition to the new meaning of YYERROR, for GCC. - Once GCC version 2 has supplanted version 1, this can go. */ +#define YYACCEPT goto yyacceptlab +#define YYABORT goto yyabortlab +#define YYERROR goto yyerrorlab -#define YYFAIL goto yyerrlab #define YYRECOVERING() (!!yyerrstatus) -#define YYBACKUP(Token, Value) \ -do \ - if (yychar == YYEMPTY && yylen == 1) \ - { \ - yychar = (Token); \ - yylval = (Value); \ - yytoken = YYTRANSLATE (yychar); \ - YYPOPSTACK (1); \ - goto yybackup; \ - } \ - else \ - { \ +#define YYBACKUP(Token, Value) \ +do \ + if (yychar == YYEMPTY) \ + { \ + yychar = (Token); \ + yylval = (Value); \ + YYPOPSTACK (yylen); \ + yystate = *yyssp; \ + goto yybackup; \ + } \ + else \ + { \ yyerror (&yylloc, info, YY_("syntax error: cannot back up")); \ - YYERROR; \ - } \ -while (YYID (0)) + YYERROR; \ + } \ +while (0) - -#define YYTERROR 1 -#define YYERRCODE 256 +/* Error token number */ +#define YYTERROR 1 +#define YYERRCODE 256 /* YYLLOC_DEFAULT -- Set CURRENT to span from RHS[1] to RHS[N]. If N is 0, then set CURRENT to the empty location which ends the previous symbol: RHS[0] (always defined). */ -#define YYRHSLOC(Rhs, K) ((Rhs)[K]) #ifndef YYLLOC_DEFAULT -# define YYLLOC_DEFAULT(Current, Rhs, N) \ - do \ - if (YYID (N)) \ - { \ - (Current).first_line = YYRHSLOC (Rhs, 1).first_line; \ - (Current).first_column = YYRHSLOC (Rhs, 1).first_column; \ - (Current).last_line = YYRHSLOC (Rhs, N).last_line; \ - (Current).last_column = YYRHSLOC (Rhs, N).last_column; \ - } \ - else \ - { \ - (Current).first_line = (Current).last_line = \ - YYRHSLOC (Rhs, 0).last_line; \ - (Current).first_column = (Current).last_column = \ - YYRHSLOC (Rhs, 0).last_column; \ - } \ - while (YYID (0)) +# define YYLLOC_DEFAULT(Current, Rhs, N) \ + do \ + if (N) \ + { \ + (Current).first_line = YYRHSLOC (Rhs, 1).first_line; \ + (Current).first_column = YYRHSLOC (Rhs, 1).first_column; \ + (Current).last_line = YYRHSLOC (Rhs, N).last_line; \ + (Current).last_column = YYRHSLOC (Rhs, N).last_column; \ + } \ + else \ + { \ + (Current).first_line = (Current).last_line = \ + YYRHSLOC (Rhs, 0).last_line; \ + (Current).first_column = (Current).last_column = \ + YYRHSLOC (Rhs, 0).last_column; \ + } \ + while (0) #endif +#define YYRHSLOC(Rhs, K) ((Rhs)[K]) + + +/* Enable debugging if requested. */ +#if YYDEBUG + +# ifndef YYFPRINTF +# include <stdio.h> /* INFRINGES ON USER NAME SPACE */ +# define YYFPRINTF fprintf +# endif + +# define YYDPRINTF(Args) \ +do { \ + if (yydebug) \ + YYFPRINTF Args; \ +} while (0) + /* YY_LOCATION_PRINT -- Print the location on the stream. This macro was not mandated originally: define only if we know we won't break user code: when these are the locations we know. */ #ifndef YY_LOCATION_PRINT -# if YYLTYPE_IS_TRIVIAL -# define YY_LOCATION_PRINT(File, Loc) \ - fprintf (File, "%d.%d-%d.%d", \ - (Loc).first_line, (Loc).first_column, \ - (Loc).last_line, (Loc).last_column) -# else -# define YY_LOCATION_PRINT(File, Loc) ((void) 0) -# endif -#endif - +# if defined YYLTYPE_IS_TRIVIAL && YYLTYPE_IS_TRIVIAL -/* YYLEX -- calling `yylex' with the right arguments. */ +/* Print *YYLOCP on YYO. Private, do not rely on its existence. */ -#ifdef YYLEX_PARAM -# define YYLEX yylex (&yylval, &yylloc, YYLEX_PARAM) -#else -# define YYLEX yylex (&yylval, &yylloc, info) -#endif +YY_ATTRIBUTE_UNUSED +static unsigned +yy_location_print_ (FILE *yyo, YYLTYPE const * const yylocp) +{ + unsigned res = 0; + int end_col = 0 != yylocp->last_column ? yylocp->last_column - 1 : 0; + if (0 <= yylocp->first_line) + { + res += YYFPRINTF (yyo, "%d", yylocp->first_line); + if (0 <= yylocp->first_column) + res += YYFPRINTF (yyo, ".%d", yylocp->first_column); + } + if (0 <= yylocp->last_line) + { + if (yylocp->first_line < yylocp->last_line) + { + res += YYFPRINTF (yyo, "-%d", yylocp->last_line); + if (0 <= end_col) + res += YYFPRINTF (yyo, ".%d", end_col); + } + else if (0 <= end_col && yylocp->first_column < end_col) + res += YYFPRINTF (yyo, "-%d", end_col); + } + return res; + } -/* Enable debugging if requested. */ -#if YYDEBUG +# define YY_LOCATION_PRINT(File, Loc) \ + yy_location_print_ (File, &(Loc)) -# ifndef YYFPRINTF -# include <stdio.h> /* INFRINGES ON USER NAME SPACE */ -# define YYFPRINTF fprintf +# else +# define YY_LOCATION_PRINT(File, Loc) ((void) 0) # endif +#endif -# define YYDPRINTF(Args) \ -do { \ - if (yydebug) \ - YYFPRINTF Args; \ -} while (YYID (0)) -# define YY_SYMBOL_PRINT(Title, Type, Value, Location) \ -do { \ - if (yydebug) \ - { \ - YYFPRINTF (stderr, "%s ", Title); \ - yy_symbol_print (stderr, \ - Type, Value, Location, info); \ - YYFPRINTF (stderr, "\n"); \ - } \ -} while (YYID (0)) +# define YY_SYMBOL_PRINT(Title, Type, Value, Location) \ +do { \ + if (yydebug) \ + { \ + YYFPRINTF (stderr, "%s ", Title); \ + yy_symbol_print (stderr, \ + Type, Value, Location, info); \ + YYFPRINTF (stderr, "\n"); \ + } \ +} while (0) -/*--------------------------------. -| Print this symbol on YYOUTPUT. | -`--------------------------------*/ +/*----------------------------------------. +| Print this symbol's value on YYOUTPUT. | +`----------------------------------------*/ -/*ARGSUSED*/ -#if (defined __STDC__ || defined __C99__FUNC__ \ - || defined __cplusplus || defined _MSC_VER) static void yy_symbol_value_print (FILE *yyoutput, int yytype, YYSTYPE const * const yyvaluep, YYLTYPE const * const yylocationp, DateInfo* info) -#else -static void -yy_symbol_value_print (yyoutput, yytype, yyvaluep, yylocationp, info) - FILE *yyoutput; - int yytype; - YYSTYPE const * const yyvaluep; - YYLTYPE const * const yylocationp; - DateInfo* info; -#endif { - if (!yyvaluep) - return; + FILE *yyo = yyoutput; + YYUSE (yyo); YYUSE (yylocationp); YYUSE (info); + if (!yyvaluep) + return; # ifdef YYPRINT if (yytype < YYNTOKENS) YYPRINT (yyoutput, yytoknum[yytype], *yyvaluep); -# else - YYUSE (yyoutput); # endif - switch (yytype) - { - default: - break; - } + YYUSE (yytype); } @@ -928,24 +929,11 @@ yy_symbol_value_print (yyoutput, yytype, yyvaluep, yylocationp, info) | Print this symbol on YYOUTPUT. | `--------------------------------*/ -#if (defined __STDC__ || defined __C99__FUNC__ \ - || defined __cplusplus || defined _MSC_VER) static void yy_symbol_print (FILE *yyoutput, int yytype, YYSTYPE const * const yyvaluep, YYLTYPE const * const yylocationp, DateInfo* info) -#else -static void -yy_symbol_print (yyoutput, yytype, yyvaluep, yylocationp, info) - FILE *yyoutput; - int yytype; - YYSTYPE const * const yyvaluep; - YYLTYPE const * const yylocationp; - DateInfo* info; -#endif { - if (yytype < YYNTOKENS) - YYFPRINTF (yyoutput, "token %s (", yytname[yytype]); - else - YYFPRINTF (yyoutput, "nterm %s (", yytname[yytype]); + YYFPRINTF (yyoutput, "%s %s (", + yytype < YYNTOKENS ? "token" : "nterm", yytname[yytype]); YY_LOCATION_PRINT (yyoutput, *yylocationp); YYFPRINTF (yyoutput, ": "); @@ -958,68 +946,54 @@ yy_symbol_print (yyoutput, yytype, yyvaluep, yylocationp, info) | TOP (included). | `------------------------------------------------------------------*/ -#if (defined __STDC__ || defined __C99__FUNC__ \ - || defined __cplusplus || defined _MSC_VER) -static void -yy_stack_print (yytype_int16 *bottom, yytype_int16 *top) -#else static void -yy_stack_print (bottom, top) - yytype_int16 *bottom; - yytype_int16 *top; -#endif +yy_stack_print (yytype_int16 *yybottom, yytype_int16 *yytop) { YYFPRINTF (stderr, "Stack now"); - for (; bottom <= top; ++bottom) - YYFPRINTF (stderr, " %d", *bottom); + for (; yybottom <= yytop; yybottom++) + { + int yybot = *yybottom; + YYFPRINTF (stderr, " %d", yybot); + } YYFPRINTF (stderr, "\n"); } -# define YY_STACK_PRINT(Bottom, Top) \ -do { \ - if (yydebug) \ - yy_stack_print ((Bottom), (Top)); \ -} while (YYID (0)) +# define YY_STACK_PRINT(Bottom, Top) \ +do { \ + if (yydebug) \ + yy_stack_print ((Bottom), (Top)); \ +} while (0) /*------------------------------------------------. | Report that the YYRULE is going to be reduced. | `------------------------------------------------*/ -#if (defined __STDC__ || defined __C99__FUNC__ \ - || defined __cplusplus || defined _MSC_VER) static void -yy_reduce_print (YYSTYPE *yyvsp, YYLTYPE *yylsp, int yyrule, DateInfo* info) -#else -static void -yy_reduce_print (yyvsp, yylsp, yyrule, info) - YYSTYPE *yyvsp; - YYLTYPE *yylsp; - int yyrule; - DateInfo* info; -#endif +yy_reduce_print (yytype_int16 *yyssp, YYSTYPE *yyvsp, YYLTYPE *yylsp, int yyrule, DateInfo* info) { + unsigned long yylno = yyrline[yyrule]; int yynrhs = yyr2[yyrule]; int yyi; - unsigned long int yylno = yyrline[yyrule]; YYFPRINTF (stderr, "Reducing stack by rule %d (line %lu):\n", - yyrule - 1, yylno); + yyrule - 1, yylno); /* The symbols being reduced. */ for (yyi = 0; yyi < yynrhs; yyi++) { - fprintf (stderr, " $%d = ", yyi + 1); - yy_symbol_print (stderr, yyrhs[yyprhs[yyrule] + yyi], - &(yyvsp[(yyi + 1) - (yynrhs)]) - , &(yylsp[(yyi + 1) - (yynrhs)]) , info); - fprintf (stderr, "\n"); + YYFPRINTF (stderr, " $%d = ", yyi + 1); + yy_symbol_print (stderr, + yystos[yyssp[yyi + 1 - yynrhs]], + &(yyvsp[(yyi + 1) - (yynrhs)]) + , &(yylsp[(yyi + 1) - (yynrhs)]) , info); + YYFPRINTF (stderr, "\n"); } } -# define YY_REDUCE_PRINT(Rule) \ -do { \ - if (yydebug) \ - yy_reduce_print (yyvsp, yylsp, Rule, info); \ -} while (YYID (0)) +# define YY_REDUCE_PRINT(Rule) \ +do { \ + if (yydebug) \ + yy_reduce_print (yyssp, yyvsp, yylsp, Rule, info); \ +} while (0) /* Nonzero means print parse trace. It is left uninitialized so that multiple parsers can coexist. */ @@ -1033,7 +1007,7 @@ int yydebug; /* YYINITDEPTH -- initial size of the parser's stacks. */ -#ifndef YYINITDEPTH +#ifndef YYINITDEPTH # define YYINITDEPTH 200 #endif @@ -1048,7 +1022,6 @@ int yydebug; # define YYMAXDEPTH 10000 #endif - #if YYERROR_VERBOSE @@ -1057,15 +1030,8 @@ int yydebug; # define yystrlen strlen # else /* Return the length of YYSTR. */ -#if (defined __STDC__ || defined __C99__FUNC__ \ - || defined __cplusplus || defined _MSC_VER) static YYSIZE_T yystrlen (const char *yystr) -#else -static YYSIZE_T -yystrlen (yystr) - const char *yystr; -#endif { YYSIZE_T yylen; for (yylen = 0; yystr[yylen]; yylen++) @@ -1081,16 +1047,8 @@ yystrlen (yystr) # else /* Copy YYSRC to YYDEST, returning the address of the terminating '\0' in YYDEST. */ -#if (defined __STDC__ || defined __C99__FUNC__ \ - || defined __cplusplus || defined _MSC_VER) static char * yystpcpy (char *yydest, const char *yysrc) -#else -static char * -yystpcpy (yydest, yysrc) - char *yydest; - const char *yysrc; -#endif { char *yyd = yydest; const char *yys = yysrc; @@ -1120,27 +1078,27 @@ yytnamerr (char *yyres, const char *yystr) char const *yyp = yystr; for (;;) - switch (*++yyp) - { - case '\'': - case ',': - goto do_not_strip_quotes; - - case '\\': - if (*++yyp != '\\') - goto do_not_strip_quotes; - /* Fall through. */ - default: - if (yyres) - yyres[yyn] = *yyp; - yyn++; - break; - - case '"': - if (yyres) - yyres[yyn] = '\0'; - return yyn; - } + switch (*++yyp) + { + case '\'': + case ',': + goto do_not_strip_quotes; + + case '\\': + if (*++yyp != '\\') + goto do_not_strip_quotes; + /* Fall through. */ + default: + if (yyres) + yyres[yyn] = *yyp; + yyn++; + break; + + case '"': + if (yyres) + yyres[yyn] = '\0'; + return yyn; + } do_not_strip_quotes: ; } @@ -1151,169 +1109,161 @@ yytnamerr (char *yyres, const char *yystr) } # endif -/* Copy into YYRESULT an error message about the unexpected token - YYCHAR while in state YYSTATE. Return the number of bytes copied, - including the terminating null byte. If YYRESULT is null, do not - copy anything; just return the number of bytes that would be - copied. As a special case, return 0 if an ordinary "syntax error" - message will do. Return YYSIZE_MAXIMUM if overflow occurs during - size calculation. */ -static YYSIZE_T -yysyntax_error (char *yyresult, int yystate, int yychar) +/* Copy into *YYMSG, which is of size *YYMSG_ALLOC, an error message + about the unexpected token YYTOKEN for the state stack whose top is + YYSSP. + + Return 0 if *YYMSG was successfully written. Return 1 if *YYMSG is + not large enough to hold the message. In that case, also set + *YYMSG_ALLOC to the required number of bytes. Return 2 if the + required number of bytes is too large to store. */ +static int +yysyntax_error (YYSIZE_T *yymsg_alloc, char **yymsg, + yytype_int16 *yyssp, int yytoken) { - int yyn = yypact[yystate]; + YYSIZE_T yysize0 = yytnamerr (YY_NULLPTR, yytname[yytoken]); + YYSIZE_T yysize = yysize0; + enum { YYERROR_VERBOSE_ARGS_MAXIMUM = 5 }; + /* Internationalized format string. */ + const char *yyformat = YY_NULLPTR; + /* Arguments of yyformat. */ + char const *yyarg[YYERROR_VERBOSE_ARGS_MAXIMUM]; + /* Number of reported tokens (one for the "unexpected", one per + "expected"). */ + int yycount = 0; + + /* There are many possibilities here to consider: + - If this state is a consistent state with a default action, then + the only way this function was invoked is if the default action + is an error action. In that case, don't check for expected + tokens because there are none. + - The only way there can be no lookahead present (in yychar) is if + this state is a consistent state with a default action. Thus, + detecting the absence of a lookahead is sufficient to determine + that there is no unexpected or expected token to report. In that + case, just report a simple "syntax error". + - Don't assume there isn't a lookahead just because this state is a + consistent state with a default action. There might have been a + previous inconsistent state, consistent state with a non-default + action, or user semantic action that manipulated yychar. + - Of course, the expected token list depends on states to have + correct lookahead information, and it depends on the parser not + to perform extra reductions after fetching a lookahead from the + scanner and before detecting a syntax error. Thus, state merging + (from LALR or IELR) and default reductions corrupt the expected + token list. However, the list is correct for canonical LR with + one exception: it will still contain any token that will not be + accepted due to an error action in a later state. + */ + if (yytoken != YYEMPTY) + { + int yyn = yypact[*yyssp]; + yyarg[yycount++] = yytname[yytoken]; + if (!yypact_value_is_default (yyn)) + { + /* Start YYX at -YYN if negative to avoid negative indexes in + YYCHECK. In other words, skip the first -YYN actions for + this state because they are default actions. */ + int yyxbegin = yyn < 0 ? -yyn : 0; + /* Stay within bounds of both yycheck and yytname. */ + int yychecklim = YYLAST - yyn + 1; + int yyxend = yychecklim < YYNTOKENS ? yychecklim : YYNTOKENS; + int yyx; + + for (yyx = yyxbegin; yyx < yyxend; ++yyx) + if (yycheck[yyx + yyn] == yyx && yyx != YYTERROR + && !yytable_value_is_error (yytable[yyx + yyn])) + { + if (yycount == YYERROR_VERBOSE_ARGS_MAXIMUM) + { + yycount = 1; + yysize = yysize0; + break; + } + yyarg[yycount++] = yytname[yyx]; + { + YYSIZE_T yysize1 = yysize + yytnamerr (YY_NULLPTR, yytname[yyx]); + if (! (yysize <= yysize1 + && yysize1 <= YYSTACK_ALLOC_MAXIMUM)) + return 2; + yysize = yysize1; + } + } + } + } - if (! (YYPACT_NINF < yyn && yyn <= YYLAST)) - return 0; - else + switch (yycount) + { +# define YYCASE_(N, S) \ + case N: \ + yyformat = S; \ + break + default: /* Avoid compiler warnings. */ + YYCASE_(0, YY_("syntax error")); + YYCASE_(1, YY_("syntax error, unexpected %s")); + YYCASE_(2, YY_("syntax error, unexpected %s, expecting %s")); + YYCASE_(3, YY_("syntax error, unexpected %s, expecting %s or %s")); + YYCASE_(4, YY_("syntax error, unexpected %s, expecting %s or %s or %s")); + YYCASE_(5, YY_("syntax error, unexpected %s, expecting %s or %s or %s or %s")); +# undef YYCASE_ + } + + { + YYSIZE_T yysize1 = yysize + yystrlen (yyformat); + if (! (yysize <= yysize1 && yysize1 <= YYSTACK_ALLOC_MAXIMUM)) + return 2; + yysize = yysize1; + } + + if (*yymsg_alloc < yysize) { - int yytype = YYTRANSLATE (yychar); - YYSIZE_T yysize0 = yytnamerr (0, yytname[yytype]); - YYSIZE_T yysize = yysize0; - YYSIZE_T yysize1; - int yysize_overflow = 0; - enum { YYERROR_VERBOSE_ARGS_MAXIMUM = 5 }; - char const *yyarg[YYERROR_VERBOSE_ARGS_MAXIMUM]; - int yyx; - -# if 0 - /* This is so xgettext sees the translatable formats that are - constructed on the fly. */ - YY_("syntax error, unexpected %s"); - YY_("syntax error, unexpected %s, expecting %s"); - YY_("syntax error, unexpected %s, expecting %s or %s"); - YY_("syntax error, unexpected %s, expecting %s or %s or %s"); - YY_("syntax error, unexpected %s, expecting %s or %s or %s or %s"); -# endif - char *yyfmt; - char const *yyf; - static char const yyunexpected[] = "syntax error, unexpected %s"; - static char const yyexpecting[] = ", expecting %s"; - static char const yyor[] = " or %s"; - char yyformat[sizeof yyunexpected - + sizeof yyexpecting - 1 - + ((YYERROR_VERBOSE_ARGS_MAXIMUM - 2) - * (sizeof yyor - 1))]; - char const *yyprefix = yyexpecting; - - /* Start YYX at -YYN if negative to avoid negative indexes in - YYCHECK. */ - int yyxbegin = yyn < 0 ? -yyn : 0; - - /* Stay within bounds of both yycheck and yytname. */ - int yychecklim = YYLAST - yyn + 1; - int yyxend = yychecklim < YYNTOKENS ? yychecklim : YYNTOKENS; - int yycount = 1; - - yyarg[0] = yytname[yytype]; - yyfmt = yystpcpy (yyformat, yyunexpected); - - for (yyx = yyxbegin; yyx < yyxend; ++yyx) - if (yycheck[yyx + yyn] == yyx && yyx != YYTERROR) - { - if (yycount == YYERROR_VERBOSE_ARGS_MAXIMUM) - { - yycount = 1; - yysize = yysize0; - yyformat[sizeof yyunexpected - 1] = '\0'; - break; - } - yyarg[yycount++] = yytname[yyx]; - yysize1 = yysize + yytnamerr (0, yytname[yyx]); - yysize_overflow |= (yysize1 < yysize); - yysize = yysize1; - yyfmt = yystpcpy (yyfmt, yyprefix); - yyprefix = yyor; - } - - yyf = YY_(yyformat); - yysize1 = yysize + yystrlen (yyf); - yysize_overflow |= (yysize1 < yysize); - yysize = yysize1; - - if (yysize_overflow) - return YYSIZE_MAXIMUM; - - if (yyresult) - { - /* Avoid sprintf, as that infringes on the user's name space. - Don't have undefined behavior even if the translation - produced a string with the wrong number of "%s"s. */ - char *yyp = yyresult; - int yyi = 0; - while ((*yyp = *yyf) != '\0') - { - if (*yyp == '%' && yyf[1] == 's' && yyi < yycount) - { - yyp += yytnamerr (yyp, yyarg[yyi++]); - yyf += 2; - } - else - { - yyp++; - yyf++; - } - } - } - return yysize; + *yymsg_alloc = 2 * yysize; + if (! (yysize <= *yymsg_alloc + && *yymsg_alloc <= YYSTACK_ALLOC_MAXIMUM)) + *yymsg_alloc = YYSTACK_ALLOC_MAXIMUM; + return 1; } + + /* Avoid sprintf, as that infringes on the user's name space. + Don't have undefined behavior even if the translation + produced a string with the wrong number of "%s"s. */ + { + char *yyp = *yymsg; + int yyi = 0; + while ((*yyp = *yyformat) != '\0') + if (*yyp == '%' && yyformat[1] == 's' && yyi < yycount) + { + yyp += yytnamerr (yyp, yyarg[yyi++]); + yyformat += 2; + } + else + { + yyp++; + yyformat++; + } + } + return 0; } #endif /* YYERROR_VERBOSE */ - /*-----------------------------------------------. | Release the memory associated to this symbol. | `-----------------------------------------------*/ -/*ARGSUSED*/ -#if (defined __STDC__ || defined __C99__FUNC__ \ - || defined __cplusplus || defined _MSC_VER) static void yydestruct (const char *yymsg, int yytype, YYSTYPE *yyvaluep, YYLTYPE *yylocationp, DateInfo* info) -#else -static void -yydestruct (yymsg, yytype, yyvaluep, yylocationp, info) - const char *yymsg; - int yytype; - YYSTYPE *yyvaluep; - YYLTYPE *yylocationp; - DateInfo* info; -#endif { YYUSE (yyvaluep); YYUSE (yylocationp); YYUSE (info); - if (!yymsg) yymsg = "Deleting"; YY_SYMBOL_PRINT (yymsg, yytype, yyvaluep, yylocationp); - switch (yytype) - { - - default: - break; - } + YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN + YYUSE (yytype); + YY_IGNORE_MAYBE_UNINITIALIZED_END } - - -/* Prevent warnings from -Wmissing-prototypes. */ - -#ifdef YYPARSE_PARAM -#if defined __STDC__ || defined __cplusplus -int yyparse (void *YYPARSE_PARAM); -#else -int yyparse (); -#endif -#else /* ! YYPARSE_PARAM */ -#if defined __STDC__ || defined __cplusplus -int yyparse (DateInfo* info); -#else -int yyparse (); -#endif -#endif /* ! YYPARSE_PARAM */ - - @@ -1322,112 +1272,96 @@ int yyparse (); | yyparse. | `----------*/ -#ifdef YYPARSE_PARAM -#if (defined __STDC__ || defined __C99__FUNC__ \ - || defined __cplusplus || defined _MSC_VER) -int -yyparse (void *YYPARSE_PARAM) -#else -int -yyparse (YYPARSE_PARAM) - void *YYPARSE_PARAM; -#endif -#else /* ! YYPARSE_PARAM */ -#if (defined __STDC__ || defined __C99__FUNC__ \ - || defined __cplusplus || defined _MSC_VER) int yyparse (DateInfo* info) -#else -int -yyparse (info) - DateInfo* info; -#endif -#endif { - /* The look-ahead symbol. */ +/* The lookahead symbol. */ int yychar; -/* The semantic value of the look-ahead symbol. */ -YYSTYPE yylval = {0}; -/* Number of syntax errors so far. */ -int yynerrs; -/* Location data for the look-ahead symbol. */ -YYLTYPE yylloc; +/* The semantic value of the lookahead symbol. */ +/* Default value used for initialization, for pacifying older GCCs + or non-GCC compilers. */ +YY_INITIAL_VALUE (static YYSTYPE yyval_default;) +YYSTYPE yylval YY_INITIAL_VALUE (= yyval_default); - int yystate; - int yyn; - int yyresult; - /* Number of tokens to shift before error messages enabled. */ - int yyerrstatus; - /* Look-ahead token as an internal (translated) token number. */ - int yytoken = 0; -#if YYERROR_VERBOSE - /* Buffer for error messages, and its allocated size. */ - char yymsgbuf[128]; - char *yymsg = yymsgbuf; - YYSIZE_T yymsg_alloc = sizeof yymsgbuf; -#endif +/* Location data for the lookahead symbol. */ +static YYLTYPE yyloc_default +# if defined YYLTYPE_IS_TRIVIAL && YYLTYPE_IS_TRIVIAL + = { 1, 1, 1, 1 } +# endif +; +YYLTYPE yylloc = yyloc_default; - /* Three stacks and their tools: - `yyss': related to states, - `yyvs': related to semantic values, - `yyls': related to locations. + /* Number of syntax errors so far. */ + int yynerrs; - Refer to the stacks thru separate pointers, to allow yyoverflow - to reallocate them elsewhere. */ + int yystate; + /* Number of tokens to shift before error messages enabled. */ + int yyerrstatus; - /* The state stack. */ - yytype_int16 yyssa[YYINITDEPTH]; - yytype_int16 *yyss = yyssa; - yytype_int16 *yyssp; + /* The stacks and their tools: + 'yyss': related to states. + 'yyvs': related to semantic values. + 'yyls': related to locations. - /* The semantic value stack. */ - YYSTYPE yyvsa[YYINITDEPTH]; - YYSTYPE *yyvs = yyvsa; - YYSTYPE *yyvsp; + Refer to the stacks through separate pointers, to allow yyoverflow + to reallocate them elsewhere. */ - /* The location stack. */ - YYLTYPE yylsa[YYINITDEPTH]; - YYLTYPE *yyls = yylsa; - YYLTYPE *yylsp; - /* The locations where the error started and ended. */ - YYLTYPE yyerror_range[2]; + /* The state stack. */ + yytype_int16 yyssa[YYINITDEPTH]; + yytype_int16 *yyss; + yytype_int16 *yyssp; -#define YYPOPSTACK(N) (yyvsp -= (N), yyssp -= (N), yylsp -= (N)) + /* The semantic value stack. */ + YYSTYPE yyvsa[YYINITDEPTH]; + YYSTYPE *yyvs; + YYSTYPE *yyvsp; - YYSIZE_T yystacksize = YYINITDEPTH; + /* The location stack. */ + YYLTYPE yylsa[YYINITDEPTH]; + YYLTYPE *yyls; + YYLTYPE *yylsp; + /* The locations where the error started and ended. */ + YYLTYPE yyerror_range[3]; + + YYSIZE_T yystacksize; + + int yyn; + int yyresult; + /* Lookahead token as an internal (translated) token number. */ + int yytoken = 0; /* The variables used to return semantic value and location from the action routines. */ YYSTYPE yyval; YYLTYPE yyloc; +#if YYERROR_VERBOSE + /* Buffer for error messages, and its allocated size. */ + char yymsgbuf[128]; + char *yymsg = yymsgbuf; + YYSIZE_T yymsg_alloc = sizeof yymsgbuf; +#endif + +#define YYPOPSTACK(N) (yyvsp -= (N), yyssp -= (N), yylsp -= (N)) + /* The number of symbols on the RHS of the reduced rule. Keep to zero when no symbol should be popped. */ int yylen = 0; + yyssp = yyss = yyssa; + yyvsp = yyvs = yyvsa; + yylsp = yyls = yylsa; + yystacksize = YYINITDEPTH; + YYDPRINTF ((stderr, "Starting parse\n")); yystate = 0; yyerrstatus = 0; yynerrs = 0; - yychar = YYEMPTY; /* Cause a token to be read. */ - - /* Initialize stack pointers. - Waste one element of value and location stack - so that they stay on the same level as the state stack. - The wasted elements are never initialized. */ - - yyssp = yyss; - yyvsp = yyvs; - yylsp = yyls; -#if YYLTYPE_IS_TRIVIAL - /* Initialize the default location before parsing starts. */ - yylloc.first_line = yylloc.last_line = 1; - yylloc.first_column = yylloc.last_column = 0; -#endif - + yychar = YYEMPTY; /* Cause a token to be read. */ + yylsp[0] = yylloc; goto yysetstate; /*------------------------------------------------------------. @@ -1448,25 +1382,26 @@ YYLTYPE yylloc; #ifdef yyoverflow { - /* Give user a chance to reallocate the stack. Use copies of - these so that the &'s don't force the real ones into - memory. */ - YYSTYPE *yyvs1 = yyvs; - yytype_int16 *yyss1 = yyss; - YYLTYPE *yyls1 = yyls; - - /* Each stack pointer address is followed by the size of the - data in use in that stack, in bytes. This used to be a - conditional around just the two extra args, but that might - be undefined if yyoverflow is a macro. */ - yyoverflow (YY_("memory exhausted"), - &yyss1, yysize * sizeof (*yyssp), - &yyvs1, yysize * sizeof (*yyvsp), - &yyls1, yysize * sizeof (*yylsp), - &yystacksize); - yyls = yyls1; - yyss = yyss1; - yyvs = yyvs1; + /* Give user a chance to reallocate the stack. Use copies of + these so that the &'s don't force the real ones into + memory. */ + YYSTYPE *yyvs1 = yyvs; + yytype_int16 *yyss1 = yyss; + YYLTYPE *yyls1 = yyls; + + /* Each stack pointer address is followed by the size of the + data in use in that stack, in bytes. This used to be a + conditional around just the two extra args, but that might + be undefined if yyoverflow is a macro. */ + yyoverflow (YY_("memory exhausted"), + &yyss1, yysize * sizeof (*yyssp), + &yyvs1, yysize * sizeof (*yyvsp), + &yyls1, yysize * sizeof (*yylsp), + &yystacksize); + + yyls = yyls1; + yyss = yyss1; + yyvs = yyvs1; } #else /* no yyoverflow */ # ifndef YYSTACK_RELOCATE @@ -1474,23 +1409,23 @@ YYLTYPE yylloc; # else /* Extend the stack our own way. */ if (YYMAXDEPTH <= yystacksize) - goto yyexhaustedlab; + goto yyexhaustedlab; yystacksize *= 2; if (YYMAXDEPTH < yystacksize) - yystacksize = YYMAXDEPTH; + yystacksize = YYMAXDEPTH; { - yytype_int16 *yyss1 = yyss; - union yyalloc *yyptr = - (union yyalloc *) YYSTACK_ALLOC (YYSTACK_BYTES (yystacksize)); - if (! yyptr) - goto yyexhaustedlab; - YYSTACK_RELOCATE (yyss); - YYSTACK_RELOCATE (yyvs); - YYSTACK_RELOCATE (yyls); + yytype_int16 *yyss1 = yyss; + union yyalloc *yyptr = + (union yyalloc *) YYSTACK_ALLOC (YYSTACK_BYTES (yystacksize)); + if (! yyptr) + goto yyexhaustedlab; + YYSTACK_RELOCATE (yyss_alloc, yyss); + YYSTACK_RELOCATE (yyvs_alloc, yyvs); + YYSTACK_RELOCATE (yyls_alloc, yyls); # undef YYSTACK_RELOCATE - if (yyss1 != yyssa) - YYSTACK_FREE (yyss1); + if (yyss1 != yyssa) + YYSTACK_FREE (yyss1); } # endif #endif /* no yyoverflow */ @@ -1500,14 +1435,17 @@ YYLTYPE yylloc; yylsp = yyls + yysize - 1; YYDPRINTF ((stderr, "Stack size increased to %lu\n", - (unsigned long int) yystacksize)); + (unsigned long) yystacksize)); if (yyss + yystacksize - 1 <= yyssp) - YYABORT; + YYABORT; } YYDPRINTF ((stderr, "Entering state %d\n", yystate)); + if (yystate == YYFINAL) + YYACCEPT; + goto yybackup; /*-----------. @@ -1516,20 +1454,20 @@ YYLTYPE yylloc; yybackup: /* Do appropriate processing given the current state. Read a - look-ahead token if we need one and don't already have one. */ + lookahead token if we need one and don't already have one. */ - /* First try to decide what to do without reference to look-ahead token. */ + /* First try to decide what to do without reference to lookahead token. */ yyn = yypact[yystate]; - if (yyn == YYPACT_NINF) + if (yypact_value_is_default (yyn)) goto yydefault; - /* Not known => get a look-ahead token if don't already have one. */ + /* Not known => get a lookahead token if don't already have one. */ - /* YYCHAR is either YYEMPTY or YYEOF or a valid look-ahead symbol. */ + /* YYCHAR is either YYEMPTY or YYEOF or a valid lookahead symbol. */ if (yychar == YYEMPTY) { YYDPRINTF ((stderr, "Reading a token: ")); - yychar = YYLEX; + yychar = yylex (&yylval, &yylloc, info); } if (yychar <= YYEOF) @@ -1551,29 +1489,27 @@ yybackup: yyn = yytable[yyn]; if (yyn <= 0) { - if (yyn == 0 || yyn == YYTABLE_NINF) - goto yyerrlab; + if (yytable_value_is_error (yyn)) + goto yyerrlab; yyn = -yyn; goto yyreduce; } - if (yyn == YYFINAL) - YYACCEPT; - /* Count tokens shifted since error; after three, turn off error status. */ if (yyerrstatus) yyerrstatus--; - /* Shift the look-ahead token. */ + /* Shift the lookahead token. */ YY_SYMBOL_PRINT ("Shifting", yytoken, &yylval, &yylloc); - /* Discard the shifted token unless it is eof. */ - if (yychar != YYEOF) - yychar = YYEMPTY; + /* Discard the shifted token. */ + yychar = YYEMPTY; yystate = yyn; + YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN *++yyvsp = yylval; + YY_IGNORE_MAYBE_UNINITIALIZED_END *++yylsp = yylloc; goto yynewstate; @@ -1596,7 +1532,7 @@ yyreduce: yylen = yyr2[yyn]; /* If YYLEN is nonzero, implement the default value of the action: - `$$ = $1'. + '$$ = $1'. Otherwise, the following line sets YYVAL to garbage. This behavior is undocumented and Bison @@ -1605,8 +1541,9 @@ yyreduce: GCC warning that YYVAL may be used uninitialized. */ yyval = yyvsp[1-yylen]; - /* Default location. */ + /* Default location. */ YYLLOC_DEFAULT (yyloc, (yylsp - yylen), yylen); + yyerror_range[1] = yyloc; YY_REDUCE_PRINT (yyn); switch (yyn) { @@ -1614,42 +1551,48 @@ yyreduce: { yyHaveTime++; - ;} + } + break; case 5: { yyHaveZone++; - ;} + } + break; case 6: { yyHaveDate++; - ;} + } + break; case 7: { yyHaveOrdinalMonth++; - ;} + } + break; case 8: { yyHaveDay++; - ;} + } + break; case 9: { yyHaveRel++; - ;} + } + break; case 10: @@ -1657,7 +1600,8 @@ yyreduce: { yyHaveTime++; yyHaveDate++; - ;} + } + break; case 11: @@ -1666,195 +1610,217 @@ yyreduce: yyHaveTime++; yyHaveDate++; yyHaveRel++; - ;} + } + break; case 13: { - yyHour = (yyvsp[(1) - (2)].Number); + yyHour = (yyvsp[-1].Number); yyMinutes = 0; yySeconds = 0; - yyMeridian = (yyvsp[(2) - (2)].Meridian); - ;} + yyMeridian = (yyvsp[0].Meridian); + } + break; case 14: { - yyHour = (yyvsp[(1) - (4)].Number); - yyMinutes = (yyvsp[(3) - (4)].Number); + yyHour = (yyvsp[-3].Number); + yyMinutes = (yyvsp[-1].Number); yySeconds = 0; - yyMeridian = (yyvsp[(4) - (4)].Meridian); - ;} + yyMeridian = (yyvsp[0].Meridian); + } + break; case 15: { - yyHour = (yyvsp[(1) - (5)].Number); - yyMinutes = (yyvsp[(3) - (5)].Number); + yyHour = (yyvsp[-4].Number); + yyMinutes = (yyvsp[-2].Number); yyMeridian = MER24; yyDSTmode = DSToff; - yyTimezone = ((yyvsp[(5) - (5)].Number) % 100 + ((yyvsp[(5) - (5)].Number) / 100) * 60); + yyTimezone = ((yyvsp[0].Number) % 100 + ((yyvsp[0].Number) / 100) * 60); ++yyHaveZone; - ;} + } + break; case 16: { - yyHour = (yyvsp[(1) - (6)].Number); - yyMinutes = (yyvsp[(3) - (6)].Number); - yySeconds = (yyvsp[(5) - (6)].Number); - yyMeridian = (yyvsp[(6) - (6)].Meridian); - ;} + yyHour = (yyvsp[-5].Number); + yyMinutes = (yyvsp[-3].Number); + yySeconds = (yyvsp[-1].Number); + yyMeridian = (yyvsp[0].Meridian); + } + break; case 17: { - yyHour = (yyvsp[(1) - (7)].Number); - yyMinutes = (yyvsp[(3) - (7)].Number); - yySeconds = (yyvsp[(5) - (7)].Number); + yyHour = (yyvsp[-6].Number); + yyMinutes = (yyvsp[-4].Number); + yySeconds = (yyvsp[-2].Number); yyMeridian = MER24; yyDSTmode = DSToff; - yyTimezone = ((yyvsp[(7) - (7)].Number) % 100 + ((yyvsp[(7) - (7)].Number) / 100) * 60); + yyTimezone = ((yyvsp[0].Number) % 100 + ((yyvsp[0].Number) / 100) * 60); ++yyHaveZone; - ;} + } + break; case 18: { - yyTimezone = (yyvsp[(1) - (2)].Number); + yyTimezone = (yyvsp[-1].Number); yyDSTmode = DSTon; - ;} + } + break; case 19: { - yyTimezone = (yyvsp[(1) - (1)].Number); + yyTimezone = (yyvsp[0].Number); yyDSTmode = DSToff; - ;} + } + break; case 20: { - yyTimezone = (yyvsp[(1) - (1)].Number); + yyTimezone = (yyvsp[0].Number); yyDSTmode = DSTon; - ;} + } + break; case 21: { yyDayOrdinal = 1; - yyDayNumber = (yyvsp[(1) - (1)].Number); - ;} + yyDayNumber = (yyvsp[0].Number); + } + break; case 22: { yyDayOrdinal = 1; - yyDayNumber = (yyvsp[(1) - (2)].Number); - ;} + yyDayNumber = (yyvsp[-1].Number); + } + break; case 23: { - yyDayOrdinal = (yyvsp[(1) - (2)].Number); - yyDayNumber = (yyvsp[(2) - (2)].Number); - ;} + yyDayOrdinal = (yyvsp[-1].Number); + yyDayNumber = (yyvsp[0].Number); + } + break; case 24: { - yyDayOrdinal = (yyvsp[(1) - (3)].Number) * (yyvsp[(2) - (3)].Number); - yyDayNumber = (yyvsp[(3) - (3)].Number); - ;} + yyDayOrdinal = (yyvsp[-2].Number) * (yyvsp[-1].Number); + yyDayNumber = (yyvsp[0].Number); + } + break; case 25: { yyDayOrdinal = 2; - yyDayNumber = (yyvsp[(2) - (2)].Number); - ;} + yyDayNumber = (yyvsp[0].Number); + } + break; case 26: { - yyMonth = (yyvsp[(1) - (3)].Number); - yyDay = (yyvsp[(3) - (3)].Number); - ;} + yyMonth = (yyvsp[-2].Number); + yyDay = (yyvsp[0].Number); + } + break; case 27: { - yyMonth = (yyvsp[(1) - (5)].Number); - yyDay = (yyvsp[(3) - (5)].Number); - yyYear = (yyvsp[(5) - (5)].Number); - ;} + yyMonth = (yyvsp[-4].Number); + yyDay = (yyvsp[-2].Number); + yyYear = (yyvsp[0].Number); + } + break; case 28: { - yyYear = (yyvsp[(1) - (1)].Number) / 10000; - yyMonth = ((yyvsp[(1) - (1)].Number) % 10000)/100; - yyDay = (yyvsp[(1) - (1)].Number) % 100; - ;} + yyYear = (yyvsp[0].Number) / 10000; + yyMonth = ((yyvsp[0].Number) % 10000)/100; + yyDay = (yyvsp[0].Number) % 100; + } + break; case 29: { - yyDay = (yyvsp[(1) - (5)].Number); - yyMonth = (yyvsp[(3) - (5)].Number); - yyYear = (yyvsp[(5) - (5)].Number); - ;} + yyDay = (yyvsp[-4].Number); + yyMonth = (yyvsp[-2].Number); + yyYear = (yyvsp[0].Number); + } + break; case 30: { - yyMonth = (yyvsp[(3) - (5)].Number); - yyDay = (yyvsp[(5) - (5)].Number); - yyYear = (yyvsp[(1) - (5)].Number); - ;} + yyMonth = (yyvsp[-2].Number); + yyDay = (yyvsp[0].Number); + yyYear = (yyvsp[-4].Number); + } + break; case 31: { - yyMonth = (yyvsp[(1) - (2)].Number); - yyDay = (yyvsp[(2) - (2)].Number); - ;} + yyMonth = (yyvsp[-1].Number); + yyDay = (yyvsp[0].Number); + } + break; case 32: { - yyMonth = (yyvsp[(1) - (4)].Number); - yyDay = (yyvsp[(2) - (4)].Number); - yyYear = (yyvsp[(4) - (4)].Number); - ;} + yyMonth = (yyvsp[-3].Number); + yyDay = (yyvsp[-2].Number); + yyYear = (yyvsp[0].Number); + } + break; case 33: { - yyMonth = (yyvsp[(2) - (2)].Number); - yyDay = (yyvsp[(1) - (2)].Number); - ;} + yyMonth = (yyvsp[0].Number); + yyDay = (yyvsp[-1].Number); + } + break; case 34: @@ -1863,70 +1829,77 @@ yyreduce: yyMonth = 1; yyDay = 1; yyYear = EPOCH; - ;} + } + break; case 35: { - yyMonth = (yyvsp[(2) - (3)].Number); - yyDay = (yyvsp[(1) - (3)].Number); - yyYear = (yyvsp[(3) - (3)].Number); - ;} + yyMonth = (yyvsp[-1].Number); + yyDay = (yyvsp[-2].Number); + yyYear = (yyvsp[0].Number); + } + break; case 36: { yyMonthOrdinal = 1; - yyMonth = (yyvsp[(2) - (2)].Number); - ;} + yyMonth = (yyvsp[0].Number); + } + break; case 37: { - yyMonthOrdinal = (yyvsp[(2) - (3)].Number); - yyMonth = (yyvsp[(3) - (3)].Number); - ;} + yyMonthOrdinal = (yyvsp[-1].Number); + yyMonth = (yyvsp[0].Number); + } + break; case 38: { - if ((yyvsp[(2) - (3)].Number) != HOUR( 7)) YYABORT; - yyYear = (yyvsp[(1) - (3)].Number) / 10000; - yyMonth = ((yyvsp[(1) - (3)].Number) % 10000)/100; - yyDay = (yyvsp[(1) - (3)].Number) % 100; - yyHour = (yyvsp[(3) - (3)].Number) / 10000; - yyMinutes = ((yyvsp[(3) - (3)].Number) % 10000)/100; - yySeconds = (yyvsp[(3) - (3)].Number) % 100; - ;} + if ((yyvsp[-1].Number) != HOUR( 7)) YYABORT; + yyYear = (yyvsp[-2].Number) / 10000; + yyMonth = ((yyvsp[-2].Number) % 10000)/100; + yyDay = (yyvsp[-2].Number) % 100; + yyHour = (yyvsp[0].Number) / 10000; + yyMinutes = ((yyvsp[0].Number) % 10000)/100; + yySeconds = (yyvsp[0].Number) % 100; + } + break; case 39: { - if ((yyvsp[(2) - (7)].Number) != HOUR( 7)) YYABORT; - yyYear = (yyvsp[(1) - (7)].Number) / 10000; - yyMonth = ((yyvsp[(1) - (7)].Number) % 10000)/100; - yyDay = (yyvsp[(1) - (7)].Number) % 100; - yyHour = (yyvsp[(3) - (7)].Number); - yyMinutes = (yyvsp[(5) - (7)].Number); - yySeconds = (yyvsp[(7) - (7)].Number); - ;} + if ((yyvsp[-5].Number) != HOUR( 7)) YYABORT; + yyYear = (yyvsp[-6].Number) / 10000; + yyMonth = ((yyvsp[-6].Number) % 10000)/100; + yyDay = (yyvsp[-6].Number) % 100; + yyHour = (yyvsp[-4].Number); + yyMinutes = (yyvsp[-2].Number); + yySeconds = (yyvsp[0].Number); + } + break; case 40: { - yyYear = (yyvsp[(1) - (2)].Number) / 10000; - yyMonth = ((yyvsp[(1) - (2)].Number) % 10000)/100; - yyDay = (yyvsp[(1) - (2)].Number) % 100; - yyHour = (yyvsp[(2) - (2)].Number) / 10000; - yyMinutes = ((yyvsp[(2) - (2)].Number) % 10000)/100; - yySeconds = (yyvsp[(2) - (2)].Number) % 100; - ;} + yyYear = (yyvsp[-1].Number) / 10000; + yyMonth = ((yyvsp[-1].Number) % 10000)/100; + yyDay = (yyvsp[-1].Number) % 100; + yyHour = (yyvsp[0].Number) / 10000; + yyMinutes = ((yyvsp[0].Number) % 10000)/100; + yySeconds = (yyvsp[0].Number) % 100; + } + break; case 41: @@ -1937,12 +1910,13 @@ yyreduce: * in a range accessible with a 32 bit clock seconds value. */ - yyYear = (yyvsp[(2) - (4)].Number)/1000 + 2323 - 377; + yyYear = (yyvsp[-2].Number)/1000 + 2323 - 377; yyDay = 1; yyMonth = 1; - yyRelDay += (((yyvsp[(2) - (4)].Number)%1000)*(365 + IsLeapYear(yyYear)))/1000; - yyRelSeconds += (yyvsp[(4) - (4)].Number) * 144 * 60; - ;} + yyRelDay += (((yyvsp[-2].Number)%1000)*(365 + IsLeapYear(yyYear)))/1000; + yyRelSeconds += (yyvsp[0].Number) * 144 * 60; + } + break; case 42: @@ -1951,121 +1925,145 @@ yyreduce: yyRelSeconds *= -1; yyRelMonth *= -1; yyRelDay *= -1; - ;} + } + break; case 44: { - *yyRelPointer += (yyvsp[(1) - (3)].Number) * (yyvsp[(2) - (3)].Number) * (yyvsp[(3) - (3)].Number); - ;} + *yyRelPointer += (yyvsp[-2].Number) * (yyvsp[-1].Number) * (yyvsp[0].Number); + } + break; case 45: { - *yyRelPointer += (yyvsp[(1) - (2)].Number) * (yyvsp[(2) - (2)].Number); - ;} + *yyRelPointer += (yyvsp[-1].Number) * (yyvsp[0].Number); + } + break; case 46: { - *yyRelPointer += (yyvsp[(2) - (2)].Number); - ;} + *yyRelPointer += (yyvsp[0].Number); + } + break; case 47: { - *yyRelPointer += (yyvsp[(2) - (3)].Number) * (yyvsp[(3) - (3)].Number); - ;} + *yyRelPointer += (yyvsp[-1].Number) * (yyvsp[0].Number); + } + break; case 48: { - *yyRelPointer += (yyvsp[(1) - (1)].Number); - ;} + *yyRelPointer += (yyvsp[0].Number); + } + break; case 49: { (yyval.Number) = -1; - ;} + } + break; case 50: { (yyval.Number) = 1; - ;} + } + break; case 51: { - (yyval.Number) = (yyvsp[(1) - (1)].Number); + (yyval.Number) = (yyvsp[0].Number); yyRelPointer = &yyRelSeconds; - ;} + } + break; case 52: { - (yyval.Number) = (yyvsp[(1) - (1)].Number); + (yyval.Number) = (yyvsp[0].Number); yyRelPointer = &yyRelDay; - ;} + } + break; case 53: { - (yyval.Number) = (yyvsp[(1) - (1)].Number); + (yyval.Number) = (yyvsp[0].Number); yyRelPointer = &yyRelMonth; - ;} + } + break; case 54: { if (yyHaveTime && yyHaveDate && !yyHaveRel) { - yyYear = (yyvsp[(1) - (1)].Number); + yyYear = (yyvsp[0].Number); } else { yyHaveTime++; if (yyDigitCount <= 2) { - yyHour = (yyvsp[(1) - (1)].Number); + yyHour = (yyvsp[0].Number); yyMinutes = 0; } else { - yyHour = (yyvsp[(1) - (1)].Number) / 100; - yyMinutes = (yyvsp[(1) - (1)].Number) % 100; + yyHour = (yyvsp[0].Number) / 100; + yyMinutes = (yyvsp[0].Number) % 100; } yySeconds = 0; yyMeridian = MER24; } - ;} + } + break; case 55: { (yyval.Meridian) = MER24; - ;} + } + break; case 56: { - (yyval.Meridian) = (yyvsp[(1) - (1)].Meridian); - ;} + (yyval.Meridian) = (yyvsp[0].Meridian); + } + break; -/* Line 1267 of yacc.c. */ default: break; } + /* User semantic actions sometimes alter yychar, and that requires + that yytoken be updated with the new translation. We take the + approach of translating immediately before every use of yytoken. + One alternative is translating here after every semantic action, + but that translation would be missed if the semantic action invokes + YYABORT, YYACCEPT, or YYERROR immediately after altering yychar or + if it invokes YYBACKUP. In the case of YYABORT or YYACCEPT, an + incorrect destructor might then be invoked immediately. In the + case of YYERROR or YYBACKUP, subsequent parser actions might lead + to an incorrect destructor call or verbose syntax error message + before the lookahead is translated. */ YY_SYMBOL_PRINT ("-> $$ =", yyr1[yyn], &yyval, &yyloc); YYPOPSTACK (yylen); @@ -2075,7 +2073,7 @@ yyreduce: *++yyvsp = yyval; *++yylsp = yyloc; - /* Now `shift' the result of the reduction. Determine what state + /* Now 'shift' the result of the reduction. Determine what state that goes to, based on the state we popped back to and the rule number reduced by. */ @@ -2090,10 +2088,14 @@ yyreduce: goto yynewstate; -/*------------------------------------. -| yyerrlab -- here on detecting error | -`------------------------------------*/ +/*--------------------------------------. +| yyerrlab -- here on detecting error. | +`--------------------------------------*/ yyerrlab: + /* Make sure we have latest lookahead translation. See comments at + user semantic actions for why this is necessary. */ + yytoken = yychar == YYEMPTY ? YYEMPTY : YYTRANSLATE (yychar); + /* If not already recovering from an error, report this error. */ if (!yyerrstatus) { @@ -2101,62 +2103,61 @@ yyerrlab: #if ! YYERROR_VERBOSE yyerror (&yylloc, info, YY_("syntax error")); #else +# define YYSYNTAX_ERROR yysyntax_error (&yymsg_alloc, &yymsg, \ + yyssp, yytoken) { - YYSIZE_T yysize = yysyntax_error (0, yystate, yychar); - if (yymsg_alloc < yysize && yymsg_alloc < YYSTACK_ALLOC_MAXIMUM) - { - YYSIZE_T yyalloc = 2 * yysize; - if (! (yysize <= yyalloc && yyalloc <= YYSTACK_ALLOC_MAXIMUM)) - yyalloc = YYSTACK_ALLOC_MAXIMUM; - if (yymsg != yymsgbuf) - YYSTACK_FREE (yymsg); - yymsg = (char *) YYSTACK_ALLOC (yyalloc); - if (yymsg) - yymsg_alloc = yyalloc; - else - { - yymsg = yymsgbuf; - yymsg_alloc = sizeof yymsgbuf; - } - } - - if (0 < yysize && yysize <= yymsg_alloc) - { - (void) yysyntax_error (yymsg, yystate, yychar); - yyerror (&yylloc, info, yymsg); - } - else - { - yyerror (&yylloc, info, YY_("syntax error")); - if (yysize != 0) - goto yyexhaustedlab; - } + char const *yymsgp = YY_("syntax error"); + int yysyntax_error_status; + yysyntax_error_status = YYSYNTAX_ERROR; + if (yysyntax_error_status == 0) + yymsgp = yymsg; + else if (yysyntax_error_status == 1) + { + if (yymsg != yymsgbuf) + YYSTACK_FREE (yymsg); + yymsg = (char *) YYSTACK_ALLOC (yymsg_alloc); + if (!yymsg) + { + yymsg = yymsgbuf; + yymsg_alloc = sizeof yymsgbuf; + yysyntax_error_status = 2; + } + else + { + yysyntax_error_status = YYSYNTAX_ERROR; + yymsgp = yymsg; + } + } + yyerror (&yylloc, info, yymsgp); + if (yysyntax_error_status == 2) + goto yyexhaustedlab; } +# undef YYSYNTAX_ERROR #endif } - yyerror_range[0] = yylloc; + yyerror_range[1] = yylloc; if (yyerrstatus == 3) { - /* If just tried and failed to reuse look-ahead token after an - error, discard it. */ + /* If just tried and failed to reuse lookahead token after an + error, discard it. */ if (yychar <= YYEOF) - { - /* Return failure if at end of input. */ - if (yychar == YYEOF) - YYABORT; - } + { + /* Return failure if at end of input. */ + if (yychar == YYEOF) + YYABORT; + } else - { - yydestruct ("Error: discarding", - yytoken, &yylval, &yylloc, info); - yychar = YYEMPTY; - } + { + yydestruct ("Error: discarding", + yytoken, &yylval, &yylloc, info); + yychar = YYEMPTY; + } } - /* Else will try to reuse look-ahead token after shifting the error + /* Else will try to reuse lookahead token after shifting the error token. */ goto yyerrlab1; @@ -2172,8 +2173,7 @@ yyerrorlab: if (/*CONSTCOND*/ 0) goto yyerrorlab; - yyerror_range[0] = yylsp[1-yylen]; - /* Do not reclaim the symbols of the rule which action triggered + /* Do not reclaim the symbols of the rule whose action triggered this YYERROR. */ YYPOPSTACK (yylen); yylen = 0; @@ -2186,43 +2186,42 @@ yyerrorlab: | yyerrlab1 -- common code for both syntax error and YYERROR. | `-------------------------------------------------------------*/ yyerrlab1: - yyerrstatus = 3; /* Each real token shifted decrements this. */ + yyerrstatus = 3; /* Each real token shifted decrements this. */ for (;;) { yyn = yypact[yystate]; - if (yyn != YYPACT_NINF) - { - yyn += YYTERROR; - if (0 <= yyn && yyn <= YYLAST && yycheck[yyn] == YYTERROR) - { - yyn = yytable[yyn]; - if (0 < yyn) - break; - } - } + if (!yypact_value_is_default (yyn)) + { + yyn += YYTERROR; + if (0 <= yyn && yyn <= YYLAST && yycheck[yyn] == YYTERROR) + { + yyn = yytable[yyn]; + if (0 < yyn) + break; + } + } /* Pop the current state because it cannot handle the error token. */ if (yyssp == yyss) - YYABORT; + YYABORT; - yyerror_range[0] = *yylsp; + yyerror_range[1] = *yylsp; yydestruct ("Error: popping", - yystos[yystate], yyvsp, yylsp, info); + yystos[yystate], yyvsp, yylsp, info); YYPOPSTACK (1); yystate = *yyssp; YY_STACK_PRINT (yyss, yyssp); } - if (yyn == YYFINAL) - YYACCEPT; - + YY_IGNORE_MAYBE_UNINITIALIZED_BEGIN *++yyvsp = yylval; + YY_IGNORE_MAYBE_UNINITIALIZED_END - yyerror_range[1] = yylloc; + yyerror_range[2] = yylloc; /* Using YYLLOC is tempting, but would change the location of - the look-ahead. YYLOC is available though. */ - YYLLOC_DEFAULT (yyloc, (yyerror_range - 1), 2); + the lookahead. YYLOC is available though. */ + YYLLOC_DEFAULT (yyloc, yyerror_range, 2); *++yylsp = yyloc; /* Shift the error token. */ @@ -2246,7 +2245,7 @@ yyabortlab: yyresult = 1; goto yyreturn; -#ifndef yyoverflow +#if !defined yyoverflow || YYERROR_VERBOSE /*-------------------------------------------------. | yyexhaustedlab -- memory exhaustion comes here. | `-------------------------------------------------*/ @@ -2257,17 +2256,22 @@ yyexhaustedlab: #endif yyreturn: - if (yychar != YYEOF && yychar != YYEMPTY) - yydestruct ("Cleanup: discarding lookahead", - yytoken, &yylval, &yylloc, info); - /* Do not reclaim the symbols of the rule which action triggered + if (yychar != YYEMPTY) + { + /* Make sure we have latest lookahead translation. See comments at + user semantic actions for why this is necessary. */ + yytoken = YYTRANSLATE (yychar); + yydestruct ("Cleanup: discarding lookahead", + yytoken, &yylval, &yylloc, info); + } + /* Do not reclaim the symbols of the rule whose action triggered this YYABORT or YYACCEPT. */ YYPOPSTACK (yylen); YY_STACK_PRINT (yyss, yyssp); while (yyssp != yyss) { yydestruct ("Cleanup: popping", - yystos[*yyssp], yyvsp, yylsp, info); + yystos[*yyssp], yyvsp, yylsp, info); YYPOPSTACK (1); } #ifndef yyoverflow @@ -2278,13 +2282,10 @@ yyreturn: if (yymsg != yymsgbuf) YYSTACK_FREE (yymsg); #endif - /* Make sure YYID is used. */ - return YYID (yyresult); + return yyresult; } - - /* * Month and day table. */ @@ -2680,7 +2681,7 @@ TclDatelex( location->first_column = yyInput - info->dateStart; for ( ; ; ) { - while (TclIsSpaceProc(*yyInput)) { + while (TclIsSpaceProc(UCHAR(*yyInput))) { yyInput++; } @@ -2743,7 +2744,7 @@ TclDatelex( int TclClockOldscanObjCmd( - ClientData clientData, /* Unused */ + void *clientData, /* Unused */ Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Count of paraneters */ Tcl_Obj *const *objv) /* Parameters */ @@ -2911,4 +2912,3 @@ TclClockOldscanObjCmd( * fill-column: 78 * End: */ - diff --git a/generic/tclDecls.h b/generic/tclDecls.h index 3de71af..3f39cd5 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -23,6 +23,15 @@ # endif #endif +#if !defined(BUILD_tcl) +# define TCL_DEPRECATED(msg) EXTERN TCL_DEPRECATED_API(msg) +#elif defined(TCL_NO_DEPRECATED) +# define TCL_DEPRECATED(msg) MODULE_SCOPE +#else +# define TCL_DEPRECATED(msg) EXTERN +#endif + + /* * WARNING: This file is automatically generated by the tools/genStubs.tcl * script. Any modifications to the function declarations below should be made @@ -44,7 +53,7 @@ EXTERN int Tcl_PkgProvideEx(Tcl_Interp *interp, const char *name, const char *version, const void *clientData); /* 1 */ -EXTERN CONST84_RETURN char * Tcl_PkgRequireEx(Tcl_Interp *interp, +EXTERN const char * Tcl_PkgRequireEx(Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 2 */ @@ -110,7 +119,8 @@ EXTERN void Tcl_DbIncrRefCount(Tcl_Obj *objPtr, const char *file, EXTERN int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file, int line); /* 22 */ -EXTERN Tcl_Obj * Tcl_DbNewBooleanObj(int boolValue, const char *file, +TCL_DEPRECATED("No longer in use, changed to macro") +Tcl_Obj * Tcl_DbNewBooleanObj(int boolValue, const char *file, int line); /* 23 */ EXTERN Tcl_Obj * Tcl_DbNewByteArrayObj(const unsigned char *bytes, @@ -122,7 +132,8 @@ EXTERN Tcl_Obj * Tcl_DbNewDoubleObj(double doubleValue, EXTERN Tcl_Obj * Tcl_DbNewListObj(int objc, Tcl_Obj *const *objv, const char *file, int line); /* 26 */ -EXTERN Tcl_Obj * Tcl_DbNewLongObj(long longValue, const char *file, +TCL_DEPRECATED("No longer in use, changed to macro") +Tcl_Obj * Tcl_DbNewLongObj(long longValue, const char *file, int line); /* 27 */ EXTERN Tcl_Obj * Tcl_DbNewObj(const char *file, int line); @@ -132,7 +143,7 @@ EXTERN Tcl_Obj * Tcl_DbNewStringObj(const char *bytes, int length, /* 29 */ EXTERN Tcl_Obj * Tcl_DuplicateObj(Tcl_Obj *objPtr); /* 30 */ -EXTERN void TclFreeObj(Tcl_Obj *objPtr); +EXTERN void TclOldFreeObj(Tcl_Obj *objPtr); /* 31 */ EXTERN int Tcl_GetBoolean(Tcl_Interp *interp, const char *src, int *boolPtr); @@ -149,9 +160,9 @@ EXTERN int Tcl_GetDouble(Tcl_Interp *interp, const char *src, EXTERN int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr); /* 36 */ -EXTERN int Tcl_GetIndexFromObj(Tcl_Interp *interp, - Tcl_Obj *objPtr, - CONST84 char *const *tablePtr, +TCL_DEPRECATED("No longer in use, changed to macro") +int Tcl_GetIndexFromObj(Tcl_Interp *interp, + Tcl_Obj *objPtr, const char *const *tablePtr, const char *msg, int flags, int *indexPtr); /* 37 */ EXTERN int Tcl_GetInt(Tcl_Interp *interp, const char *src, @@ -190,24 +201,28 @@ EXTERN int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, int objc, Tcl_Obj *const objv[]); /* 49 */ -EXTERN Tcl_Obj * Tcl_NewBooleanObj(int boolValue); +TCL_DEPRECATED("No longer in use, changed to macro") +Tcl_Obj * Tcl_NewBooleanObj(int boolValue); /* 50 */ EXTERN Tcl_Obj * Tcl_NewByteArrayObj(const unsigned char *bytes, int length); /* 51 */ EXTERN Tcl_Obj * Tcl_NewDoubleObj(double doubleValue); /* 52 */ -EXTERN Tcl_Obj * Tcl_NewIntObj(int intValue); +TCL_DEPRECATED("No longer in use, changed to macro") +Tcl_Obj * Tcl_NewIntObj(int intValue); /* 53 */ EXTERN Tcl_Obj * Tcl_NewListObj(int objc, Tcl_Obj *const objv[]); /* 54 */ -EXTERN Tcl_Obj * Tcl_NewLongObj(long longValue); +TCL_DEPRECATED("No longer in use, changed to macro") +Tcl_Obj * Tcl_NewLongObj(long longValue); /* 55 */ EXTERN Tcl_Obj * Tcl_NewObj(void); /* 56 */ EXTERN Tcl_Obj * Tcl_NewStringObj(const char *bytes, int length); /* 57 */ -EXTERN void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue); +TCL_DEPRECATED("No longer in use, changed to macro") +void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue); /* 58 */ EXTERN unsigned char * Tcl_SetByteArrayLength(Tcl_Obj *objPtr, int length); /* 59 */ @@ -216,22 +231,26 @@ EXTERN void Tcl_SetByteArrayObj(Tcl_Obj *objPtr, /* 60 */ EXTERN void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue); /* 61 */ -EXTERN void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue); +TCL_DEPRECATED("No longer in use, changed to macro") +void Tcl_SetIntObj(Tcl_Obj *objPtr, int intValue); /* 62 */ EXTERN void Tcl_SetListObj(Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[]); /* 63 */ -EXTERN void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue); +TCL_DEPRECATED("No longer in use, changed to macro") +void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue); /* 64 */ EXTERN void Tcl_SetObjLength(Tcl_Obj *objPtr, int length); /* 65 */ EXTERN void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, int length); /* 66 */ -EXTERN void Tcl_AddErrorInfo(Tcl_Interp *interp, +TCL_DEPRECATED("No longer in use, changed to macro") +void Tcl_AddErrorInfo(Tcl_Interp *interp, const char *message); /* 67 */ -EXTERN void Tcl_AddObjErrorInfo(Tcl_Interp *interp, +TCL_DEPRECATED("No longer in use, changed to macro") +void Tcl_AddObjErrorInfo(Tcl_Interp *interp, const char *message, int length); /* 68 */ EXTERN void Tcl_AllowExceptions(Tcl_Interp *interp); @@ -252,9 +271,11 @@ EXTERN void Tcl_AsyncMark(Tcl_AsyncHandler async); /* 75 */ EXTERN int Tcl_AsyncReady(void); /* 76 */ -EXTERN void Tcl_BackgroundError(Tcl_Interp *interp); +TCL_DEPRECATED("No longer in use, changed to macro") +void Tcl_BackgroundError(Tcl_Interp *interp); /* 77 */ -EXTERN char Tcl_Backslash(const char *src, int *readPtr); +TCL_DEPRECATED("Use Tcl_UtfBackslash") +char Tcl_Backslash(const char *src, int *readPtr); /* 78 */ EXTERN int Tcl_BadChannelOption(Tcl_Interp *interp, const char *optionName, @@ -271,7 +292,7 @@ EXTERN int Tcl_Close(Tcl_Interp *interp, Tcl_Channel chan); /* 82 */ EXTERN int Tcl_CommandComplete(const char *cmd); /* 83 */ -EXTERN char * Tcl_Concat(int argc, CONST84 char *const *argv); +EXTERN char * Tcl_Concat(int argc, const char *const *argv); /* 84 */ EXTERN int Tcl_ConvertElement(const char *src, char *dst, int flags); @@ -282,7 +303,7 @@ EXTERN int Tcl_ConvertCountedElement(const char *src, EXTERN int Tcl_CreateAlias(Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int argc, - CONST84 char *const *argv); + const char *const *argv); /* 87 */ EXTERN int Tcl_CreateAliasObj(Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, @@ -313,7 +334,8 @@ EXTERN void Tcl_CreateExitHandler(Tcl_ExitProc *proc, /* 94 */ EXTERN Tcl_Interp * Tcl_CreateInterp(void); /* 95 */ -EXTERN void Tcl_CreateMathFunc(Tcl_Interp *interp, +TCL_DEPRECATED("") +void Tcl_CreateMathFunc(Tcl_Interp *interp, const char *name, int numArgs, Tcl_ValueType *argTypes, Tcl_MathProc *proc, ClientData clientData); @@ -403,16 +425,17 @@ EXTERN void Tcl_DStringStartSublist(Tcl_DString *dsPtr); /* 126 */ EXTERN int Tcl_Eof(Tcl_Channel chan); /* 127 */ -EXTERN CONST84_RETURN char * Tcl_ErrnoId(void); +EXTERN const char * Tcl_ErrnoId(void); /* 128 */ -EXTERN CONST84_RETURN char * Tcl_ErrnoMsg(int err); +EXTERN const char * Tcl_ErrnoMsg(int err); /* 129 */ EXTERN int Tcl_Eval(Tcl_Interp *interp, const char *script); /* 130 */ EXTERN int Tcl_EvalFile(Tcl_Interp *interp, const char *fileName); /* 131 */ -EXTERN int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr); +TCL_DEPRECATED("No longer in use, changed to macro") +int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr); /* 132 */ EXTERN void Tcl_EventuallyFree(ClientData clientData, Tcl_FreeProc *freeProc); @@ -460,13 +483,13 @@ EXTERN void Tcl_FreeResult(Tcl_Interp *interp); EXTERN int Tcl_GetAlias(Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, - CONST84 char **targetCmdPtr, int *argcPtr, - CONST84 char ***argvPtr); + const char **targetCmdPtr, int *argcPtr, + const char ***argvPtr); /* 149 */ EXTERN int Tcl_GetAliasObj(Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, - CONST84 char **targetCmdPtr, int *objcPtr, + const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 150 */ EXTERN ClientData Tcl_GetAssocData(Tcl_Interp *interp, @@ -485,7 +508,7 @@ EXTERN ClientData Tcl_GetChannelInstanceData(Tcl_Channel chan); /* 155 */ EXTERN int Tcl_GetChannelMode(Tcl_Channel chan); /* 156 */ -EXTERN CONST84_RETURN char * Tcl_GetChannelName(Tcl_Channel chan); +EXTERN const char * Tcl_GetChannelName(Tcl_Channel chan); /* 157 */ EXTERN int Tcl_GetChannelOption(Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, @@ -496,12 +519,12 @@ EXTERN CONST86 Tcl_ChannelType * Tcl_GetChannelType(Tcl_Channel chan); EXTERN int Tcl_GetCommandInfo(Tcl_Interp *interp, const char *cmdName, Tcl_CmdInfo *infoPtr); /* 160 */ -EXTERN CONST84_RETURN char * Tcl_GetCommandName(Tcl_Interp *interp, +EXTERN const char * Tcl_GetCommandName(Tcl_Interp *interp, Tcl_Command command); /* 161 */ EXTERN int Tcl_GetErrno(void); /* 162 */ -EXTERN CONST84_RETURN char * Tcl_GetHostName(void); +EXTERN const char * Tcl_GetHostName(void); /* 163 */ EXTERN int Tcl_GetInterpPath(Tcl_Interp *askInterp, Tcl_Interp *slaveInterp); @@ -537,19 +560,20 @@ EXTERN Tcl_Interp * Tcl_GetSlave(Tcl_Interp *interp, /* 173 */ EXTERN Tcl_Channel Tcl_GetStdChannel(int type); /* 174 */ -EXTERN CONST84_RETURN char * Tcl_GetStringResult(Tcl_Interp *interp); +EXTERN const char * Tcl_GetStringResult(Tcl_Interp *interp); /* 175 */ -EXTERN CONST84_RETURN char * Tcl_GetVar(Tcl_Interp *interp, - const char *varName, int flags); -/* 176 */ -EXTERN CONST84_RETURN char * Tcl_GetVar2(Tcl_Interp *interp, - const char *part1, const char *part2, +TCL_DEPRECATED("No longer in use, changed to macro") +const char * Tcl_GetVar(Tcl_Interp *interp, const char *varName, int flags); +/* 176 */ +EXTERN const char * Tcl_GetVar2(Tcl_Interp *interp, const char *part1, + const char *part2, int flags); /* 177 */ EXTERN int Tcl_GlobalEval(Tcl_Interp *interp, const char *command); /* 178 */ -EXTERN int Tcl_GlobalEvalObj(Tcl_Interp *interp, +TCL_DEPRECATED("No longer in use, changed to macro") +int Tcl_GlobalEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr); /* 179 */ EXTERN int Tcl_HideCommand(Tcl_Interp *interp, @@ -569,11 +593,11 @@ EXTERN int Tcl_InterpDeleted(Tcl_Interp *interp); /* 185 */ EXTERN int Tcl_IsSafe(Tcl_Interp *interp); /* 186 */ -EXTERN char * Tcl_JoinPath(int argc, CONST84 char *const *argv, +EXTERN char * Tcl_JoinPath(int argc, const char *const *argv, Tcl_DString *resultPtr); /* 187 */ EXTERN int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, - char *addr, int type); + void *addr, int type); /* Slot 188 is reserved */ /* 189 */ EXTERN Tcl_Channel Tcl_MakeFileChannel(ClientData handle, int mode); @@ -582,7 +606,7 @@ EXTERN int Tcl_MakeSafe(Tcl_Interp *interp); /* 191 */ EXTERN Tcl_Channel Tcl_MakeTcpClientChannel(ClientData tcpSocket); /* 192 */ -EXTERN char * Tcl_Merge(int argc, CONST84 char *const *argv); +EXTERN char * Tcl_Merge(int argc, const char *const *argv); /* 193 */ EXTERN Tcl_HashEntry * Tcl_NextHashEntry(Tcl_HashSearch *searchPtr); /* 194 */ @@ -596,7 +620,7 @@ EXTERN Tcl_Obj * Tcl_ObjSetVar2(Tcl_Interp *interp, Tcl_Obj *part1Ptr, int flags); /* 197 */ EXTERN Tcl_Channel Tcl_OpenCommandChannel(Tcl_Interp *interp, int argc, - CONST84 char **argv, int flags); + const char **argv, int flags); /* 198 */ EXTERN Tcl_Channel Tcl_OpenFileChannel(Tcl_Interp *interp, const char *fileName, const char *modeString, @@ -618,7 +642,7 @@ EXTERN void Tcl_PrintDouble(Tcl_Interp *interp, double value, /* 203 */ EXTERN int Tcl_PutEnv(const char *assignment); /* 204 */ -EXTERN CONST84_RETURN char * Tcl_PosixError(Tcl_Interp *interp); +EXTERN const char * Tcl_PosixError(Tcl_Interp *interp); /* 205 */ EXTERN void Tcl_QueueEvent(Tcl_Event *evPtr, Tcl_QueuePosition position); @@ -648,8 +672,7 @@ EXTERN int Tcl_RegExpMatch(Tcl_Interp *interp, const char *text, const char *pattern); /* 215 */ EXTERN void Tcl_RegExpRange(Tcl_RegExp regexp, int index, - CONST84 char **startPtr, - CONST84 char **endPtr); + const char **startPtr, const char **endPtr); /* 216 */ EXTERN void Tcl_Release(ClientData clientData); /* 217 */ @@ -660,7 +683,8 @@ EXTERN int Tcl_ScanElement(const char *src, int *flagPtr); EXTERN int Tcl_ScanCountedElement(const char *src, int length, int *flagPtr); /* 220 */ -EXTERN int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode); +TCL_DEPRECATED("") +int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode); /* 221 */ EXTERN int Tcl_ServiceAll(void); /* 222 */ @@ -704,37 +728,40 @@ EXTERN void Tcl_SetObjResult(Tcl_Interp *interp, /* 236 */ EXTERN void Tcl_SetStdChannel(Tcl_Channel channel, int type); /* 237 */ -EXTERN CONST84_RETURN char * Tcl_SetVar(Tcl_Interp *interp, - const char *varName, const char *newValue, - int flags); -/* 238 */ -EXTERN CONST84_RETURN char * Tcl_SetVar2(Tcl_Interp *interp, - const char *part1, const char *part2, +TCL_DEPRECATED("No longer in use, changed to macro") +const char * Tcl_SetVar(Tcl_Interp *interp, const char *varName, const char *newValue, int flags); +/* 238 */ +EXTERN const char * Tcl_SetVar2(Tcl_Interp *interp, const char *part1, + const char *part2, const char *newValue, + int flags); /* 239 */ -EXTERN CONST84_RETURN char * Tcl_SignalId(int sig); +EXTERN const char * Tcl_SignalId(int sig); /* 240 */ -EXTERN CONST84_RETURN char * Tcl_SignalMsg(int sig); +EXTERN const char * Tcl_SignalMsg(int sig); /* 241 */ EXTERN void Tcl_SourceRCFile(Tcl_Interp *interp); /* 242 */ EXTERN int Tcl_SplitList(Tcl_Interp *interp, const char *listStr, int *argcPtr, - CONST84 char ***argvPtr); + const char ***argvPtr); /* 243 */ EXTERN void Tcl_SplitPath(const char *path, int *argcPtr, - CONST84 char ***argvPtr); + const char ***argvPtr); /* 244 */ EXTERN void Tcl_StaticPackage(Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 245 */ -EXTERN int Tcl_StringMatch(const char *str, const char *pattern); +TCL_DEPRECATED("No longer in use, changed to macro") +int Tcl_StringMatch(const char *str, const char *pattern); /* 246 */ -EXTERN int Tcl_TellOld(Tcl_Channel chan); +TCL_DEPRECATED("") +int Tcl_TellOld(Tcl_Channel chan); /* 247 */ -EXTERN int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, +TCL_DEPRECATED("No longer in use, changed to macro") +int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 248 */ @@ -755,13 +782,15 @@ EXTERN void Tcl_UnlinkVar(Tcl_Interp *interp, EXTERN int Tcl_UnregisterChannel(Tcl_Interp *interp, Tcl_Channel chan); /* 253 */ -EXTERN int Tcl_UnsetVar(Tcl_Interp *interp, const char *varName, +TCL_DEPRECATED("No longer in use, changed to macro") +int Tcl_UnsetVar(Tcl_Interp *interp, const char *varName, int flags); /* 254 */ EXTERN int Tcl_UnsetVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 255 */ -EXTERN void Tcl_UntraceVar(Tcl_Interp *interp, +TCL_DEPRECATED("No longer in use, changed to macro") +void Tcl_UntraceVar(Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); @@ -774,7 +803,8 @@ EXTERN void Tcl_UntraceVar2(Tcl_Interp *interp, EXTERN void Tcl_UpdateLinkedVar(Tcl_Interp *interp, const char *varName); /* 258 */ -EXTERN int Tcl_UpVar(Tcl_Interp *interp, const char *frameName, +TCL_DEPRECATED("No longer in use, changed to macro") +int Tcl_UpVar(Tcl_Interp *interp, const char *frameName, const char *varName, const char *localName, int flags); /* 259 */ @@ -784,7 +814,8 @@ EXTERN int Tcl_UpVar2(Tcl_Interp *interp, const char *frameName, /* 260 */ EXTERN int Tcl_VarEval(Tcl_Interp *interp, ...); /* 261 */ -EXTERN ClientData Tcl_VarTraceInfo(Tcl_Interp *interp, +TCL_DEPRECATED("No longer in use, changed to macro") +ClientData Tcl_VarTraceInfo(Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData); @@ -803,40 +834,46 @@ EXTERN int Tcl_DumpActiveMemory(const char *fileName); /* 266 */ EXTERN void Tcl_ValidateAllMemory(const char *file, int line); /* 267 */ -EXTERN void Tcl_AppendResultVA(Tcl_Interp *interp, +TCL_DEPRECATED("see TIP #422") +void Tcl_AppendResultVA(Tcl_Interp *interp, va_list argList); /* 268 */ -EXTERN void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, +TCL_DEPRECATED("see TIP #422") +void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, va_list argList); /* 269 */ EXTERN char * Tcl_HashStats(Tcl_HashTable *tablePtr); /* 270 */ -EXTERN CONST84_RETURN char * Tcl_ParseVar(Tcl_Interp *interp, - const char *start, CONST84 char **termPtr); +EXTERN const char * Tcl_ParseVar(Tcl_Interp *interp, const char *start, + const char **termPtr); /* 271 */ -EXTERN CONST84_RETURN char * Tcl_PkgPresent(Tcl_Interp *interp, - const char *name, const char *version, - int exact); +TCL_DEPRECATED("No longer in use, changed to macro") +const char * Tcl_PkgPresent(Tcl_Interp *interp, const char *name, + const char *version, int exact); /* 272 */ -EXTERN CONST84_RETURN char * Tcl_PkgPresentEx(Tcl_Interp *interp, +EXTERN const char * Tcl_PkgPresentEx(Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 273 */ -EXTERN int Tcl_PkgProvide(Tcl_Interp *interp, const char *name, +TCL_DEPRECATED("No longer in use, changed to macro") +int Tcl_PkgProvide(Tcl_Interp *interp, const char *name, const char *version); /* 274 */ -EXTERN CONST84_RETURN char * Tcl_PkgRequire(Tcl_Interp *interp, - const char *name, const char *version, - int exact); +TCL_DEPRECATED("No longer in use, changed to macro") +const char * Tcl_PkgRequire(Tcl_Interp *interp, const char *name, + const char *version, int exact); /* 275 */ -EXTERN void Tcl_SetErrorCodeVA(Tcl_Interp *interp, +TCL_DEPRECATED("see TIP #422") +void Tcl_SetErrorCodeVA(Tcl_Interp *interp, va_list argList); /* 276 */ -EXTERN int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList); +TCL_DEPRECATED("see TIP #422") +int Tcl_VarEvalVA(Tcl_Interp *interp, va_list argList); /* 277 */ EXTERN Tcl_Pid Tcl_WaitPid(Tcl_Pid pid, int *statPtr, int options); /* 278 */ -EXTERN TCL_NORETURN void Tcl_PanicVA(const char *format, va_list argList); +TCL_DEPRECATED("see TIP #422") +TCL_NORETURN void Tcl_PanicVA(const char *format, va_list argList); /* 279 */ EXTERN void Tcl_GetVersion(int *major, int *minor, int *patchLevel, int *type); @@ -878,7 +915,7 @@ EXTERN int Tcl_EvalObjv(Tcl_Interp *interp, int objc, EXTERN int Tcl_EvalObjEx(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 294 */ -EXTERN void Tcl_ExitThread(int status); +EXTERN TCL_NORETURN void Tcl_ExitThread(int status); /* 295 */ EXTERN int Tcl_ExternalToUtf(Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, @@ -901,7 +938,7 @@ EXTERN Tcl_ThreadId Tcl_GetCurrentThread(void); /* 301 */ EXTERN Tcl_Encoding Tcl_GetEncoding(Tcl_Interp *interp, const char *name); /* 302 */ -EXTERN CONST84_RETURN char * Tcl_GetEncodingName(Tcl_Encoding encoding); +EXTERN const char * Tcl_GetEncodingName(Tcl_Encoding encoding); /* 303 */ EXTERN void Tcl_GetEncodingNames(Tcl_Interp *interp); /* 304 */ @@ -950,30 +987,30 @@ EXTERN void Tcl_ThreadAlert(Tcl_ThreadId threadId); EXTERN void Tcl_ThreadQueueEvent(Tcl_ThreadId threadId, Tcl_Event *evPtr, Tcl_QueuePosition position); /* 320 */ -EXTERN Tcl_UniChar Tcl_UniCharAtIndex(const char *src, int index); +EXTERN int Tcl_UniCharAtIndex(const char *src, int index); /* 321 */ -EXTERN Tcl_UniChar Tcl_UniCharToLower(int ch); +EXTERN int Tcl_UniCharToLower(int ch); /* 322 */ -EXTERN Tcl_UniChar Tcl_UniCharToTitle(int ch); +EXTERN int Tcl_UniCharToTitle(int ch); /* 323 */ -EXTERN Tcl_UniChar Tcl_UniCharToUpper(int ch); +EXTERN int Tcl_UniCharToUpper(int ch); /* 324 */ EXTERN int Tcl_UniCharToUtf(int ch, char *buf); /* 325 */ -EXTERN CONST84_RETURN char * Tcl_UtfAtIndex(const char *src, int index); +EXTERN const char * Tcl_UtfAtIndex(const char *src, int index); /* 326 */ EXTERN int Tcl_UtfCharComplete(const char *src, int length); /* 327 */ EXTERN int Tcl_UtfBackslash(const char *src, int *readPtr, char *dst); /* 328 */ -EXTERN CONST84_RETURN char * Tcl_UtfFindFirst(const char *src, int ch); +EXTERN const char * Tcl_UtfFindFirst(const char *src, int ch); /* 329 */ -EXTERN CONST84_RETURN char * Tcl_UtfFindLast(const char *src, int ch); +EXTERN const char * Tcl_UtfFindLast(const char *src, int ch); /* 330 */ -EXTERN CONST84_RETURN char * Tcl_UtfNext(const char *src); +EXTERN const char * Tcl_UtfNext(const char *src); /* 331 */ -EXTERN CONST84_RETURN char * Tcl_UtfPrev(const char *src, const char *start); +EXTERN const char * Tcl_UtfPrev(const char *src, const char *start); /* 332 */ EXTERN int Tcl_UtfToExternal(Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, @@ -1001,9 +1038,11 @@ EXTERN int Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr); /* 340 */ EXTERN char * Tcl_GetString(Tcl_Obj *objPtr); /* 341 */ -EXTERN CONST84_RETURN char * Tcl_GetDefaultEncodingDir(void); +TCL_DEPRECATED("Use Tcl_GetEncodingSearchPath") +const char * Tcl_GetDefaultEncodingDir(void); /* 342 */ -EXTERN void Tcl_SetDefaultEncodingDir(const char *path); +TCL_DEPRECATED("Use Tcl_SetEncodingSearchPath") +void Tcl_SetDefaultEncodingDir(const char *path); /* 343 */ EXTERN void Tcl_AlertNotifier(ClientData clientData); /* 344 */ @@ -1038,7 +1077,8 @@ EXTERN Tcl_UniChar * Tcl_UtfToUniCharDString(const char *src, int length, EXTERN Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj, int flags); /* 357 */ -EXTERN Tcl_Obj * Tcl_EvalTokens(Tcl_Interp *interp, +TCL_DEPRECATED("Use Tcl_EvalTokensStandard") +Tcl_Obj * Tcl_EvalTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, int count); /* 358 */ EXTERN void Tcl_FreeParse(Tcl_Parse *parsePtr); @@ -1050,7 +1090,7 @@ EXTERN void Tcl_LogCommandInfo(Tcl_Interp *interp, EXTERN int Tcl_ParseBraces(Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, - CONST84 char **termPtr); + const char **termPtr); /* 361 */ EXTERN int Tcl_ParseCommand(Tcl_Interp *interp, const char *start, int numBytes, int nested, @@ -1062,7 +1102,7 @@ EXTERN int Tcl_ParseExpr(Tcl_Interp *interp, const char *start, EXTERN int Tcl_ParseQuotedString(Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, - CONST84 char **termPtr); + const char **termPtr); /* 364 */ EXTERN int Tcl_ParseVarName(Tcl_Interp *interp, const char *start, int numBytes, @@ -1108,9 +1148,10 @@ EXTERN void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, /* 380 */ EXTERN int Tcl_GetCharLength(Tcl_Obj *objPtr); /* 381 */ -EXTERN Tcl_UniChar Tcl_GetUniChar(Tcl_Obj *objPtr, int index); +EXTERN int Tcl_GetUniChar(Tcl_Obj *objPtr, int index); /* 382 */ -EXTERN Tcl_UniChar * Tcl_GetUnicode(Tcl_Obj *objPtr); +TCL_DEPRECATED("No longer in use, changed to macro") +Tcl_UniChar * Tcl_GetUnicode(Tcl_Obj *objPtr); /* 383 */ EXTERN Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, int first, int last); /* 384 */ @@ -1152,8 +1193,7 @@ EXTERN Tcl_Channel Tcl_GetTopChannel(Tcl_Channel chan); /* 397 */ EXTERN int Tcl_ChannelBuffered(Tcl_Channel chan); /* 398 */ -EXTERN CONST84_RETURN char * Tcl_ChannelName( - const Tcl_ChannelType *chanTypePtr); +EXTERN const char * Tcl_ChannelName(const Tcl_ChannelType *chanTypePtr); /* 399 */ EXTERN Tcl_ChannelTypeVersion Tcl_ChannelVersion( const Tcl_ChannelType *chanTypePtr); @@ -1259,13 +1299,15 @@ EXTERN Tcl_ThreadId Tcl_GetChannelThread(Tcl_Channel channel); EXTERN Tcl_UniChar * Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, int *lengthPtr); /* 435 */ -EXTERN int Tcl_GetMathFuncInfo(Tcl_Interp *interp, +TCL_DEPRECATED("") +int Tcl_GetMathFuncInfo(Tcl_Interp *interp, const char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, ClientData *clientDataPtr); /* 436 */ -EXTERN Tcl_Obj * Tcl_ListMathFuncs(Tcl_Interp *interp, +TCL_DEPRECATED("") +Tcl_Obj * Tcl_ListMathFuncs(Tcl_Interp *interp, const char *pattern); /* 437 */ EXTERN Tcl_Obj * Tcl_SubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr, @@ -1816,6 +1858,52 @@ 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); +/* 632 */ +EXTERN int TclZipfs_Mount(Tcl_Interp *interp, + const char *mountPoint, const char *zipname, + const char *passwd); +/* 633 */ +EXTERN int TclZipfs_Unmount(Tcl_Interp *interp, + const char *mountPoint); +/* 634 */ +EXTERN Tcl_Obj * TclZipfs_TclLibrary(void); +/* 635 */ +EXTERN int TclZipfs_MountBuffer(Tcl_Interp *interp, + const char *mountPoint, unsigned char *data, + size_t datalen, int copy); +/* 636 */ +EXTERN void Tcl_FreeIntRep(Tcl_Obj *objPtr); +/* 637 */ +EXTERN char * Tcl_InitStringRep(Tcl_Obj *objPtr, const char *bytes, + unsigned int numBytes); +/* 638 */ +EXTERN Tcl_ObjIntRep * Tcl_FetchIntRep(Tcl_Obj *objPtr, + const Tcl_ObjType *typePtr); +/* 639 */ +EXTERN void Tcl_StoreIntRep(Tcl_Obj *objPtr, + const Tcl_ObjType *typePtr, + const Tcl_ObjIntRep *irPtr); +/* 640 */ +EXTERN int Tcl_HasStringRep(Tcl_Obj *objPtr); +/* 641 */ +EXTERN void Tcl_IncrRefCount(Tcl_Obj *objPtr); +/* 642 */ +EXTERN void Tcl_DecrRefCount(Tcl_Obj *objPtr); +/* 643 */ +EXTERN int Tcl_IsShared(Tcl_Obj *objPtr); +/* 644 */ +EXTERN int Tcl_LinkArray(Tcl_Interp *interp, + const char *varName, void *addr, int type, + int size); +/* 645 */ +EXTERN int Tcl_GetIntForIndex(Tcl_Interp *interp, + Tcl_Obj *objPtr, int endValue, int *indexPtr); typedef struct { const struct TclPlatStubs *tclPlatStubs; @@ -1828,7 +1916,7 @@ typedef struct TclStubs { const TclStubHooks *hooks; int (*tcl_PkgProvideEx) (Tcl_Interp *interp, const char *name, const char *version, const void *clientData); /* 0 */ - CONST84_RETURN char * (*tcl_PkgRequireEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 1 */ + const char * (*tcl_PkgRequireEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 1 */ TCL_NORETURN1 void (*tcl_Panic) (const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 2 */ char * (*tcl_Alloc) (unsigned int size); /* 3 */ void (*tcl_Free) (char *ptr); /* 4 */ @@ -1865,21 +1953,21 @@ typedef struct TclStubs { void (*tcl_DbDecrRefCount) (Tcl_Obj *objPtr, const char *file, int line); /* 19 */ void (*tcl_DbIncrRefCount) (Tcl_Obj *objPtr, const char *file, int line); /* 20 */ int (*tcl_DbIsShared) (Tcl_Obj *objPtr, const char *file, int line); /* 21 */ - Tcl_Obj * (*tcl_DbNewBooleanObj) (int boolValue, const char *file, int line); /* 22 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_DbNewBooleanObj) (int boolValue, const char *file, int line); /* 22 */ Tcl_Obj * (*tcl_DbNewByteArrayObj) (const unsigned char *bytes, int length, const char *file, int line); /* 23 */ Tcl_Obj * (*tcl_DbNewDoubleObj) (double doubleValue, const char *file, int line); /* 24 */ Tcl_Obj * (*tcl_DbNewListObj) (int objc, Tcl_Obj *const *objv, const char *file, int line); /* 25 */ - Tcl_Obj * (*tcl_DbNewLongObj) (long longValue, const char *file, int line); /* 26 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_DbNewLongObj) (long longValue, const char *file, int line); /* 26 */ Tcl_Obj * (*tcl_DbNewObj) (const char *file, int line); /* 27 */ Tcl_Obj * (*tcl_DbNewStringObj) (const char *bytes, int length, const char *file, int line); /* 28 */ Tcl_Obj * (*tcl_DuplicateObj) (Tcl_Obj *objPtr); /* 29 */ - void (*tclFreeObj) (Tcl_Obj *objPtr); /* 30 */ + void (*tclOldFreeObj) (Tcl_Obj *objPtr); /* 30 */ int (*tcl_GetBoolean) (Tcl_Interp *interp, const char *src, int *boolPtr); /* 31 */ int (*tcl_GetBooleanFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *boolPtr); /* 32 */ unsigned char * (*tcl_GetByteArrayFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 33 */ int (*tcl_GetDouble) (Tcl_Interp *interp, const char *src, double *doublePtr); /* 34 */ int (*tcl_GetDoubleFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr); /* 35 */ - int (*tcl_GetIndexFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, CONST84 char *const *tablePtr, const char *msg, int flags, int *indexPtr); /* 36 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_GetIndexFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, const char *const *tablePtr, const char *msg, int flags, int *indexPtr); /* 36 */ int (*tcl_GetInt) (Tcl_Interp *interp, const char *src, int *intPtr); /* 37 */ int (*tcl_GetIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int *intPtr); /* 38 */ int (*tcl_GetLongFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr); /* 39 */ @@ -1892,25 +1980,25 @@ typedef struct TclStubs { int (*tcl_ListObjIndex) (Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj **objPtrPtr); /* 46 */ int (*tcl_ListObjLength) (Tcl_Interp *interp, Tcl_Obj *listPtr, int *lengthPtr); /* 47 */ int (*tcl_ListObjReplace) (Tcl_Interp *interp, Tcl_Obj *listPtr, int first, int count, int objc, Tcl_Obj *const objv[]); /* 48 */ - Tcl_Obj * (*tcl_NewBooleanObj) (int boolValue); /* 49 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_NewBooleanObj) (int boolValue); /* 49 */ Tcl_Obj * (*tcl_NewByteArrayObj) (const unsigned char *bytes, int length); /* 50 */ Tcl_Obj * (*tcl_NewDoubleObj) (double doubleValue); /* 51 */ - Tcl_Obj * (*tcl_NewIntObj) (int intValue); /* 52 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_NewIntObj) (int intValue); /* 52 */ Tcl_Obj * (*tcl_NewListObj) (int objc, Tcl_Obj *const objv[]); /* 53 */ - Tcl_Obj * (*tcl_NewLongObj) (long longValue); /* 54 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_NewLongObj) (long longValue); /* 54 */ Tcl_Obj * (*tcl_NewObj) (void); /* 55 */ Tcl_Obj * (*tcl_NewStringObj) (const char *bytes, int length); /* 56 */ - void (*tcl_SetBooleanObj) (Tcl_Obj *objPtr, int boolValue); /* 57 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_SetBooleanObj) (Tcl_Obj *objPtr, int boolValue); /* 57 */ unsigned char * (*tcl_SetByteArrayLength) (Tcl_Obj *objPtr, int length); /* 58 */ void (*tcl_SetByteArrayObj) (Tcl_Obj *objPtr, const unsigned char *bytes, int length); /* 59 */ void (*tcl_SetDoubleObj) (Tcl_Obj *objPtr, double doubleValue); /* 60 */ - void (*tcl_SetIntObj) (Tcl_Obj *objPtr, int intValue); /* 61 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_SetIntObj) (Tcl_Obj *objPtr, int intValue); /* 61 */ void (*tcl_SetListObj) (Tcl_Obj *objPtr, int objc, Tcl_Obj *const objv[]); /* 62 */ - void (*tcl_SetLongObj) (Tcl_Obj *objPtr, long longValue); /* 63 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_SetLongObj) (Tcl_Obj *objPtr, long longValue); /* 63 */ void (*tcl_SetObjLength) (Tcl_Obj *objPtr, int length); /* 64 */ void (*tcl_SetStringObj) (Tcl_Obj *objPtr, const char *bytes, int length); /* 65 */ - void (*tcl_AddErrorInfo) (Tcl_Interp *interp, const char *message); /* 66 */ - void (*tcl_AddObjErrorInfo) (Tcl_Interp *interp, const char *message, int length); /* 67 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_AddErrorInfo) (Tcl_Interp *interp, const char *message); /* 66 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_AddObjErrorInfo) (Tcl_Interp *interp, const char *message, int length); /* 67 */ void (*tcl_AllowExceptions) (Tcl_Interp *interp); /* 68 */ void (*tcl_AppendElement) (Tcl_Interp *interp, const char *element); /* 69 */ void (*tcl_AppendResult) (Tcl_Interp *interp, ...); /* 70 */ @@ -1919,17 +2007,17 @@ typedef struct TclStubs { int (*tcl_AsyncInvoke) (Tcl_Interp *interp, int code); /* 73 */ void (*tcl_AsyncMark) (Tcl_AsyncHandler async); /* 74 */ int (*tcl_AsyncReady) (void); /* 75 */ - void (*tcl_BackgroundError) (Tcl_Interp *interp); /* 76 */ - char (*tcl_Backslash) (const char *src, int *readPtr); /* 77 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_BackgroundError) (Tcl_Interp *interp); /* 76 */ + TCL_DEPRECATED_API("Use Tcl_UtfBackslash") char (*tcl_Backslash) (const char *src, int *readPtr); /* 77 */ int (*tcl_BadChannelOption) (Tcl_Interp *interp, const char *optionName, const char *optionList); /* 78 */ void (*tcl_CallWhenDeleted) (Tcl_Interp *interp, Tcl_InterpDeleteProc *proc, ClientData clientData); /* 79 */ void (*tcl_CancelIdleCall) (Tcl_IdleProc *idleProc, ClientData clientData); /* 80 */ int (*tcl_Close) (Tcl_Interp *interp, Tcl_Channel chan); /* 81 */ int (*tcl_CommandComplete) (const char *cmd); /* 82 */ - char * (*tcl_Concat) (int argc, CONST84 char *const *argv); /* 83 */ + char * (*tcl_Concat) (int argc, const char *const *argv); /* 83 */ int (*tcl_ConvertElement) (const char *src, char *dst, int flags); /* 84 */ int (*tcl_ConvertCountedElement) (const char *src, int length, char *dst, int flags); /* 85 */ - int (*tcl_CreateAlias) (Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int argc, CONST84 char *const *argv); /* 86 */ + int (*tcl_CreateAlias) (Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int argc, const char *const *argv); /* 86 */ int (*tcl_CreateAliasObj) (Tcl_Interp *slave, const char *slaveCmd, Tcl_Interp *target, const char *targetCmd, int objc, Tcl_Obj *const objv[]); /* 87 */ Tcl_Channel (*tcl_CreateChannel) (const Tcl_ChannelType *typePtr, const char *chanName, ClientData instanceData, int mask); /* 88 */ void (*tcl_CreateChannelHandler) (Tcl_Channel chan, int mask, Tcl_ChannelProc *proc, ClientData clientData); /* 89 */ @@ -1938,7 +2026,7 @@ typedef struct TclStubs { void (*tcl_CreateEventSource) (Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, ClientData clientData); /* 92 */ void (*tcl_CreateExitHandler) (Tcl_ExitProc *proc, ClientData clientData); /* 93 */ Tcl_Interp * (*tcl_CreateInterp) (void); /* 94 */ - void (*tcl_CreateMathFunc) (Tcl_Interp *interp, const char *name, int numArgs, Tcl_ValueType *argTypes, Tcl_MathProc *proc, ClientData clientData); /* 95 */ + TCL_DEPRECATED_API("") void (*tcl_CreateMathFunc) (Tcl_Interp *interp, const char *name, int numArgs, Tcl_ValueType *argTypes, Tcl_MathProc *proc, ClientData clientData); /* 95 */ Tcl_Command (*tcl_CreateObjCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); /* 96 */ Tcl_Interp * (*tcl_CreateSlave) (Tcl_Interp *interp, const char *slaveName, int isSafe); /* 97 */ Tcl_TimerToken (*tcl_CreateTimerHandler) (int milliseconds, Tcl_TimerProc *proc, ClientData clientData); /* 98 */ @@ -1970,11 +2058,11 @@ typedef struct TclStubs { void (*tcl_DStringSetLength) (Tcl_DString *dsPtr, int length); /* 124 */ void (*tcl_DStringStartSublist) (Tcl_DString *dsPtr); /* 125 */ int (*tcl_Eof) (Tcl_Channel chan); /* 126 */ - CONST84_RETURN char * (*tcl_ErrnoId) (void); /* 127 */ - CONST84_RETURN char * (*tcl_ErrnoMsg) (int err); /* 128 */ + const char * (*tcl_ErrnoId) (void); /* 127 */ + const char * (*tcl_ErrnoMsg) (int err); /* 128 */ int (*tcl_Eval) (Tcl_Interp *interp, const char *script); /* 129 */ int (*tcl_EvalFile) (Tcl_Interp *interp, const char *fileName); /* 130 */ - int (*tcl_EvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 131 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_EvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 131 */ void (*tcl_EventuallyFree) (ClientData clientData, Tcl_FreeProc *freeProc); /* 132 */ TCL_NORETURN1 void (*tcl_Exit) (int status); /* 133 */ int (*tcl_ExposeCommand) (Tcl_Interp *interp, const char *hiddenCmdToken, const char *cmdName); /* 134 */ @@ -1987,25 +2075,25 @@ typedef struct TclStubs { int (*tcl_ExprObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj **resultPtrPtr); /* 141 */ int (*tcl_ExprString) (Tcl_Interp *interp, const char *expr); /* 142 */ void (*tcl_Finalize) (void); /* 143 */ - void (*tcl_FindExecutable) (const char *argv0); /* 144 */ + TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") void (*tcl_FindExecutable) (const char *argv0); /* 144 */ Tcl_HashEntry * (*tcl_FirstHashEntry) (Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); /* 145 */ int (*tcl_Flush) (Tcl_Channel chan); /* 146 */ void (*tcl_FreeResult) (Tcl_Interp *interp); /* 147 */ - int (*tcl_GetAlias) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *argcPtr, CONST84 char ***argvPtr); /* 148 */ - int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, CONST84 char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 149 */ + int (*tcl_GetAlias) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *argcPtr, const char ***argvPtr); /* 148 */ + int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *slaveCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objv); /* 149 */ ClientData (*tcl_GetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc **procPtr); /* 150 */ Tcl_Channel (*tcl_GetChannel) (Tcl_Interp *interp, const char *chanName, int *modePtr); /* 151 */ int (*tcl_GetChannelBufferSize) (Tcl_Channel chan); /* 152 */ int (*tcl_GetChannelHandle) (Tcl_Channel chan, int direction, ClientData *handlePtr); /* 153 */ ClientData (*tcl_GetChannelInstanceData) (Tcl_Channel chan); /* 154 */ int (*tcl_GetChannelMode) (Tcl_Channel chan); /* 155 */ - CONST84_RETURN char * (*tcl_GetChannelName) (Tcl_Channel chan); /* 156 */ + const char * (*tcl_GetChannelName) (Tcl_Channel chan); /* 156 */ int (*tcl_GetChannelOption) (Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, Tcl_DString *dsPtr); /* 157 */ CONST86 Tcl_ChannelType * (*tcl_GetChannelType) (Tcl_Channel chan); /* 158 */ int (*tcl_GetCommandInfo) (Tcl_Interp *interp, const char *cmdName, Tcl_CmdInfo *infoPtr); /* 159 */ - CONST84_RETURN char * (*tcl_GetCommandName) (Tcl_Interp *interp, Tcl_Command command); /* 160 */ + const char * (*tcl_GetCommandName) (Tcl_Interp *interp, Tcl_Command command); /* 160 */ int (*tcl_GetErrno) (void); /* 161 */ - CONST84_RETURN char * (*tcl_GetHostName) (void); /* 162 */ + const char * (*tcl_GetHostName) (void); /* 162 */ int (*tcl_GetInterpPath) (Tcl_Interp *askInterp, Tcl_Interp *slaveInterp); /* 163 */ Tcl_Interp * (*tcl_GetMaster) (Tcl_Interp *interp); /* 164 */ const char * (*tcl_GetNameOfExecutable) (void); /* 165 */ @@ -2025,11 +2113,11 @@ typedef struct TclStubs { int (*tcl_GetServiceMode) (void); /* 171 */ Tcl_Interp * (*tcl_GetSlave) (Tcl_Interp *interp, const char *slaveName); /* 172 */ Tcl_Channel (*tcl_GetStdChannel) (int type); /* 173 */ - CONST84_RETURN char * (*tcl_GetStringResult) (Tcl_Interp *interp); /* 174 */ - CONST84_RETURN char * (*tcl_GetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 175 */ - CONST84_RETURN char * (*tcl_GetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 176 */ + const char * (*tcl_GetStringResult) (Tcl_Interp *interp); /* 174 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") const char * (*tcl_GetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 175 */ + const char * (*tcl_GetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 176 */ int (*tcl_GlobalEval) (Tcl_Interp *interp, const char *command); /* 177 */ - int (*tcl_GlobalEvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 178 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_GlobalEvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 178 */ int (*tcl_HideCommand) (Tcl_Interp *interp, const char *cmdName, const char *hiddenCmdToken); /* 179 */ int (*tcl_Init) (Tcl_Interp *interp); /* 180 */ void (*tcl_InitHashTable) (Tcl_HashTable *tablePtr, int keyType); /* 181 */ @@ -2037,25 +2125,25 @@ typedef struct TclStubs { int (*tcl_InputBuffered) (Tcl_Channel chan); /* 183 */ int (*tcl_InterpDeleted) (Tcl_Interp *interp); /* 184 */ int (*tcl_IsSafe) (Tcl_Interp *interp); /* 185 */ - char * (*tcl_JoinPath) (int argc, CONST84 char *const *argv, Tcl_DString *resultPtr); /* 186 */ - int (*tcl_LinkVar) (Tcl_Interp *interp, const char *varName, char *addr, int type); /* 187 */ + char * (*tcl_JoinPath) (int argc, const char *const *argv, Tcl_DString *resultPtr); /* 186 */ + int (*tcl_LinkVar) (Tcl_Interp *interp, const char *varName, void *addr, int type); /* 187 */ void (*reserved188)(void); Tcl_Channel (*tcl_MakeFileChannel) (ClientData handle, int mode); /* 189 */ int (*tcl_MakeSafe) (Tcl_Interp *interp); /* 190 */ Tcl_Channel (*tcl_MakeTcpClientChannel) (ClientData tcpSocket); /* 191 */ - char * (*tcl_Merge) (int argc, CONST84 char *const *argv); /* 192 */ + char * (*tcl_Merge) (int argc, const char *const *argv); /* 192 */ Tcl_HashEntry * (*tcl_NextHashEntry) (Tcl_HashSearch *searchPtr); /* 193 */ void (*tcl_NotifyChannel) (Tcl_Channel channel, int mask); /* 194 */ Tcl_Obj * (*tcl_ObjGetVar2) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, int flags); /* 195 */ Tcl_Obj * (*tcl_ObjSetVar2) (Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, int flags); /* 196 */ - Tcl_Channel (*tcl_OpenCommandChannel) (Tcl_Interp *interp, int argc, CONST84 char **argv, int flags); /* 197 */ + Tcl_Channel (*tcl_OpenCommandChannel) (Tcl_Interp *interp, int argc, const char **argv, int flags); /* 197 */ Tcl_Channel (*tcl_OpenFileChannel) (Tcl_Interp *interp, const char *fileName, const char *modeString, int permissions); /* 198 */ Tcl_Channel (*tcl_OpenTcpClient) (Tcl_Interp *interp, int port, const char *address, const char *myaddr, int myport, int async); /* 199 */ Tcl_Channel (*tcl_OpenTcpServer) (Tcl_Interp *interp, int port, const char *host, Tcl_TcpAcceptProc *acceptProc, ClientData callbackData); /* 200 */ void (*tcl_Preserve) (ClientData data); /* 201 */ void (*tcl_PrintDouble) (Tcl_Interp *interp, double value, char *dst); /* 202 */ int (*tcl_PutEnv) (const char *assignment); /* 203 */ - CONST84_RETURN char * (*tcl_PosixError) (Tcl_Interp *interp); /* 204 */ + const char * (*tcl_PosixError) (Tcl_Interp *interp); /* 204 */ void (*tcl_QueueEvent) (Tcl_Event *evPtr, Tcl_QueuePosition position); /* 205 */ int (*tcl_Read) (Tcl_Channel chan, char *bufPtr, int toRead); /* 206 */ void (*tcl_ReapDetachedProcs) (void); /* 207 */ @@ -2066,12 +2154,12 @@ typedef struct TclStubs { Tcl_RegExp (*tcl_RegExpCompile) (Tcl_Interp *interp, const char *pattern); /* 212 */ int (*tcl_RegExpExec) (Tcl_Interp *interp, Tcl_RegExp regexp, const char *text, const char *start); /* 213 */ int (*tcl_RegExpMatch) (Tcl_Interp *interp, const char *text, const char *pattern); /* 214 */ - void (*tcl_RegExpRange) (Tcl_RegExp regexp, int index, CONST84 char **startPtr, CONST84 char **endPtr); /* 215 */ + void (*tcl_RegExpRange) (Tcl_RegExp regexp, int index, const char **startPtr, const char **endPtr); /* 215 */ void (*tcl_Release) (ClientData clientData); /* 216 */ void (*tcl_ResetResult) (Tcl_Interp *interp); /* 217 */ int (*tcl_ScanElement) (const char *src, int *flagPtr); /* 218 */ int (*tcl_ScanCountedElement) (const char *src, int length, int *flagPtr); /* 219 */ - int (*tcl_SeekOld) (Tcl_Channel chan, int offset, int mode); /* 220 */ + TCL_DEPRECATED_API("") int (*tcl_SeekOld) (Tcl_Channel chan, int offset, int mode); /* 220 */ int (*tcl_ServiceAll) (void); /* 221 */ int (*tcl_ServiceEvent) (int flags); /* 222 */ void (*tcl_SetAssocData) (Tcl_Interp *interp, const char *name, Tcl_InterpDeleteProc *proc, ClientData clientData); /* 223 */ @@ -2081,55 +2169,55 @@ typedef struct TclStubs { void (*tcl_SetErrno) (int err); /* 227 */ void (*tcl_SetErrorCode) (Tcl_Interp *interp, ...); /* 228 */ void (*tcl_SetMaxBlockTime) (const Tcl_Time *timePtr); /* 229 */ - void (*tcl_SetPanicProc) (TCL_NORETURN1 Tcl_PanicProc *panicProc); /* 230 */ + TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") void (*tcl_SetPanicProc) (TCL_NORETURN1 Tcl_PanicProc *panicProc); /* 230 */ int (*tcl_SetRecursionLimit) (Tcl_Interp *interp, int depth); /* 231 */ void (*tcl_SetResult) (Tcl_Interp *interp, char *result, Tcl_FreeProc *freeProc); /* 232 */ int (*tcl_SetServiceMode) (int mode); /* 233 */ void (*tcl_SetObjErrorCode) (Tcl_Interp *interp, Tcl_Obj *errorObjPtr); /* 234 */ void (*tcl_SetObjResult) (Tcl_Interp *interp, Tcl_Obj *resultObjPtr); /* 235 */ void (*tcl_SetStdChannel) (Tcl_Channel channel, int type); /* 236 */ - CONST84_RETURN char * (*tcl_SetVar) (Tcl_Interp *interp, const char *varName, const char *newValue, int flags); /* 237 */ - CONST84_RETURN char * (*tcl_SetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, const char *newValue, int flags); /* 238 */ - CONST84_RETURN char * (*tcl_SignalId) (int sig); /* 239 */ - CONST84_RETURN char * (*tcl_SignalMsg) (int sig); /* 240 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") const char * (*tcl_SetVar) (Tcl_Interp *interp, const char *varName, const char *newValue, int flags); /* 237 */ + const char * (*tcl_SetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, const char *newValue, int flags); /* 238 */ + const char * (*tcl_SignalId) (int sig); /* 239 */ + const char * (*tcl_SignalMsg) (int sig); /* 240 */ void (*tcl_SourceRCFile) (Tcl_Interp *interp); /* 241 */ - int (*tcl_SplitList) (Tcl_Interp *interp, const char *listStr, int *argcPtr, CONST84 char ***argvPtr); /* 242 */ - void (*tcl_SplitPath) (const char *path, int *argcPtr, CONST84 char ***argvPtr); /* 243 */ - void (*tcl_StaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 244 */ - int (*tcl_StringMatch) (const char *str, const char *pattern); /* 245 */ - int (*tcl_TellOld) (Tcl_Channel chan); /* 246 */ - int (*tcl_TraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 247 */ + int (*tcl_SplitList) (Tcl_Interp *interp, const char *listStr, int *argcPtr, const char ***argvPtr); /* 242 */ + void (*tcl_SplitPath) (const char *path, int *argcPtr, const char ***argvPtr); /* 243 */ + TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") void (*tcl_StaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 244 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_StringMatch) (const char *str, const char *pattern); /* 245 */ + TCL_DEPRECATED_API("") int (*tcl_TellOld) (Tcl_Channel chan); /* 246 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_TraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 247 */ int (*tcl_TraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 248 */ char * (*tcl_TranslateFileName) (Tcl_Interp *interp, const char *name, Tcl_DString *bufferPtr); /* 249 */ int (*tcl_Ungets) (Tcl_Channel chan, const char *str, int len, int atHead); /* 250 */ void (*tcl_UnlinkVar) (Tcl_Interp *interp, const char *varName); /* 251 */ int (*tcl_UnregisterChannel) (Tcl_Interp *interp, Tcl_Channel chan); /* 252 */ - int (*tcl_UnsetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 253 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_UnsetVar) (Tcl_Interp *interp, const char *varName, int flags); /* 253 */ int (*tcl_UnsetVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags); /* 254 */ - void (*tcl_UntraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 255 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_UntraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 255 */ void (*tcl_UntraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, ClientData clientData); /* 256 */ void (*tcl_UpdateLinkedVar) (Tcl_Interp *interp, const char *varName); /* 257 */ - int (*tcl_UpVar) (Tcl_Interp *interp, const char *frameName, const char *varName, const char *localName, int flags); /* 258 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_UpVar) (Tcl_Interp *interp, const char *frameName, const char *varName, const char *localName, int flags); /* 258 */ int (*tcl_UpVar2) (Tcl_Interp *interp, const char *frameName, const char *part1, const char *part2, const char *localName, int flags); /* 259 */ int (*tcl_VarEval) (Tcl_Interp *interp, ...); /* 260 */ - ClientData (*tcl_VarTraceInfo) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData); /* 261 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") ClientData (*tcl_VarTraceInfo) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData); /* 261 */ ClientData (*tcl_VarTraceInfo2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *procPtr, ClientData prevClientData); /* 262 */ int (*tcl_Write) (Tcl_Channel chan, const char *s, int slen); /* 263 */ void (*tcl_WrongNumArgs) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], const char *message); /* 264 */ int (*tcl_DumpActiveMemory) (const char *fileName); /* 265 */ void (*tcl_ValidateAllMemory) (const char *file, int line); /* 266 */ - void (*tcl_AppendResultVA) (Tcl_Interp *interp, va_list argList); /* 267 */ - void (*tcl_AppendStringsToObjVA) (Tcl_Obj *objPtr, va_list argList); /* 268 */ + TCL_DEPRECATED_API("see TIP #422") void (*tcl_AppendResultVA) (Tcl_Interp *interp, va_list argList); /* 267 */ + TCL_DEPRECATED_API("see TIP #422") void (*tcl_AppendStringsToObjVA) (Tcl_Obj *objPtr, va_list argList); /* 268 */ char * (*tcl_HashStats) (Tcl_HashTable *tablePtr); /* 269 */ - CONST84_RETURN char * (*tcl_ParseVar) (Tcl_Interp *interp, const char *start, CONST84 char **termPtr); /* 270 */ - CONST84_RETURN char * (*tcl_PkgPresent) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 271 */ - CONST84_RETURN char * (*tcl_PkgPresentEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 272 */ - int (*tcl_PkgProvide) (Tcl_Interp *interp, const char *name, const char *version); /* 273 */ - CONST84_RETURN char * (*tcl_PkgRequire) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 274 */ - void (*tcl_SetErrorCodeVA) (Tcl_Interp *interp, va_list argList); /* 275 */ - int (*tcl_VarEvalVA) (Tcl_Interp *interp, va_list argList); /* 276 */ + const char * (*tcl_ParseVar) (Tcl_Interp *interp, const char *start, const char **termPtr); /* 270 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") const char * (*tcl_PkgPresent) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 271 */ + const char * (*tcl_PkgPresentEx) (Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); /* 272 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_PkgProvide) (Tcl_Interp *interp, const char *name, const char *version); /* 273 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") const char * (*tcl_PkgRequire) (Tcl_Interp *interp, const char *name, const char *version, int exact); /* 274 */ + TCL_DEPRECATED_API("see TIP #422") void (*tcl_SetErrorCodeVA) (Tcl_Interp *interp, va_list argList); /* 275 */ + TCL_DEPRECATED_API("see TIP #422") int (*tcl_VarEvalVA) (Tcl_Interp *interp, va_list argList); /* 276 */ Tcl_Pid (*tcl_WaitPid) (Tcl_Pid pid, int *statPtr, int options); /* 277 */ - TCL_NORETURN1 void (*tcl_PanicVA) (const char *format, va_list argList); /* 278 */ + TCL_DEPRECATED_API("see TIP #422") TCL_NORETURN1 void (*tcl_PanicVA) (const char *format, va_list argList); /* 278 */ void (*tcl_GetVersion) (int *major, int *minor, int *patchLevel, int *type); /* 279 */ void (*tcl_InitMemory) (Tcl_Interp *interp); /* 280 */ Tcl_Channel (*tcl_StackChannel) (Tcl_Interp *interp, const Tcl_ChannelType *typePtr, ClientData instanceData, int mask, Tcl_Channel prevChan); /* 281 */ @@ -2145,7 +2233,7 @@ typedef struct TclStubs { int (*tcl_EvalEx) (Tcl_Interp *interp, const char *script, int numBytes, int flags); /* 291 */ int (*tcl_EvalObjv) (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags); /* 292 */ int (*tcl_EvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 293 */ - void (*tcl_ExitThread) (int status); /* 294 */ + TCL_NORETURN1 void (*tcl_ExitThread) (int status); /* 294 */ int (*tcl_ExternalToUtf) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 295 */ char * (*tcl_ExternalToUtfDString) (Tcl_Encoding encoding, const char *src, int srcLen, Tcl_DString *dsPtr); /* 296 */ void (*tcl_FinalizeThread) (void); /* 297 */ @@ -2153,7 +2241,7 @@ typedef struct TclStubs { void (*tcl_FreeEncoding) (Tcl_Encoding encoding); /* 299 */ Tcl_ThreadId (*tcl_GetCurrentThread) (void); /* 300 */ Tcl_Encoding (*tcl_GetEncoding) (Tcl_Interp *interp, const char *name); /* 301 */ - CONST84_RETURN char * (*tcl_GetEncodingName) (Tcl_Encoding encoding); /* 302 */ + const char * (*tcl_GetEncodingName) (Tcl_Encoding encoding); /* 302 */ void (*tcl_GetEncodingNames) (Tcl_Interp *interp); /* 303 */ int (*tcl_GetIndexFromObjStruct) (Tcl_Interp *interp, Tcl_Obj *objPtr, const void *tablePtr, int offset, const char *msg, int flags, int *indexPtr); /* 304 */ void * (*tcl_GetThreadData) (Tcl_ThreadDataKey *keyPtr, int size); /* 305 */ @@ -2171,18 +2259,18 @@ typedef struct TclStubs { Tcl_Obj * (*tcl_SetVar2Ex) (Tcl_Interp *interp, const char *part1, const char *part2, Tcl_Obj *newValuePtr, int flags); /* 317 */ void (*tcl_ThreadAlert) (Tcl_ThreadId threadId); /* 318 */ void (*tcl_ThreadQueueEvent) (Tcl_ThreadId threadId, Tcl_Event *evPtr, Tcl_QueuePosition position); /* 319 */ - Tcl_UniChar (*tcl_UniCharAtIndex) (const char *src, int index); /* 320 */ - Tcl_UniChar (*tcl_UniCharToLower) (int ch); /* 321 */ - Tcl_UniChar (*tcl_UniCharToTitle) (int ch); /* 322 */ - Tcl_UniChar (*tcl_UniCharToUpper) (int ch); /* 323 */ + int (*tcl_UniCharAtIndex) (const char *src, int index); /* 320 */ + int (*tcl_UniCharToLower) (int ch); /* 321 */ + int (*tcl_UniCharToTitle) (int ch); /* 322 */ + int (*tcl_UniCharToUpper) (int ch); /* 323 */ int (*tcl_UniCharToUtf) (int ch, char *buf); /* 324 */ - CONST84_RETURN char * (*tcl_UtfAtIndex) (const char *src, int index); /* 325 */ + const char * (*tcl_UtfAtIndex) (const char *src, int index); /* 325 */ int (*tcl_UtfCharComplete) (const char *src, int length); /* 326 */ int (*tcl_UtfBackslash) (const char *src, int *readPtr, char *dst); /* 327 */ - CONST84_RETURN char * (*tcl_UtfFindFirst) (const char *src, int ch); /* 328 */ - CONST84_RETURN char * (*tcl_UtfFindLast) (const char *src, int ch); /* 329 */ - CONST84_RETURN char * (*tcl_UtfNext) (const char *src); /* 330 */ - CONST84_RETURN char * (*tcl_UtfPrev) (const char *src, const char *start); /* 331 */ + const char * (*tcl_UtfFindFirst) (const char *src, int ch); /* 328 */ + const char * (*tcl_UtfFindLast) (const char *src, int ch); /* 329 */ + const char * (*tcl_UtfNext) (const char *src); /* 330 */ + const char * (*tcl_UtfPrev) (const char *src, const char *start); /* 331 */ int (*tcl_UtfToExternal) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); /* 332 */ char * (*tcl_UtfToExternalDString) (Tcl_Encoding encoding, const char *src, int srcLen, Tcl_DString *dsPtr); /* 333 */ int (*tcl_UtfToLower) (char *src); /* 334 */ @@ -2192,8 +2280,8 @@ typedef struct TclStubs { int (*tcl_WriteChars) (Tcl_Channel chan, const char *src, int srcLen); /* 338 */ int (*tcl_WriteObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 339 */ char * (*tcl_GetString) (Tcl_Obj *objPtr); /* 340 */ - CONST84_RETURN char * (*tcl_GetDefaultEncodingDir) (void); /* 341 */ - void (*tcl_SetDefaultEncodingDir) (const char *path); /* 342 */ + TCL_DEPRECATED_API("Use Tcl_GetEncodingSearchPath") const char * (*tcl_GetDefaultEncodingDir) (void); /* 341 */ + TCL_DEPRECATED_API("Use Tcl_SetEncodingSearchPath") void (*tcl_SetDefaultEncodingDir) (const char *path); /* 342 */ void (*tcl_AlertNotifier) (ClientData clientData); /* 343 */ void (*tcl_ServiceModeHook) (int mode); /* 344 */ int (*tcl_UniCharIsAlnum) (int ch); /* 345 */ @@ -2208,13 +2296,13 @@ typedef struct TclStubs { char * (*tcl_UniCharToUtfDString) (const Tcl_UniChar *uniStr, int uniLength, Tcl_DString *dsPtr); /* 354 */ Tcl_UniChar * (*tcl_UtfToUniCharDString) (const char *src, int length, Tcl_DString *dsPtr); /* 355 */ Tcl_RegExp (*tcl_GetRegExpFromObj) (Tcl_Interp *interp, Tcl_Obj *patObj, int flags); /* 356 */ - Tcl_Obj * (*tcl_EvalTokens) (Tcl_Interp *interp, Tcl_Token *tokenPtr, int count); /* 357 */ + TCL_DEPRECATED_API("Use Tcl_EvalTokensStandard") Tcl_Obj * (*tcl_EvalTokens) (Tcl_Interp *interp, Tcl_Token *tokenPtr, int count); /* 357 */ void (*tcl_FreeParse) (Tcl_Parse *parsePtr); /* 358 */ void (*tcl_LogCommandInfo) (Tcl_Interp *interp, const char *script, const char *command, int length); /* 359 */ - int (*tcl_ParseBraces) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, CONST84 char **termPtr); /* 360 */ + int (*tcl_ParseBraces) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr); /* 360 */ int (*tcl_ParseCommand) (Tcl_Interp *interp, const char *start, int numBytes, int nested, Tcl_Parse *parsePtr); /* 361 */ int (*tcl_ParseExpr) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr); /* 362 */ - int (*tcl_ParseQuotedString) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, CONST84 char **termPtr); /* 363 */ + int (*tcl_ParseQuotedString) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr); /* 363 */ int (*tcl_ParseVarName) (Tcl_Interp *interp, const char *start, int numBytes, Tcl_Parse *parsePtr, int append); /* 364 */ char * (*tcl_GetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 365 */ int (*tcl_Chdir) (const char *dirName); /* 366 */ @@ -2232,8 +2320,8 @@ typedef struct TclStubs { Tcl_Obj * (*tcl_NewUnicodeObj) (const Tcl_UniChar *unicode, int numChars); /* 378 */ void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int numChars); /* 379 */ int (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 380 */ - Tcl_UniChar (*tcl_GetUniChar) (Tcl_Obj *objPtr, int index); /* 381 */ - Tcl_UniChar * (*tcl_GetUnicode) (Tcl_Obj *objPtr); /* 382 */ + int (*tcl_GetUniChar) (Tcl_Obj *objPtr, int index); /* 381 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_UniChar * (*tcl_GetUnicode) (Tcl_Obj *objPtr); /* 382 */ Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, int first, int last); /* 383 */ void (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, int length); /* 384 */ int (*tcl_RegExpMatchObj) (Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); /* 385 */ @@ -2249,7 +2337,7 @@ typedef struct TclStubs { int (*tcl_WriteRaw) (Tcl_Channel chan, const char *src, int srcLen); /* 395 */ Tcl_Channel (*tcl_GetTopChannel) (Tcl_Channel chan); /* 396 */ int (*tcl_ChannelBuffered) (Tcl_Channel chan); /* 397 */ - CONST84_RETURN char * (*tcl_ChannelName) (const Tcl_ChannelType *chanTypePtr); /* 398 */ + const char * (*tcl_ChannelName) (const Tcl_ChannelType *chanTypePtr); /* 398 */ Tcl_ChannelTypeVersion (*tcl_ChannelVersion) (const Tcl_ChannelType *chanTypePtr); /* 399 */ Tcl_DriverBlockModeProc * (*tcl_ChannelBlockModeProc) (const Tcl_ChannelType *chanTypePtr); /* 400 */ Tcl_DriverCloseProc * (*tcl_ChannelCloseProc) (const Tcl_ChannelType *chanTypePtr); /* 401 */ @@ -2286,8 +2374,8 @@ typedef struct TclStubs { int (*tcl_AttemptSetObjLength) (Tcl_Obj *objPtr, int length); /* 432 */ Tcl_ThreadId (*tcl_GetChannelThread) (Tcl_Channel channel); /* 433 */ Tcl_UniChar * (*tcl_GetUnicodeFromObj) (Tcl_Obj *objPtr, int *lengthPtr); /* 434 */ - int (*tcl_GetMathFuncInfo) (Tcl_Interp *interp, const char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, ClientData *clientDataPtr); /* 435 */ - Tcl_Obj * (*tcl_ListMathFuncs) (Tcl_Interp *interp, const char *pattern); /* 436 */ + TCL_DEPRECATED_API("") int (*tcl_GetMathFuncInfo) (Tcl_Interp *interp, const char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, ClientData *clientDataPtr); /* 435 */ + TCL_DEPRECATED_API("") Tcl_Obj * (*tcl_ListMathFuncs) (Tcl_Interp *interp, const char *pattern); /* 436 */ Tcl_Obj * (*tcl_SubstObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 437 */ int (*tcl_DetachChannel) (Tcl_Interp *interp, Tcl_Channel channel); /* 438 */ int (*tcl_IsStandardChannel) (Tcl_Channel channel); /* 439 */ @@ -2370,7 +2458,7 @@ typedef struct TclStubs { Tcl_Command (*tcl_GetCommandFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 516 */ void (*tcl_GetCommandFullName) (Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 517 */ int (*tcl_FSEvalFileEx) (Tcl_Interp *interp, Tcl_Obj *fileName, const char *encodingName); /* 518 */ - Tcl_ExitProc * (*tcl_SetExitProc) (TCL_NORETURN1 Tcl_ExitProc *proc); /* 519 */ + TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") Tcl_ExitProc * (*tcl_SetExitProc) (TCL_NORETURN1 Tcl_ExitProc *proc); /* 519 */ void (*tcl_LimitAddHandler) (Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, ClientData clientData, Tcl_LimitHandlerDeleteProc *deleteProc); /* 520 */ void (*tcl_LimitRemoveHandler) (Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, ClientData clientData); /* 521 */ int (*tcl_LimitReady) (Tcl_Interp *interp); /* 522 */ @@ -2482,6 +2570,21 @@ 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 */ + int (*tclZipfs_Mount) (Tcl_Interp *interp, const char *mountPoint, const char *zipname, const char *passwd); /* 632 */ + int (*tclZipfs_Unmount) (Tcl_Interp *interp, const char *mountPoint); /* 633 */ + Tcl_Obj * (*tclZipfs_TclLibrary) (void); /* 634 */ + int (*tclZipfs_MountBuffer) (Tcl_Interp *interp, const char *mountPoint, unsigned char *data, size_t datalen, int copy); /* 635 */ + void (*tcl_FreeIntRep) (Tcl_Obj *objPtr); /* 636 */ + char * (*tcl_InitStringRep) (Tcl_Obj *objPtr, const char *bytes, unsigned int numBytes); /* 637 */ + Tcl_ObjIntRep * (*tcl_FetchIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr); /* 638 */ + void (*tcl_StoreIntRep) (Tcl_Obj *objPtr, const Tcl_ObjType *typePtr, const Tcl_ObjIntRep *irPtr); /* 639 */ + int (*tcl_HasStringRep) (Tcl_Obj *objPtr); /* 640 */ + void (*tcl_IncrRefCount) (Tcl_Obj *objPtr); /* 641 */ + void (*tcl_DecrRefCount) (Tcl_Obj *objPtr); /* 642 */ + int (*tcl_IsShared) (Tcl_Obj *objPtr); /* 643 */ + int (*tcl_LinkArray) (Tcl_Interp *interp, const char *varName, void *addr, int type, int size); /* 644 */ + int (*tcl_GetIntForIndex) (Tcl_Interp *interp, Tcl_Obj *objPtr, int endValue, int *indexPtr); /* 645 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -2568,8 +2671,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_DbNewStringObj) /* 28 */ #define Tcl_DuplicateObj \ (tclStubsPtr->tcl_DuplicateObj) /* 29 */ -#define TclFreeObj \ - (tclStubsPtr->tclFreeObj) /* 30 */ +#define TclOldFreeObj \ + (tclStubsPtr->tclOldFreeObj) /* 30 */ #define Tcl_GetBoolean \ (tclStubsPtr->tcl_GetBoolean) /* 31 */ #define Tcl_GetBooleanFromObj \ @@ -3774,6 +3877,36 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_FSUnloadFile) /* 629 */ #define Tcl_ZlibStreamSetCompressionDictionary \ (tclStubsPtr->tcl_ZlibStreamSetCompressionDictionary) /* 630 */ +#define Tcl_OpenTcpServerEx \ + (tclStubsPtr->tcl_OpenTcpServerEx) /* 631 */ +#define TclZipfs_Mount \ + (tclStubsPtr->tclZipfs_Mount) /* 632 */ +#define TclZipfs_Unmount \ + (tclStubsPtr->tclZipfs_Unmount) /* 633 */ +#define TclZipfs_TclLibrary \ + (tclStubsPtr->tclZipfs_TclLibrary) /* 634 */ +#define TclZipfs_MountBuffer \ + (tclStubsPtr->tclZipfs_MountBuffer) /* 635 */ +#define Tcl_FreeIntRep \ + (tclStubsPtr->tcl_FreeIntRep) /* 636 */ +#define Tcl_InitStringRep \ + (tclStubsPtr->tcl_InitStringRep) /* 637 */ +#define Tcl_FetchIntRep \ + (tclStubsPtr->tcl_FetchIntRep) /* 638 */ +#define Tcl_StoreIntRep \ + (tclStubsPtr->tcl_StoreIntRep) /* 639 */ +#define Tcl_HasStringRep \ + (tclStubsPtr->tcl_HasStringRep) /* 640 */ +#define Tcl_IncrRefCount \ + (tclStubsPtr->tcl_IncrRefCount) /* 641 */ +#define Tcl_DecrRefCount \ + (tclStubsPtr->tcl_DecrRefCount) /* 642 */ +#define Tcl_IsShared \ + (tclStubsPtr->tcl_IsShared) /* 643 */ +#define Tcl_LinkArray \ + (tclStubsPtr->tcl_LinkArray) /* 644 */ +#define Tcl_GetIntForIndex \ + (tclStubsPtr->tcl_GetIntForIndex) /* 645 */ #endif /* defined(USE_TCL_STUBS) */ @@ -3785,15 +3918,12 @@ extern const TclStubs *tclStubsPtr; # undef Tcl_GetStringResult # undef Tcl_Init # undef Tcl_SetPanicProc -# undef Tcl_SetVar +# undef Tcl_SetExitProc # undef Tcl_ObjSetVar2 # undef Tcl_StaticPackage # define Tcl_CreateInterp() (tclStubsPtr->tcl_CreateInterp()) # define Tcl_GetStringResult(interp) (tclStubsPtr->tcl_GetStringResult(interp)) # define Tcl_Init(interp) (tclStubsPtr->tcl_Init(interp)) -# define Tcl_SetPanicProc(proc) (tclStubsPtr->tcl_SetPanicProc(proc)) -# define Tcl_SetVar(interp, varName, newValue, flags) \ - (tclStubsPtr->tcl_SetVar(interp, varName, newValue, flags)) # define Tcl_ObjSetVar2(interp, part1, part2, newValue, flags) \ (tclStubsPtr->tcl_ObjSetVar2(interp, part1, part2, newValue, flags)) #endif @@ -3803,6 +3933,7 @@ extern const TclStubs *tclStubsPtr; # define Tcl_MainEx Tcl_MainExW EXTERN void Tcl_MainExW(int argc, wchar_t **argv, Tcl_AppInitProc *appInitProc, Tcl_Interp *interp); + EXTERN int TclZipfs_AppHook(int *argc, wchar_t ***argv); #endif #undef TCL_STORAGE_CLASS @@ -3826,13 +3957,13 @@ extern const TclStubs *tclStubsPtr; sizeof(char *), msg, flags, indexPtr) #undef Tcl_NewBooleanObj #define Tcl_NewBooleanObj(boolValue) \ - Tcl_NewIntObj((boolValue)!=0) + Tcl_NewWideIntObj((boolValue)!=0) #undef Tcl_DbNewBooleanObj #define Tcl_DbNewBooleanObj(boolValue, file, line) \ - Tcl_DbNewLongObj((boolValue)!=0, file, line) + Tcl_DbNewWideIntObj((boolValue)!=0, file, line) #undef Tcl_SetBooleanObj #define Tcl_SetBooleanObj(objPtr, boolValue) \ - Tcl_SetIntObj((objPtr), (boolValue)!=0) + Tcl_SetWideIntObj(objPtr, (boolValue)!=0) #undef Tcl_SetVar #define Tcl_SetVar(interp, varName, newValue, flags) \ Tcl_SetVar2(interp, varName, NULL, newValue, flags) @@ -3854,6 +3985,53 @@ 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_GetStringResult +#define Tcl_GetStringResult(interp) Tcl_GetString(Tcl_GetObjResult(interp)) +#undef Tcl_Eval +#define Tcl_Eval(interp, objPtr) \ + Tcl_EvalEx(interp, objPtr, -1, 0) +#undef Tcl_GlobalEval +#define Tcl_GlobalEval(interp, objPtr) \ + Tcl_EvalEx(interp, objPtr, -1, TCL_EVAL_GLOBAL) +#undef Tcl_SaveResult +#define Tcl_SaveResult(interp, statePtr) \ + do { \ + (statePtr)->objResultPtr = Tcl_GetObjResult(interp); \ + Tcl_IncrRefCount((statePtr)->objResultPtr); \ + Tcl_SetObjResult(interp, Tcl_NewObj()); \ + } while(0) +#undef Tcl_RestoreResult +#define Tcl_RestoreResult(interp, statePtr) \ + do { \ + Tcl_ResetResult(interp); \ + Tcl_SetObjResult(interp, (statePtr)->objResultPtr); \ + Tcl_DecrRefCount((statePtr)->objResultPtr); \ + } while(0) +#undef Tcl_DiscardResult +#define Tcl_DiscardResult(statePtr) \ + Tcl_DecrRefCount((statePtr)->objResultPtr) +#undef Tcl_SetResult +#define Tcl_SetResult(interp, result, freeProc) \ + do { \ + char *__result = result; \ + Tcl_FreeProc *__freeProc = freeProc; \ + Tcl_SetObjResult(interp, Tcl_NewStringObj(__result, -1)); \ + if (__result != NULL && __freeProc != NULL && __freeProc != TCL_VOLATILE) { \ + if (__freeProc == TCL_DYNAMIC) { \ + ckfree(__result); \ + } else { \ + (*__freeProc)(__result); \ + } \ + } \ + } while(0) +#endif /* TCL_NO_DEPRECATED */ #if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) # if defined(__CYGWIN__) && defined(TCL_WIDE_INT_IS_LONG) @@ -3864,20 +4042,14 @@ extern const TclStubs *tclStubsPtr; * possible. Tcl 9 must find a better solution, but that cannot be done * without introducing a binary incompatibility. */ -# undef Tcl_DbNewLongObj # undef Tcl_GetLongFromObj -# undef Tcl_NewLongObj -# undef Tcl_SetLongObj # undef Tcl_ExprLong # undef Tcl_ExprLongObj # undef Tcl_UniCharNcmp # undef Tcl_UtfNcmp # undef Tcl_UtfNcasecmp # undef Tcl_UniCharNcasecmp -# define Tcl_DbNewLongObj ((Tcl_Obj*(*)(long,const char*,int))Tcl_DbNewWideIntObj) # define Tcl_GetLongFromObj ((int(*)(Tcl_Interp*,Tcl_Obj*,long*))Tcl_GetWideIntFromObj) -# define Tcl_NewLongObj ((Tcl_Obj*(*)(long))Tcl_NewWideIntObj) -# define Tcl_SetLongObj ((void(*)(Tcl_Obj*,long))Tcl_SetWideIntObj) # define Tcl_ExprLong TclExprLong static inline int TclExprLong(Tcl_Interp *interp, const char *string, long *ptr){ int intValue; @@ -3903,15 +4075,32 @@ extern const TclStubs *tclStubsPtr; # endif #endif +#undef Tcl_NewLongObj +#define Tcl_NewLongObj(value) Tcl_NewWideIntObj((long)(value)) +#undef Tcl_NewIntObj +#define Tcl_NewIntObj(value) Tcl_NewWideIntObj((int)(value)) +#undef Tcl_DbNewLongObj +#define Tcl_DbNewLongObj(value, file, line) Tcl_DbNewWideIntObj((long)(value), file, line) +#undef Tcl_SetIntObj +#define Tcl_SetIntObj(objPtr, value) Tcl_SetWideIntObj((objPtr), (int)(value)) +#undef Tcl_SetLongObj +#define Tcl_SetLongObj(objPtr, value) Tcl_SetWideIntObj((objPtr), (long)(value)) +#undef Tcl_GetUnicode +#define Tcl_GetUnicode(objPtr) Tcl_GetUnicodeFromObj((objPtr), NULL) +#undef Tcl_BackgroundError +#define Tcl_BackgroundError(interp) Tcl_BackgroundException((interp), TCL_ERROR) +#undef Tcl_StringMatch +#define Tcl_StringMatch(str, pattern) Tcl_StringCaseMatch((str), (pattern), 0) + /* * Deprecated Tcl procedures: */ #undef Tcl_EvalObj -#define Tcl_EvalObj(interp,objPtr) \ - Tcl_EvalObjEx((interp),(objPtr),0) +#define Tcl_EvalObj(interp, objPtr) \ + Tcl_EvalObjEx(interp, objPtr, 0) #undef Tcl_GlobalEvalObj -#define Tcl_GlobalEvalObj(interp,objPtr) \ - Tcl_EvalObjEx((interp),(objPtr),TCL_EVAL_GLOBAL) +#define Tcl_GlobalEvalObj(interp, objPtr) \ + Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL) #endif /* _TCLDECLS */ diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 32234a3..f3b0981 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -12,6 +12,7 @@ #include "tclInt.h" #include "tommath.h" +#include <assert.h> /* * Forward declaration. @@ -33,6 +34,8 @@ static int DictFilterCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static int DictGetCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); +static int DictGetDefCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); static int DictIncrCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static int DictInfoCmd(ClientData dummy, Tcl_Interp *interp, @@ -88,6 +91,9 @@ static const EnsembleImplMap implementationMap[] = { {"filter", DictFilterCmd, NULL, NULL, NULL, 0 }, {"for", NULL, TclCompileDictForCmd, DictForNRCmd, NULL, 0 }, {"get", DictGetCmd, TclCompileDictGetCmd, NULL, NULL, 0 }, + {"getdef", DictGetDefCmd, TclCompileDictGetWithDefaultCmd, NULL,NULL,0}, + {"getwithdefault", DictGetDefCmd, TclCompileDictGetWithDefaultCmd, + NULL, NULL, 0 }, {"incr", DictIncrCmd, TclCompileDictIncrCmd, NULL, NULL, 0 }, {"info", DictInfoCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0 }, {"keys", DictKeysCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0 }, @@ -141,7 +147,7 @@ typedef struct Dict { * the dictionary. Used for doing traversal of * the entries in the order that they are * created. */ - int epoch; /* Epoch counter */ + unsigned int epoch; /* Epoch counter */ size_t refCount; /* Reference counter (see above) */ Tcl_Obj *chain; /* Linked list used for invalidating the * string representations of updated nested @@ -149,13 +155,6 @@ typedef struct Dict { } Dict; /* - * Accessor macro for converting between a Tcl_Obj* and a Dict. Note that this - * must be assignable as well as readable. - */ - -#define DICT(dictObj) ((dictObj)->internalRep.twoPtrValue.ptr1) - -/* * The structure below defines the dictionary object type by means of * functions that can be invoked by generic object code. */ @@ -168,6 +167,21 @@ const Tcl_ObjType tclDictType = { SetDictFromAny /* setFromAnyProc */ }; +#define DictSetIntRep(objPtr, dictRepPtr) \ + do { \ + Tcl_ObjIntRep ir; \ + ir.twoPtrValue.ptr1 = (dictRepPtr); \ + ir.twoPtrValue.ptr2 = NULL; \ + Tcl_StoreIntRep((objPtr), &tclDictType, &ir); \ + } while (0) + +#define DictGetIntRep(objPtr, dictRepPtr) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = TclFetchIntRep((objPtr), &tclDictType); \ + (dictRepPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + } while (0) + /* * The type of the specially adapted version of the Tcl_Obj*-containing hash * table defined in the tclObj.c code. This version differs in that it @@ -363,10 +377,11 @@ DupDictInternalRep( Tcl_Obj *srcPtr, Tcl_Obj *copyPtr) { - Dict *oldDict = DICT(srcPtr); - Dict *newDict = ckalloc(sizeof(Dict)); + Dict *oldDict, *newDict = ckalloc(sizeof(Dict)); ChainEntry *cPtr; + DictGetIntRep(srcPtr, oldDict); + /* * Copy values across from the old hash table. */ @@ -390,7 +405,7 @@ DupDictInternalRep( * Initialise other fields. */ - newDict->epoch = 0; + newDict->epoch = 1; newDict->chain = NULL; newDict->refCount = 1; @@ -398,9 +413,7 @@ DupDictInternalRep( * Store in the object. */ - DICT(copyPtr) = newDict; - copyPtr->internalRep.twoPtrValue.ptr2 = NULL; - copyPtr->typePtr = &tclDictType; + DictSetIntRep(copyPtr, newDict); } /* @@ -425,12 +438,13 @@ static void FreeDictInternalRep( Tcl_Obj *dictPtr) { - Dict *dict = DICT(dictPtr); + Dict *dict; + + DictGetIntRep(dictPtr, dict); if (dict->refCount-- <= 1) { DeleteDict(dict); } - dictPtr->typePtr = NULL; } /* @@ -489,7 +503,7 @@ UpdateStringOfDict( { #define LOCAL_SIZE 64 char localFlags[LOCAL_SIZE], *flagPtr = NULL; - Dict *dict = DICT(dictPtr); + Dict *dict; ChainEntry *cPtr; Tcl_Obj *keyPtr, *valuePtr; int i, length, bytesNeeded = 0; @@ -501,12 +515,17 @@ UpdateStringOfDict( * is not exposed by any API function... */ - int numElems = dict->table.numEntries * 2; + int numElems; + + DictGetIntRep(dictPtr, dict); + + assert (dict != NULL); + + numElems = dict->table.numEntries * 2; /* Handle empty list case first, simplifies what follows */ if (numElems == 0) { - dictPtr->bytes = tclEmptyStringRep; - dictPtr->length = 0; + Tcl_InitStringRep(dictPtr, NULL, 0); return; } @@ -550,9 +569,8 @@ UpdateStringOfDict( * Pass 2: copy into string rep buffer. */ - dictPtr->length = bytesNeeded - 1; - dictPtr->bytes = ckalloc(bytesNeeded); - dst = dictPtr->bytes; + dst = Tcl_InitStringRep(dictPtr, NULL, bytesNeeded - 1); + TclOOM(dst, bytesNeeded); for (i=0,cPtr=dict->entryChainHead; i<numElems; i+=2,cPtr=cPtr->nextPtr) { flagPtr[i] |= ( i ? TCL_DONT_QUOTE_HASH : 0 ); keyPtr = Tcl_GetHashKey(&dict->table, &cPtr->entry); @@ -566,7 +584,7 @@ UpdateStringOfDict( dst += TclConvertElement(elem, length, dst, flagPtr[i+1]); *dst++ = ' '; } - dictPtr->bytes[dictPtr->length] = '\0'; + (void)Tcl_InitStringRep(dictPtr, NULL, bytesNeeded - 1); if (flagPtr != localFlags) { ckfree(flagPtr); @@ -610,7 +628,7 @@ SetDictFromAny( * the conversion from lists to dictionaries. */ - if (objPtr->typePtr == &tclListType) { + if (TclHasIntRep(objPtr, &tclListType)) { int objc, i; Tcl_Obj **objv; @@ -665,10 +683,14 @@ SetDictFromAny( TclNewStringObj(keyPtr, elemStart, elemSize); } else { /* Avoid double copy */ + char *dst; + TclNewObj(keyPtr); - keyPtr->bytes = ckalloc((unsigned) elemSize + 1); - keyPtr->length = TclCopyAndCollapse(elemSize, elemStart, - keyPtr->bytes); + Tcl_InvalidateStringRep(keyPtr); + dst = Tcl_InitStringRep(keyPtr, NULL, elemSize); + TclOOM(dst, elemSize); /* Consider error */ + (void)Tcl_InitStringRep(keyPtr, NULL, + TclCopyAndCollapse(elemSize, elemStart, dst)); } if (TclFindDictElement(interp, nextElem, (limit - nextElem), @@ -681,10 +703,14 @@ SetDictFromAny( TclNewStringObj(valuePtr, elemStart, elemSize); } else { /* Avoid double copy */ + char *dst; + TclNewObj(valuePtr); - valuePtr->bytes = ckalloc((unsigned) elemSize + 1); - valuePtr->length = TclCopyAndCollapse(elemSize, elemStart, - valuePtr->bytes); + Tcl_InvalidateStringRep(valuePtr); + dst = Tcl_InitStringRep(valuePtr, NULL, elemSize); + TclOOM(dst, elemSize); /* Consider error */ + (void)Tcl_InitStringRep(valuePtr, NULL, + TclCopyAndCollapse(elemSize, elemStart, dst)); } /* Store key and value in the hash table we're building. */ @@ -706,13 +732,10 @@ SetDictFromAny( * Tcl_GetStringFromObj, to use that old internalRep. */ - TclFreeIntRep(objPtr); - dict->epoch = 0; + dict->epoch = 1; dict->chain = NULL; dict->refCount = 1; - DICT(objPtr) = dict; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; - objPtr->typePtr = &tclDictType; + DictSetIntRep(objPtr, dict); return TCL_OK; missingValue: @@ -726,6 +749,23 @@ SetDictFromAny( ckfree(dict); return TCL_ERROR; } + +static Dict * +GetDictFromObj( + Tcl_Interp *interp, + Tcl_Obj *dictPtr) +{ + Dict *dict; + + DictGetIntRep(dictPtr, dict); + if (dict == NULL) { + if (SetDictFromAny(interp, dictPtr) != TCL_OK) { + return NULL; + } + DictGetIntRep(dictPtr, dict); + } + return dict; +} /* *---------------------------------------------------------------------- @@ -770,11 +810,13 @@ TclTraceDictPath( Dict *dict, *newDict; int i; - if (dictPtr->typePtr != &tclDictType - && SetDictFromAny(interp, dictPtr) != TCL_OK) { - return NULL; + DictGetIntRep(dictPtr, dict); + if (dict == NULL) { + if (SetDictFromAny(interp, dictPtr) != TCL_OK) { + return NULL; + } + DictGetIntRep(dictPtr, dict); } - dict = DICT(dictPtr); if (flags & DICT_PATH_UPDATE) { dict->chain = NULL; } @@ -810,13 +852,17 @@ TclTraceDictPath( Tcl_SetHashValue(hPtr, tmpObj); } else { tmpObj = Tcl_GetHashValue(hPtr); - if (tmpObj->typePtr != &tclDictType - && SetDictFromAny(interp, tmpObj) != TCL_OK) { - return NULL; + + DictGetIntRep(tmpObj, newDict); + + if (newDict == NULL) { + if (SetDictFromAny(interp, tmpObj) != TCL_OK) { + return NULL; + } } } - newDict = DICT(tmpObj); + DictGetIntRep(tmpObj, newDict); if (flags & DICT_PATH_UPDATE) { if (Tcl_IsShared(tmpObj)) { TclDecrRefCount(tmpObj); @@ -824,7 +870,7 @@ TclTraceDictPath( Tcl_IncrRefCount(tmpObj); Tcl_SetHashValue(hPtr, tmpObj); dict->epoch++; - newDict = DICT(tmpObj); + DictGetIntRep(tmpObj, newDict); } newDict->chain = dictPtr; @@ -859,17 +905,24 @@ static void InvalidateDictChain( Tcl_Obj *dictObj) { - Dict *dict = DICT(dictObj); + Dict *dict; + + DictGetIntRep(dictObj, dict); + assert( dict != NULL); do { + dict->refCount++; TclInvalidateStringRep(dictObj); + TclFreeIntRep(dictObj); + DictSetIntRep(dictObj, dict); + dict->epoch++; dictObj = dict->chain; if (dictObj == NULL) { break; } dict->chain = NULL; - dict = DICT(dictObj); + DictGetIntRep(dictObj, dict); } while (dict != NULL); } @@ -907,16 +960,16 @@ Tcl_DictObjPut( Tcl_Panic("%s called with shared object", "Tcl_DictObjPut"); } - if (dictPtr->typePtr != &tclDictType - && SetDictFromAny(interp, dictPtr) != TCL_OK) { + dict = GetDictFromObj(interp, dictPtr); + if (dict == NULL) { return TCL_ERROR; } - if (dictPtr->bytes != NULL) { - TclInvalidateStringRep(dictPtr); - } - dict = DICT(dictPtr); + TclInvalidateStringRep(dictPtr); hPtr = CreateChainEntry(dict, keyPtr, &isNew); + dict->refCount++; + TclFreeIntRep(dictPtr) + DictSetIntRep(dictPtr, dict); Tcl_IncrRefCount(valuePtr); if (!isNew) { Tcl_Obj *oldValuePtr = Tcl_GetHashValue(hPtr); @@ -958,13 +1011,12 @@ Tcl_DictObjGet( Dict *dict; Tcl_HashEntry *hPtr; - if (dictPtr->typePtr != &tclDictType - && SetDictFromAny(interp, dictPtr) != TCL_OK) { + dict = GetDictFromObj(interp, dictPtr); + if (dict == NULL) { *valuePtrPtr = NULL; return TCL_ERROR; } - dict = DICT(dictPtr); hPtr = Tcl_FindHashEntry(&dict->table, keyPtr); if (hPtr == NULL) { *valuePtrPtr = NULL; @@ -1005,16 +1057,13 @@ Tcl_DictObjRemove( Tcl_Panic("%s called with shared object", "Tcl_DictObjRemove"); } - if (dictPtr->typePtr != &tclDictType - && SetDictFromAny(interp, dictPtr) != TCL_OK) { + dict = GetDictFromObj(interp, dictPtr); + if (dict == NULL) { return TCL_ERROR; } - dict = DICT(dictPtr); if (DeleteChainEntry(dict, keyPtr)) { - if (dictPtr->bytes != NULL) { - TclInvalidateStringRep(dictPtr); - } + TclInvalidateStringRep(dictPtr); dict->epoch++; } return TCL_OK; @@ -1046,12 +1095,11 @@ Tcl_DictObjSize( { Dict *dict; - if (dictPtr->typePtr != &tclDictType - && SetDictFromAny(interp, dictPtr) != TCL_OK) { + dict = GetDictFromObj(interp, dictPtr); + if (dict == NULL) { return TCL_ERROR; } - dict = DICT(dictPtr); *sizePtr = dict->table.numEntries; return TCL_OK; } @@ -1098,15 +1146,14 @@ Tcl_DictObjFirst( Dict *dict; ChainEntry *cPtr; - if (dictPtr->typePtr != &tclDictType - && SetDictFromAny(interp, dictPtr) != TCL_OK) { + dict = GetDictFromObj(interp, dictPtr); + if (dict == NULL) { return TCL_ERROR; } - dict = DICT(dictPtr); cPtr = dict->entryChainHead; if (cPtr == NULL) { - searchPtr->epoch = -1; + searchPtr->epoch = 0; *donePtr = 1; } else { *donePtr = 0; @@ -1167,7 +1214,7 @@ Tcl_DictObjNext( * If the searh is done; we do no work. */ - if (searchPtr->epoch == -1) { + if (!searchPtr->epoch) { *donePtr = 1; return; } @@ -1224,8 +1271,8 @@ Tcl_DictObjDone( { Dict *dict; - if (searchPtr->epoch != -1) { - searchPtr->epoch = -1; + if (searchPtr->epoch) { + searchPtr->epoch = 0; dict = (Dict *) searchPtr->dictionaryPtr; if (dict->refCount-- <= 1) { DeleteDict(dict); @@ -1277,7 +1324,8 @@ Tcl_DictObjPutKeyList( return TCL_ERROR; } - dict = DICT(dictPtr); + DictGetIntRep(dictPtr, dict); + assert(dict != NULL); hPtr = CreateChainEntry(dict, keyv[keyc-1], &isNew); Tcl_IncrRefCount(valuePtr); if (!isNew) { @@ -1334,7 +1382,8 @@ Tcl_DictObjRemoveKeyList( return TCL_ERROR; } - dict = DICT(dictPtr); + DictGetIntRep(dictPtr, dict); + assert(dict != NULL); DeleteChainEntry(dict, keyv[keyc-1]); InvalidateDictChain(dictPtr); return TCL_OK; @@ -1377,12 +1426,10 @@ Tcl_NewDictObj(void) TclInvalidateStringRep(dictPtr); dict = ckalloc(sizeof(Dict)); InitChainTable(dict); - dict->epoch = 0; + dict->epoch = 1; dict->chain = NULL; dict->refCount = 1; - DICT(dictPtr) = dict; - dictPtr->internalRep.twoPtrValue.ptr2 = NULL; - dictPtr->typePtr = &tclDictType; + DictSetIntRep(dictPtr, dict); return dictPtr; #endif } @@ -1427,12 +1474,10 @@ Tcl_DbNewDictObj( TclInvalidateStringRep(dictPtr); dict = ckalloc(sizeof(Dict)); InitChainTable(dict); - dict->epoch = 0; + dict->epoch = 1; dict->chain = NULL; dict->refCount = 1; - DICT(dictPtr) = dict; - dictPtr->internalRep.twoPtrValue.ptr2 = NULL; - dictPtr->typePtr = &tclDictType; + DictSetIntRep(dictPtr, dict); return dictPtr; #else /* !TCL_MEM_DEBUG */ return Tcl_NewDictObj(); @@ -1587,6 +1632,71 @@ DictGetCmd( /* *---------------------------------------------------------------------- * + * DictGetDefCmd -- + * + * This function implements the "dict getdef" and "dict getwithdefault" + * Tcl commands. See the user documentation for details on what it does, + * and TIP#342 for the formal specification. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +DictGetDefCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Tcl_Obj *dictPtr, *keyPtr, *valuePtr, *defaultPtr; + Tcl_Obj *const *keyPath; + int numKeys; + + if (objc < 4) { + Tcl_WrongNumArgs(interp, 1, objv, "dictionary ?key ...? key default"); + return TCL_ERROR; + } + + /* + * Give the bits of arguments names for clarity. + */ + + dictPtr = objv[1]; + keyPath = &objv[2]; + numKeys = objc - 4; /* Number of keys in keyPath; there's always + * one extra key afterwards too. */ + keyPtr = objv[objc - 2]; + defaultPtr = objv[objc - 1]; + + /* + * Implement the getting-with-default operation. + */ + + dictPtr = TclTraceDictPath(interp, dictPtr, numKeys, keyPath, + DICT_PATH_EXISTS); + if (dictPtr == NULL) { + return TCL_ERROR; + } else if (dictPtr == DICT_PATH_NON_EXISTENT) { + Tcl_SetObjResult(interp, defaultPtr); + } else if (Tcl_DictObjGet(interp, dictPtr, keyPtr, &valuePtr) != TCL_OK) { + return TCL_ERROR; + } else if (valuePtr == NULL) { + Tcl_SetObjResult(interp, defaultPtr); + } else { + Tcl_SetObjResult(interp, valuePtr); + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * DictReplaceCmd -- * * This function implements the "dict replace" Tcl command. See the user @@ -1618,16 +1728,13 @@ DictReplaceCmd( } dictPtr = objv[1]; - if (dictPtr->typePtr != &tclDictType - && SetDictFromAny(interp, dictPtr) != TCL_OK) { + if (GetDictFromObj(interp, dictPtr) == NULL) { return TCL_ERROR; } if (Tcl_IsShared(dictPtr)) { dictPtr = Tcl_DuplicateObj(dictPtr); } - if (dictPtr->bytes != NULL) { - TclInvalidateStringRep(dictPtr); - } + TclInvalidateStringRep(dictPtr); for (i=2 ; i<objc ; i+=2) { Tcl_DictObjPut(NULL, dictPtr, objv[i], objv[i+1]); } @@ -1669,16 +1776,13 @@ DictRemoveCmd( } dictPtr = objv[1]; - if (dictPtr->typePtr != &tclDictType - && SetDictFromAny(interp, dictPtr) != TCL_OK) { + if (GetDictFromObj(interp, dictPtr) == NULL) { return TCL_ERROR; } if (Tcl_IsShared(dictPtr)) { dictPtr = Tcl_DuplicateObj(dictPtr); } - if (dictPtr->bytes != NULL) { - TclInvalidateStringRep(dictPtr); - } + TclInvalidateStringRep(dictPtr); for (i=2 ; i<objc ; i++) { Tcl_DictObjRemove(NULL, dictPtr, objv[i]); } @@ -1729,8 +1833,7 @@ DictMergeCmd( */ targetObj = objv[1]; - if (targetObj->typePtr != &tclDictType - && SetDictFromAny(interp, targetObj) != TCL_OK) { + if (GetDictFromObj(interp, targetObj) == NULL) { return TCL_ERROR; } @@ -1813,8 +1916,7 @@ DictKeysCmd( * need. [Bug 1705778, leak K04] */ - if (objv[1]->typePtr != &tclDictType - && SetDictFromAny(interp, objv[1]) != TCL_OK) { + if (GetDictFromObj(interp, objv[1]) == NULL) { return TCL_ERROR; } @@ -1984,11 +2086,9 @@ DictExistsCmd( return TCL_ERROR; } - dictPtr = TclTraceDictPath(interp, objv[1], objc-3, objv+2, - DICT_PATH_EXISTS); - if (dictPtr == NULL || dictPtr == DICT_PATH_NON_EXISTENT - || Tcl_DictObjGet(interp, dictPtr, objv[objc-1], - &valuePtr) != TCL_OK) { + dictPtr = TclTraceDictPath(NULL, objv[1], objc-3, objv+2,DICT_PATH_EXISTS); + if (dictPtr == NULL || dictPtr == DICT_PATH_NON_EXISTENT || + Tcl_DictObjGet(NULL, dictPtr, objv[objc-1], &valuePtr) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); } else { Tcl_SetObjResult(interp, Tcl_NewBooleanObj(valuePtr != NULL)); @@ -2021,7 +2121,6 @@ DictInfoCmd( int objc, Tcl_Obj *const *objv) { - Tcl_Obj *dictPtr; Dict *dict; char *statsStr; @@ -2030,12 +2129,10 @@ DictInfoCmd( return TCL_ERROR; } - dictPtr = objv[1]; - if (dictPtr->typePtr != &tclDictType - && SetDictFromAny(interp, dictPtr) != TCL_OK) { + dict = GetDictFromObj(interp, objv[1]); + if (dict == NULL) { return TCL_ERROR; } - dict = DICT(dictPtr); statsStr = Tcl_HashStats(&dict->table); Tcl_SetObjResult(interp, Tcl_NewStringObj(statsStr, -1)); @@ -2096,12 +2193,11 @@ DictIncrCmd( * soon be no good. */ - char *saved = dictPtr->bytes; Tcl_Obj *oldPtr = dictPtr; - dictPtr->bytes = NULL; - dictPtr = Tcl_DuplicateObj(dictPtr); - oldPtr->bytes = saved; + TclNewObj(dictPtr); + TclInvalidateStringRep(dictPtr); + DupDictInternalRep(oldPtr, dictPtr); } if (valuePtr == NULL) { /* @@ -2238,7 +2334,7 @@ DictLappendCmd( if (allocatedValue) { Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr); - } else if (dictPtr->bytes != NULL) { + } else { TclInvalidateStringRep(dictPtr); } @@ -2277,7 +2373,7 @@ DictAppendCmd( Tcl_Obj *const *objv) { Tcl_Obj *dictPtr, *valuePtr, *resultPtr; - int i, allocatedDict = 0; + int allocatedDict = 0; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "dictVarName key ?value ...?"); @@ -2300,17 +2396,49 @@ DictAppendCmd( return TCL_ERROR; } - if (valuePtr == NULL) { - TclNewObj(valuePtr); - } else if (Tcl_IsShared(valuePtr)) { - valuePtr = Tcl_DuplicateObj(valuePtr); - } + if ((objc > 3) || (valuePtr == NULL)) { + /* Only go through append activites when something will change. */ + Tcl_Obj *appendObjPtr = NULL; + + if (objc > 3) { + /* Something to append */ - for (i=3 ; i<objc ; i++) { - Tcl_AppendObjToObj(valuePtr, objv[i]); + if (objc == 4) { + appendObjPtr = objv[3]; + } else { + appendObjPtr = TclStringCat(interp, objc-3, objv+3, + TCL_STRING_IN_PLACE); + if (appendObjPtr == NULL) { + 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_IncrRefCount(appendObjPtr); + Tcl_AppendObjToObj(valuePtr, appendObjPtr); + Tcl_DecrRefCount(appendObjPtr); + } + + Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr); } - Tcl_DictObjPut(NULL, dictPtr, objv[2], valuePtr); + /* + * Even if nothing changed, we still overwrite so that variable + * trace expectations are met. + */ resultPtr = Tcl_ObjSetVar2(interp, objv[1], NULL, dictPtr, TCL_LEAVE_ERR_MSG); diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index f62c260..76a4d46 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -38,7 +38,7 @@ static void UpdateStringOfInstName(Tcl_Obj *objPtr); * reporting of inner contexts in errorstack without string allocation. */ -static const Tcl_ObjType tclInstNameType = { +static const Tcl_ObjType instNameType = { "instname", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ @@ -46,12 +46,21 @@ static const Tcl_ObjType tclInstNameType = { NULL, /* setFromAnyProc */ }; -/* - * How to get the bytecode out of a Tcl_Obj. - */ +#define InstNameSetIntRep(objPtr, inst) \ + do { \ + Tcl_ObjIntRep ir; \ + ir.wideValue = (inst); \ + Tcl_StoreIntRep((objPtr), &instNameType, &ir); \ + } while (0) + +#define InstNameGetIntRep(objPtr, inst) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = TclFetchIntRep((objPtr), &instNameType); \ + assert(irPtr != NULL); \ + (inst) = (size_t)irPtr->wideValue; \ + } while (0) -#define BYTECODE(objPtr) \ - ((ByteCode *) (objPtr)->internalRep.twoPtrValue.ptr1) /* *---------------------------------------------------------------------- @@ -191,7 +200,7 @@ TclPrintObject( char *bytes; int length; - bytes = Tcl_GetStringFromObj(objPtr, &length); + bytes = TclGetStringFromObj(objPtr, &length); TclPrintSource(outFile, bytes, TclMin(length, maxChars)); } @@ -245,17 +254,20 @@ DisassembleByteCodeObj( Tcl_Interp *interp, Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ { - ByteCode *codePtr = BYTECODE(objPtr); + ByteCode *codePtr; unsigned char *codeStart, *codeLimit, *pc; unsigned char *codeDeltaNext, *codeLengthNext; unsigned char *srcDeltaNext, *srcLengthNext; int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i, line; - Interp *iPtr = (Interp *) *codePtr->interpHandle; + Interp *iPtr; Tcl_Obj *bufferObj, *fileObj; - char ptrBuf1[20], ptrBuf2[20]; + + ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr); + + iPtr = (Interp *) *codePtr->interpHandle; TclNewObj(bufferObj); - if (codePtr->refCount <= 0) { + if (!codePtr->refCount) { return bufferObj; /* Already freed. */ } @@ -267,11 +279,9 @@ DisassembleByteCodeObj( * Print header lines describing the ByteCode. */ - sprintf(ptrBuf1, "%p", codePtr); - sprintf(ptrBuf2, "%p", iPtr); Tcl_AppendPrintfToObj(bufferObj, - "ByteCode 0x%s, refCt %u, epoch %u, interp 0x%s (epoch %u)\n", - ptrBuf1, codePtr->refCount, codePtr->compileEpoch, ptrBuf2, + "ByteCode %p, refCt %u, epoch %u, interp %p (epoch %u)\n", + codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr, iPtr->compileEpoch); Tcl_AppendToObj(bufferObj, " Source ", -1); PrintSourceToObj(bufferObj, codePtr->source, @@ -314,10 +324,9 @@ DisassembleByteCodeObj( Proc *procPtr = codePtr->procPtr; int numCompiledLocals = procPtr->numCompiledLocals; - sprintf(ptrBuf1, "%p", procPtr); Tcl_AppendPrintfToObj(bufferObj, - " Proc 0x%s, refCt %d, args %d, compiled locals %d\n", - ptrBuf1, procPtr->refCount, procPtr->numArgs, + " Proc %p, refCt %u, args %d, compiled locals %d\n", + procPtr, procPtr->refCount, procPtr->numArgs, numCompiledLocals); if (numCompiledLocals > 0) { CompiledLocal *localPtr = procPtr->firstLocalPtr; @@ -648,7 +657,7 @@ FormatInstruction( int length; Tcl_AppendToObj(bufferObj, "\t# ", -1); - bytes = Tcl_GetStringFromObj(codePtr->objArrayPtr[opnd], &length); + bytes = TclGetStringFromObj(codePtr->objArrayPtr[opnd], &length); PrintSourceToObj(bufferObj, bytes, TclMin(length, 40)); } else if (suffixBuffer[0]) { Tcl_AppendPrintfToObj(bufferObj, "\t# %s", suffixBuffer); @@ -800,9 +809,8 @@ TclNewInstNameObj( { Tcl_Obj *objPtr = Tcl_NewObj(); - objPtr->typePtr = &tclInstNameType; - objPtr->internalRep.longValue = (long) inst; - objPtr->bytes = NULL; + TclInvalidateStringRep(objPtr); + InstNameSetIntRep(objPtr, (long) inst); return objPtr; } @@ -821,20 +829,22 @@ static void UpdateStringOfInstName( Tcl_Obj *objPtr) { - int inst = objPtr->internalRep.longValue; - char *s, buf[20]; - int len; + size_t inst; /* NOTE: We know this is really an unsigned char */ + char *dst; - if ((inst < 0) || (inst > LAST_INST_OPCODE)) { - sprintf(buf, "inst_%d", inst); - s = buf; + InstNameGetIntRep(objPtr, inst); + + if (inst > LAST_INST_OPCODE) { + dst = Tcl_InitStringRep(objPtr, NULL, TCL_INTEGER_SPACE + 5); + TclOOM(dst, TCL_INTEGER_SPACE + 5); + sprintf(dst, "inst_%" TCL_Z_MODIFIER "u", inst); + (void) Tcl_InitStringRep(objPtr, NULL, strlen(dst)); } else { - s = (char *) tclInstructionTable[objPtr->internalRep.longValue].name; + const char *s = tclInstructionTable[inst].name; + unsigned int len = strlen(s); + dst = Tcl_InitStringRep(objPtr, s, len); + TclOOM(dst, len); } - len = strlen(s); - objPtr->bytes = ckalloc(len + 1); - memcpy(objPtr->bytes, s, len + 1); - objPtr->length = len; } /* @@ -898,7 +908,7 @@ PrintSourceToObj( Tcl_AppendPrintfToObj(appendObj, "\\U%08x", ch); i += 10; } else -#elif TCL_UTF_MAX > 3 +#else /* If len == 0, this means we have a char > 0xffff, resulting in * TclUtfToUniChar producing a surrogate pair. We want to output * this pair as a single Unicode character. @@ -946,13 +956,15 @@ DisassembleByteCodeAsDicts( * procedure, if one exists. */ Tcl_Obj *objPtr) /* The bytecode-holding value to take apart */ { - ByteCode *codePtr = BYTECODE(objPtr); + ByteCode *codePtr; Tcl_Obj *description, *literals, *variables, *instructions, *inst; Tcl_Obj *aux, *exn, *commands, *file; unsigned char *pc, *opnd, *codeOffPtr, *codeLenPtr, *srcOffPtr, *srcLenPtr; int codeOffset, codeLength, sourceOffset, sourceLength; int i, val, line; + ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr); + /* * Get the literals from the bytecode. */ @@ -1290,6 +1302,7 @@ Tcl_DisassembleObjCmd( Proc *procPtr = NULL; Tcl_HashEntry *hPtr; Object *oPtr; + ByteCode *codePtr; Method *methodPtr; if (objc < 2) { @@ -1308,27 +1321,19 @@ Tcl_DisassembleObjCmd( /* * Compile (if uncompiled) and disassemble a lambda term. - * - * WARNING! Pokes inside the lambda objtype. */ if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "lambdaTerm"); return TCL_ERROR; } - if (objv[2]->typePtr == &tclLambdaType) { - procPtr = objv[2]->internalRep.twoPtrValue.ptr1; - } - if (procPtr == NULL || procPtr->iPtr != (Interp *) interp) { - result = tclLambdaType.setFromAnyProc(interp, objv[2]); - if (result != TCL_OK) { - return result; - } - procPtr = objv[2]->internalRep.twoPtrValue.ptr1; + + procPtr = TclGetLambdaFromObj(interp, objv[2], &nsObjPtr); + if (procPtr == NULL) { + return TCL_ERROR; } memset(&cmd, 0, sizeof(Command)); - nsObjPtr = objv[2]->internalRep.twoPtrValue.ptr2; result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); if (result != TCL_OK) { return result; @@ -1378,8 +1383,9 @@ Tcl_DisassembleObjCmd( Tcl_WrongNumArgs(interp, 2, objv, "script"); return TCL_ERROR; } - if ((objv[2]->typePtr != &tclByteCodeType) - && (TclSetByteCodeFromAny(interp, objv[2], NULL, NULL) != TCL_OK)) { + + if (!TclHasIntRep(objv[2], &tclByteCodeType) && (TCL_OK + != TclSetByteCodeFromAny(interp, objv[2], NULL, NULL))) { return TCL_ERROR; } codeObjPtr = objv[2]; @@ -1429,7 +1435,7 @@ Tcl_DisassembleObjCmd( * Compile if necessary. */ - if (procPtr->bodyPtr->typePtr != &tclByteCodeType) { + if (!TclHasIntRep(procPtr->bodyPtr, &tclByteCodeType)) { Command cmd; /* @@ -1494,7 +1500,7 @@ Tcl_DisassembleObjCmd( * Compile if necessary. */ - if (procPtr->bodyPtr->typePtr != &tclByteCodeType) { + if (!TclHasIntRep(procPtr->bodyPtr, &tclByteCodeType)) { Command cmd; /* @@ -1579,7 +1585,7 @@ Tcl_DisassembleObjCmd( "METHODTYPE", NULL); return TCL_ERROR; } - if (procPtr->bodyPtr->typePtr != &tclByteCodeType) { + if (!TclHasIntRep(procPtr->bodyPtr, &tclByteCodeType)) { Command cmd; /* @@ -1607,14 +1613,16 @@ Tcl_DisassembleObjCmd( * Do the actual disassembly. */ - if (BYTECODE(codeObjPtr)->flags & TCL_BYTECODE_PRECOMPILED) { + ByteCodeGetIntRep(codeObjPtr, &tclByteCodeType, codePtr); + + if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "may not disassemble prebuilt bytecode", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE", "BYTECODE", NULL); return TCL_ERROR; } - if (PTR2INT(clientData)) { + if (clientData) { Tcl_SetObjResult(interp, DisassembleByteCodeAsDicts(interp, codeObjPtr)); } else { diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 144954b..a88c1a7 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -18,7 +18,7 @@ typedef size_t (LengthProc)(const char *src); * convert between various character sets and UTF-8. */ -typedef struct Encoding { +typedef struct { char *name; /* Name of encoding. Malloced because (1) hash * table entry that owns this encoding may be * freed prior to this encoding being freed, @@ -46,7 +46,7 @@ typedef struct Encoding { * nullSize is 2, this is a function that * returns the number of bytes in a 0x0000 * terminated string. */ - int refCount; /* Number of uses of this structure. */ + size_t refCount; /* Number of uses of this structure. */ Tcl_HashEntry *hPtr; /* Hash table entry that owns this encoding. */ } Encoding; @@ -57,7 +57,7 @@ typedef struct Encoding { * encoding. */ -typedef struct TableEncodingData { +typedef struct { int fallback; /* Character (in this encoding) to substitute * when this encoding cannot represent a UTF-8 * character. */ @@ -91,7 +91,7 @@ typedef struct TableEncodingData { * for switching character sets. */ -typedef struct EscapeSubTable { +typedef struct { unsigned sequenceLen; /* Length of following string. */ char sequence[16]; /* Escape code that marks this encoding. */ char name[32]; /* Name for encoding. */ @@ -100,7 +100,7 @@ typedef struct EscapeSubTable { * yet. */ } EscapeSubTable; -typedef struct EscapeEncodingData { +typedef struct { int fallback; /* Character (in this encoding) to substitute * when this encoding cannot represent a UTF-8 * character. */ @@ -234,12 +234,17 @@ static int TableToUtfProc(ClientData clientData, const char *src, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); static size_t unilen(const char *src); -static int UnicodeToUtfProc(ClientData clientData, +static int Utf16ToUtfProc(ClientData clientData, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); -static int UtfToUnicodeProc(ClientData clientData, +static int UtfToUtf16Proc(ClientData clientData, + const char *src, int srcLen, int flags, + Tcl_EncodingState *statePtr, char *dst, int dstLen, + int *srcReadPtr, int *dstWrotePtr, + int *dstCharsPtr); +static int UtfToUcs2Proc(ClientData clientData, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, @@ -279,6 +284,21 @@ static int Iso88591ToUtfProc(ClientData clientData, static const Tcl_ObjType encodingType = { "encoding", FreeEncodingIntRep, DupEncodingIntRep, NULL, NULL }; +#define EncodingSetIntRep(objPtr, encoding) \ + do { \ + Tcl_ObjIntRep ir; \ + ir.twoPtrValue.ptr1 = (encoding); \ + ir.twoPtrValue.ptr2 = NULL; \ + Tcl_StoreIntRep((objPtr), &encodingType, &ir); \ + } while (0) + +#define EncodingGetIntRep(objPtr, encoding) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = TclFetchIntRep ((objPtr), &encodingType); \ + (encoding) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + } while (0) + /* *---------------------------------------------------------------------- @@ -305,17 +325,16 @@ Tcl_GetEncodingFromObj( Tcl_Obj *objPtr, Tcl_Encoding *encodingPtr) { - const char *name = Tcl_GetString(objPtr); - - if (objPtr->typePtr != &encodingType) { - Tcl_Encoding encoding = Tcl_GetEncoding(interp, name); + Tcl_Encoding encoding; + const char *name = TclGetString(objPtr); + EncodingGetIntRep(objPtr, encoding); + if (encoding == NULL) { + encoding = Tcl_GetEncoding(interp, name); if (encoding == NULL) { return TCL_ERROR; } - TclFreeIntRep(objPtr); - objPtr->internalRep.twoPtrValue.ptr1 = encoding; - objPtr->typePtr = &encodingType; + EncodingSetIntRep(objPtr, encoding); } *encodingPtr = Tcl_GetEncoding(NULL, name); return TCL_OK; @@ -335,8 +354,10 @@ static void FreeEncodingIntRep( Tcl_Obj *objPtr) { - Tcl_FreeEncoding(objPtr->internalRep.twoPtrValue.ptr1); - objPtr->typePtr = NULL; + Tcl_Encoding encoding; + + EncodingGetIntRep(objPtr, encoding); + Tcl_FreeEncoding(encoding); } /* @@ -354,7 +375,8 @@ DupEncodingIntRep( Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { - dupPtr->internalRep.twoPtrValue.ptr1 = Tcl_GetEncoding(NULL, srcPtr->bytes); + Tcl_Encoding encoding = Tcl_GetEncoding(NULL, TclGetString(srcPtr)); + EncodingSetIntRep(dupPtr, encoding); } /* @@ -547,11 +569,16 @@ TclInitEncodingSubsystem(void) TableEncodingData *dataPtr; unsigned size; unsigned short i; + union { + char c; + short s; + } isLe; if (encodingsInitialized) { return; } + isLe.s = 1; Tcl_MutexLock(&encodingMutex); Tcl_InitHashTable(&encodingTable, TCL_STRING_KEYS); Tcl_MutexUnlock(&encodingMutex); @@ -562,7 +589,7 @@ TclInitEncodingSubsystem(void) * formed UTF-8 into a properly formed stream. */ - type.encodingName = "identity"; + type.encodingName = NULL; type.toUtfProc = BinaryProc; type.fromUtfProc = BinaryProc; type.freeProc = NULL; @@ -578,14 +605,39 @@ TclInitEncodingSubsystem(void) type.clientData = NULL; Tcl_CreateEncoding(&type); - type.encodingName = "unicode"; - type.toUtfProc = UnicodeToUtfProc; - type.fromUtfProc = UtfToUnicodeProc; + type.toUtfProc = Utf16ToUtfProc; + type.fromUtfProc = UtfToUcs2Proc; type.freeProc = NULL; type.nullSize = 2; - type.clientData = NULL; + type.encodingName = "ucs-2le"; + type.clientData = INT2PTR(1); + Tcl_CreateEncoding(&type); + type.encodingName = "ucs-2be"; + type.clientData = INT2PTR(0); + Tcl_CreateEncoding(&type); + type.encodingName = "ucs-2"; + type.clientData = INT2PTR(isLe.c); Tcl_CreateEncoding(&type); + type.toUtfProc = Utf16ToUtfProc; + type.fromUtfProc = UtfToUtf16Proc; + type.freeProc = NULL; + type.nullSize = 2; + type.encodingName = "utf-16le"; + type.clientData = INT2PTR(1);; + Tcl_CreateEncoding(&type); + type.encodingName = "utf-16be"; + type.clientData = INT2PTR(0); + Tcl_CreateEncoding(&type); + type.encodingName = "utf-16"; + type.clientData = INT2PTR(isLe.c);; + Tcl_CreateEncoding(&type); + +#ifndef TCL_NO_DEPRECATED + type.encodingName = "unicode"; + Tcl_CreateEncoding(&type); +#endif + /* * Need the iso8859-1 encoding in order to process binary data, so force * it to always be embedded. Note that this encoding *must* be a proper @@ -692,6 +744,7 @@ TclFinalizeEncodingSubsystem(void) *------------------------------------------------------------------------- */ +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 const char * Tcl_GetDefaultEncodingDir(void) { @@ -704,7 +757,7 @@ Tcl_GetDefaultEncodingDir(void) } Tcl_ListObjIndex(NULL, searchPath, 0, &first); - return Tcl_GetString(first); + return TclGetString(first); } /* @@ -735,6 +788,7 @@ Tcl_SetDefaultEncodingDir( Tcl_ListObjReplace(NULL, searchPath, 0, 0, 1, &directory); Tcl_SetEncodingSearchPath(searchPath); } +#endif /* *------------------------------------------------------------------------- @@ -843,18 +897,16 @@ FreeEncoding( if (encodingPtr == NULL) { return; } - if (encodingPtr->refCount<=0) { - Tcl_Panic("FreeEncoding: refcount problem !!!"); - } - encodingPtr->refCount--; - if (encodingPtr->refCount == 0) { + if (encodingPtr->refCount-- <= 1) { if (encodingPtr->freeProc != NULL) { encodingPtr->freeProc(encodingPtr->clientData); } if (encodingPtr->hPtr != NULL) { Tcl_DeleteHashEntry(encodingPtr->hPtr); } - ckfree(encodingPtr->name); + if (encodingPtr->name) { + ckfree(encodingPtr->name); + } ckfree(encodingPtr); } } @@ -1043,9 +1095,24 @@ Tcl_CreateEncoding( const Tcl_EncodingType *typePtr) /* The encoding type. */ { + Encoding *encodingPtr = ckalloc(sizeof(Encoding)); + encodingPtr->name = NULL; + encodingPtr->toUtfProc = typePtr->toUtfProc; + encodingPtr->fromUtfProc = typePtr->fromUtfProc; + encodingPtr->freeProc = typePtr->freeProc; + encodingPtr->nullSize = typePtr->nullSize; + encodingPtr->clientData = typePtr->clientData; + if (typePtr->nullSize == 1) { + encodingPtr->lengthProc = (LengthProc *) strlen; + } else { + encodingPtr->lengthProc = (LengthProc *) unilen; + } + encodingPtr->refCount = 1; + encodingPtr->hPtr = NULL; + + if (typePtr->encodingName) { Tcl_HashEntry *hPtr; int isNew; - Encoding *encodingPtr; char *name; Tcl_MutexLock(&encodingMutex); @@ -1056,30 +1123,17 @@ Tcl_CreateEncoding( * reference goes away. */ - encodingPtr = Tcl_GetHashValue(hPtr); - encodingPtr->hPtr = NULL; + Encoding *replaceMe = Tcl_GetHashValue(hPtr); + replaceMe->hPtr = NULL; } name = ckalloc(strlen(typePtr->encodingName) + 1); - - encodingPtr = ckalloc(sizeof(Encoding)); encodingPtr->name = strcpy(name, typePtr->encodingName); - encodingPtr->toUtfProc = typePtr->toUtfProc; - encodingPtr->fromUtfProc = typePtr->fromUtfProc; - encodingPtr->freeProc = typePtr->freeProc; - encodingPtr->nullSize = typePtr->nullSize; - encodingPtr->clientData = typePtr->clientData; - if (typePtr->nullSize == 1) { - encodingPtr->lengthProc = (LengthProc *) strlen; - } else { - encodingPtr->lengthProc = (LengthProc *) unilen; - } - encodingPtr->refCount = 1; encodingPtr->hPtr = hPtr; Tcl_SetHashValue(hPtr, encodingPtr); Tcl_MutexUnlock(&encodingMutex); - + } return (Tcl_Encoding) encodingPtr; } @@ -1260,7 +1314,7 @@ Tcl_ExternalToUtf( if (*dstCharsPtr <= maxChars) { break; } - dstLen = Tcl_UtfAtIndex(dst, maxChars) - 1 - dst + TCL_UTF_MAX; + dstLen = Tcl_UtfAtIndex(dst, maxChars) - dst + (TCL_UTF_MAX - 1); flags = savedFlags; *statePtr = savedState; } while (1); @@ -1518,10 +1572,10 @@ OpenEncodingFileChannel( } } if (!verified) { - const char *dirString = Tcl_GetString(directory); + const char *dirString = TclGetString(directory); for (i=0; i<numDirs && !verified; i++) { - if (strcmp(dirString, Tcl_GetString(dir[i])) == 0) { + if (strcmp(dirString, TclGetString(dir[i])) == 0) { verified = 1; } } @@ -1720,7 +1774,7 @@ LoadTableEncoding( }; Tcl_DStringInit(&lineString); - if (Tcl_Gets(chan, &lineString) < 0) { + if (Tcl_Gets(chan, &lineString) == TCL_IO_FAILURE) { return NULL; } line = Tcl_DStringValue(&lineString); @@ -1767,7 +1821,7 @@ LoadTableEncoding( if (Tcl_ReadChars(chan, objPtr, expected, 0) != expected) { return NULL; } - p = Tcl_GetString(objPtr); + p = TclGetString(objPtr); hi = (staticHex[UCHAR(p[0])] << 4) + staticHex[UCHAR(p[1])]; dataPtr->toUnicode[hi] = pageMemPtr; p += 2; @@ -2054,13 +2108,13 @@ LoadEscapeEncoding( + Tcl_DStringLength(&escapeData); dataPtr = ckalloc(size); dataPtr->initLen = strlen(init); - memcpy(dataPtr->init, init, (unsigned) dataPtr->initLen + 1); + memcpy(dataPtr->init, init, dataPtr->initLen + 1); dataPtr->finalLen = strlen(final); - memcpy(dataPtr->final, final, (unsigned) dataPtr->finalLen + 1); + memcpy(dataPtr->final, final, dataPtr->finalLen + 1); dataPtr->numSubTables = Tcl_DStringLength(&escapeData) / sizeof(EscapeSubTable); memcpy(dataPtr->subTables, Tcl_DStringValue(&escapeData), - (size_t) Tcl_DStringLength(&escapeData)); + Tcl_DStringLength(&escapeData)); Tcl_DStringFree(&escapeData); memset(dataPtr->prefixBytes, 0, sizeof(dataPtr->prefixBytes)); @@ -2148,7 +2202,7 @@ BinaryProc( *srcReadPtr = srcLen; *dstWrotePtr = srcLen; *dstCharsPtr = srcLen; - memcpy(dst, src, (size_t) srcLen); + memcpy(dst, src, srcLen); return result; } @@ -2364,7 +2418,7 @@ UtfToUtfProc( int len = TclUtfToUniChar(src, chPtr); src += len; dst += Tcl_UniCharToUtf(*chPtr, dst); -#if TCL_UTF_MAX == 4 +#if TCL_UTF_MAX <= 4 if ((*chPtr >= 0xD800) && (len < 3)) { src += TclUtfToUniChar(src + len, chPtr); dst += Tcl_UniCharToUtf(*chPtr, dst); @@ -2382,9 +2436,9 @@ UtfToUtfProc( /* *------------------------------------------------------------------------- * - * UnicodeToUtfProc -- + * Utf16ToUtfProc -- * - * Convert from Unicode to UTF-8. + * Convert from UTF-16 to UTF-8. * * Results: * Returns TCL_OK if conversion was successful. @@ -2396,8 +2450,8 @@ UtfToUtfProc( */ static int -UnicodeToUtfProc( - ClientData clientData, /* Not used. */ +Utf16ToUtfProc( + ClientData clientData, /* != NULL means LE, == NUL means BE */ const char *src, /* Source string in Unicode. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ @@ -2425,19 +2479,16 @@ UnicodeToUtfProc( const char *srcStart, *srcEnd; const char *dstEnd, *dstStart; int result, numChars, charLimit = INT_MAX; - Tcl_UniChar *chPtr = (Tcl_UniChar *) statePtr; + unsigned short ch; - if (flags & TCL_ENCODING_START) { - *statePtr = 0; - } if (flags & TCL_ENCODING_CHAR_LIMIT) { charLimit = *dstCharsPtr; } result = TCL_OK; - if ((srcLen % sizeof(Tcl_UniChar)) != 0) { + if ((srcLen % sizeof(unsigned short)) != 0) { result = TCL_CONVERT_MULTIBYTE; - srcLen /= sizeof(Tcl_UniChar); - srcLen *= sizeof(Tcl_UniChar); + srcLen /= sizeof(unsigned short); + srcLen *= sizeof(unsigned short); } srcStart = src; @@ -2452,18 +2503,21 @@ UnicodeToUtfProc( break; } + if (clientData) { + ch = (src[1] & 0xFF) << 8 | (src[0] & 0xFF); + } else { + ch = (src[0] & 0xFF) << 8 | (src[1] & 0xFF); + } /* * Special case for 1-byte utf chars for speed. Make sure we work with - * Tcl_UniChar-size data. + * unsigned short-size data. */ - - *chPtr = *(Tcl_UniChar *)src; - if (*chPtr && *chPtr < 0x80) { - *dst++ = (*chPtr & 0xFF); + if (ch && ch < 0x80) { + *dst++ = (ch & 0xFF); } else { - dst += Tcl_UniCharToUtf(*chPtr, dst); + dst += Tcl_UniCharToUtf(ch, dst); } - src += sizeof(Tcl_UniChar); + src += sizeof(unsigned short); } *srcReadPtr = src - srcStart; @@ -2475,9 +2529,9 @@ UnicodeToUtfProc( /* *------------------------------------------------------------------------- * - * UtfToUnicodeProc -- + * UtfToUtf16Proc -- * - * Convert from UTF-8 to Unicode. + * Convert from UTF-8 to UTF-16. * * Results: * Returns TCL_OK if conversion was successful. @@ -2489,9 +2543,8 @@ UnicodeToUtfProc( */ static int -UtfToUnicodeProc( - ClientData clientData, /* TableEncodingData that specifies - * encoding. */ +UtfToUtf16Proc( + ClientData clientData, /* != NULL means LE, == NUL means BE */ const char *src, /* Source string in UTF-8. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ @@ -2555,27 +2608,37 @@ UtfToUnicodeProc( * casting dst to a Tcl_UniChar. [Bug 1122671] */ -#ifdef WORDS_BIGENDIAN + if (clientData) { #if TCL_UTF_MAX > 4 - *dst++ = (*chPtr >> 24); - *dst++ = ((*chPtr >> 16) & 0xFF); - *dst++ = ((*chPtr >> 8) & 0xFF); - *dst++ = (*chPtr & 0xFF); + if (*chPtr <= 0xFFFF) { + *dst++ = (*chPtr & 0xFF); + *dst++ = (*chPtr >> 8); + } else { + *dst++ = (((*chPtr - 0x10000) >> 10) & 0xFF); + *dst++ = (((*chPtr - 0x10000) >> 18) & 0x3) | 0xD8; + *dst++ = (*chPtr & 0xFF); + *dst++ = ((*chPtr & 0x3) >> 8) | 0xDC; + } #else - *dst++ = (*chPtr >> 8); - *dst++ = (*chPtr & 0xFF); + *dst++ = (*chPtr & 0xFF); + *dst++ = (*chPtr >> 8); #endif -#else + } else { #if TCL_UTF_MAX > 4 - *dst++ = (*chPtr & 0xFF); - *dst++ = ((*chPtr >> 8) & 0xFF); - *dst++ = ((*chPtr >> 16) & 0xFF); - *dst++ = (*chPtr >> 24); + if (*chPtr <= 0xFFFF) { + *dst++ = (*chPtr >> 8); + *dst++ = (*chPtr & 0xFF); + } else { + *dst++ = ((*chPtr & 0x3) >> 8) | 0xDC; + *dst++ = (*chPtr & 0xFF); + *dst++ = (((*chPtr - 0x10000) >> 18) & 0x3) | 0xD8; + *dst++ = (((*chPtr - 0x10000) >> 10) & 0xFF); + } #else - *dst++ = (*chPtr & 0xFF); - *dst++ = (*chPtr >> 8); -#endif + *dst++ = (*chPtr >> 8); + *dst++ = (*chPtr & 0xFF); #endif + } } *srcReadPtr = src - srcStart; *dstWrotePtr = dst - dstStart; @@ -2586,6 +2649,113 @@ UtfToUnicodeProc( /* *------------------------------------------------------------------------- * + * UtfToUcs2Proc -- + * + * Convert from UTF-8 to UCS-2. + * + * Results: + * Returns TCL_OK if conversion was successful. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +UtfToUcs2Proc( + ClientData clientData, /* != NULL means LE, == NUL means BE */ + const char *src, /* Source string in UTF-8. */ + int srcLen, /* Source string length in bytes. */ + int flags, /* Conversion control flags. */ + Tcl_EncodingState *statePtr,/* Place for conversion routine to store state + * information used during a piecewise + * conversion. Contents of statePtr are + * initialized and/or reset by conversion + * routine under control of flags argument. */ + char *dst, /* Output buffer in which converted string is + * stored. */ + int dstLen, /* The maximum length of output buffer in + * bytes. */ + int *srcReadPtr, /* Filled with the number of bytes from the + * source string that were converted. This may + * be less than the original source length if + * there was a problem converting some source + * characters. */ + int *dstWrotePtr, /* Filled with the number of bytes that were + * stored in the output buffer as a result of + * the conversion. */ + int *dstCharsPtr) /* Filled with the number of characters that + * correspond to the bytes stored in the + * output buffer. */ +{ + const char *srcStart, *srcEnd, *srcClose, *dstStart, *dstEnd; + int result, numChars; +#if TCL_UTF_MAX <= 4 + int len; +#endif + Tcl_UniChar ch = 0; + + srcStart = src; + srcEnd = src + srcLen; + srcClose = srcEnd; + if ((flags & TCL_ENCODING_END) == 0) { + srcClose -= TCL_UTF_MAX; + } + + dstStart = dst; + dstEnd = dst + dstLen - sizeof(Tcl_UniChar); + + result = TCL_OK; + for (numChars = 0; src < srcEnd; numChars++) { + if ((src > srcClose) && (!Tcl_UtfCharComplete(src, srcEnd - src))) { + /* + * If there is more string to follow, this will ensure that the + * last UTF-8 character in the source buffer hasn't been cut off. + */ + + result = TCL_CONVERT_MULTIBYTE; + break; + } + if (dst > dstEnd) { + result = TCL_CONVERT_NOSPACE; + break; + } +#if TCL_UTF_MAX <= 4 + src += (len = TclUtfToUniChar(src, &ch)); + if ((ch >= 0xD800) && (len < 3)) { + src += TclUtfToUniChar(src, &ch); + ch = 0xFFFD; + } +#else + src += TclUtfToUniChar(src, &ch); + if (ch > 0xFFFF) { + ch = 0xFFFD; + } +#endif + + /* + * Need to handle this in a way that won't cause misalignment by + * casting dst to a Tcl_UniChar. [Bug 1122671] + */ + + if (clientData) { + *dst++ = (ch & 0xFF); + *dst++ = (ch >> 8); + } else { + *dst++ = (ch >> 8); + *dst++ = (ch & 0xFF); + } + } + *srcReadPtr = src - srcStart; + *dstWrotePtr = dst - dstStart; + *dstCharsPtr = numChars; + return result; +} + +/* + *------------------------------------------------------------------------- + * * TableToUtfProc -- * * Convert from the encoding specified by the TableEncodingData into @@ -2784,7 +2954,7 @@ TableFromUtfProc( if (ch & 0xffff0000) { word = 0; } else -#elif TCL_UTF_MAX == 4 +#else if (!len) { word = 0; } else @@ -2986,7 +3156,7 @@ Iso88591FromUtfProc( */ if (ch > 0xff -#if TCL_UTF_MAX == 4 +#if TCL_UTF_MAX <= 4 || ((ch >= 0xD800) && (len < 3)) #endif ) { @@ -2994,10 +3164,9 @@ Iso88591FromUtfProc( result = TCL_CONVERT_UNKNOWN; break; } -#if TCL_UTF_MAX == 4 +#if TCL_UTF_MAX <= 4 if ((ch >= 0xD800) && (len < 3)) len = 4; #endif - /* * Plunge on, using '?' as a fallback character. */ @@ -3346,7 +3515,7 @@ EscapeFromUtfProc( *dstWrotePtr = 0; return TCL_CONVERT_NOSPACE; } - memcpy(dst, dataPtr->init, (size_t)dataPtr->initLen); + memcpy(dst, dataPtr->init, dataPtr->initLen); dst += dataPtr->initLen; } else { state = PTR2INT(*statePtr); @@ -3468,7 +3637,7 @@ EscapeFromUtfProc( memcpy(dst, dataPtr->subTables[0].sequence, len); dst += len; } - memcpy(dst, dataPtr->final, (size_t) dataPtr->finalLen); + memcpy(dst, dataPtr->final, dataPtr->finalLen); dst += dataPtr->finalLen; state &= ~TCL_ENCODING_END; } @@ -3631,11 +3800,11 @@ unilen( static void InitializeEncodingSearchPath( char **valuePtr, - int *lengthPtr, + unsigned int *lengthPtr, Tcl_Encoding *encodingPtr) { const char *bytes; - int i, numDirs, numBytes; + int i, numDirs; Tcl_Obj *libPathObj, *encodingObj, *searchPathObj; TclNewLiteralStringObj(encodingObj, "encoding"); @@ -3665,11 +3834,11 @@ InitializeEncodingSearchPath( if (*encodingPtr) { ((Encoding *)(*encodingPtr))->refCount++; } - bytes = Tcl_GetStringFromObj(searchPathObj, &numBytes); + bytes = TclGetString(searchPathObj); - *lengthPtr = numBytes; - *valuePtr = ckalloc(numBytes + 1); - memcpy(*valuePtr, bytes, (size_t) numBytes + 1); + *lengthPtr = searchPathObj->length; + *valuePtr = ckalloc(*lengthPtr + 1); + memcpy(*valuePtr, bytes, *lengthPtr + 1); Tcl_DecrRefCount(searchPathObj); } diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 03bbf03..9964250 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -21,8 +21,6 @@ static inline Tcl_Obj * NewNsObj(Tcl_Namespace *namespacePtr); static inline int EnsembleUnknownCallback(Tcl_Interp *interp, EnsembleConfig *ensemblePtr, int objc, Tcl_Obj *const objv[], Tcl_Obj **prefixObjPtr); -static int NsEnsembleImplementationCmd(ClientData clientData, - Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static int NsEnsembleImplementationCmdNR(ClientData clientData, Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static void BuildEnsembleConfig(EnsembleConfig *ensemblePtr); @@ -86,22 +84,36 @@ static const Tcl_ObjType ensembleCmdType = { NULL /* setFromAnyProc */ }; +#define ECRSetIntRep(objPtr, ecRepPtr) \ + do { \ + Tcl_ObjIntRep ir; \ + ir.twoPtrValue.ptr1 = (ecRepPtr); \ + ir.twoPtrValue.ptr2 = NULL; \ + Tcl_StoreIntRep((objPtr), &ensembleCmdType, &ir); \ + } while (0) + +#define ECRGetIntRep(objPtr, ecRepPtr) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = TclFetchIntRep((objPtr), &ensembleCmdType); \ + (ecRepPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + } while (0) + /* - * The internal rep for caching ensemble subcommand lookups and - * spell corrections. + * The internal rep for caching ensemble subcommand lookups and spelling + * corrections. */ typedef struct { - int epoch; /* Used to confirm when the data in this + unsigned 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 * structure is a cache of the resolution. */ Tcl_Obj *fix; /* Corrected spelling, if needed. */ - Tcl_HashEntry *hPtr; /* Direct link to entry in the subcommand - * hash table. */ + Tcl_HashEntry *hPtr; /* Direct link to entry in the subcommand hash + * table. */ } EnsembleCmdRep; - static inline Tcl_Obj * NewNsObj( @@ -111,9 +123,8 @@ NewNsObj( if (namespacePtr == TclGetGlobalNamespace(nsPtr->interp)) { return Tcl_NewStringObj("::", 2); - } else { - return Tcl_NewStringObj(nsPtr->fullName, -1); } + return Tcl_NewStringObj(nsPtr->fullName, -1); } /* @@ -147,7 +158,7 @@ TclNamespaceEnsembleCmd( { Tcl_Namespace *namespacePtr; Namespace *nsPtr = (Namespace *) TclGetCurrentNamespace(interp), *cxtPtr, - *foundNsPtr, *altFoundNsPtr, *actualCxtPtr; + *foundNsPtr, *altFoundNsPtr, *actualCxtPtr; Tcl_Command token; Tcl_DictSearch search; Tcl_Obj *listObj; @@ -302,7 +313,8 @@ TclNamespaceEnsembleCmd( Tcl_DictObjPut(NULL, patchedDict, subcmdWordsObj, newList); } - Tcl_DictObjNext(&search, &subcmdWordsObj,&listObj, &done); + Tcl_DictObjNext(&search, &subcmdWordsObj, &listObj, + &done); } while (!done); if (allocatedMapFlag) { @@ -336,8 +348,8 @@ TclNamespaceEnsembleCmd( } TclGetNamespaceForQualName(interp, name, cxtPtr, - TCL_CREATE_NS_IF_UNKNOWN, &foundNsPtr, &altFoundNsPtr, &actualCxtPtr, - &simpleName); + TCL_CREATE_NS_IF_UNKNOWN, &foundNsPtr, &altFoundNsPtr, + &actualCxtPtr, &simpleName); /* * Create the ensemble. Note that this might delete another ensemble @@ -347,8 +359,8 @@ TclNamespaceEnsembleCmd( */ token = TclCreateEnsembleInNs(interp, simpleName, - (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr, - (permitPrefix ? TCL_ENSEMBLE_PREFIX : 0)); + (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr, + (permitPrefix ? TCL_ENSEMBLE_PREFIX : 0)); Tcl_SetEnsembleSubcommandList(interp, token, subcmdObj); Tcl_SetEnsembleMappingDict(interp, token, mapObj); Tcl_SetEnsembleUnknownHandler(interp, token, unknownObj); @@ -576,7 +588,8 @@ TclNamespaceEnsembleCmd( Tcl_AppendStringsToObj(newCmd, "::", NULL); } Tcl_AppendObjToObj(newCmd, listv[0]); - Tcl_ListObjReplace(NULL, newList, 0,1, 1,&newCmd); + Tcl_ListObjReplace(NULL, newList, 0, 1, 1, + &newCmd); if (patchedDict == NULL) { patchedDict = Tcl_DuplicateObj(objv[1]); } @@ -650,15 +663,13 @@ TclNamespaceEnsembleCmd( Tcl_Command TclCreateEnsembleInNs( Tcl_Interp *interp, - - const char *name, /* Simple name of command to create (no */ - /* namespace components). */ - Tcl_Namespace /* Name of namespace to create the command in. */ - *nameNsPtr, - Tcl_Namespace - *ensembleNsPtr, /* Name of the namespace for the ensemble. */ - int flags - ) + const char *name, /* Simple name of command to create (no + * namespace components). */ + Tcl_Namespace *nameNsPtr, /* Name of namespace to create the command + * in. */ + Tcl_Namespace *ensembleNsPtr, + /* Name of the namespace for the ensemble. */ + int flags) { Namespace *nsPtr = (Namespace *) ensembleNsPtr; EnsembleConfig *ensemblePtr; @@ -666,8 +677,8 @@ TclCreateEnsembleInNs( ensemblePtr = ckalloc(sizeof(EnsembleConfig)); token = TclNRCreateCommandInNs(interp, name, - (Tcl_Namespace *) nameNsPtr, NsEnsembleImplementationCmd, - NsEnsembleImplementationCmdNR, ensemblePtr, DeleteEnsembleConfig); + (Tcl_Namespace *) nameNsPtr, TclEnsembleImplementationCmd, + NsEnsembleImplementationCmdNR, ensemblePtr, DeleteEnsembleConfig); if (token == NULL) { ckfree(ensemblePtr); return NULL; @@ -701,18 +712,15 @@ TclCreateEnsembleInNs( } return ensemblePtr->token; - } - - + /* *---------------------------------------------------------------------- * * Tcl_CreateEnsemble * - * Create a simple ensemble attached to the given namespace. - * - * Deprecated by TclCreateEnsembleInNs. + * Create a simple ensemble attached to the given namespace. Deprecated + * (internally) by TclCreateEnsembleInNs. * * Value * @@ -732,8 +740,8 @@ Tcl_CreateEnsemble( Tcl_Namespace *namespacePtr, int flags) { - Namespace *nsPtr = (Namespace *)namespacePtr, *foundNsPtr, *altNsPtr, - *actualNsPtr; + Namespace *nsPtr = (Namespace *) namespacePtr, *foundNsPtr, *altNsPtr, + *actualNsPtr; const char * simpleName; if (nsPtr == NULL) { @@ -741,11 +749,10 @@ Tcl_CreateEnsemble( } TclGetNamespaceForQualName(interp, name, nsPtr, TCL_CREATE_NS_IF_UNKNOWN, - &foundNsPtr, &altNsPtr, &actualNsPtr, &simpleName); + &foundNsPtr, &altNsPtr, &actualNsPtr, &simpleName); return TclCreateEnsembleInNs(interp, simpleName, - (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr, flags); + (Tcl_Namespace *) foundNsPtr, (Tcl_Namespace *) nsPtr, flags); } - /* *---------------------------------------------------------------------- @@ -774,7 +781,7 @@ Tcl_SetEnsembleSubcommandList( EnsembleConfig *ensemblePtr; Tcl_Obj *oldList; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (cmdPtr->objProc != TclEnsembleImplementationCmd) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); @@ -850,7 +857,7 @@ Tcl_SetEnsembleParameterList( Tcl_Obj *oldList; int length; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (cmdPtr->objProc != TclEnsembleImplementationCmd) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); @@ -926,7 +933,7 @@ Tcl_SetEnsembleMappingDict( EnsembleConfig *ensemblePtr; Tcl_Obj *oldDict; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (cmdPtr->objProc != TclEnsembleImplementationCmd) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); @@ -1025,7 +1032,7 @@ Tcl_SetEnsembleUnknownHandler( EnsembleConfig *ensemblePtr; Tcl_Obj *oldList; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (cmdPtr->objProc != TclEnsembleImplementationCmd) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); @@ -1091,7 +1098,7 @@ Tcl_SetEnsembleFlags( EnsembleConfig *ensemblePtr; int wasCompiled; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (cmdPtr->objProc != TclEnsembleImplementationCmd) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); Tcl_SetErrorCode(interp, "TCL", "ENSEMBLE", "NOT_ENSEMBLE", NULL); @@ -1167,7 +1174,7 @@ Tcl_GetEnsembleSubcommandList( Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (cmdPtr->objProc != TclEnsembleImplementationCmd) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); @@ -1209,7 +1216,7 @@ Tcl_GetEnsembleParameterList( Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (cmdPtr->objProc != TclEnsembleImplementationCmd) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); @@ -1251,7 +1258,7 @@ Tcl_GetEnsembleMappingDict( Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (cmdPtr->objProc != TclEnsembleImplementationCmd) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); @@ -1292,7 +1299,7 @@ Tcl_GetEnsembleUnknownHandler( Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (cmdPtr->objProc != TclEnsembleImplementationCmd) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); @@ -1333,7 +1340,7 @@ Tcl_GetEnsembleFlags( Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (cmdPtr->objProc != TclEnsembleImplementationCmd) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); @@ -1374,7 +1381,7 @@ Tcl_GetEnsembleNamespace( Command *cmdPtr = (Command *) token; EnsembleConfig *ensemblePtr; - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (cmdPtr->objProc != TclEnsembleImplementationCmd) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "command is not an ensemble", -1)); @@ -1424,7 +1431,7 @@ Tcl_FindEnsemble( return NULL; } - if (cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (cmdPtr->objProc != TclEnsembleImplementationCmd) { /* * Reuse existing infrastructure for following import link chains * rather than duplicating it. @@ -1432,7 +1439,8 @@ Tcl_FindEnsemble( cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); - if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd){ + if (cmdPtr == NULL + || cmdPtr->objProc != TclEnsembleImplementationCmd) { if (flags & TCL_LEAVE_ERR_MSG) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "\"%s\" is not an ensemble command", @@ -1470,11 +1478,11 @@ Tcl_IsEnsemble( { Command *cmdPtr = (Command *) token; - if (cmdPtr->objProc == NsEnsembleImplementationCmd) { + if (cmdPtr->objProc == TclEnsembleImplementationCmd) { return 1; } cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); - if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd) { + if (cmdPtr == NULL || cmdPtr->objProc != TclEnsembleImplementationCmd) { return 0; } return 1; @@ -1637,7 +1645,7 @@ TclMakeEnsemble( Tcl_DStringFree(&buf); Tcl_DStringFree(&hiddenBuf); if (nameParts != NULL) { - ckfree((char *) nameParts); + ckfree(nameParts); } return ensemble; } @@ -1645,7 +1653,7 @@ TclMakeEnsemble( /* *---------------------------------------------------------------------- * - * NsEnsembleImplementationCmd -- + * TclEnsembleImplementationCmd -- * * Implements an ensemble of commands (being those exported by a * namespace other than the global namespace) as a command with the same @@ -1664,8 +1672,8 @@ TclMakeEnsemble( *---------------------------------------------------------------------- */ -static int -NsEnsembleImplementationCmd( +int +TclEnsembleImplementationCmd( ClientData clientData, Tcl_Interp *interp, int objc, @@ -1749,10 +1757,10 @@ NsEnsembleImplementationCmdNR( * check here, and if we're still valid, we can jump straight to the * part where we do the invocation of the subcommand. */ + EnsembleCmdRep *ensembleCmd; - if (subObj->typePtr==&ensembleCmdType){ - EnsembleCmdRep *ensembleCmd = subObj->internalRep.twoPtrValue.ptr1; - + ECRGetIntRep(subObj, ensembleCmd); + if (ensembleCmd) { if (ensembleCmd->epoch == ensemblePtr->epoch && ensembleCmd->token == (Command *)ensemblePtr->token) { prefixObj = Tcl_GetHashValue(ensembleCmd->hPtr); @@ -1803,11 +1811,11 @@ NsEnsembleImplementationCmdNR( int tableLength = ensemblePtr->subcommandTable.numEntries; Tcl_Obj *fix; - subcmdName = Tcl_GetStringFromObj(subObj, &stringLength); + subcmdName = TclGetStringFromObj(subObj, &stringLength); for (i=0 ; i<tableLength ; i++) { register int cmp = strncmp(subcmdName, ensemblePtr->subcommandArrayPtr[i], - (unsigned) stringLength); + stringLength); if (cmp == 0) { if (fullName != NULL) { @@ -2123,7 +2131,7 @@ TclSpellFix( */ size = iPtr->ensembleRewrite.numRemovedObjs + objc - - iPtr->ensembleRewrite.numInsertedObjs; + - iPtr->ensembleRewrite.numInsertedObjs; search = iPtr->ensembleRewrite.sourceObjs; if (search[0] == NULL) { @@ -2398,8 +2406,8 @@ MakeCachedEnsembleCommand( { register EnsembleCmdRep *ensembleCmd; - if (objPtr->typePtr == &ensembleCmdType) { - ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; + ECRGetIntRep(objPtr, ensembleCmd); + if (ensembleCmd) { TclCleanupCommandMacro(ensembleCmd->token); if (ensembleCmd->fix) { Tcl_DecrRefCount(ensembleCmd->fix); @@ -2410,10 +2418,8 @@ MakeCachedEnsembleCommand( * our own. */ - TclFreeIntRep(objPtr); ensembleCmd = ckalloc(sizeof(EnsembleCmdRep)); - objPtr->internalRep.twoPtrValue.ptr1 = ensembleCmd; - objPtr->typePtr = &ensembleCmdType; + ECRSetIntRep(objPtr, ensembleCmd); } /* @@ -2539,9 +2545,10 @@ DeleteEnsembleConfig( * BuildEnsembleConfig -- * * Create the internal data structures that describe how an ensemble - * looks, being a hash mapping from the simple command name to the Tcl list + * looks, being a hash mapping from the full command name to the Tcl list * that describes the implementation prefix words, and a sorted array of - * the names to allow for reasonably efficient unambiguous prefix handling. + * all the full command names to allow for reasonably efficient + * unambiguous prefix handling. * * Results: * None. @@ -2573,7 +2580,7 @@ BuildEnsembleConfig( if (subList) { int subc; Tcl_Obj **subv, *target, *cmdObj, *cmdPrefixObj; - char *name; + const char *name; /* * There is a list of exactly what subcommands go in the table. @@ -2607,7 +2614,9 @@ BuildEnsembleConfig( } } } else { - /* Usual case where we can freely act on the list and dict. */ + /* + * Usual case where we can freely act on the list and dict. + */ for (i = 0; i < subc; i++) { name = TclGetString(subv[i]); @@ -2616,7 +2625,10 @@ BuildEnsembleConfig( continue; } - /* Lookup target in the dictionary */ + /* + * Lookup target in the dictionary. + */ + if (mapDict) { Tcl_DictObjGet(NULL, mapDict, subv[i], &target); if (target) { @@ -2628,10 +2640,11 @@ BuildEnsembleConfig( /* * target was not in the dictionary so map onto the namespace. - * Note in this case that we do not guarantee that the - * command is actually there; that is the programmer's - * responsibility (or [::unknown] of course). + * Note in this case that we do not guarantee that the command + * is actually there; that is the programmer's responsibility + * (or [::unknown] of course). */ + cmdObj = Tcl_NewStringObj(name, -1); cmdPrefixObj = Tcl_NewListObj(1, &cmdObj); Tcl_SetHashValue(hPtr, cmdPrefixObj); @@ -2652,7 +2665,7 @@ BuildEnsembleConfig( Tcl_DictObjFirst(NULL, ensemblePtr->subcommandDict, &dictSearch, &keyObj, &valueObj, &done); while (!done) { - char *name = TclGetString(keyObj); + const char *name = TclGetString(keyObj); hPtr = Tcl_CreateHashEntry(hash, name, &isNew); Tcl_SetHashValue(hPtr, valueObj); @@ -2760,7 +2773,7 @@ BuildEnsembleConfig( hPtr = Tcl_NextHashEntry(&search); } if (hash->numEntries > 1) { - qsort(ensemblePtr->subcommandArrayPtr, (unsigned) hash->numEntries, + qsort(ensemblePtr->subcommandArrayPtr, hash->numEntries, sizeof(char *), NsEnsembleStringOrder); } } @@ -2814,14 +2827,14 @@ static void FreeEnsembleCmdRep( Tcl_Obj *objPtr) { - EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; + EnsembleCmdRep *ensembleCmd; + ECRGetIntRep(objPtr, ensembleCmd); TclCleanupCommandMacro(ensembleCmd->token); if (ensembleCmd->fix) { Tcl_DecrRefCount(ensembleCmd->fix); } ckfree(ensembleCmd); - objPtr->typePtr = NULL; } /* @@ -2847,11 +2860,12 @@ DupEnsembleCmdRep( Tcl_Obj *objPtr, Tcl_Obj *copyPtr) { - EnsembleCmdRep *ensembleCmd = objPtr->internalRep.twoPtrValue.ptr1; + EnsembleCmdRep *ensembleCmd; EnsembleCmdRep *ensembleCopy = ckalloc(sizeof(EnsembleCmdRep)); - copyPtr->typePtr = &ensembleCmdType; - copyPtr->internalRep.twoPtrValue.ptr1 = ensembleCopy; + ECRGetIntRep(objPtr, ensembleCmd); + ECRSetIntRep(copyPtr, ensembleCopy); + ensembleCopy->epoch = ensembleCmd->epoch; ensembleCopy->token = ensembleCmd->token; ensembleCopy->token->refCount++; @@ -2977,7 +2991,7 @@ TclCompileEnsemble( goto failed; } for (i=0 ; i<len ; i++) { - str = Tcl_GetStringFromObj(elems[i], &sclen); + str = TclGetStringFromObj(elems[i], &sclen); if ((sclen == (int) numBytes) && !memcmp(word, str, numBytes)) { /* * Exact match! Excellent! @@ -3365,8 +3379,8 @@ CompileToInvokedCommand( { Tcl_Token *tokPtr; Tcl_Obj *objPtr, **words; - char *bytes; - int length, i, numWords, cmdLit, extraLiteralFlags = LITERAL_CMD_NAME; + const char *bytes; + int i, numWords, cmdLit, extraLiteralFlags = LITERAL_CMD_NAME; DefineLineInformation; /* @@ -3379,15 +3393,15 @@ CompileToInvokedCommand( for (i = 0, tokPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++, tokPtr = TokenAfter(tokPtr)) { if (i > 0 && i < numWords+1) { - bytes = Tcl_GetStringFromObj(words[i-1], &length); - PushLiteral(envPtr, bytes, length); + bytes = TclGetString(words[i-1]); + PushLiteral(envPtr, bytes, words[i-1]->length); continue; } SetLineInformation(i); if (tokPtr->type == TCL_TOKEN_SIMPLE_WORD) { - int literal = TclRegisterNewLiteral(envPtr, - tokPtr[1].start, tokPtr[1].size); + int literal = TclRegisterLiteral(envPtr, + tokPtr[1].start, tokPtr[1].size, 0); if (envPtr->clNext) { TclContinuationsEnterDerived( @@ -3408,11 +3422,11 @@ CompileToInvokedCommand( objPtr = Tcl_NewObj(); Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); - bytes = Tcl_GetStringFromObj(objPtr, &length); + bytes = TclGetString(objPtr); if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) { extraLiteralFlags |= LITERAL_UNSHARED; } - cmdLit = TclRegisterLiteral(envPtr, (char *)bytes, length, extraLiteralFlags); + cmdLit = TclRegisterLiteral(envPtr, bytes, objPtr->length, extraLiteralFlags); TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLit), cmdPtr); TclEmitPush(cmdLit, envPtr); TclDecrRefCount(objPtr); diff --git a/generic/tclEnv.c b/generic/tclEnv.c index da05f93..9677b86 100644 --- a/generic/tclEnv.c +++ b/generic/tclEnv.c @@ -273,7 +273,7 @@ TclSetEnv( Tcl_DStringFree(&envString); oldValue = environ[index]; - nameLength = (unsigned) length; + nameLength = length; } /* @@ -294,7 +294,7 @@ TclSetEnv( */ p = ckrealloc(p, Tcl_DStringLength(&envString) + 1); - memcpy(p, p2, (unsigned) Tcl_DStringLength(&envString) + 1); + memcpy(p, p2, Tcl_DStringLength(&envString) + 1); Tcl_DStringFree(&envString); #ifdef USE_PUTENV @@ -455,19 +455,19 @@ TclUnsetEnv( #if defined(_WIN32) string = ckalloc(length + 2); - memcpy(string, name, (size_t) length); + memcpy(string, name, length); string[length] = '='; string[length+1] = '\0'; #else string = ckalloc(length + 1); - memcpy(string, name, (size_t) length); + memcpy(string, name, length); string[length] = '\0'; #endif /* _WIN32 */ Tcl_UtfToExternalDString(NULL, string, -1, &envString); string = ckrealloc(string, Tcl_DStringLength(&envString) + 1); memcpy(string, Tcl_DStringValue(&envString), - (unsigned) Tcl_DStringLength(&envString)+1); + Tcl_DStringLength(&envString)+1); Tcl_DStringFree(&envString); putenv(string); diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 79985ed..734f114 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -37,7 +37,7 @@ typedef struct BgError { * pending background errors for the interpreter. */ -typedef struct ErrAssocData { +typedef struct { Tcl_Interp *interp; /* Interpreter in which error occurred. */ Tcl_Obj *cmdPrefix; /* First word(s) of the handler command */ BgError *firstBgPtr; /* First in list of all background errors @@ -100,7 +100,7 @@ typedef struct ThreadSpecificData { } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; -#ifdef TCL_THREADS +#if TCL_THREADS typedef struct { Tcl_ThreadCreateProc *proc; /* Main() function of the thread */ ClientData clientData; /* The one argument to Main() */ @@ -139,6 +139,8 @@ static void FinalizeThread(int quick); *---------------------------------------------------------------------- */ +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 +#undef Tcl_BackgroundError void Tcl_BackgroundError( Tcl_Interp *interp) /* Interpreter in which an error has @@ -146,6 +148,7 @@ Tcl_BackgroundError( { Tcl_BackgroundException(interp, TCL_ERROR); } +#endif /* TCL_NO_DEPRECATED */ void Tcl_BackgroundException( @@ -1048,6 +1051,9 @@ TclInitSubsystems(void) #if USE_TCLALLOC TclInitAlloc(); /* Process wide mutex init */ #endif +#if TCL_THREADS && defined(USE_THREAD_ALLOC) + TclInitThreadAlloc(); /* Setup thread allocator caches */ +#endif #ifdef TCL_MEM_DEBUG TclInitDbCkalloc(); /* Process wide mutex init */ #endif @@ -1059,7 +1065,6 @@ TclInitSubsystems(void) * mutexes. */ TclInitIOSubsystem(); /* Inits a tsd key (noop). */ TclInitEncodingSubsystem(); /* Process wide encoding init. */ - TclpSetInterfaces(); TclInitNamespaceSubsystem();/* Register ns obj type (mutexed). */ subsystemsInitialized = 1; } @@ -1223,7 +1228,7 @@ Tcl_Finalize(void) * Close down the thread-specific object allocator. */ -#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) +#if TCL_THREADS && defined(USE_THREAD_ALLOC) TclFinalizeThreadAlloc(); #endif @@ -1541,7 +1546,7 @@ Tcl_UpdateObjCmd( return TCL_OK; } -#ifdef TCL_THREADS +#if TCL_THREADS /* *---------------------------------------------------------------------- * @@ -1604,7 +1609,7 @@ Tcl_CreateThread( int flags) /* Flags controlling behaviour of the new * thread. */ { -#ifdef TCL_THREADS +#if TCL_THREADS ThreadClientData *cdPtr = ckalloc(sizeof(ThreadClientData)); int result; diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 832054e..faf5865 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -34,14 +34,14 @@ #endif /* - * 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. + * 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. */ -#ifndef ASYNC_CHECK_COUNT_MASK -# define ASYNC_CHECK_COUNT_MASK 63 -#endif /* !ASYNC_CHECK_COUNT_MASK */ +#ifndef ASYNC_CHECK_COUNT +# define ASYNC_CHECK_COUNT 64 +#endif /* !ASYNC_CHECK_COUNT */ /* * Boolean flag indicating whether the Tcl bytecode interpreter has been @@ -97,9 +97,9 @@ static const char *const resultStrings[] = { */ #ifdef TCL_COMPILE_STATS -long tclObjsAlloced = 0; -long tclObjsFreed = 0; -long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; +size_t tclObjsAlloced = 0; +size_t tclObjsFreed = 0; +size_t tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; #endif /* TCL_COMPILE_STATS */ /* @@ -211,7 +211,7 @@ typedef struct TEBCdata { */ #define VarHashGetValue(hPtr) \ - ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry))) + ((Var *) ((char *)hPtr - offsetof(VarInHash, entry))) static inline Var * VarHashCreateVar( @@ -498,55 +498,20 @@ VarHashCreateVar( * ClientData *ptrPtr, int *tPtr); */ -#ifdef TCL_WIDE_INT_IS_LONG #define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ - (((objPtr)->typePtr == &tclIntType) \ - ? (*(tPtr) = TCL_NUMBER_LONG, \ - *(ptrPtr) = (ClientData) \ - (&((objPtr)->internalRep.longValue)), TCL_OK) : \ - ((objPtr)->typePtr == &tclDoubleType) \ - ? (((TclIsNaN((objPtr)->internalRep.doubleValue)) \ - ? (*(tPtr) = TCL_NUMBER_NAN) \ - : (*(tPtr) = TCL_NUMBER_DOUBLE)), \ - *(ptrPtr) = (ClientData) \ - (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ - (((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) \ - (((objPtr)->typePtr == &tclIntType) \ - ? (*(tPtr) = TCL_NUMBER_LONG, \ - *(ptrPtr) = (ClientData) \ - (&((objPtr)->internalRep.longValue)), TCL_OK) : \ - ((objPtr)->typePtr == &tclWideIntType) \ - ? (*(tPtr) = TCL_NUMBER_WIDE, \ + ((TclHasIntRep((objPtr), &tclIntType)) \ + ? (*(tPtr) = TCL_NUMBER_INT, \ *(ptrPtr) = (ClientData) \ (&((objPtr)->internalRep.wideValue)), TCL_OK) : \ - ((objPtr)->typePtr == &tclDoubleType) \ + TclHasIntRep((objPtr), &tclDoubleType) \ ? (((TclIsNaN((objPtr)->internalRep.doubleValue)) \ ? (*(tPtr) = TCL_NUMBER_NAN) \ : (*(tPtr) = TCL_NUMBER_DOUBLE)), \ *(ptrPtr) = (ClientData) \ (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ (((objPtr)->bytes != NULL) && ((objPtr)->length == 0)) \ - ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \ + ? TCL_ERROR : \ TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr))) -#endif /* TCL_WIDE_INT_IS_LONG */ - -/* - * Macro used in this file to save a function call for common uses of - * Tcl_GetBooleanFromObj(). The ANSI C "prototype" is: - * - * MODULE_SCOPE int TclGetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - * int *boolPtr); - */ - -#define TclGetBooleanFromObj(interp, objPtr, boolPtr) \ - ((((objPtr)->typePtr == &tclIntType) \ - || ((objPtr)->typePtr == &tclBooleanType)) \ - ? (*(boolPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \ - : Tcl_GetBooleanFromObj((interp), (objPtr), (boolPtr))) /* * Macro used to make the check for type overflow more mnemonic. This works by @@ -576,40 +541,6 @@ VarHashCreateVar( * Auxiliary tables used to compute powers of small integers. */ -#if (LONG_MAX == 0x7fffffff) - -/* - * Maximum base that, when raised to powers 2, 3, ... 8, fits in a 32-bit - * signed integer. - */ - -static const long MaxBase32[] = {46340, 1290, 215, 73, 35, 21, 14}; -static const size_t MaxBase32Size = sizeof(MaxBase32)/sizeof(long); - -/* - * Table giving 3, 4, ..., 11, raised to the powers 9, 10, ..., as far as they - * fit in a 32-bit signed integer. Exp32Index[i] gives the starting index of - * powers of i+3; Exp32Value[i] gives the corresponding powers. - */ - -static const unsigned short Exp32Index[] = { - 0, 11, 18, 23, 26, 29, 31, 32, 33 -}; -static const size_t Exp32IndexSize = - sizeof(Exp32Index) / sizeof(unsigned short); -static const long Exp32Value[] = { - 19683, 59049, 177147, 531441, 1594323, 4782969, 14348907, 43046721, - 129140163, 387420489, 1162261467, 262144, 1048576, 4194304, - 16777216, 67108864, 268435456, 1073741824, 1953125, 9765625, - 48828125, 244140625, 1220703125, 10077696, 60466176, 362797056, - 40353607, 282475249, 1977326743, 134217728, 1073741824, 387420489, - 1000000000 -}; -static const size_t Exp32ValueSize = sizeof(Exp32Value)/sizeof(long); -#endif /* LONG_MAX == 0x7fffffff -- 32 bit machine */ - -#if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG) - /* * Maximum base that, when raised to powers 2, 3, ..., 16, fits in a * Tcl_WideInt. @@ -713,7 +644,6 @@ static const Tcl_WideInt Exp64Value[] = { (Tcl_WideInt)371293*371293*371293*13*13 }; static const size_t Exp64ValueSize = sizeof(Exp64Value) / sizeof(Tcl_WideInt); -#endif /* (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG) */ /* * Markers for ExecuteExtendedBinaryMathOp. @@ -744,8 +674,6 @@ static ByteCode * CompileExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr); static void DeleteExecStack(ExecStack *esPtr); static void DupExprCodeInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); -MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr, - Tcl_Obj *value2Ptr); static Tcl_Obj * ExecuteExtendedBinaryMathOp(Tcl_Interp *interp, int opcode, Tcl_Obj **constants, Tcl_Obj *valuePtr, Tcl_Obj *value2Ptr); @@ -820,20 +748,22 @@ ReleaseDictIterator( { Tcl_DictSearch *searchPtr; Tcl_Obj *dictPtr; + const Tcl_ObjIntRep *irPtr; + + irPtr = TclFetchIntRep(objPtr, &dictIteratorType); + assert(irPtr != NULL); /* * First kill the search, and then release the reference to the dictionary * that we were holding. */ - searchPtr = objPtr->internalRep.twoPtrValue.ptr1; + searchPtr = irPtr->twoPtrValue.ptr1; Tcl_DictObjDone(searchPtr); ckfree(searchPtr); - dictPtr = objPtr->internalRep.twoPtrValue.ptr2; + dictPtr = irPtr->twoPtrValue.ptr2; TclDecrRefCount(dictPtr); - - objPtr->typePtr = NULL; } /* @@ -908,9 +838,9 @@ TclCreateExecEnv( + (size_t) (size-1) * sizeof(Tcl_Obj *)); eePtr->execStackPtr = esPtr; - TclNewBooleanObj(eePtr->constants[0], 0); + TclNewIntObj(eePtr->constants[0], 0); Tcl_IncrRefCount(eePtr->constants[0]); - TclNewBooleanObj(eePtr->constants[1], 1); + TclNewIntObj(eePtr->constants[1], 1); Tcl_IncrRefCount(eePtr->constants[1]); eePtr->interp = interp; eePtr->callbackPtr = NULL; @@ -1272,7 +1202,7 @@ TclStackFree( Tcl_Obj **markerPtr, *marker; if (iPtr == NULL || iPtr->execEnvPtr == NULL) { - ckfree((char *) freePtr); + ckfree(freePtr); return; } @@ -1496,11 +1426,9 @@ 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 "bytecode" type, + * The Tcl_ObjType of objPtr is changed to the "exprcode" 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. @@ -1524,28 +1452,31 @@ CompileExprObj( * Get the expression ByteCode from the object. If it exists, make sure it * is valid in the current context. */ - if (objPtr->typePtr == &exprCodeType) { + + ByteCodeGetIntRep(objPtr, &exprCodeType, codePtr); + + if (codePtr != NULL) { Namespace *namespacePtr = iPtr->varFramePtr->nsPtr; - codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != namespacePtr) || (codePtr->nsEpoch != namespacePtr->resolverEpoch) || (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) { - FreeExprCodeInternalRep(objPtr); + Tcl_StoreIntRep(objPtr, &exprCodeType, NULL); + codePtr = NULL; } } - if (objPtr->typePtr != &exprCodeType) { + + if (codePtr == NULL) { /* * TIP #280: No invoker (yet) - Expression compilation. */ - int length; - const char *string = TclGetStringFromObj(objPtr, &length); + const char *string = TclGetString(objPtr); - TclInitCompileEnv(interp, &compEnv, string, length, NULL, 0); - TclCompileExpr(interp, string, length, &compEnv, 0); + TclInitCompileEnv(interp, &compEnv, string, objPtr->length, NULL, 0); + TclCompileExpr(interp, string, objPtr->length, &compEnv, 0); /* * Successful compilation. If the expression yielded no instructions, @@ -1553,7 +1484,7 @@ CompileExprObj( */ if (compEnv.codeNext == compEnv.codeStart) { - TclEmitPush(TclRegisterNewLiteral(&compEnv, "0", 1), + TclEmitPush(TclRegisterLiteral(&compEnv, "0", 1, 0), &compEnv); } @@ -1564,10 +1495,8 @@ CompileExprObj( */ TclEmitOpcode(INST_DONE, &compEnv); - TclInitByteCodeObj(objPtr, &compEnv); - objPtr->typePtr = &exprCodeType; + codePtr = TclInitByteCodeObj(objPtr, &exprCodeType, &compEnv); TclFreeCompileEnv(&compEnv); - codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (iPtr->varFramePtr->localCachePtr) { codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; @@ -1639,12 +1568,11 @@ static void FreeExprCodeInternalRep( Tcl_Obj *objPtr) { - ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; + ByteCode *codePtr; + ByteCodeGetIntRep(objPtr, &exprCodeType, codePtr); + assert(codePtr != NULL); - objPtr->typePtr = NULL; - if (codePtr->refCount-- <= 1) { - TclCleanupByteCode(codePtr); - } + TclReleaseByteCode(codePtr); } /* @@ -1680,7 +1608,8 @@ TclCompileObj( * compilation). Otherwise, check that it is "fresh" enough. */ - if (objPtr->typePtr == &tclByteCodeType) { + ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr); + if (codePtr != NULL) { /* * Make sure the Bytecode hasn't been invalidated by, e.g., someone * redefining a command with a compile procedure (this might make the @@ -1698,7 +1627,6 @@ TclCompileObj( * here. */ - codePtr = objPtr->internalRep.twoPtrValue.ptr1; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != namespacePtr) @@ -1826,7 +1754,7 @@ TclCompileObj( iPtr->invokeWord = word; TclSetByteCodeFromAny(interp, objPtr, NULL, NULL); iPtr->invokeCmdFramePtr = NULL; - codePtr = objPtr->internalRep.twoPtrValue.ptr1; + ByteCodeGetIntRep(objPtr, &tclByteCodeType, codePtr); if (iPtr->varFramePtr->localCachePtr) { codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; codePtr->localCachePtr->refCount++; @@ -1885,37 +1813,6 @@ TclIncrObj( return TCL_ERROR; } - if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { - long augend = *((const long *) ptr1); - long addend = *((const long *) ptr2); - long sum = augend + addend; - - /* - * Overflow when (augend and sum have different sign) and (augend and - * addend have the same sign). This is encapsulated in the Overflowing - * macro. - */ - - if (!Overflowing(augend, addend, sum)) { - TclSetLongObj(valuePtr, sum); - return TCL_OK; - } -#ifndef TCL_WIDE_INT_IS_LONG - { - Tcl_WideInt w1 = (Tcl_WideInt) augend; - Tcl_WideInt w2 = (Tcl_WideInt) addend; - - /* - * We know the sum value is outside the long range, so we use the - * macro form that doesn't range test again. - */ - - TclSetWideIntObj(valuePtr, w1 + w2); - return TCL_OK; - } -#endif - } - if ((type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN)) { /* * Produce error message (reparse?!) @@ -1933,12 +1830,11 @@ TclIncrObj( return TCL_ERROR; } -#ifndef TCL_WIDE_INT_IS_LONG - if ((type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) { + if ((type1 == TCL_NUMBER_INT) && (type2 == TCL_NUMBER_INT)) { Tcl_WideInt w1, w2, sum; - TclGetWideIntFromObj(NULL, valuePtr, &w1); - TclGetWideIntFromObj(NULL, incrPtr, &w2); + w1 = *((const Tcl_WideInt *)ptr1); + w2 = *((const Tcl_WideInt *)ptr2); sum = w1 + w2; /* @@ -1946,11 +1842,10 @@ TclIncrObj( */ if (!Overflowing(w1, w2, sum)) { - Tcl_SetWideIntObj(valuePtr, sum); + TclSetIntObj(valuePtr, sum); return TCL_OK; } } -#endif Tcl_TakeBignumFromObj(interp, valuePtr, &value); Tcl_GetBignumFromObj(interp, incrPtr, &incr); @@ -2030,7 +1925,7 @@ TclNRExecuteByteCode( * sizeof(void *); int numWords = (size + sizeof(Tcl_Obj *) - 1) / sizeof(Tcl_Obj *); - codePtr->refCount++; + TclPreserveByteCode(codePtr); /* * Reserve the stack, setup the TEBCdataPtr (TD) and CallFrame @@ -2126,8 +2021,14 @@ TEBCresume( * sporadically: no special need for speed. */ - int instructionCount = 0; /* Counter that is used to work out when to - * call Tcl_AsyncReady() */ + 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. */ const char *curInstName; #ifdef TCL_COMPILE_DEBUG int traceInstructions; /* Whether we are doing instruction-level @@ -2326,10 +2227,11 @@ TEBCresume( /* * Check for asynchronous handlers [Bug 746722]; we do the check every - * ASYNC_CHECK_COUNT_MASK instruction, of the form (2**n-1). + * ASYNC_CHECK_COUNT instructions. */ - if ((instructionCount++ & ASYNC_CHECK_COUNT_MASK) == 0) { + if ((--interruptCounter) == 0) { + interruptCounter = ASYNC_CHECK_COUNT; DECACHE_STACK_INFO(); if (TclAsyncReady(iPtr)) { result = Tcl_AsyncInvoke(interp, result); @@ -2543,7 +2445,7 @@ TEBCresume( /* FIXME: What is the right thing to trace? */ fprintf(stdout, "%d: (%u) yielding to [%.30s]\n", iPtr->numLevels, (unsigned)(pc - codePtr->codeStart), - Tcl_GetString(valuePtr)); + TclGetString(valuePtr)); } fflush(stdout); } @@ -2698,154 +2600,18 @@ TEBCresume( NEXT_INST_F(5, 0, 0); } - case INST_STR_CONCAT1: { - int appendLen = 0; - char *bytes, *p; - Tcl_Obj **currPtr; - int onlyb = 1; + case INST_STR_CONCAT1: opnd = TclGetUInt1AtPtr(pc+1); - - /* - * Detect only-bytearray-or-null case. - */ - - for (currPtr=&OBJ_AT_DEPTH(opnd-1); currPtr<=&OBJ_AT_TOS; currPtr++) { - if (((*currPtr)->typePtr != &tclByteArrayType) - && ((*currPtr)->bytes != tclEmptyStringRep)) { - onlyb = 0; - break; - } else if (((*currPtr)->typePtr == &tclByteArrayType) && - ((*currPtr)->bytes != NULL)) { - onlyb = 0; - break; - } - } - - /* - * Compute the length to be appended. - */ - - if (onlyb) { - for (currPtr = &OBJ_AT_DEPTH(opnd-2); - appendLen >= 0 && currPtr <= &OBJ_AT_TOS; currPtr++) { - if ((*currPtr)->bytes != tclEmptyStringRep) { - Tcl_GetByteArrayFromObj(*currPtr, &length); - appendLen += length; - } - } - } else { - for (currPtr = &OBJ_AT_DEPTH(opnd-2); - appendLen >= 0 && currPtr <= &OBJ_AT_TOS; currPtr++) { - bytes = TclGetStringFromObj(*currPtr, &length); - if (bytes != NULL) { - appendLen += length; - } - } - } - - if (appendLen < 0) { - /* TODO: convert panic to error ? */ - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); - } - - /* - * If nothing is to be appended, just return the first object by - * dropping all the others from the stack; this saves both the - * computation and copy of the string rep of the first object, - * enabling the fast '$x[set x {}]' idiom for 'K $x [set x {}]'. - */ - - if (appendLen == 0) { - TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); - NEXT_INST_V(2, (opnd-1), 0); - } - - /* - * If the first object is shared, we need a new obj for the result; - * otherwise, we can reuse the first object. In any case, make sure it - * has enough room to accomodate all the concatenated bytes. Note that - * if it is unshared its bytes are copied by ckrealloc, so that we set - * the loop parameters to avoid copying them again: p points to the - * end of the already copied bytes, currPtr to the second object. - */ - - objResultPtr = OBJ_AT_DEPTH(opnd-1); - if (!onlyb) { - bytes = TclGetStringFromObj(objResultPtr, &length); - if (length + appendLen < 0) { - /* TODO: convert panic to error ? */ - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", - INT_MAX); - } -#ifndef TCL_COMPILE_DEBUG - if (bytes != tclEmptyStringRep && !Tcl_IsShared(objResultPtr)) { - TclFreeIntRep(objResultPtr); - objResultPtr->bytes = ckrealloc(bytes, length+appendLen+1); - objResultPtr->length = length + appendLen; - p = TclGetString(objResultPtr) + length; - currPtr = &OBJ_AT_DEPTH(opnd - 2); - } else -#endif - { - p = ckalloc(length + appendLen + 1); - TclNewObj(objResultPtr); - objResultPtr->bytes = p; - objResultPtr->length = length + appendLen; - currPtr = &OBJ_AT_DEPTH(opnd - 1); - } - - /* - * Append the remaining characters. - */ - - for (; currPtr <= &OBJ_AT_TOS; currPtr++) { - bytes = TclGetStringFromObj(*currPtr, &length); - if (bytes != NULL) { - memcpy(p, bytes, (size_t) length); - p += length; - } - } - *p = '\0'; - } else { - bytes = (char *) Tcl_GetByteArrayFromObj(objResultPtr, &length); - if (length + appendLen < 0) { - /* TODO: convert panic to error ? */ - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", - INT_MAX); - } -#ifndef TCL_COMPILE_DEBUG - if (!Tcl_IsShared(objResultPtr)) { - bytes = (char *) Tcl_SetByteArrayLength(objResultPtr, - length + appendLen); - p = bytes + length; - currPtr = &OBJ_AT_DEPTH(opnd - 2); - } else -#endif - { - TclNewObj(objResultPtr); - bytes = (char *) Tcl_SetByteArrayLength(objResultPtr, - length + appendLen); - p = bytes; - currPtr = &OBJ_AT_DEPTH(opnd - 1); - } - - /* - * Append the remaining characters. - */ - - for (; currPtr <= &OBJ_AT_TOS; currPtr++) { - if ((*currPtr)->bytes != tclEmptyStringRep) { - bytes = (char *) Tcl_GetByteArrayFromObj(*currPtr,&length); - memcpy(p, bytes, (size_t) length); - p += length; - } - } + objResultPtr = TclStringCat(interp, opnd, &OBJ_AT_DEPTH(opnd-1), + TCL_STRING_IN_PLACE); + if (objResultPtr == NULL) { + TRACE_ERROR(interp); + goto gotError; } TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); NEXT_INST_V(2, opnd, 1); - } case INST_CONCAT_STK: /* @@ -3784,9 +3550,7 @@ TEBCresume( { Tcl_Obj *incrPtr; -#ifndef TCL_WIDE_INT_IS_LONG Tcl_WideInt w; -#endif long increment; case INST_INCR_SCALAR1: @@ -3885,9 +3649,9 @@ TEBCresume( objPtr = varPtr->value.objPtr; if (GetNumberFromObj(NULL, objPtr, &ptr, &type) == TCL_OK) { - if (type == TCL_NUMBER_LONG) { - long augend = *((const long *)ptr); - long sum = augend + increment; + if (type == TCL_NUMBER_INT) { + Tcl_WideInt augend = *((const Tcl_WideInt *)ptr); + Tcl_WideInt sum = augend + increment; /* * Overflow when (augend and sum have different sign) and @@ -3899,16 +3663,15 @@ TEBCresume( TRACE(("%u %ld => ", opnd, increment)); if (Tcl_IsShared(objPtr)) { objPtr->refCount--; /* We know it's shared. */ - TclNewLongObj(objResultPtr, sum); + TclNewIntObj(objResultPtr, sum); Tcl_IncrRefCount(objResultPtr); varPtr->value.objPtr = objResultPtr; } else { objResultPtr = objPtr; - TclSetLongObj(objPtr, sum); + TclSetIntObj(objPtr, sum); } goto doneIncr; } -#ifndef TCL_WIDE_INT_IS_LONG w = (Tcl_WideInt)augend; TRACE(("%u %ld => ", opnd, increment)); @@ -3925,44 +3688,10 @@ TEBCresume( * use macro form that doesn't range test again. */ - TclSetWideIntObj(objPtr, w+increment); + TclSetIntObj(objPtr, w+increment); } goto doneIncr; -#endif - } /* end if (type == TCL_NUMBER_LONG) */ -#ifndef TCL_WIDE_INT_IS_LONG - if (type == TCL_NUMBER_WIDE) { - Tcl_WideInt sum; - - w = *((const Tcl_WideInt *) ptr); - sum = w + increment; - - /* - * Check for overflow. - */ - - if (!Overflowing(w, increment, sum)) { - TRACE(("%u %ld => ", opnd, increment)); - if (Tcl_IsShared(objPtr)) { - objPtr->refCount--; /* We know it's shared. */ - objResultPtr = Tcl_NewWideIntObj(sum); - Tcl_IncrRefCount(objResultPtr); - varPtr->value.objPtr = objResultPtr; - } else { - objResultPtr = objPtr; - - /* - * We *do not* know the sum value is outside the - * long range (wide + long can yield long); use - * the function call that checks range. - */ - - Tcl_SetWideIntObj(objPtr, sum); - } - goto doneIncr; - } - } -#endif + } /* end if (type == TCL_NUMBER_INT) */ } if (Tcl_IsShared(objPtr)) { objPtr->refCount--; /* We know it's shared */ @@ -3972,7 +3701,7 @@ TEBCresume( } else { objResultPtr = objPtr; } - TclNewLongObj(incrPtr, increment); + TclNewIntObj(incrPtr, increment); if (TclIncrObj(interp, objResultPtr, incrPtr) != TCL_OK) { Tcl_DecrRefCount(incrPtr); TRACE_ERROR(interp); @@ -3986,7 +3715,7 @@ TEBCresume( * All other cases, flow through to generic handling. */ - TclNewLongObj(incrPtr, increment); + TclNewIntObj(incrPtr, increment); Tcl_IncrRefCount(incrPtr); doIncrScalar: @@ -4370,10 +4099,7 @@ TEBCresume( TRACE_ERROR(interp); goto gotError; } - TclSetVarArray(varPtr); - varPtr->value.tablePtr = ckalloc(sizeof(TclVarHashTable)); - TclInitVarHashTable(varPtr->value.tablePtr, - TclGetVarNsPtr(varPtr)); + TclInitArrayVar(varPtr); #ifdef TCL_COMPILE_DEBUG TRACE_APPEND(("done\n")); } else { @@ -5063,8 +4789,8 @@ TEBCresume( */ if ((TclListObjGetElements(interp, valuePtr, &objc, &objv) == TCL_OK) - && (value2Ptr->typePtr != &tclListType) - && (TclGetIntForIndexM(NULL , value2Ptr, objc-1, + && !TclHasIntRep(value2Ptr, &tclListType) + && (TclGetIntForIndexM(NULL, value2Ptr, objc-1, &index) == TCL_OK)) { TclDecrRefCount(value2Ptr); tosPtr--; @@ -5236,11 +4962,11 @@ TEBCresume( TclGetInt4AtPtr(pc+5))); /* - * Get the contents of the list, making sure that it really is a list + * Get the length of the list, making sure that it really is a list * in the process. */ - if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { + if (TclListObjLength(interp, valuePtr, &objc) != TCL_OK) { TRACE_ERROR(interp); goto gotError; } @@ -5268,17 +4994,11 @@ TEBCresume( /* Decode index value operands. */ - /* - assert ( toIdx != TCL_INDEX_AFTER); - * - * Extra safety for legacy bytecodes: - */ - if (toIdx == TCL_INDEX_AFTER) { - toIdx = TCL_INDEX_END; - } - - if ((toIdx == TCL_INDEX_BEFORE) || (fromIdx == TCL_INDEX_AFTER)) { - goto emptyList; + if (toIdx == TCL_INDEX_NONE) { + emptyList: + objResultPtr = Tcl_NewObj(); + TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr))); + NEXT_INST_F(9, 1, 1); } toIdx = TclIndexDecode(toIdx, objc - 1); if (toIdx < 0) { @@ -5289,37 +5009,17 @@ TEBCresume( assert ( toIdx >= 0 && toIdx < objc); /* - assert ( fromIdx != TCL_INDEX_BEFORE ); + assert ( fromIdx != TCL_INDEX_NONE ); * * Extra safety for legacy bytecodes: */ - if (fromIdx == TCL_INDEX_BEFORE) { + if (fromIdx == TCL_INDEX_NONE) { fromIdx = TCL_INDEX_START; } fromIdx = TclIndexDecode(fromIdx, objc - 1); - if (fromIdx < 0) { - fromIdx = 0; - } - if (fromIdx <= toIdx) { - /* Construct the subsquence list */ - /* unshared optimization */ - if (Tcl_IsShared(valuePtr)) { - objResultPtr = Tcl_NewListObj(toIdx-fromIdx+1, objv+fromIdx); - } else { - if (toIdx != objc - 1) { - Tcl_ListObjReplace(NULL, valuePtr, toIdx + 1, LIST_MAX, - 0, NULL); - } - Tcl_ListObjReplace(NULL, valuePtr, 0, fromIdx, 0, NULL); - TRACE_APPEND(("%.30s\n", O2S(valuePtr))); - NEXT_INST_F(9, 0, 0); - } - } else { - emptyList: - TclNewObj(objResultPtr); - } + objResultPtr = TclListObjRange(valuePtr, fromIdx, toIdx); TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr))); NEXT_INST_F(9, 1, 1); @@ -5405,6 +5105,10 @@ TEBCresume( case INST_STR_EQ: case INST_STR_NEQ: /* String (in)equality check */ case INST_STR_CMP: /* String compare. */ + case INST_STR_LT: + case INST_STR_GT: + case INST_STR_LE: + case INST_STR_GE: stringCompare: value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; @@ -5435,15 +5139,19 @@ TEBCresume( match = (match != 0); break; case INST_LT: + case INST_STR_LT: match = (match < 0); break; case INST_GT: + case INST_STR_GT: match = (match > 0); break; case INST_LE: + case INST_STR_LE: match = (match <= 0); break; case INST_GE: + case INST_STR_GE: match = (match >= 0); break; } @@ -5536,17 +5244,23 @@ TEBCresume( objResultPtr = Tcl_NewStringObj((const char *) valuePtr->bytes+index, 1); } else { - char buf[TCL_UTF_MAX] = ""; - Tcl_UniChar ch = Tcl_GetUniChar(valuePtr, index); + char buf[4] = ""; + int ch = Tcl_GetUniChar(valuePtr, index); /* * This could be: Tcl_NewUnicodeObj((const Tcl_UniChar *)&ch, 1) * but creating the object as a string seems to be faster in * practical use. */ - - length = Tcl_UniCharToUtf(ch, buf); - objResultPtr = Tcl_NewStringObj(buf, length); + if (ch == -1) { + objResultPtr = Tcl_NewObj(); + } else { + length = Tcl_UniCharToUtf(ch, buf); + if ((ch >= 0xD800) && (length < 3)) { + length += Tcl_UniCharToUtf(-1, buf + length); + } + objResultPtr = Tcl_NewStringObj(buf, length); + } } TRACE_APPEND(("\"%s\"\n", O2S(objResultPtr))); @@ -5594,17 +5308,13 @@ TEBCresume( /* Decode index operands. */ /* - assert ( toIdx != TCL_INDEX_BEFORE ); - assert ( toIdx != TCL_INDEX_AFTER); + assert ( toIdx != TCL_INDEX_NONE ); * * Extra safety for legacy bytecodes: */ - if (toIdx == TCL_INDEX_BEFORE) { + if (toIdx == TCL_INDEX_NONE) { goto emptyRange; } - if (toIdx == TCL_INDEX_AFTER) { - toIdx = TCL_INDEX_END; - } toIdx = TclIndexDecode(toIdx, length - 1); if (toIdx < 0) { @@ -5616,17 +5326,13 @@ TEBCresume( assert ( toIdx >= 0 && toIdx < length ); /* - assert ( fromIdx != TCL_INDEX_BEFORE ); - assert ( fromIdx != TCL_INDEX_AFTER); + assert ( fromIdx != TCL_INDEX_NONE ); * * Extra safety for legacy bytecodes: */ - if (fromIdx == TCL_INDEX_BEFORE) { + if (fromIdx == TCL_INDEX_NONE) { fromIdx = TCL_INDEX_START; } - if (fromIdx == TCL_INDEX_AFTER) { - goto emptyRange; - } fromIdx = TclIndexDecode(fromIdx, length - 1); if (fromIdx < 0) { @@ -5689,82 +5395,9 @@ TEBCresume( NEXT_INST_F(1, 0, 0); } - length3 = Tcl_GetCharLength(value3Ptr); - - /* - * See if we can splice in place. This happens when the number of - * characters being replaced is the same as the number of characters - * in the string to be inserted. - */ - - if (length3 - 1 == toIdx - fromIdx) { - unsigned char *bytes1, *bytes2; - - if (Tcl_IsShared(valuePtr)) { - objResultPtr = Tcl_DuplicateObj(valuePtr); - } else { - objResultPtr = valuePtr; - } - if (TclIsPureByteArray(objResultPtr) - && TclIsPureByteArray(value3Ptr)) { - bytes1 = Tcl_GetByteArrayFromObj(objResultPtr, NULL); - bytes2 = Tcl_GetByteArrayFromObj(value3Ptr, NULL); - memcpy(bytes1 + fromIdx, bytes2, length3); - } else { - ustring1 = Tcl_GetUnicodeFromObj(objResultPtr, NULL); - ustring2 = Tcl_GetUnicodeFromObj(value3Ptr, NULL); - memcpy(ustring1 + fromIdx, ustring2, - length3 * sizeof(Tcl_UniChar)); - } - Tcl_InvalidateStringRep(objResultPtr); - TclDecrRefCount(value3Ptr); - TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); - if (objResultPtr == valuePtr) { - NEXT_INST_F(1, 0, 0); - } else { - NEXT_INST_F(1, 1, 1); - } - } - - /* - * Get the unicode representation; this is where we guarantee to lose - * bytearrays. - */ + objResultPtr = TclStringReplace(interp, valuePtr, fromIdx, + toIdx - fromIdx + 1, value3Ptr, TCL_STRING_IN_PLACE); - ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length); - length--; - - /* - * Remove substring using copying. - */ - - objResultPtr = NULL; - if (fromIdx > 0) { - objResultPtr = Tcl_NewUnicodeObj(ustring1, fromIdx); - } - if (length3 > 0) { - if (objResultPtr) { - Tcl_AppendObjToObj(objResultPtr, value3Ptr); - } else if (Tcl_IsShared(value3Ptr)) { - objResultPtr = Tcl_DuplicateObj(value3Ptr); - } else { - objResultPtr = value3Ptr; - } - } - if (toIdx < length) { - if (objResultPtr) { - Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1, - length - toIdx); - } else { - objResultPtr = Tcl_NewUnicodeObj(ustring1 + toIdx + 1, - length - toIdx); - } - } - if (objResultPtr == NULL) { - /* This has to be the case [string replace $s 0 end {}] */ - /* which has result {} which is same as value3Ptr. */ - objResultPtr = value3Ptr; - } if (objResultPtr == value3Ptr) { /* See [Bug 82e7f67325] */ TclDecrRefCount(OBJ_AT_TOS); @@ -5837,20 +5470,7 @@ TEBCresume( NEXT_INST_V(1, 3, 1); case INST_STR_FIND: - ustring1 = Tcl_GetUnicodeFromObj(OBJ_AT_TOS, &length); /* Haystack */ - ustring2 = Tcl_GetUnicodeFromObj(OBJ_UNDER_TOS, &length2);/* Needle */ - - match = -1; - if (length2 > 0 && length2 <= length) { - end = ustring1 + length - length2 + 1; - for (p=ustring1 ; p<end ; p++) { - if ((*p == *ustring2) && - memcmp(ustring2,p,sizeof(Tcl_UniChar)*length2) == 0) { - match = p - ustring1; - break; - } - } - } + match = TclStringFirst(OBJ_UNDER_TOS, OBJ_AT_TOS, 0); TRACE(("%.20s %.20s => %d\n", O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match)); @@ -5858,23 +5478,10 @@ TEBCresume( NEXT_INST_F(1, 2, 1); case INST_STR_FIND_LAST: - ustring1 = Tcl_GetUnicodeFromObj(OBJ_AT_TOS, &length); /* Haystack */ - ustring2 = Tcl_GetUnicodeFromObj(OBJ_UNDER_TOS, &length2);/* Needle */ - - match = -1; - if (length2 > 0 && length2 <= length) { - for (p=ustring1+length-length2 ; p>=ustring1 ; p--) { - if ((*p == *ustring2) && - memcmp(ustring2,p,sizeof(Tcl_UniChar)*length2) == 0) { - match = p - ustring1; - break; - } - } - } + match = TclStringLast(OBJ_UNDER_TOS, OBJ_AT_TOS, INT_MAX - 1); TRACE(("%.20s %.20s => %d\n", O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match)); - TclNewIntObj(objResultPtr, match); NEXT_INST_F(1, 2, 1); @@ -5908,8 +5515,8 @@ TEBCresume( * both. */ - if ((valuePtr->typePtr == &tclStringType) - || (value2Ptr->typePtr == &tclStringType)) { + if (TclHasIntRep(valuePtr, &tclStringType) + || TclHasIntRep(value2Ptr, &tclStringType)) { Tcl_UniChar *ustring1, *ustring2; ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length); @@ -6043,35 +5650,18 @@ TEBCresume( { ClientData ptr1, ptr2; int type1, type2; - long l1, l2, lResult; + Tcl_WideInt w1, w2, wResult; case INST_NUM_TYPE: if (GetNumberFromObj(NULL, OBJ_AT_TOS, &ptr1, &type1) != TCL_OK) { type1 = 0; - } else if (type1 == TCL_NUMBER_LONG) { - /* value is between LONG_MIN and LONG_MAX */ - /* [string is integer] is -UINT_MAX to UINT_MAX range */ - int i; - - if (TclGetIntFromObj(NULL, OBJ_AT_TOS, &i) != TCL_OK) { - type1 = TCL_NUMBER_WIDE; - } -#ifndef TCL_WIDE_INT_IS_LONG - } else if (type1 == TCL_NUMBER_WIDE) { - /* value is between WIDE_MIN and WIDE_MAX */ - /* [string is wideinteger] is -UWIDE_MAX to UWIDE_MAX range */ - int i; - if (TclGetIntFromObj(NULL, OBJ_AT_TOS, &i) == TCL_OK) { - type1 = TCL_NUMBER_LONG; - } -#endif } else if (type1 == TCL_NUMBER_BIG) { /* value is an integer outside the WIDE_MIN to WIDE_MAX range */ - /* [string is wideinteger] is -UWIDE_MAX to UWIDE_MAX range */ + /* [string is wideinteger] is WIDE_MIN to WIDE_MAX range */ Tcl_WideInt w; if (TclGetWideIntFromObj(NULL, OBJ_AT_TOS, &w) == TCL_OK) { - type1 = TCL_NUMBER_WIDE; + type1 = TCL_NUMBER_INT; } } TclNewIntObj(objResultPtr, type1); @@ -6117,10 +5707,10 @@ TEBCresume( compare = MP_EQ; goto convertComparison; } - if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { - l1 = *((const long *)ptr1); - l2 = *((const long *)ptr2); - compare = (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ); + if ((type1 == TCL_NUMBER_INT) && (type2 == TCL_NUMBER_INT)) { + w1 = *((const Tcl_WideInt *)ptr1); + w2 = *((const Tcl_WideInt *)ptr2); + compare = (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ); } else { compare = TclCompareTwoNumbers(valuePtr, value2Ptr); } @@ -6196,17 +5786,17 @@ TEBCresume( * Check for common, simple case. */ - if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { - l1 = *((const long *)ptr1); - l2 = *((const long *)ptr2); + if ((type1 == TCL_NUMBER_INT) && (type2 == TCL_NUMBER_INT)) { + w1 = *((const Tcl_WideInt *)ptr1); + w2 = *((const Tcl_WideInt *)ptr2); switch (*pc) { case INST_MOD: - if (l2 == 0) { + if (w2 == 0) { TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr), O2S(value2Ptr))); goto divideByZero; - } else if ((l2 == 1) || (l2 == -1)) { + } else if ((w2 == 1) || (w2 == -1)) { /* * Div. by |1| always yields remainder of 0. */ @@ -6215,7 +5805,7 @@ TEBCresume( objResultPtr = TCONST(0); TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); - } else if (l1 == 0) { + } else if (w1 == 0) { /* * 0 % (non-zero) always yields remainder of 0. */ @@ -6225,24 +5815,24 @@ TEBCresume( TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } else { - lResult = l1 / l2; + wResult = w1 / w2; /* * Force Tcl's integer division rules. * TODO: examine for logic simplification */ - if ((lResult < 0 || (lResult == 0 && - ((l1 < 0 && l2 > 0) || (l1 > 0 && l2 < 0)))) && - (lResult * l2 != l1)) { - lResult -= 1; + if ((wResult < 0 || (wResult == 0 && + ((w1 < 0 && w2 > 0) || (w1 > 0 && w2 < 0)))) && + (wResult * w2 != w1)) { + wResult -= 1; } - lResult = l1 - l2*lResult; - goto longResultOfArithmetic; + wResult = w1 - w2*wResult; + goto wideResultOfArithmetic; } case INST_RSHIFT: - if (l2 < 0) { + if (w2 < 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "negative shift argument", -1)); #ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR @@ -6253,7 +5843,7 @@ TEBCresume( CACHE_STACK_INFO(); #endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ goto gotError; - } else if (l1 == 0) { + } else if (w1 == 0) { TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); objResultPtr = TCONST(0); TRACE(("%s\n", O2S(objResultPtr))); @@ -6263,7 +5853,7 @@ TEBCresume( * Quickly force large right shifts to 0 or -1. */ - if (l2 >= (long)(CHAR_BIT*sizeof(long))) { + if (w2 >= (Tcl_WideInt)(CHAR_BIT*sizeof(long))) { /* * We assume that INT_MAX is much larger than the * number of bits in a long. This is a pretty safe @@ -6272,7 +5862,7 @@ TEBCresume( */ TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - if (l1 > 0L) { + if (w1 > 0L) { objResultPtr = TCONST(0); } else { TclNewIntObj(objResultPtr, -1); @@ -6285,12 +5875,12 @@ TEBCresume( * Handle shifts within the native long range. */ - lResult = l1 >> ((int) l2); - goto longResultOfArithmetic; + wResult = w1 >> ((int) w2); + goto wideResultOfArithmetic; } case INST_LSHIFT: - if (l2 < 0) { + if (w2 < 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "negative shift argument", -1)); #ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR @@ -6301,12 +5891,12 @@ TEBCresume( CACHE_STACK_INFO(); #endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ goto gotError; - } else if (l1 == 0) { + } else if (w1 == 0) { TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); objResultPtr = TCONST(0); TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); - } else if (l2 > (long) INT_MAX) { + } else if (w2 > INT_MAX) { /* * Technically, we could hold the value (1 << (INT_MAX+1)) * in an mp_int, but since we're using mp_mul_2d() to do @@ -6324,17 +5914,17 @@ TEBCresume( #endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */ goto gotError; } else { - int shift = (int) l2; + int shift = (int) w2; /* * Handle shifts within the native long range. */ - if ((size_t) shift < CHAR_BIT*sizeof(long) && (l1 != 0) - && !((l1>0 ? l1 : ~l1) & + if ((size_t) shift < CHAR_BIT*sizeof(long) && (w1 != 0) + && !((w1>0 ? w1 : ~w1) & -(1L<<(CHAR_BIT*sizeof(long) - 1 - shift)))) { - lResult = l1 << shift; - goto longResultOfArithmetic; + wResult = w1 << shift; + goto wideResultOfArithmetic; } } @@ -6346,23 +5936,14 @@ TEBCresume( break; case INST_BITAND: - lResult = l1 & l2; - goto longResultOfArithmetic; + wResult = w1 & w2; + goto wideResultOfArithmetic; case INST_BITOR: - lResult = l1 | l2; - goto longResultOfArithmetic; + wResult = w1 | w2; + goto wideResultOfArithmetic; case INST_BITXOR: - lResult = l1 ^ l2; - longResultOfArithmetic: - TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); - if (Tcl_IsShared(valuePtr)) { - TclNewLongObj(objResultPtr, lResult); - TRACE(("%s\n", O2S(objResultPtr))); - NEXT_INST_F(1, 2, 1); - } - TclSetLongObj(valuePtr, lResult); - TRACE(("%s\n", O2S(valuePtr))); - NEXT_INST_F(1, 1, 0); + wResult = w1 ^ w2; + goto wideResultOfArithmetic; } } @@ -6445,18 +6026,13 @@ TEBCresume( * an external function. */ - if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) { - Tcl_WideInt w1, w2, wResult; - - l1 = *((const long *)ptr1); - l2 = *((const long *)ptr2); + if ((type1 == TCL_NUMBER_INT) && (type2 == TCL_NUMBER_INT)) { + w1 = *((const Tcl_WideInt *)ptr1); + w2 = *((const Tcl_WideInt *)ptr2); switch (*pc) { case INST_ADD: - w1 = (Tcl_WideInt) l1; - w2 = (Tcl_WideInt) l2; wResult = w1 + w2; -#ifdef TCL_WIDE_INT_IS_LONG /* * Check for overflow. */ @@ -6464,14 +6040,10 @@ TEBCresume( if (Overflowing(w1, w2, wResult)) { goto overflow; } -#endif goto wideResultOfArithmetic; case INST_SUB: - w1 = (Tcl_WideInt) l1; - w2 = (Tcl_WideInt) l2; wResult = w1 - w2; -#ifdef TCL_WIDE_INT_IS_LONG /* * Must check for overflow. The macro tests for overflows in * sums by looking at the sign bits. As we have a subtraction @@ -6485,7 +6057,6 @@ TEBCresume( if (Overflowing(w1, ~w2, wResult)) { goto overflow; } -#endif wideResultOfArithmetic: TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr))); if (Tcl_IsShared(valuePtr)) { @@ -6493,45 +6064,45 @@ TEBCresume( TRACE(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 2, 1); } - Tcl_SetWideIntObj(valuePtr, wResult); + TclSetIntObj(valuePtr, wResult); TRACE(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 1, 0); case INST_DIV: - if (l2 == 0) { + if (w2 == 0) { TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr), O2S(value2Ptr))); goto divideByZero; - } else if ((l1 == LONG_MIN) && (l2 == -1)) { + } else if ((w1 == WIDE_MIN) && (w2 == -1)) { /* - * Can't represent (-LONG_MIN) as a long. + * Can't represent (-WIDE_MIN) as a Tcl_WideInt. */ goto overflow; } - lResult = l1 / l2; + wResult = w1 / w2; /* * Force Tcl's integer division rules. * TODO: examine for logic simplification */ - if (((lResult < 0) || ((lResult == 0) && - ((l1 < 0 && l2 > 0) || (l1 > 0 && l2 < 0)))) && - ((lResult * l2) != l1)) { - lResult -= 1; + if (((wResult < 0) || ((wResult == 0) && + ((w1 < 0 && w2 > 0) || (w1 > 0 && w2 < 0)))) && + ((wResult * w2) != w1)) { + wResult -= 1; } - goto longResultOfArithmetic; + goto wideResultOfArithmetic; case INST_MULT: - if (((sizeof(long) >= 2*sizeof(int)) - && (l1 <= INT_MAX) && (l1 >= INT_MIN) - && (l2 <= INT_MAX) && (l2 >= INT_MIN)) - || ((sizeof(long) >= 2*sizeof(short)) - && (l1 <= SHRT_MAX) && (l1 >= SHRT_MIN) - && (l2 <= SHRT_MAX) && (l2 >= SHRT_MIN))) { - lResult = l1 * l2; - goto longResultOfArithmetic; + if (((sizeof(Tcl_WideInt) >= 2*sizeof(int)) + && (w1 <= INT_MAX) && (w1 >= INT_MIN) + && (w2 <= INT_MAX) && (w2 >= INT_MIN)) + || ((sizeof(Tcl_WideInt) >= 2*sizeof(short)) + && (w1 <= SHRT_MAX) && (w1 >= SHRT_MIN) + && (w2 <= SHRT_MAX) && (w2 >= SHRT_MIN))) { + wResult = w1 * w2; + goto wideResultOfArithmetic; } } @@ -6598,14 +6169,14 @@ TEBCresume( CACHE_STACK_INFO(); goto gotError; } - if (type1 == TCL_NUMBER_LONG) { - l1 = *((const long *) ptr1); + if (type1 == TCL_NUMBER_INT) { + w1 = *((const Tcl_WideInt *) ptr1); if (Tcl_IsShared(valuePtr)) { - TclNewLongObj(objResultPtr, ~l1); + TclNewIntObj(objResultPtr, ~w1); TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } - TclSetLongObj(valuePtr, ~l1); + TclSetIntObj(valuePtr, ~w1); TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } @@ -6635,15 +6206,15 @@ TEBCresume( /* -NaN => NaN */ TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); - case TCL_NUMBER_LONG: - l1 = *((const long *) ptr1); - if (l1 != LONG_MIN) { + case TCL_NUMBER_INT: + w1 = *((const Tcl_WideInt *) ptr1); + if (w1 != WIDE_MIN) { if (Tcl_IsShared(valuePtr)) { - TclNewLongObj(objResultPtr, -l1); + TclNewIntObj(objResultPtr, -w1); TRACE_APPEND(("%s\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } - TclSetLongObj(valuePtr, -l1); + TclSetIntObj(valuePtr, -w1); TRACE_APPEND(("%s\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); } @@ -6751,7 +6322,7 @@ TEBCresume( case INST_TRY_CVT_TO_BOOLEAN: valuePtr = OBJ_AT_TOS; - if (valuePtr->typePtr == &tclBooleanType) { + if (TclHasIntRep(valuePtr, &tclBooleanType)) { objResultPtr = TCONST(1); } else { int result = (TclSetBooleanFromAny(NULL, valuePtr) == TCL_OK); @@ -6787,7 +6358,8 @@ TEBCresume( Var *iterVarPtr, *listVarPtr; Tcl_Obj *oldValuePtr, *listPtr, **elements; ForeachVarList *varListPtr; - int numLists, iterNum, listTmpIndex, listLen, numVars; + int numLists, listTmpIndex, listLen, numVars; + size_t iterNum; int varIndex, valIndex, continueLoop, j, iterTmpIndex; long i; @@ -6804,10 +6376,10 @@ TEBCresume( oldValuePtr = iterVarPtr->value.objPtr; if (oldValuePtr == NULL) { - TclNewLongObj(iterVarPtr->value.objPtr, -1); + TclNewIntObj(iterVarPtr->value.objPtr, -1); Tcl_IncrRefCount(iterVarPtr->value.objPtr); } else { - TclSetLongObj(oldValuePtr, -1); + TclSetIntObj(oldValuePtr, -1); } TRACE(("%u => loop iter count temp %d\n", opnd, iterTmpIndex)); @@ -6841,8 +6413,8 @@ TEBCresume( iterVarPtr = LOCAL(infoPtr->loopCtTemp); valuePtr = iterVarPtr->value.objPtr; - iterNum = valuePtr->internalRep.longValue + 1; - TclSetLongObj(valuePtr, iterNum); + iterNum = (size_t)valuePtr->internalRep.wideValue + 1; + TclSetIntObj(valuePtr, iterNum); /* * Check whether all value lists are exhausted and we should stop the @@ -6862,7 +6434,7 @@ TEBCresume( i, O2S(listPtr), O2S(Tcl_GetObjResult(interp)))); goto gotError; } - if (listLen > iterNum * numVars) { + if ((size_t)listLen > iterNum * numVars) { continueLoop = 1; } listTmpIndex++; @@ -6928,7 +6500,7 @@ TEBCresume( listTmpIndex++; } } - TRACE_APPEND(("%d lists, iter %d, %s loop\n", + TRACE_APPEND(("%d lists, iter %" TCL_Z_MODIFIER "u, %s loop\n", numLists, iterNum, (continueLoop? "continue" : "exit"))); /* @@ -6949,8 +6521,9 @@ TEBCresume( ForeachInfo *infoPtr; Tcl_Obj *listPtr, **elements, *tmpPtr; ForeachVarList *varListPtr; - int numLists, iterMax, listLen, numVars; - int iterTmp, iterNum, listTmpDepth; + int numLists, listLen, numVars; + int listTmpDepth; + size_t iterNum, iterMax, iterTmp; int varIndex, valIndex, j; long i; @@ -7001,8 +6574,8 @@ TEBCresume( */ TclNewObj(tmpPtr); - tmpPtr->internalRep.twoPtrValue.ptr1 = INT2PTR(0); - tmpPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(iterMax); + tmpPtr->internalRep.twoPtrValue.ptr1 = NULL; + tmpPtr->internalRep.twoPtrValue.ptr2 = (void *)iterMax; PUSH_OBJECT(tmpPtr); /* iterCounts object */ /* @@ -7034,8 +6607,8 @@ TEBCresume( TRACE(("=> ")); tmpPtr = OBJ_AT_DEPTH(1); - iterNum = PTR2INT(tmpPtr->internalRep.twoPtrValue.ptr1); - iterMax = PTR2INT(tmpPtr->internalRep.twoPtrValue.ptr2); + iterNum = (size_t)tmpPtr->internalRep.twoPtrValue.ptr1; + iterMax = (size_t)tmpPtr->internalRep.twoPtrValue.ptr2; /* * If some list still has a remaining list element iterate one more @@ -7047,7 +6620,7 @@ TEBCresume( * Set the variables and jump back to run the body */ - tmpPtr->internalRep.twoPtrValue.ptr1 = INT2PTR(iterNum + 1); + tmpPtr->internalRep.twoPtrValue.ptr1 =(void *)(iterNum + 1); listTmpDepth = numLists + 1; @@ -7225,55 +6798,23 @@ TEBCresume( TRACE_APPEND(("OK\n")); NEXT_INST_F(1, 1, 0); - case INST_DICT_GET: case INST_DICT_EXISTS: { - register Tcl_Interp *interp2 = interp; register int found; opnd = TclGetUInt4AtPtr(pc+1); TRACE(("%u => ", opnd)); dictPtr = OBJ_AT_DEPTH(opnd); - if (*pc == INST_DICT_EXISTS) { - interp2 = NULL; - } if (opnd > 1) { - dictPtr = TclTraceDictPath(interp2, dictPtr, opnd-1, - &OBJ_AT_DEPTH(opnd-1), DICT_PATH_READ); - if (dictPtr == NULL) { - if (*pc == INST_DICT_EXISTS) { - found = 0; - goto afterDictExists; - } - TRACE_WITH_OBJ(( - "ERROR tracing dictionary path into \"%.30s\": ", - O2S(OBJ_AT_DEPTH(opnd))), - Tcl_GetObjResult(interp)); - goto gotError; + dictPtr = TclTraceDictPath(NULL, dictPtr, opnd-1, + &OBJ_AT_DEPTH(opnd-1), DICT_PATH_EXISTS); + if (dictPtr == NULL || dictPtr == DICT_PATH_NON_EXISTENT) { + found = 0; + goto afterDictExists; } } - if (Tcl_DictObjGet(interp2, dictPtr, OBJ_AT_TOS, + if (Tcl_DictObjGet(NULL, dictPtr, OBJ_AT_TOS, &objResultPtr) == TCL_OK) { - if (*pc == INST_DICT_EXISTS) { - found = (objResultPtr ? 1 : 0); - goto afterDictExists; - } - if (!objResultPtr) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "key \"%s\" not known in dictionary", - TclGetString(OBJ_AT_TOS))); - DECACHE_STACK_INFO(); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", - TclGetString(OBJ_AT_TOS), NULL); - CACHE_STACK_INFO(); - TRACE_ERROR(interp); - goto gotError; - } - TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); - NEXT_INST_V(5, opnd+1, 1); - } else if (*pc != INST_DICT_EXISTS) { - TRACE_APPEND(("ERROR reading leaf dictionary key \"%.30s\": %s", - O2S(dictPtr), O2S(Tcl_GetObjResult(interp)))); - goto gotError; + found = (objResultPtr ? 1 : 0); } else { found = 0; } @@ -7289,6 +6830,68 @@ TEBCresume( JUMP_PEEPHOLE_V(found, 5, opnd+1); } + case INST_DICT_GET: + opnd = TclGetUInt4AtPtr(pc+1); + TRACE(("%u => ", opnd)); + dictPtr = OBJ_AT_DEPTH(opnd); + if (opnd > 1) { + dictPtr = TclTraceDictPath(interp, dictPtr, opnd-1, + &OBJ_AT_DEPTH(opnd-1), DICT_PATH_READ); + if (dictPtr == NULL) { + TRACE_WITH_OBJ(( + "ERROR tracing dictionary path into \"%.30s\": ", + O2S(OBJ_AT_DEPTH(opnd))), + Tcl_GetObjResult(interp)); + goto gotError; + } + } + if (Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, + &objResultPtr) != TCL_OK) { + TRACE_APPEND(("ERROR reading leaf dictionary key \"%.30s\": %s", + O2S(dictPtr), O2S(Tcl_GetObjResult(interp)))); + goto gotError; + } + if (!objResultPtr) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "key \"%s\" not known in dictionary", + TclGetString(OBJ_AT_TOS))); + DECACHE_STACK_INFO(); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT", + TclGetString(OBJ_AT_TOS), NULL); + CACHE_STACK_INFO(); + TRACE_ERROR(interp); + goto gotError; + } + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(5, opnd+1, 1); + case INST_DICT_GET_DEF: + opnd = TclGetUInt4AtPtr(pc+1); + TRACE(("%u => ", opnd)); + dictPtr = OBJ_AT_DEPTH(opnd+1); + if (opnd > 1) { + dictPtr = TclTraceDictPath(interp, dictPtr, opnd-1, + &OBJ_AT_DEPTH(opnd), DICT_PATH_EXISTS); + if (dictPtr == NULL) { + TRACE_WITH_OBJ(( + "ERROR tracing dictionary path into \"%.30s\": ", + O2S(OBJ_AT_DEPTH(opnd+1))), + Tcl_GetObjResult(interp)); + goto gotError; + } else if (dictPtr == DICT_PATH_NON_EXISTENT) { + goto dictGetDefUseDefault; + } + } + if (Tcl_DictObjGet(interp, dictPtr, OBJ_UNDER_TOS, + &objResultPtr) != TCL_OK) { + TRACE_APPEND(("ERROR reading leaf dictionary key \"%.30s\": %s", + O2S(dictPtr), O2S(Tcl_GetObjResult(interp)))); + goto gotError; + } else if (!objResultPtr) { + dictGetDefUseDefault: + objResultPtr = OBJ_AT_TOS; + } + TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); + NEXT_INST_V(5, opnd+2, 1); case INST_DICT_SET: case INST_DICT_UNSET: @@ -7555,13 +7158,16 @@ TEBCresume( TRACE_ERROR(interp); goto gotError; } - TclNewObj(statePtr); - statePtr->typePtr = &dictIteratorType; - statePtr->internalRep.twoPtrValue.ptr1 = searchPtr; - statePtr->internalRep.twoPtrValue.ptr2 = dictPtr; + { + Tcl_ObjIntRep ir; + TclNewObj(statePtr); + ir.twoPtrValue.ptr1 = searchPtr; + ir.twoPtrValue.ptr2 = dictPtr; + Tcl_StoreIntRep(statePtr, &dictIteratorType, &ir); + } varPtr = LOCAL(opnd); if (varPtr->value.objPtr) { - if (varPtr->value.objPtr->typePtr == &dictIteratorType) { + if (TclHasIntRep(varPtr->value.objPtr, &dictIteratorType)) { Tcl_Panic("mis-issued dictFirst!"); } TclDecrRefCount(varPtr->value.objPtr); @@ -7574,11 +7180,17 @@ TEBCresume( opnd = TclGetUInt4AtPtr(pc+1); TRACE(("%u => ", opnd)); statePtr = (*LOCAL(opnd)).value.objPtr; - if (statePtr == NULL || statePtr->typePtr != &dictIteratorType) { - Tcl_Panic("mis-issued dictNext!"); + { + const Tcl_ObjIntRep *irPtr; + + if (statePtr && + (irPtr = TclFetchIntRep(statePtr, &dictIteratorType))) { + searchPtr = irPtr->twoPtrValue.ptr1; + Tcl_DictObjNext(searchPtr, &keyPtr, &valuePtr, &done); + } else { + Tcl_Panic("mis-issued dictNext!"); + } } - searchPtr = statePtr->internalRep.twoPtrValue.ptr1; - Tcl_DictObjNext(searchPtr, &keyPtr, &valuePtr, &done); pushDictIteratorResult: if (done) { TclNewObj(emptyPtr); @@ -7841,7 +7453,6 @@ TEBCresume( 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); @@ -8135,9 +7746,7 @@ TEBCresume( } iPtr->cmdFramePtr = bcFramePtr->nextPtr; - if (codePtr->refCount-- <= 1) { - TclCleanupByteCode(codePtr); - } + TclReleaseByteCode(codePtr); TclStackFree(interp, TD); /* free my stack */ return result; @@ -8243,47 +7852,10 @@ FinalizeOONextFilter( } /* - * LongPwrSmallExpon -- , WidePwrSmallExpon -- + * WidePwrSmallExpon -- * - * Helpers to calculate small powers of integers whose result is long or wide. + * Helper to calculate small powers of integers whose result is wide. */ -#if (LONG_MAX == 0x7fffffff) -static inline long -LongPwrSmallExpon(long l1, long exponent) { - - long lResult; - - lResult = l1 * l1; /* b**2 */ - switch (exponent) { - case 2: - break; - case 3: - lResult *= l1; /* b**3 */ - break; - case 4: - lResult *= lResult; /* b**4 */ - break; - case 5: - lResult *= lResult; /* b**4 */ - lResult *= l1; /* b**5 */ - break; - case 6: - lResult *= l1; /* b**3 */ - lResult *= lResult; /* b**6 */ - break; - case 7: - lResult *= l1; /* b**3 */ - lResult *= lResult; /* b**6 */ - lResult *= l1; /* b**7 */ - break; - case 8: - lResult *= lResult; /* b**4 */ - lResult *= lResult; /* b**8 */ - break; - } - return lResult; -} -#endif static inline Tcl_WideInt WidePwrSmallExpon(Tcl_WideInt w1, long exponent) { @@ -8397,19 +7969,11 @@ ExecuteExtendedBinaryMathOp( Tcl_Obj *valuePtr, /* The first operand on the stack. */ Tcl_Obj *value2Ptr) /* The second operand on the stack. */ { -#define LONG_RESULT(l) \ - if (Tcl_IsShared(valuePtr)) { \ - TclNewLongObj(objResultPtr, l); \ - return objResultPtr; \ - } else { \ - Tcl_SetLongObj(valuePtr, l); \ - return NULL; \ - } #define WIDE_RESULT(w) \ if (Tcl_IsShared(valuePtr)) { \ return Tcl_NewWideIntObj(w); \ } else { \ - Tcl_SetWideIntObj(valuePtr, w); \ + TclSetIntObj(valuePtr, w); \ return NULL; \ } #define BIG_RESULT(b) \ @@ -8431,7 +7995,6 @@ ExecuteExtendedBinaryMathOp( int type1, type2; ClientData ptr1, ptr2; double d1, d2, dResult; - long l1, l2, lResult; Tcl_WideInt w1, w2, wResult; mp_int big1, big2, bigResult, bigRemainder; Tcl_Obj *objResultPtr; @@ -8445,13 +8008,13 @@ ExecuteExtendedBinaryMathOp( case INST_MOD: /* TODO: Attempts to re-use unshared operands on stack */ - l2 = 0; /* silence gcc warning */ - if (type2 == TCL_NUMBER_LONG) { - l2 = *((const long *)ptr2); - if (l2 == 0) { + w2 = 0; /* silence gcc warning */ + if (type2 == TCL_NUMBER_INT) { + w2 = *((const Tcl_WideInt *)ptr2); + if (w2 == 0) { return DIVIDED_BY_ZERO; } - if ((l2 == 1) || (l2 == -1)) { + if ((w2 == 1) || (w2 == -1)) { /* * Div. by |1| always yields remainder of 0. */ @@ -8459,12 +8022,19 @@ ExecuteExtendedBinaryMathOp( return constants[0]; } } -#ifndef TCL_WIDE_INT_IS_LONG - if (type1 == TCL_NUMBER_WIDE) { + if (type1 == TCL_NUMBER_INT) { w1 = *((const Tcl_WideInt *)ptr1); - if (type2 != TCL_NUMBER_BIG) { + + if (w1 == 0) { + /* + * 0 % (non-zero) always yields remainder of 0. + */ + + return constants[0]; + } + if (type2 == TCL_NUMBER_INT) { Tcl_WideInt wQuotient, wRemainder; - TclGetWideIntFromObj(NULL, value2Ptr, &w2); + w2 = *((const Tcl_WideInt *)ptr2); wQuotient = w1 / w2; /* @@ -8474,8 +8044,8 @@ ExecuteExtendedBinaryMathOp( if (((wQuotient < (Tcl_WideInt) 0) || ((wQuotient == (Tcl_WideInt) 0) - && ((w1 < (Tcl_WideInt)0 && w2 > (Tcl_WideInt)0) - || (w1 > (Tcl_WideInt)0 && w2 < (Tcl_WideInt)0)))) + && ((w1 < 0 && w2 > 0) + || (w1 > 0 && w2 < 0)))) && (wQuotient * w2 != w1)) { wQuotient -= (Tcl_WideInt) 1; } @@ -8491,7 +8061,7 @@ ExecuteExtendedBinaryMathOp( * Arguments are opposite sign; remainder is sum. */ - TclBNInitBignumFromWideInt(&big1, w1); + TclInitBignumFromWideInt(&big1, w1); mp_add(&big2, &big1, &big2); mp_clear(&big1); BIG_RESULT(&big2); @@ -8504,13 +8074,12 @@ ExecuteExtendedBinaryMathOp( mp_clear(&big2); return NULL; } -#endif Tcl_GetBignumFromObj(NULL, valuePtr, &big1); Tcl_GetBignumFromObj(NULL, value2Ptr, &big2); mp_init(&bigResult); mp_init(&bigRemainder); mp_div(&big1, &big2, &bigResult, &bigRemainder); - if ((bigRemainder.used) != 0 && (bigRemainder.sign != big2.sign)) { + if ((bigRemainder.used != 0) && (bigRemainder.sign != big2.sign)) { /* * Convert to Tcl's integer division rules. */ @@ -8531,17 +8100,12 @@ ExecuteExtendedBinaryMathOp( */ switch (type2) { - case TCL_NUMBER_LONG: - invalid = (*((const long *)ptr2) < 0L); - break; -#ifndef TCL_WIDE_INT_IS_LONG - case TCL_NUMBER_WIDE: - invalid = (*((const Tcl_WideInt *)ptr2) < (Tcl_WideInt)0); + case TCL_NUMBER_INT: + invalid = (*((const Tcl_WideInt *)ptr2) < 0); break; -#endif case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - invalid = (mp_cmp_d(&big2, 0) == MP_LT); + invalid = big2.sign != MP_ZPOS; mp_clear(&big2); break; default: @@ -8558,7 +8122,7 @@ ExecuteExtendedBinaryMathOp( * Zero shifted any number of bits is still zero. */ - if ((type1==TCL_NUMBER_LONG) && (*((const long *)ptr1) == (long)0)) { + if ((type1==TCL_NUMBER_INT) && (*((const Tcl_WideInt *)ptr1) == 0)) { return constants[0]; } @@ -8571,8 +8135,8 @@ ExecuteExtendedBinaryMathOp( * counterparts, leading to incorrect results. */ - if ((type2 != TCL_NUMBER_LONG) - || (*((const long *)ptr2) > (long) INT_MAX)) { + if ((type2 != TCL_NUMBER_INT) + || (*((const Tcl_WideInt *)ptr2) > INT_MAX)) { /* * Technically, we could hold the value (1 << (INT_MAX+1)) in * an mp_int, but since we're using mp_mul_2d() to do the @@ -8584,15 +8148,15 @@ ExecuteExtendedBinaryMathOp( "integer value too large to represent", -1)); return GENERAL_ARITHMETIC_ERROR; } - shift = (int)(*((const long *)ptr2)); + shift = (int)(*((const Tcl_WideInt *)ptr2)); /* * Handle shifts within the native wide range. */ - if ((type1 != TCL_NUMBER_BIG) + if ((type1 == TCL_NUMBER_INT) && ((size_t)shift < CHAR_BIT*sizeof(Tcl_WideInt))) { - TclGetWideIntFromObj(NULL, valuePtr, &w1); + w1 = *((const Tcl_WideInt *)ptr1); if (!((w1>0 ? w1 : ~w1) & -(((Tcl_WideInt)1) << (CHAR_BIT*sizeof(Tcl_WideInt) - 1 - shift)))) { @@ -8604,8 +8168,8 @@ ExecuteExtendedBinaryMathOp( * Quickly force large right shifts to 0 or -1. */ - if ((type2 != TCL_NUMBER_LONG) - || (*(const long *)ptr2 > INT_MAX)) { + if ((type2 != TCL_NUMBER_INT) + || (*(const Tcl_WideInt *)ptr2 > INT_MAX)) { /* * Again, technically, the value to be shifted could be an * mp_int so huge that a right shift by (INT_MAX+1) bits could @@ -8615,17 +8179,12 @@ ExecuteExtendedBinaryMathOp( */ switch (type1) { - case TCL_NUMBER_LONG: - zero = (*(const long *)ptr1 > 0L); - break; -#ifndef TCL_WIDE_INT_IS_LONG - case TCL_NUMBER_WIDE: - zero = (*(const Tcl_WideInt *)ptr1 > (Tcl_WideInt)0); + case TCL_NUMBER_INT: + zero = (*(const Tcl_WideInt *)ptr1 > 0); break; -#endif case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); - zero = (mp_cmp_d(&big1, 0) == MP_GT); + zero = (big1.sign == MP_ZPOS); mp_clear(&big1); break; default: @@ -8635,26 +8194,24 @@ ExecuteExtendedBinaryMathOp( if (zero) { return constants[0]; } - LONG_RESULT(-1); + WIDE_RESULT(-1); } - shift = (int)(*(const long *)ptr2); + shift = (int)(*(const Tcl_WideInt *)ptr2); -#ifndef TCL_WIDE_INT_IS_LONG /* * Handle shifts within the native wide range. */ - if (type1 == TCL_NUMBER_WIDE) { + if (type1 == TCL_NUMBER_INT) { w1 = *(const Tcl_WideInt *)ptr1; if ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideInt)) { - if (w1 >= (Tcl_WideInt)0) { + if (w1 >= 0) { return constants[0]; } - LONG_RESULT(-1); + WIDE_RESULT(-1); } WIDE_RESULT(w1 >> shift); } -#endif } Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); @@ -8672,7 +8229,7 @@ ExecuteExtendedBinaryMathOp( case INST_BITOR: case INST_BITXOR: case INST_BITAND: - if ((type1 == TCL_NUMBER_BIG) || (type2 == TCL_NUMBER_BIG)) { + if ((type1 != TCL_NUMBER_INT) || (type2 != TCL_NUMBER_INT)) { Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); @@ -8697,46 +8254,24 @@ ExecuteExtendedBinaryMathOp( BIG_RESULT(&bigResult); } -#ifndef TCL_WIDE_INT_IS_LONG - if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) { - TclGetWideIntFromObj(NULL, valuePtr, &w1); - TclGetWideIntFromObj(NULL, value2Ptr, &w2); - - switch (opcode) { - case INST_BITAND: - wResult = w1 & w2; - break; - case INST_BITOR: - wResult = w1 | w2; - break; - case INST_BITXOR: - wResult = w1 ^ w2; - break; - default: - /* Unused, here to silence compiler warning. */ - wResult = 0; - } - WIDE_RESULT(wResult); - } -#endif - l1 = *((const long *)ptr1); - l2 = *((const long *)ptr2); + w1 = *((const Tcl_WideInt *)ptr1); + w2 = *((const Tcl_WideInt *)ptr2); switch (opcode) { case INST_BITAND: - lResult = l1 & l2; + wResult = w1 & w2; break; case INST_BITOR: - lResult = l1 | l2; + wResult = w1 | w2; break; case INST_BITXOR: - lResult = l1 ^ l2; + wResult = w1 ^ w2; break; default: /* Unused, here to silence compiler warning. */ - lResult = 0; + wResult = 0; } - LONG_RESULT(lResult); + WIDE_RESULT(wResult); case INST_EXPON: { int oddExponent = 0, negativeExponent = 0; @@ -8752,97 +8287,57 @@ ExecuteExtendedBinaryMathOp( dResult = pow(d1, d2); goto doubleResult; } - l1 = l2 = 0; w1 = w2 = 0; /* to silence compiler warning (maybe-uninitialized) */ - switch (type2) { - case TCL_NUMBER_LONG: - l2 = *((const long *) ptr2); -#ifndef TCL_WIDE_INT_IS_LONG - pwrLongExpon: -#endif - if (l2 == 0) { + if (type2 == TCL_NUMBER_INT) { + w2 = *((const Tcl_WideInt *) ptr2); + if (w2 == 0) { /* * Anything to the zero power is 1. */ return constants[1]; - } else if (l2 == 1) { + } else if (w2 == 1) { /* * Anything to the first power is itself */ return NULL; } - negativeExponent = (l2 < 0); - oddExponent = (int) (l2 & 1); - break; -#ifndef TCL_WIDE_INT_IS_LONG - case TCL_NUMBER_WIDE: - w2 = *((const Tcl_WideInt *)ptr2); - /* check it fits in long */ - l2 = (long)w2; - if (w2 == l2) { - type2 = TCL_NUMBER_LONG; - goto pwrLongExpon; - } + negativeExponent = (w2 < 0); oddExponent = (int) (w2 & (Tcl_WideInt)1); - break; -#endif - case TCL_NUMBER_BIG: + } else { Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - negativeExponent = (mp_cmp_d(&big2, 0) == MP_LT); + negativeExponent = big2.sign != MP_ZPOS; mp_mod_2d(&big2, 1, &big2); oddExponent = big2.used != 0; mp_clear(&big2); - break; } - switch (type1) { - case TCL_NUMBER_LONG: - l1 = *((const long *)ptr1); -#ifndef TCL_WIDE_INT_IS_LONG - pwrLongBase: -#endif - switch (l1) { - case 0: - /* - * Zero to a positive power is zero. - * Zero to a negative power is div by zero error. - */ + if (type1 == TCL_NUMBER_INT) { + w1 = *((const Tcl_WideInt *)ptr1); - return (!negativeExponent) ? constants[0] : EXPONENT_OF_ZERO; - case 1: - /* - * 1 to any power is 1. - */ + if (negativeExponent) { + switch (w1) { + case 0: + /* + * Zero to a negative power is div by zero error. + */ - return constants[1]; - case -1: - if (!negativeExponent) { - if (!oddExponent) { - return constants[1]; + return EXPONENT_OF_ZERO; + case -1: + if (oddExponent) { + WIDE_RESULT(-1); } - LONG_RESULT(-1); - } - /* negativeExponent */ - if (oddExponent) { - LONG_RESULT(-1); + /* fallthrough */ + case 1: + /* + * 1 to any power is 1. + */ + + return constants[1]; } - return constants[1]; - } - break; -#ifndef TCL_WIDE_INT_IS_LONG - case TCL_NUMBER_WIDE: - w1 = *((const Tcl_WideInt *) ptr1); - /* check it fits in long */ - l1 = (long)w1; - if (w1 == l1) { - type1 = TCL_NUMBER_LONG; - goto pwrLongBase; } - break; -#endif } if (negativeExponent) { @@ -8850,123 +8345,80 @@ ExecuteExtendedBinaryMathOp( * Integers with magnitude greater than 1 raise to a negative * power yield the answer zero (see TIP 123). */ - return constants[0]; } - - if (type1 == TCL_NUMBER_BIG) { + if (type1 != TCL_NUMBER_INT) { goto overflowExpon; } + switch (w1) { + case 0: + /* + * Zero to a positive power is zero. + */ + + return constants[0]; + case 1: + /* + * 1 to any power is 1. + */ + + return constants[1]; + case -1: + if (!oddExponent) { + return constants[1]; + } + WIDE_RESULT(-1); + } + /* * We refuse to accept exponent arguments that exceed one mp_digit * which means the max exponent value is 2**28-1 = 0x0fffffff = * 268435455, which fits into a signed 32 bit int which is within the * range of the long int type. This means any numeric Tcl_Obj value - * not using TCL_NUMBER_LONG type must hold a value larger than we + * not using TCL_NUMBER_INT type must hold a value larger than we * accept. */ - if (type2 != TCL_NUMBER_LONG) { + if (type2 != TCL_NUMBER_INT) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "exponent too large", -1)); return GENERAL_ARITHMETIC_ERROR; } - /* From here (up to overflowExpon) exponent is long (l2). */ - - if (type1 == TCL_NUMBER_LONG) { - if (l1 == 2) { - /* - * Reduce small powers of 2 to shifts. - */ - - if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) { - LONG_RESULT(1L << l2); - } -#if !defined(TCL_WIDE_INT_IS_LONG) - if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1) { - WIDE_RESULT(((Tcl_WideInt) 1) << l2); - } -#endif - goto overflowExpon; - } - if (l1 == -2) { - int signum = oddExponent ? -1 : 1; + /* From here (up to overflowExpon) w1 and exponent w2 are wide-int's. */ + assert(type1 == TCL_NUMBER_INT && type2 == TCL_NUMBER_INT); - /* - * Reduce small powers of 2 to shifts. - */ - - if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) { - LONG_RESULT(signum * (1L << l2)); - } -#if !defined(TCL_WIDE_INT_IS_LONG) - if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1){ - WIDE_RESULT(signum * (((Tcl_WideInt) 1) << l2)); - } -#endif - goto overflowExpon; - } -#if (LONG_MAX == 0x7fffffff) - if (l2 - 2 < (long)MaxBase32Size - && l1 <= MaxBase32[l2 - 2] - && l1 >= -MaxBase32[l2 - 2]) { - /* - * Small powers of 32-bit integers. - */ - lResult = LongPwrSmallExpon(l1, l2); + if (w1 == 2) { + /* + * Reduce small powers of 2 to shifts. + */ - LONG_RESULT(lResult); + if ((Tcl_WideUInt) w2 < (Tcl_WideUInt) CHAR_BIT*sizeof(Tcl_WideInt) - 1) { + WIDE_RESULT(((Tcl_WideInt) 1) << (int)w2); } + goto overflowExpon; + } + if (w1 == -2) { + int signum = oddExponent ? -1 : 1; - if (l1 - 3 >= 0 && l1 -2 < (long)Exp32IndexSize - && l2 - 2 < (long)(Exp32ValueSize + MaxBase32Size)) { - base = Exp32Index[l1 - 3] - + (unsigned short) (l2 - 2 - MaxBase32Size); - if (base < Exp32Index[l1 - 2]) { - /* - * 32-bit number raised to intermediate power, done by - * table lookup. - */ - - LONG_RESULT(Exp32Value[base]); - } - } - if (-l1 - 3 >= 0 && -l1 - 2 < (long)Exp32IndexSize - && l2 - 2 < (long)(Exp32ValueSize + MaxBase32Size)) { - base = Exp32Index[-l1 - 3] - + (unsigned short) (l2 - 2 - MaxBase32Size); - if (base < Exp32Index[-l1 - 2]) { - /* - * 32-bit number raised to intermediate power, done by - * table lookup. - */ + /* + * Reduce small powers of 2 to shifts. + */ - lResult = (oddExponent) ? - -Exp32Value[base] : Exp32Value[base]; - LONG_RESULT(lResult); - } + if ((Tcl_WideUInt) w2 < CHAR_BIT * sizeof(Tcl_WideInt) - 1) { + WIDE_RESULT(signum * (((Tcl_WideInt) 1) << (int) w2)); } -#endif -#if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG) - /* Code below (up to overflowExpon) works with wide-int base */ - w1 = l1; -#endif + goto overflowExpon; } - -#if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG) - - /* From here (up to overflowExpon) base is wide-int (w1). */ - - if (l2 - 2 < (long)MaxBase64Size - && w1 <= MaxBase64[l2 - 2] - && w1 >= -MaxBase64[l2 - 2]) { + if (w2 - 2 < (long)MaxBase64Size + && w1 <= MaxBase64[w2 - 2] + && w1 >= -MaxBase64[w2 - 2]) { /* * Small powers of integers whose result is wide. */ - wResult = WidePwrSmallExpon(w1, l2); + wResult = WidePwrSmallExpon(w1, (long)w2); WIDE_RESULT(wResult); } @@ -8977,9 +8429,9 @@ ExecuteExtendedBinaryMathOp( */ if (w1 - 3 >= 0 && w1 - 2 < (long)Exp64IndexSize - && l2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) { + && w2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) { base = Exp64Index[w1 - 3] - + (unsigned short) (l2 - 2 - MaxBase64Size); + + (unsigned short) (w2 - 2 - MaxBase64Size); if (base < Exp64Index[w1 - 2]) { /* * 64-bit number raised to intermediate power, done by @@ -8991,9 +8443,9 @@ ExecuteExtendedBinaryMathOp( } if (-w1 - 3 >= 0 && -w1 - 2 < (long)Exp64IndexSize - && l2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) { + && w2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) { base = Exp64Index[-w1 - 3] - + (unsigned short) (l2 - 2 - MaxBase64Size); + + (unsigned short) (w2 - 2 - MaxBase64Size); if (base < Exp64Index[-w1 - 2]) { /* * 64-bit number raised to intermediate power, done by @@ -9004,7 +8456,6 @@ ExecuteExtendedBinaryMathOp( WIDE_RESULT(wResult); } } -#endif overflowExpon: @@ -9077,16 +8528,14 @@ ExecuteExtendedBinaryMathOp( #endif DOUBLE_RESULT(dResult); } - if ((type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) { - TclGetWideIntFromObj(NULL, valuePtr, &w1); - TclGetWideIntFromObj(NULL, value2Ptr, &w2); + if ((type1 == TCL_NUMBER_INT) && (type2 == TCL_NUMBER_INT)) { + w1 = *((const Tcl_WideInt *)ptr1); + w2 = *((const Tcl_WideInt *)ptr2); switch (opcode) { case INST_ADD: wResult = w1 + w2; -#ifndef TCL_WIDE_INT_IS_LONG - if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) -#endif + if ((type1 == TCL_NUMBER_INT) || (type2 == TCL_NUMBER_INT)) { /* * Check for overflow. @@ -9100,9 +8549,7 @@ ExecuteExtendedBinaryMathOp( case INST_SUB: wResult = w1 - w2; -#ifndef TCL_WIDE_INT_IS_LONG - if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) -#endif + if ((type1 == TCL_NUMBER_INT) || (type2 == TCL_NUMBER_INT)) { /* * Must check for overflow. The macro tests for overflows @@ -9122,8 +8569,7 @@ ExecuteExtendedBinaryMathOp( break; case INST_MULT: - if ((type1 != TCL_NUMBER_LONG) || (type2 != TCL_NUMBER_LONG) - || (sizeof(Tcl_WideInt) < 2*sizeof(long))) { + if ((w1 < INT_MIN) || (w1 > INT_MAX) || (w2 < INT_MIN) || (w2 > INT_MAX)) { goto overflowBasic; } wResult = w1 * w2; @@ -9135,10 +8581,10 @@ ExecuteExtendedBinaryMathOp( } /* - * Need a bignum to represent (LLONG_MIN / -1) + * Need a bignum to represent (WIDE_MIN / -1) */ - if ((w1 == LLONG_MIN) && (w2 == -1)) { + if ((w1 == WIDE_MIN) && (w2 == -1)) { goto overflowBasic; } wResult = w1 / w2; @@ -9190,7 +8636,7 @@ ExecuteExtendedBinaryMathOp( mp_init(&bigRemainder); mp_div(&big1, &big2, &bigResult, &bigRemainder); /* TODO: internals intrusion */ - if (bigRemainder.used != 0 + if ((bigRemainder.used != 0) && (bigRemainder.sign != big2.sign)) { /* * Convert to Tcl's integer division rules. @@ -9226,12 +8672,10 @@ ExecuteExtendedUnaryMathOp( switch (opcode) { case INST_BITNOT: -#ifndef TCL_WIDE_INT_IS_LONG - if (type == TCL_NUMBER_WIDE) { + if (type == TCL_NUMBER_INT) { w = *((const Tcl_WideInt *) ptr); WIDE_RESULT(~w); } -#endif Tcl_TakeBignumFromObj(NULL, valuePtr, &big); /* ~a = - a - 1 */ mp_neg(&big, &big); @@ -9241,22 +8685,13 @@ ExecuteExtendedUnaryMathOp( switch (type) { case TCL_NUMBER_DOUBLE: DOUBLE_RESULT(-(*((const double *) ptr))); - case TCL_NUMBER_LONG: - w = (Tcl_WideInt) (*((const long *) ptr)); - if (w != LLONG_MIN) { - WIDE_RESULT(-w); - } - TclBNInitBignumFromLong(&big, *(const long *) ptr); - break; -#ifndef TCL_WIDE_INT_IS_LONG - case TCL_NUMBER_WIDE: + case TCL_NUMBER_INT: w = *((const Tcl_WideInt *) ptr); - if (w != LLONG_MIN) { + if (w != WIDE_MIN) { WIDE_RESULT(-w); } - TclBNInitBignumFromWideInt(&big, w); + TclInitBignumFromWideInt(&big, w); break; -#endif default: Tcl_TakeBignumFromObj(NULL, valuePtr, &big); } @@ -9267,7 +8702,6 @@ ExecuteExtendedUnaryMathOp( Tcl_Panic("unexpected opcode"); return NULL; } -#undef LONG_RESULT #undef WIDE_RESULT #undef BIG_RESULT #undef DOUBLE_RESULT @@ -9299,31 +8733,22 @@ TclCompareTwoNumbers( ClientData ptr1, ptr2; mp_int big1, big2; double d1, d2, tmp; - long l1, l2; -#ifndef TCL_WIDE_INT_IS_LONG Tcl_WideInt w1, w2; -#endif (void) GetNumberFromObj(NULL, valuePtr, &ptr1, &type1); (void) GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2); switch (type1) { - case TCL_NUMBER_LONG: - l1 = *((const long *)ptr1); + case TCL_NUMBER_INT: + w1 = *((const Tcl_WideInt *)ptr1); switch (type2) { - case TCL_NUMBER_LONG: - l2 = *((const long *)ptr2); - longCompare: - return (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ); -#ifndef TCL_WIDE_INT_IS_LONG - case TCL_NUMBER_WIDE: + case TCL_NUMBER_INT: w2 = *((const Tcl_WideInt *)ptr2); - w1 = (Tcl_WideInt)l1; - goto wideCompare; -#endif + wideCompare: + return (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ); case TCL_NUMBER_DOUBLE: d2 = *((const double *)ptr2); - d1 = (double) l1; + d1 = (double) w1; /* * If the double has a fractional part, or if the long can be @@ -9331,7 +8756,7 @@ TclCompareTwoNumbers( * doubles. */ - if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) || l1 == (long) d1 + if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt) || w1 == (Tcl_WideInt) d1 || modf(d2, &tmp) != 0.0) { goto doubleCompare; } @@ -9348,55 +8773,17 @@ TclCompareTwoNumbers( * integer comparison can tell the difference. */ - if (d2 < (double)LONG_MIN) { + if (d2 < (double)WIDE_MIN) { return MP_GT; } - if (d2 > (double)LONG_MAX) { - return MP_LT; - } - l2 = (long) d2; - goto longCompare; - case TCL_NUMBER_BIG: - Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - if (mp_cmp_d(&big2, 0) == MP_LT) { - compare = MP_GT; - } else { - compare = MP_LT; - } - mp_clear(&big2); - return compare; - } - -#ifndef TCL_WIDE_INT_IS_LONG - case TCL_NUMBER_WIDE: - w1 = *((const Tcl_WideInt *)ptr1); - switch (type2) { - case TCL_NUMBER_WIDE: - w2 = *((const Tcl_WideInt *)ptr2); - wideCompare: - return (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ); - case TCL_NUMBER_LONG: - l2 = *((const long *)ptr2); - w2 = (Tcl_WideInt)l2; - goto wideCompare; - case TCL_NUMBER_DOUBLE: - d2 = *((const double *)ptr2); - d1 = (double) w1; - if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt) - || w1 == (Tcl_WideInt) d1 || modf(d2, &tmp) != 0.0) { - goto doubleCompare; - } - if (d2 < (double)LLONG_MIN) { - return MP_GT; - } - if (d2 > (double)LLONG_MAX) { + if (d2 > (double)WIDE_MAX) { return MP_LT; } w2 = (Tcl_WideInt) d2; goto wideCompare; case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - if (mp_cmp_d(&big2, 0) == MP_LT) { + if (big2.sign != MP_ZPOS) { compare = MP_GT; } else { compare = MP_LT; @@ -9404,7 +8791,6 @@ TclCompareTwoNumbers( mp_clear(&big2); return compare; } -#endif case TCL_NUMBER_DOUBLE: d1 = *((const double *)ptr1); @@ -9413,45 +8799,28 @@ TclCompareTwoNumbers( d2 = *((const double *)ptr2); doubleCompare: return (d1 < d2) ? MP_LT : ((d1 > d2) ? MP_GT : MP_EQ); - case TCL_NUMBER_LONG: - l2 = *((const long *)ptr2); - d2 = (double) l2; - if (DBL_MANT_DIG > CHAR_BIT*sizeof(long) || l2 == (long) d2 - || modf(d1, &tmp) != 0.0) { - goto doubleCompare; - } - if (d1 < (double)LONG_MIN) { - return MP_LT; - } - if (d1 > (double)LONG_MAX) { - return MP_GT; - } - l1 = (long) d1; - goto longCompare; -#ifndef TCL_WIDE_INT_IS_LONG - case TCL_NUMBER_WIDE: + case TCL_NUMBER_INT: w2 = *((const Tcl_WideInt *)ptr2); d2 = (double) w2; if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt) || w2 == (Tcl_WideInt) d2 || modf(d1, &tmp) != 0.0) { goto doubleCompare; } - if (d1 < (double)LLONG_MIN) { + if (d1 < (double)WIDE_MIN) { return MP_LT; } - if (d1 > (double)LLONG_MAX) { + if (d1 > (double)WIDE_MAX) { return MP_GT; } w1 = (Tcl_WideInt) d1; goto wideCompare; -#endif case TCL_NUMBER_BIG: if (TclIsInfinite(d1)) { return (d1 > 0.0) ? MP_GT : MP_LT; } Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2); - if ((d1 < (double)LONG_MAX) && (d1 > (double)LONG_MIN)) { - if (mp_cmp_d(&big2, 0) == MP_LT) { + if ((d1 < (double)WIDE_MAX) && (d1 > (double)WIDE_MIN)) { + if (big2.sign != MP_ZPOS) { compare = MP_GT; } else { compare = MP_LT; @@ -9472,10 +8841,7 @@ TclCompareTwoNumbers( case TCL_NUMBER_BIG: Tcl_TakeBignumFromObj(NULL, valuePtr, &big1); switch (type2) { -#ifndef TCL_WIDE_INT_IS_LONG - case TCL_NUMBER_WIDE: -#endif - case TCL_NUMBER_LONG: + case TCL_NUMBER_INT: compare = mp_cmp_d(&big1, 0); mp_clear(&big1); return compare; @@ -9486,7 +8852,7 @@ TclCompareTwoNumbers( mp_clear(&big1); return compare; } - if ((d2 < (double)LONG_MAX) && (d2 > (double)LONG_MIN)) { + if ((d2 < (double)WIDE_MAX) && (d2 > (double)WIDE_MIN)) { compare = mp_cmp_d(&big1, 0); mp_clear(&big1); return compare; @@ -9540,8 +8906,8 @@ PrintByteCodeInfo( Proc *procPtr = codePtr->procPtr; Interp *iPtr = (Interp *) *codePtr->interpHandle; - fprintf(stdout, "\nExecuting ByteCode 0x%p, refCt %u, epoch %u, interp 0x%p (epoch %u)\n", - codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr, + fprintf(stdout, "\nExecuting ByteCode 0x%p, refCt %" TCL_Z_MODIFIER "u, epoch %u, interp 0x%p (epoch %u)\n", + codePtr, (size_t)codePtr->refCount, codePtr->compileEpoch, iPtr, iPtr->compileEpoch); fprintf(stdout, " Source: "); @@ -9610,19 +8976,19 @@ ValidatePcAndStackTop( { int stackUpperBound = codePtr->maxStackDepth; /* Greatest legal value for stackTop. */ - unsigned relativePc = (unsigned) (pc - codePtr->codeStart); - unsigned long codeStart = (unsigned long) codePtr->codeStart; - unsigned long codeEnd = (unsigned long) + size_t relativePc = (size_t) (pc - codePtr->codeStart); + size_t codeStart = (size_t) codePtr->codeStart; + size_t codeEnd = (size_t) (codePtr->codeStart + codePtr->numCodeBytes); unsigned char opCode = *pc; - if (((unsigned long) pc < codeStart) || ((unsigned long) pc > codeEnd)) { + if (((size_t) pc < codeStart) || ((size_t) pc > codeEnd)) { fprintf(stderr, "\nBad instruction pc 0x%p in TclNRExecuteByteCode\n", pc); Tcl_Panic("TclNRExecuteByteCode execution failure: bad pc"); } if ((unsigned) opCode > LAST_INST_OPCODE) { - fprintf(stderr, "\nBad opcode %d at pc %u in TclNRExecuteByteCode\n", + fprintf(stderr, "\nBad opcode %d at pc %" TCL_Z_MODIFIER "u in TclNRExecuteByteCode\n", (unsigned) opCode, relativePc); Tcl_Panic("TclNRExecuteByteCode execution failure: bad opcode"); } @@ -9631,7 +8997,7 @@ ValidatePcAndStackTop( int numChars; const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL, NULL); - fprintf(stderr, "\nBad stack top %d at pc %u in TclNRExecuteByteCode (min 0, max %i)", + fprintf(stderr, "\nBad stack top %d at pc %" TCL_Z_MODIFIER "u in TclNRExecuteByteCode (min 0, max %i)", stackTop, relativePc, stackUpperBound); if (cmd != NULL) { Tcl_Obj *message; @@ -9639,7 +9005,7 @@ ValidatePcAndStackTop( TclNewLiteralStringObj(message, "\n executing "); Tcl_IncrRefCount(message); Tcl_AppendLimitedToObj(message, cmd, numChars, 100, NULL); - fprintf(stderr,"%s\n", Tcl_GetString(message)); + fprintf(stderr,"%s\n", TclGetString(message)); Tcl_DecrRefCount(message); } else { fprintf(stderr, "\n"); @@ -9689,7 +9055,7 @@ IllegalExprOperandType( if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) { int numBytes; - const char *bytes = Tcl_GetStringFromObj(opndPtr, &numBytes); + const char *bytes = TclGetStringFromObj(opndPtr, &numBytes); if (numBytes == 0) { description = "empty string"; @@ -10102,7 +9468,7 @@ TclExprFloatError( "unknown floating-point error, errno = %d", errno); Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", - Tcl_GetString(objPtr), NULL); + TclGetString(objPtr), NULL); Tcl_SetObjResult(interp, objPtr); } } @@ -10173,10 +9539,10 @@ EvalStatsCmd( double objBytesIfUnshared, strBytesIfUnshared, sharingBytesSaved; double strBytesSharedMultX, strBytesSharedOnce; double numInstructions, currentHeaderBytes; - long numCurrentByteCodes, numByteCodeLits; - long refCountSum, literalMgmtBytes, sum; - int numSharedMultX, numSharedOnce; - int decadeHigh, minSizeDecade, maxSizeDecade, length, i; + size_t numCurrentByteCodes, numByteCodeLits; + size_t refCountSum, literalMgmtBytes, sum; + size_t numSharedMultX, numSharedOnce, minSizeDecade, maxSizeDecade, i; + int decadeHigh, length; char *litTableStats; LiteralEntry *entryPtr; Tcl_Obj *objPtr; @@ -10218,12 +9584,12 @@ EvalStatsCmd( Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n"); Tcl_AppendPrintfToObj(objPtr, - "Compilation and execution statistics for interpreter %#lx\n", - (long int)iPtr); + "Compilation and execution statistics for interpreter %#" TCL_Z_MODIFIER "x\n", + (size_t)iPtr); - Tcl_AppendPrintfToObj(objPtr, "\nNumber ByteCodes executed\t%ld\n", + Tcl_AppendPrintfToObj(objPtr, "\nNumber ByteCodes executed\t%" TCL_Z_MODIFIER "u\n", statsPtr->numExecutions); - Tcl_AppendPrintfToObj(objPtr, "Number ByteCodes compiled\t%ld\n", + Tcl_AppendPrintfToObj(objPtr, "Number ByteCodes compiled\t%" TCL_Z_MODIFIER "u\n", statsPtr->numCompilations); Tcl_AppendPrintfToObj(objPtr, " Mean executions/compile\t%.1f\n", statsPtr->numExecutions / (float)statsPtr->numCompilations); @@ -10235,7 +9601,7 @@ EvalStatsCmd( Tcl_AppendPrintfToObj(objPtr, " Mean inst/execution\t\t%.0f\n", numInstructions / statsPtr->numExecutions); - Tcl_AppendPrintfToObj(objPtr, "\nTotal ByteCodes\t\t\t%ld\n", + Tcl_AppendPrintfToObj(objPtr, "\nTotal ByteCodes\t\t\t%" TCL_Z_MODIFIER "u\n", statsPtr->numCompilations); Tcl_AppendPrintfToObj(objPtr, " Source bytes\t\t\t%.6g\n", statsPtr->totalSrcBytes); @@ -10245,18 +9611,18 @@ EvalStatsCmd( statsPtr->totalByteCodeBytes); Tcl_AppendPrintfToObj(objPtr, " Literal bytes\t\t%.6g\n", totalLiteralBytes); - Tcl_AppendPrintfToObj(objPtr, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n", - (unsigned long) sizeof(LiteralTable), - (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)), - (unsigned long) (statsPtr->numLiteralsCreated * sizeof(LiteralEntry)), - (unsigned long) (statsPtr->numLiteralsCreated * sizeof(Tcl_Obj)), + Tcl_AppendPrintfToObj(objPtr, " table %" TCL_Z_MODIFIER "u + bkts %" TCL_Z_MODIFIER "u + entries %" TCL_Z_MODIFIER "u + objects %" TCL_Z_MODIFIER "u + strings %.6g\n", + sizeof(LiteralTable), + iPtr->literalTable.numBuckets * sizeof(LiteralEntry *), + statsPtr->numLiteralsCreated * sizeof(LiteralEntry), + statsPtr->numLiteralsCreated * sizeof(Tcl_Obj), statsPtr->totalLitStringBytes); Tcl_AppendPrintfToObj(objPtr, " Mean code/compile\t\t%.1f\n", totalCodeBytes / statsPtr->numCompilations); Tcl_AppendPrintfToObj(objPtr, " Mean code/source\t\t%.1f\n", totalCodeBytes / statsPtr->totalSrcBytes); - Tcl_AppendPrintfToObj(objPtr, "\nCurrent (active) ByteCodes\t%ld\n", + Tcl_AppendPrintfToObj(objPtr, "\nCurrent (active) ByteCodes\t%" TCL_Z_MODIFIER "u\n", numCurrentByteCodes); Tcl_AppendPrintfToObj(objPtr, " Source bytes\t\t\t%.6g\n", statsPtr->currentSrcBytes); @@ -10287,17 +9653,17 @@ EvalStatsCmd( numSharedMultX = 0; Tcl_AppendPrintfToObj(objPtr, "\nTcl_IsShared object check (all objects):\n"); - Tcl_AppendPrintfToObj(objPtr, " Object had refcount <=1 (not shared)\t%ld\n", + Tcl_AppendPrintfToObj(objPtr, " Object had refcount <=1 (not shared)\t%" TCL_Z_MODIFIER "u\n", tclObjsShared[1]); for (i = 2; i < TCL_MAX_SHARED_OBJ_STATS; i++) { - Tcl_AppendPrintfToObj(objPtr, " refcount ==%d\t\t%ld\n", + Tcl_AppendPrintfToObj(objPtr, " refcount ==%" TCL_Z_MODIFIER "u\t\t%" TCL_Z_MODIFIER "u\n", i, tclObjsShared[i]); numSharedMultX += tclObjsShared[i]; } - Tcl_AppendPrintfToObj(objPtr, " refcount >=%d\t\t%ld\n", + Tcl_AppendPrintfToObj(objPtr, " refcount >=%" TCL_Z_MODIFIER "u\t\t%" TCL_Z_MODIFIER "u\n", i, tclObjsShared[0]); numSharedMultX += tclObjsShared[0]; - Tcl_AppendPrintfToObj(objPtr, " Total shared objects\t\t\t%d\n", + Tcl_AppendPrintfToObj(objPtr, " Total shared objects\t\t\t%" TCL_Z_MODIFIER "u\n", numSharedMultX); /* @@ -10315,10 +9681,10 @@ EvalStatsCmd( for (i = 0; i < globalTablePtr->numBuckets; i++) { for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL; entryPtr = entryPtr->nextPtr) { - if (entryPtr->objPtr->typePtr == &tclByteCodeType) { + if (TclHasIntRep(entryPtr->objPtr, &tclByteCodeType)) { numByteCodeLits++; } - (void) Tcl_GetStringFromObj(entryPtr->objPtr, &length); + (void) TclGetStringFromObj(entryPtr->objPtr, &length); refCountSum += entryPtr->refCount; objBytesIfUnshared += (entryPtr->refCount * sizeof(Tcl_Obj)); strBytesIfUnshared += (entryPtr->refCount * (length+1)); @@ -10334,20 +9700,20 @@ EvalStatsCmd( sharingBytesSaved = (objBytesIfUnshared + strBytesIfUnshared) - currentLiteralBytes; - Tcl_AppendPrintfToObj(objPtr, "\nTotal objects (all interps)\t%ld\n", + Tcl_AppendPrintfToObj(objPtr, "\nTotal objects (all interps)\t%" TCL_Z_MODIFIER "u\n", tclObjsAlloced); - Tcl_AppendPrintfToObj(objPtr, "Current objects\t\t\t%ld\n", + Tcl_AppendPrintfToObj(objPtr, "Current objects\t\t\t%" TCL_Z_MODIFIER "u\n", (tclObjsAlloced - tclObjsFreed)); - Tcl_AppendPrintfToObj(objPtr, "Total literal objects\t\t%ld\n", + Tcl_AppendPrintfToObj(objPtr, "Total literal objects\t\t%" TCL_Z_MODIFIER "u\n", statsPtr->numLiteralsCreated); Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal objects\t\t%d (%0.1f%% of current objects)\n", globalTablePtr->numEntries, Percent(globalTablePtr->numEntries, tclObjsAlloced-tclObjsFreed)); - Tcl_AppendPrintfToObj(objPtr, " ByteCode literals\t\t%ld (%0.1f%% of current literals)\n", + Tcl_AppendPrintfToObj(objPtr, " ByteCode literals\t\t%" TCL_Z_MODIFIER "u (%0.1f%% of current literals)\n", numByteCodeLits, Percent(numByteCodeLits, globalTablePtr->numEntries)); - Tcl_AppendPrintfToObj(objPtr, " Literals reused > 1x\t\t%d\n", + Tcl_AppendPrintfToObj(objPtr, " Literals reused > 1x\t\t%" TCL_Z_MODIFIER "u\n", numSharedMultX); Tcl_AppendPrintfToObj(objPtr, " Mean reference count\t\t%.2f\n", ((double) refCountSum) / globalTablePtr->numEntries); @@ -10372,7 +9738,7 @@ EvalStatsCmd( Tcl_AppendPrintfToObj(objPtr, " String sharing savings \t%.6g = unshared %.6g - shared %.6g\n", (strBytesIfUnshared - statsPtr->currentLitStringBytes), strBytesIfUnshared, statsPtr->currentLitStringBytes); - Tcl_AppendPrintfToObj(objPtr, " Literal mgmt overhead\t\t%ld (%0.1f%% of bytes with sharing)\n", + Tcl_AppendPrintfToObj(objPtr, " Literal mgmt overhead\t\t%" TCL_Z_MODIFIER "u (%0.1f%% of bytes with sharing)\n", literalMgmtBytes, Percent(literalMgmtBytes, currentLiteralBytes)); Tcl_AppendPrintfToObj(objPtr, " table %lu + buckets %lu + entries %lu\n", @@ -10422,7 +9788,8 @@ EvalStatsCmd( Tcl_AppendPrintfToObj(objPtr, "\nLiteral string sizes:\n"); Tcl_AppendPrintfToObj(objPtr, "\t Up to length\t\tPercentage\n"); maxSizeDecade = 0; - for (i = 31; i >= 0; i--) { + i = 32; + while (i-- > 0) { if (statsPtr->literalCount[i] > 0) { maxSizeDecade = i; break; @@ -10520,7 +9887,7 @@ EvalStatsCmd( Tcl_AppendPrintfToObj(objPtr, "\nInstruction counts:\n"); for (i = 0; i <= LAST_INST_OPCODE; i++) { - Tcl_AppendPrintfToObj(objPtr, "%20s %8ld ", + Tcl_AppendPrintfToObj(objPtr, "%20s %8" TCL_Z_MODIFIER "u ", tclInstructionTable[i].name, statsPtr->instructionCount[i]); if (statsPtr->instructionCount[i]) { Tcl_AppendPrintfToObj(objPtr, "%6.1f%%\n", @@ -10540,7 +9907,7 @@ EvalStatsCmd( Tcl_SetObjResult(interp, objPtr); } else { Tcl_Channel outChan; - char *str = Tcl_GetStringFromObj(objv[1], &length); + char *str = TclGetStringFromObj(objv[1], &length); if (length) { if (strcmp(str, "stdout") == 0) { diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index 99372c5..8ef0456 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -1085,12 +1085,9 @@ TclFileAttrsCmd( } if (Tcl_GetIndexFromObj(interp, objv[0], attributeStrings, - "option", 0, &index) != TCL_OK) { + "option", INDEX_TEMP_TABLE, &index) != TCL_OK) { goto end; } - if (attributeStringsAllocated != NULL) { - TclFreeIntRep(objv[0]); - } if (Tcl_FSFileAttrsGet(interp, index, filePtr, &objPtr) != TCL_OK) { goto end; @@ -1113,12 +1110,9 @@ TclFileAttrsCmd( for (i = 0; i < objc ; i += 2) { if (Tcl_GetIndexFromObj(interp, objv[i], attributeStrings, - "option", 0, &index) != TCL_OK) { + "option", INDEX_TEMP_TABLE, &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]))); @@ -1351,7 +1345,7 @@ TclFileReadLinkCmd( /* *--------------------------------------------------------------------------- * - * TclFileTemporaryCmd + * TclFileTemporaryCmd -- * * This function implements the "tempfile" subcommand of the "file" * command. @@ -1511,6 +1505,151 @@ TclFileTemporaryCmd( } /* + *--------------------------------------------------------------------------- + * + * TclFileTempDirCmd -- + * + * This function implements the "tempdir" subcommand of the "file" + * command. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * Creates a temporary directory. + * + *--------------------------------------------------------------------------- + */ + +int +TclFileTempDirCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *dirNameObj; /* Object that will contain the directory + * name. */ + Tcl_Obj *baseDirObj = NULL, *nameBaseObj = NULL; + /* Pieces of template. Each piece is NULL if + * it is omitted. The platform temporary file + * engine might ignore some pieces. */ + + if (objc < 1 || objc > 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?template?"); + return TCL_ERROR; + } + + if (objc > 1) { + int length; + Tcl_Obj *templateObj = objv[1]; + const char *string = TclGetStringFromObj(templateObj, &length); + const int onWindows = (tclPlatform == TCL_PLATFORM_WINDOWS); + + /* + * Treat an empty string as if it wasn't there. + */ + + if (length == 0) { + goto makeTemporary; + } + + /* + * The template only gives a directory if there is a directory + * separator in it, and only gives a base name if there's at least one + * character after the last directory separator. + */ + + if (strchr(string, '/') == NULL + && (!onWindows || strchr(string, '\\') == NULL)) { + /* + * No directory separator, so just assume we have a file name. + * This is a bit wrong on Windows where we could have problems + * with disk name prefixes... but those are much less common in + * naked form so we just pass through and let the OS figure it out + * instead. + */ + + nameBaseObj = templateObj; + Tcl_IncrRefCount(nameBaseObj); + } else if (string[length-1] != '/' + && (!onWindows || string[length-1] != '\\')) { + /* + * If the template has a non-terminal directory separator, split + * into dirname and tail. + */ + + baseDirObj = TclPathPart(interp, templateObj, TCL_PATH_DIRNAME); + nameBaseObj = TclPathPart(interp, templateObj, TCL_PATH_TAIL); + } else { + /* + * Otherwise, there must be a terminal directory separator, so + * just the directory is given. + */ + + baseDirObj = templateObj; + Tcl_IncrRefCount(baseDirObj); + } + + /* + * Only allow creation of temporary directories in the native + * filesystem since they are frequently used for integration with + * external tools or system libraries. + */ + + if (baseDirObj != NULL && Tcl_FSGetFileSystemForPath(baseDirObj) + != &tclNativeFilesystem) { + TclDecrRefCount(baseDirObj); + baseDirObj = NULL; + } + } + + /* + * Convert empty parts of the template into unspecified parts. + */ + + if (baseDirObj && !TclGetString(baseDirObj)[0]) { + TclDecrRefCount(baseDirObj); + baseDirObj = NULL; + } + if (nameBaseObj && !TclGetString(nameBaseObj)[0]) { + TclDecrRefCount(nameBaseObj); + nameBaseObj = NULL; + } + + /* + * Create and open the temporary file. + */ + + makeTemporary: + dirNameObj = TclpCreateTemporaryDirectory(baseDirObj, nameBaseObj); + + /* + * If we created pieces of template, get rid of them now. + */ + + if (baseDirObj) { + TclDecrRefCount(baseDirObj); + } + if (nameBaseObj) { + TclDecrRefCount(nameBaseObj); + } + + /* + * Deal with results. + */ + + if (dirNameObj == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "can't create temporary directory: %s", + Tcl_PosixError(interp))); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, dirNameObj); + return TCL_OK; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclFileName.c b/generic/tclFileName.c index 7afcdaf..98ee37c 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 = Tcl_GetStringFromObj(pathPtr, &pathLen); + const char *path = TclGetStringFromObj(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); - Tcl_GetStringFromObj(eltPtr, &len); + TclGetStringFromObj(eltPtr, &len); size += len + 1; } @@ -597,8 +597,8 @@ Tcl_SplitPath( p = (char *) &(*argvPtr)[(*argcPtr) + 1]; for (i = 0; i < *argcPtr; i++) { Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr); - str = Tcl_GetStringFromObj(eltPtr, &len); - memcpy(p, str, (size_t) len+1); + str = TclGetStringFromObj(eltPtr, &len); + memcpy(p, str, len+1); p += len+1; } @@ -857,7 +857,7 @@ TclpNativeJoinPath( const char *p; const char *start; - start = Tcl_GetStringFromObj(prefix, &length); + start = TclGetStringFromObj(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); - Tcl_GetStringFromObj(prefix, &length); + TclGetStringFromObj(prefix, &length); } needsSep = 0; @@ -921,7 +921,7 @@ TclpNativeJoinPath( if ((length > 0) && (start[length-1] != '/') && (start[length-1] != ':')) { Tcl_AppendToObj(prefix, "/", 1); - Tcl_GetStringFromObj(prefix, &length); + TclGetStringFromObj(prefix, &length); } needsSep = 0; @@ -1003,7 +1003,7 @@ Tcl_JoinPath( * Store the result. */ - resultStr = Tcl_GetStringFromObj(resultObj, &len); + resultStr = TclGetStringFromObj(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 = Tcl_GetStringFromObj(objv[i], &length); + string = TclGetStringFromObj(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 = Tcl_GetStringFromObj(pathOrDir,&pathlength); + const char *first = TclGetStringFromObj(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 = Tcl_GetStringFromObj(look, &len); + str = TclGetStringFromObj(look, &len); if (strcmp("readonly", str) == 0) { globTypes->perm |= TCL_GLOB_PERM_RONLY; } else if (strcmp("hidden", str) == 0) { @@ -1881,7 +1881,7 @@ TclGlob( separators = "/\\"; } else if (tclPlatform == TCL_PLATFORM_UNIX) { - if (pathPrefix == NULL && tail[0] == '/') { + if (pathPrefix == NULL && tail[0] == '/' && tail[1] != '/') { pathPrefix = Tcl_NewStringObj(tail, 1); tail++; Tcl_IncrRefCount(pathPrefix); @@ -1992,7 +1992,7 @@ TclGlob( Tcl_Panic("Called TclGlob with TCL_GLOBMODE_TAILS and pathPrefix==NULL"); } - pre = Tcl_GetStringFromObj(pathPrefix, &prefixLen); + pre = TclGetStringFromObj(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 = Tcl_GetStringFromObj(objv[i], &len); + const char *oldStr = TclGetStringFromObj(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 = Tcl_GetStringFromObj(fixme, &numBytes); + bytes = TclGetStringFromObj(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) Tcl_GetStringFromObj(pathPtr, &length); + (void) TclGetStringFromObj(pathPtr, &length); } else { length = 0; } @@ -2446,7 +2446,7 @@ DoGlob( */ int len; - const char *joined = Tcl_GetStringFromObj(joinedPtr,&len); + const char *joined = TclGetStringFromObj(joinedPtr,&len); if (strchr(separators, joined[len-1]) == NULL) { Tcl_AppendToObj(joinedPtr, "/", 1); @@ -2483,7 +2483,7 @@ DoGlob( */ int len; - const char *joined = Tcl_GetStringFromObj(joinedPtr,&len); + const char *joined = TclGetStringFromObj(joinedPtr,&len); if (strchr(separators, joined[len-1]) == NULL) { if (Tcl_FSGetPathType(pathPtr) != TCL_PATH_VOLUME_RELATIVE) { @@ -2548,21 +2548,21 @@ unsigned Tcl_GetFSDeviceFromStat( const Tcl_StatBuf *statPtr) { - return (unsigned) statPtr->st_dev; + return statPtr->st_dev; } unsigned Tcl_GetFSInodeFromStat( const Tcl_StatBuf *statPtr) { - return (unsigned) statPtr->st_ino; + return statPtr->st_ino; } unsigned Tcl_GetModeFromStat( const Tcl_StatBuf *statPtr) { - return (unsigned) statPtr->st_mode; + return statPtr->st_mode; } int @@ -2639,7 +2639,7 @@ Tcl_GetBlockSizeFromStat( const Tcl_StatBuf *statPtr) { #ifdef HAVE_STRUCT_STAT_ST_BLKSIZE - return (unsigned) statPtr->st_blksize; + return statPtr->st_blksize; #else /* * Not a great guess, but will do... diff --git a/generic/tclGet.c b/generic/tclGet.c index 97e8c7b..12e0e79 100644 --- a/generic/tclGet.c +++ b/generic/tclGet.c @@ -142,7 +142,7 @@ Tcl_GetBoolean( Tcl_Panic("invalid sharing of Tcl_Obj on C stack"); } if (code == TCL_OK) { - *boolPtr = obj.internalRep.longValue; + TclGetBooleanFromObj(NULL, &obj, boolPtr); } return code; } diff --git a/generic/tclGetDate.y b/generic/tclGetDate.y index ce7c2ce..59f85bd 100644 --- a/generic/tclGetDate.y +++ b/generic/tclGetDate.y @@ -897,7 +897,7 @@ TclDatelex( location->first_column = yyInput - info->dateStart; for ( ; ; ) { - while (TclIsSpaceProc(*yyInput)) { + while (TclIsSpaceProc(UCHAR(*yyInput))) { yyInput++; } @@ -960,7 +960,7 @@ TclDatelex( int TclClockOldscanObjCmd( - ClientData clientData, /* Unused */ + void *clientData, /* Unused */ Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Count of paraneters */ Tcl_Obj *const *objv) /* Parameters */ diff --git a/generic/tclHash.c b/generic/tclHash.c index 193664d..8bbb0c7 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.c @@ -43,20 +43,7 @@ static Tcl_HashEntry * AllocArrayEntry(Tcl_HashTable *tablePtr, void *keyPtr); static int CompareArrayKeys(void *keyPtr, Tcl_HashEntry *hPtr); -static unsigned int HashArrayKey(Tcl_HashTable *tablePtr, void *keyPtr); - -/* - * Prototypes for the one word hash key methods. Not actually declared because - * this is a critical path that is implemented in the core hash table access - * function. - */ - -#if 0 -static Tcl_HashEntry * AllocOneWordEntry(Tcl_HashTable *tablePtr, - void *keyPtr); -static int CompareOneWordKeys(void *keyPtr, Tcl_HashEntry *hPtr); -static unsigned int HashOneWordKey(Tcl_HashTable *tablePtr, void *keyPtr); -#endif +static TCL_HASH_TYPE HashArrayKey(Tcl_HashTable *tablePtr, void *keyPtr); /* * Prototypes for the string hash key methods. @@ -65,7 +52,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 unsigned int HashStringKey(Tcl_HashTable *tablePtr, void *keyPtr); +static TCL_HASH_TYPE HashStringKey(Tcl_HashTable *tablePtr, void *keyPtr); /* * Function prototypes for static functions in this file: @@ -321,11 +308,9 @@ 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 keys pointers or values are equal */ if ((key == hPtr->key.oneWordValue) || compareKeysProc((void *) key, hPtr) @@ -339,11 +324,9 @@ 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; @@ -371,15 +354,9 @@ 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++; /* @@ -419,9 +396,7 @@ Tcl_DeleteHashEntry( const Tcl_HashKeyType *typePtr; Tcl_HashTable *tablePtr; Tcl_HashEntry **bucketPtr; -#if TCL_HASH_KEY_STORE_HASH int index; -#endif tablePtr = entryPtr->tablePtr; @@ -436,7 +411,6 @@ 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)); @@ -445,9 +419,6 @@ Tcl_DeleteHashEntry( } bucketPtr = &tablePtr->buckets[index]; -#else - bucketPtr = entryPtr->bucketPtr; -#endif if (*bucketPtr == entryPtr) { *bucketPtr = entryPtr->nextPtr; @@ -793,7 +764,7 @@ CompareArrayKeys( *---------------------------------------------------------------------- */ -static unsigned int +static TCL_HASH_TYPE HashArrayKey( Tcl_HashTable *tablePtr, /* Hash table. */ void *keyPtr) /* Key from which to compute hash value. */ @@ -806,7 +777,7 @@ HashArrayKey( count--, array++) { result += *array; } - return result; + return (TCL_HASH_TYPE) result; } /* @@ -838,7 +809,7 @@ AllocStringEntry( if (size < sizeof(hPtr->key)) { allocsize = sizeof(hPtr->key); } - hPtr = ckalloc(TclOffset(Tcl_HashEntry, key) + allocsize); + hPtr = ckalloc(offsetof(Tcl_HashEntry, key) + allocsize); memset(hPtr, 0, sizeof(Tcl_HashEntry) + allocsize - sizeof(hPtr->key)); memcpy(hPtr->key.string, string, size); hPtr->clientData = 0; @@ -890,7 +861,7 @@ CompareStringKeys( *---------------------------------------------------------------------- */ -static unsigned +static TCL_HASH_TYPE HashStringKey( Tcl_HashTable *tablePtr, /* Hash table. */ void *keyPtr) /* Key from which to compute hash value. */ @@ -936,7 +907,7 @@ HashStringKey( result += (result << 3) + UCHAR(c); } } - return result; + return (TCL_HASH_TYPE) result; } /* @@ -944,7 +915,7 @@ HashStringKey( * * BogusFind -- * - * This function is invoked when an Tcl_FindHashEntry is called on a + * This function is invoked when Tcl_FindHashEntry is called on a * table that has been deleted. * * Results: @@ -971,7 +942,7 @@ BogusFind( * * BogusCreate -- * - * This function is invoked when an Tcl_CreateHashEntry is called on a + * This function is invoked when Tcl_CreateHashEntry is called on a * table that has been deleted. * * Results: @@ -1048,8 +1019,8 @@ RebuildTable( tablePtr->numBuckets *= 4; if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) { - tablePtr->buckets = (Tcl_HashEntry **) TclpSysAlloc((unsigned) - (tablePtr->numBuckets * sizeof(Tcl_HashEntry *)), 0); + tablePtr->buckets = (Tcl_HashEntry **) TclpSysAlloc( + tablePtr->numBuckets * sizeof(Tcl_HashEntry *), 0); } else { tablePtr->buckets = ckalloc(tablePtr->numBuckets * sizeof(Tcl_HashEntry *)); @@ -1069,7 +1040,6 @@ 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)); @@ -1078,26 +1048,6 @@ 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 b08e352..47806d4 100644 --- a/generic/tclHistory.c +++ b/generic/tclHistory.c @@ -62,15 +62,14 @@ Tcl_RecordAndEval( * instead of Tcl_Eval. */ { register Tcl_Obj *cmdPtr; - int length = strlen(cmd); int result; - if (length > 0) { + if (cmd[0]) { /* * Call Tcl_RecordAndEvalObj to do the actual work. */ - cmdPtr = Tcl_NewStringObj(cmd, length); + cmdPtr = Tcl_NewStringObj(cmd, -1); Tcl_IncrRefCount(cmdPtr); result = Tcl_RecordAndEvalObj(interp, cmdPtr, flags); diff --git a/generic/tclIO.c b/generic/tclIO.c index d603d76..118820a 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -116,7 +116,7 @@ typedef struct CopyState { * The structure defined below is used in this file only. */ -typedef struct ThreadSpecificData { +typedef struct { NextChannelHandler *nestedHandlerPtr; /* This variable holds the list of nested * Tcl_NotifyChannel invocations. */ @@ -321,9 +321,9 @@ static int WillRead(Channel *chanPtr); typedef struct ResolvedChanName { ChannelState *statePtr; /* The saved lookup result */ Tcl_Interp *interp; /* The interp in which the lookup was done. */ - int epoch; /* The epoch of the channel when the lookup + size_t epoch; /* The epoch of the channel when the lookup * was done. Use to verify validity. */ - int refCount; /* Share this struct among many Tcl_Obj. */ + size_t refCount; /* Share this struct among many Tcl_Obj. */ } ResolvedChanName; static void DupChannelIntRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); @@ -337,6 +337,22 @@ static const Tcl_ObjType chanObjType = { NULL /* setFromAnyProc */ }; +#define ChanSetIntRep(objPtr, resPtr) \ + do { \ + Tcl_ObjIntRep ir; \ + (resPtr)->refCount++; \ + ir.twoPtrValue.ptr1 = (resPtr); \ + ir.twoPtrValue.ptr2 = NULL; \ + Tcl_StoreIntRep((objPtr), &chanObjType, &ir); \ + } while (0) + +#define ChanGetIntRep(objPtr, resPtr) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = TclFetchIntRep((objPtr), &chanObjType); \ + (resPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + } while (0) + #define BUSY_STATE(st, fl) \ ((((st)->csPtrR) && ((fl) & TCL_READABLE)) || \ (((st)->csPtrW) && ((fl) & TCL_WRITABLE))) @@ -381,20 +397,20 @@ ChanCloseHalf( * * ChanRead -- * - * Read up to dstSize bytes using the inputProc of chanPtr, store - * them at dst, and return the number of bytes stored. + * Read up to dstSize bytes using the inputProc of chanPtr, store them at + * dst, and return the number of bytes stored. * * Results: * The return value of the driver inputProc, * - number of bytes stored at dst, ot - * - -1 on error, with a Posix error code available to the - * caller by calling Tcl_GetErrno(). + * - -1 on error, with a Posix error code available to the caller by + * calling Tcl_GetErrno(). * * Side effects: - * The CHANNEL_BLOCKED and CHANNEL_EOF flags of the channel state are - * set as appropriate. - * On EOF, the inputEncodingFlags are set to perform ending operations - * on decoding. + * The CHANNEL_BLOCKED and CHANNEL_EOF flags of the channel state are set + * as appropriate. On EOF, the inputEncodingFlags are set to perform + * ending operations on decoding. + * * TODO - Is this really the right place for that? * *--------------------------------------------------------------------------- @@ -408,15 +424,17 @@ ChanRead( int bytesRead, result; /* - * If the caller asked for zero bytes, we'd force the inputProc - * to return zero bytes, and then misinterpret that as EOF. + * If the caller asked for zero bytes, we'd force the inputProc to return + * zero bytes, and then misinterpret that as EOF. */ + assert(dstSize > 0); /* * Each read op must set the blocked and eof states anew, not let * the effect of prior reads leak through. */ + if (GotFlag(chanPtr->state, CHANNEL_EOF)) { chanPtr->state->inputEncodingFlags |= TCL_ENCODING_START; } @@ -429,7 +447,10 @@ ChanRead( bytesRead = chanPtr->typePtr->inputProc(chanPtr->instanceData, dst, dstSize, &result); - /* Stop any flag leakage through stacked channel levels */ + /* + * Stop any flag leakage through stacked channel levels. + */ + if (GotFlag(chanPtr->state, CHANNEL_EOF)) { chanPtr->state->inputEncodingFlags |= TCL_ENCODING_START; } @@ -437,10 +458,10 @@ ChanRead( chanPtr->state->inputEncodingFlags &= ~TCL_ENCODING_END; if (bytesRead > 0) { /* - * If we get a short read, signal up that we may be BLOCKED. - * We should avoid calling the driver because on some - * platforms we will block in the low level reading code even - * though the channel is set into nonblocking mode. + * If we get a short read, signal up that we may be BLOCKED. We should + * avoid calling the driver because on some platforms we will block in + * the low level reading code even though the channel is set into + * nonblocking mode. */ if (bytesRead < dstSize) { @@ -477,13 +498,13 @@ ChanSeek( offset, mode, errnoPtr); } - if (offset<Tcl_LongAsWide(LONG_MIN) || offset>Tcl_LongAsWide(LONG_MAX)) { + if (offset<LONG_MIN || offset>LONG_MAX) { *errnoPtr = EOVERFLOW; - return Tcl_LongAsWide(-1); + return -1; } - return Tcl_LongAsWide(chanPtr->typePtr->seekProc(chanPtr->instanceData, - Tcl_WideAsLong(offset), mode, errnoPtr)); + return chanPtr->typePtr->seekProc(chanPtr->instanceData, + offset, mode, errnoPtr); } static inline void @@ -574,7 +595,10 @@ TclFinalizeIOSubsystem(void) int active = 1; /* Flag == 1 while there's still work to do */ int doflushnb; - /* Fetch the pre-TIP#398 compatibility flag */ + /* + * Fetch the pre-TIP#398 compatibility flag. + */ + { const char *s; Tcl_DString ds; @@ -619,18 +643,20 @@ TclFinalizeIOSubsystem(void) */ if (active) { - TclChannelPreserve((Tcl_Channel)chanPtr); + /* - * TIP #398: by default, we no longer set the channel back into - * blocking mode. To restore the old blocking behavior, the - * environment variable TCL_FLUSH_NONBLOCKING_ON_EXIT must be set + * TIP #398: by default, we no longer set the channel back into + * blocking mode. To restore the old blocking behavior, the + * environment variable TCL_FLUSH_NONBLOCKING_ON_EXIT must be set * and not be "0". */ + if (doflushnb) { - /* Set the channel back into blocking mode to ensure that we wait - * for all data to flush out. - */ + /* + * Set the channel back into blocking mode to ensure that we + * wait for all data to flush out. + */ (void) Tcl_SetChannelOption(NULL, (Tcl_Channel) chanPtr, "-blocking", "on"); @@ -1505,18 +1531,20 @@ TclGetChannelFromObj( return TCL_ERROR; } - if (objPtr->typePtr == &chanObjType) { + ChanGetIntRep(objPtr, resPtr); + if (resPtr) { /* * Confirm validity of saved lookup results. */ - resPtr = (ResolvedChanName *) objPtr->internalRep.twoPtrValue.ptr1; statePtr = resPtr->statePtr; if ((resPtr->interp == interp) /* Same interp context */ /* No epoch change in channel since lookup */ && (resPtr->epoch == statePtr->epoch)) { + /* + * Have a valid saved lookup. Jump to end to return it. + */ - /* Have a valid saved lookup. Jump to end to return it. */ goto valid; } } @@ -1525,22 +1553,21 @@ TclGetChannelFromObj( if (chan == NULL) { if (resPtr) { - FreeChannelIntRep(objPtr); + Tcl_StoreIntRep(objPtr, &chanObjType, NULL); } return TCL_ERROR; } if (resPtr && resPtr->refCount == 1) { - /* Re-use the ResolvedCmdName struct */ - Tcl_Release((ClientData) resPtr->statePtr); + /* + * Re-use the ResolvedCmdName struct. + */ + Tcl_Release((ClientData) resPtr->statePtr); } else { - TclFreeIntRep(objPtr); - resPtr = (ResolvedChanName *) ckalloc(sizeof(ResolvedChanName)); - resPtr->refCount = 1; - objPtr->internalRep.twoPtrValue.ptr1 = (ClientData) resPtr; - objPtr->typePtr = &chanObjType; + resPtr->refCount = 0; + ChanSetIntRep(objPtr, resPtr); /* Overwrites, if needed */ } statePtr = ((Channel *)chan)->state; resPtr->statePtr = statePtr; @@ -1675,7 +1702,7 @@ Tcl_CreateChannel( * Set the channel up initially in AUTO input translation mode to accept * "\n", "\r" and "\r\n". Output translation mode is set to a platform * specific default value. The eofChar is set to 0 for both input and - * output, so that Tcl does not look for an in-file EOF indicator (e.g. + * output, so that Tcl does not look for an in-file EOF indicator (e.g., * ^Z) and does not append an EOF indicator to files. */ @@ -1903,7 +1930,6 @@ Tcl_StackChannel( */ if (((mask & TCL_READABLE) != 0) && (statePtr->inQueueHead != NULL)) { - /* * When statePtr->inQueueHead is not NULL, we know * prevChanPtr->inQueueHead must be NULL. @@ -2035,9 +2061,7 @@ Tcl_UnstackChannel( * of registered channels we wind down the state of the * transformation, and then restore the state of underlying channel * into the old structure. - */ - - /* + * * TODO: Figure out how to handle the situation where the chan * operations called below by this unstacking operation cause * another unstacking recursively. In that case the downChanPtr @@ -2515,6 +2539,7 @@ RecycleBuffer( /* * Do we have to free the buffer to the OS? */ + if (IsShared(bufPtr)) { mustDiscard = 1; } @@ -2525,9 +2550,8 @@ RecycleBuffer( } /* - * Only save buffers which have the requested buffersize for the - * channel. This is to honor dynamic changes of the buffersize - * made by the user. + * Only save buffers which have the requested buffersize for the channel. + * This is to honor dynamic changes of the buffersize made by the user. */ if ((bufPtr->bufLength - BUFFER_PADDING) != statePtr->bufSize) { @@ -2697,14 +2721,18 @@ FlushChannel( /* * Should we shift the current output buffer over to the output queue? * First check that there are bytes in it. If so then... - * If the output queue is empty, then yes, trusting the caller called - * us only when written bytes ought to be flushed. - * If the current output buffer is full, then yes, so we can meet - * the post-condition that on a successful return to caller we've - * left space in the current output buffer for more writing (the flush - * call was to make new room). - * If the channel is blocking, then yes, so we guarantee that - * blocking flushes actually flush all pending data. + * + * If the output queue is empty, then yes, trusting the caller called us + * only when written bytes ought to be flushed. + * + * If the current output buffer is full, then yes, so we can meet the + * post-condition that on a successful return to caller we've left space + * in the current output buffer for more writing (the flush call was to + * make new room). + * + * If the channel is blocking, then yes, so we guarantee that blocking + * flushes actually flush all pending data. + * * Otherwise, no. Keep the current output buffer where it is so more * can be written to it, possibly filling it, to promote more efficient * buffer usage. @@ -2798,8 +2826,8 @@ FlushChannel( /* * TIP #219, Tcl Channel Reflection API. * When defering the error copy a message from the bypass into - * the unreported area. Or discard it if the new error is to be - * ignored in favor of an earlier defered error. + * the unreported area. Or discard it if the new error is to + * be ignored in favor of an earlier defered error. */ Tcl_Obj *msg = statePtr->chanMsg; @@ -2851,8 +2879,11 @@ FlushChannel( ReleaseChannelBuffer(bufPtr); break; } else { - /* TODO: Consider detecting and reacting to short writes - * on blocking channels. Ought not happen. See iocmd-24.2. */ + /* + * TODO: Consider detecting and reacting to short writes on + * blocking channels. Ought not happen. See iocmd-24.2. + */ + wroteSome = 1; } @@ -2886,7 +2917,6 @@ FlushChannel( ResetFlag(statePtr, BG_FLUSH_SCHEDULED); ChanWatch(chanPtr, statePtr->interestMask); } else { - /* * When we are calledFromAsyncFlush, that means a writable * state on the channel triggered the call, so we should be @@ -2931,7 +2961,8 @@ FlushChannel( (statePtr->outQueueHead == NULL) && ((statePtr->curOutPtr == NULL) || IsBufferEmpty(statePtr->curOutPtr))) { - errorCode = CloseChannelPart(interp, chanPtr, errorCode, TCL_CLOSE_WRITE); + errorCode = CloseChannelPart(interp, chanPtr, errorCode, + TCL_CLOSE_WRITE); goto done; } @@ -3402,7 +3433,6 @@ Tcl_Close( if (GotFlag(statePtr, TCL_WRITABLE) && (statePtr->encoding != NULL) && !(statePtr->outputEncodingFlags & TCL_ENCODING_START)) { - int code = CheckChannelErrors(statePtr, TCL_WRITABLE); if (code == 0) { @@ -3433,6 +3463,11 @@ Tcl_Close( Tcl_ClearChannelHandlers(chan); /* + * Cancel any outstanding timer. + */ + Tcl_DeleteTimerHandler(statePtr->timer); + + /* * Invoke the registered close callbacks and delete their records. */ @@ -3492,12 +3527,14 @@ Tcl_Close( } return TCL_ERROR; } + /* * Bug 97069ea11a: set error message if a flush code is set and no error * message set up to now. */ + if (flushcode != 0 && interp != NULL - && 0 == Tcl_GetCharLength(Tcl_GetObjResult(interp)) ) { + && 0 == Tcl_GetCharLength(Tcl_GetObjResult(interp))) { Tcl_SetErrno(flushcode); Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_PosixError(interp), -1)); @@ -3592,8 +3629,8 @@ Tcl_CloseEx( } /* - * A user may try to call half-close from within a channel close - * handler. That won't do. + * A user may try to call half-close from within a channel close handler. + * That won't do. */ if (statePtr->flags & CHANNEL_INCLOSE) { @@ -3664,9 +3701,12 @@ CloseWrite( * closed. May still be used by some * interpreter */ { - /* Notes: clear-channel-handlers - write side only ? or keep around, just - * not called. */ - /* No close cllbacks are run - channel is still open (read side) */ + /* + * Notes: clear-channel-handlers - write side only ? or keep around, just + * not called. + * + * No close callbacks are run - channel is still open (read side) + */ ChannelState *statePtr = chanPtr->state; /* State of real IO channel. */ @@ -3691,9 +3731,9 @@ CloseWrite( * Notes: Due to the assertion of CHANNEL_CLOSEDWRITE in the flags * FlushChannel() has called CloseChannelPart(). While we can still access * "chan" (no structures were freed), the only place which may still - * contain a message is the interpreter itself, and "CloseChannelPart" made - * sure to lift any channel message it generated into it. Hence the NULL - * argument in the call below. + * contain a message is the interpreter itself, and "CloseChannelPart" + * made sure to lift any channel message it generated into it. Hence the + * NULL argument in the call below. */ if (TclChanCaughtErrorBypass(interp, NULL)) { @@ -3917,10 +3957,10 @@ Tcl_ClearChannelHandlers( StopCopy(statePtr->csPtrW); /* - * Must set the interest mask now to 0, otherwise infinite loops - * will occur if Tcl_DoOneEvent is called before the channel is - * finally deleted in FlushChannel. This can happen if the channel - * has a background flush active. + * Must set the interest mask now to 0, otherwise infinite loops will + * occur if Tcl_DoOneEvent is called before the channel is finally deleted + * in FlushChannel. This can happen if the channel has a background flush + * active. */ statePtr->interestMask = 0; @@ -4189,22 +4229,24 @@ WillRead( Channel *chanPtr) { if (chanPtr->typePtr == NULL) { - /* Prevent read attempts on a closed channel */ + /* + * Prevent read attempts on a closed channel. + */ + DiscardInputQueued(chanPtr->state, 0); Tcl_SetErrno(EINVAL); return -1; } if ((chanPtr->typePtr->seekProc != NULL) && (Tcl_OutputBuffered((Tcl_Channel) chanPtr) > 0)) { - /* - * CAVEAT - The assumption here is that FlushChannel() will - * push out the bytes of any writes that are in progress. - * Since this is a seekable channel, we assume it is not one - * that can block and force bg flushing. Channels we know that - * can do that -- sockets, pipes -- are not seekable. If the - * assumption is wrong, more drastic measures may be required here - * like temporarily setting the channel into blocking mode. + * CAVEAT - The assumption here is that FlushChannel() will push out + * the bytes of any writes that are in progress. Since this is a + * seekable channel, we assume it is not one that can block and force + * bg flushing. Channels we know that can do that - sockets, pipes - + * are not seekable. If the assumption is wrong, more drastic measures + * may be required here like temporarily setting the channel into + * blocking mode. */ if (FlushChannel(NULL, chanPtr, 0) != 0) { @@ -4283,7 +4325,7 @@ Write( * that we need to stick at the beginning of this buffer. */ - memcpy(InsertPoint(bufPtr), safe, (size_t) saved); + memcpy(InsertPoint(bufPtr), safe, saved); bufPtr->nextAdded += saved; saved = 0; } @@ -4296,11 +4338,17 @@ Write( &statePtr->outputEncodingState, dst, dstLen + BUFFER_PADDING, &srcRead, &dstWrote, NULL); - /* See chan-io-1.[89]. Tcl Bug 506297. */ + /* + * See chan-io-1.[89]. Tcl Bug 506297. + */ + statePtr->outputEncodingFlags &= ~TCL_ENCODING_START; if ((result != TCL_OK) && (srcRead + dstWrote == 0)) { - /* We're reading from invalid/incomplete UTF-8 */ + /* + * We're reading from invalid/incomplete UTF-8. + */ + ReleaseChannelBuffer(bufPtr); if (total == 0) { Tcl_SetErrno(EINVAL); @@ -4340,11 +4388,10 @@ Write( } result |= Tcl_UtfToExternal(NULL, encoding, nl, nlLen, - statePtr->outputEncodingFlags, - &statePtr->outputEncodingState, dst, - dstLen + BUFFER_PADDING, &srcRead, &dstWrote, NULL); - - assert (srcRead == nlLen); + statePtr->outputEncodingFlags, + &statePtr->outputEncodingState, dst, + dstLen + BUFFER_PADDING, &srcRead, &dstWrote, NULL); + assert(srcRead == nlLen); bufPtr->nextAdded += dstWrote; src++; @@ -4358,15 +4405,15 @@ Write( if (IsBufferOverflowing(bufPtr)) { /* - * When translating from UTF-8 to external encoding, we - * allowed the translation to produce a character that crossed - * the end of the output buffer, so that we would get a - * completely full buffer before flushing it. The extra bytes - * will be moved to the beginning of the next buffer. + * When translating from UTF-8 to external encoding, we allowed + * the translation to produce a character that crossed the end of + * the output buffer, so that we would get a completely full + * buffer before flushing it. The extra bytes will be moved to the + * beginning of the next buffer. */ saved = -SpaceLeft(bufPtr); - memcpy(safe, dst + dstLen, (size_t) saved); + memcpy(safe, dst + dstLen, saved); bufPtr->nextAdded = bufPtr->bufLength; } @@ -4382,15 +4429,16 @@ Write( flushed += statePtr->bufSize; /* - * We just flushed. So if we have needNlFlush set to record - * that we need to flush because theres a (translated) newline - * in the buffer, that's likely not true any more. But there - * is a tricky exception. If we have saved bytes that did not - * really get flushed and those bytes came from a translation - * of a newline as the last thing taken from the src array, - * then needNlFlush needs to remain set to flag that the - * next buffer still needs a newline flush. + * We just flushed. So if we have needNlFlush set to record that + * we need to flush because theres a (translated) newline in the + * buffer, that's likely not true any more. But there is a tricky + * exception. If we have saved bytes that did not really get + * flushed and those bytes came from a translation of a newline as + * the last thing taken from the src array, then needNlFlush needs + * to remain set to flag that the next buffer still needs a + * newline flush. */ + if (needNlFlush && (saved == 0 || src[-1] != '\n')) { needNlFlush = 0; } @@ -4404,6 +4452,8 @@ Write( } } + UpdateInterest(chanPtr); + return total; } @@ -4496,8 +4546,8 @@ Tcl_GetsObj( if (GotFlag(statePtr, CHANNEL_STICKY_EOF)) { SetFlag(statePtr, CHANNEL_EOF); - assert( statePtr->inputEncodingFlags & TCL_ENCODING_END ); - assert( !GotFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR) ); + assert(statePtr->inputEncodingFlags & TCL_ENCODING_END); + assert(!GotFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR)); /* TODO: Do we need this? */ UpdateInterest(chanPtr); @@ -4837,17 +4887,17 @@ Tcl_GetsObj( */ done: - assert(!GotFlag(statePtr, CHANNEL_EOF) - || GotFlag(statePtr, CHANNEL_STICKY_EOF) - || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0); - - assert( !(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED) - == (CHANNEL_EOF|CHANNEL_BLOCKED)) ); + assert(!GotFlag(statePtr, CHANNEL_EOF) + || GotFlag(statePtr, CHANNEL_STICKY_EOF) + || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0); + assert(!(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED) + == (CHANNEL_EOF|CHANNEL_BLOCKED))); /* * Regenerate the top channel, in case it was changed due to * self-modifying reflected transforms. */ + if (chanPtr != statePtr->topChanPtr) { TclChannelRelease((Tcl_Channel)chanPtr); chanPtr = statePtr->topChanPtr; @@ -4867,10 +4917,9 @@ Tcl_GetsObj( * end-of-line or end-of-file has been seen. Bytes read from the input * channel return as a ByteArray obj. * - * WARNING! The notion of "binary" used here is different from - * notions of "binary" used in other places. In particular, this - * "binary" routine may be called when an -eofchar is set on the - * channel. + * WARNING! The notion of "binary" used here is different from notions + * of "binary" used in other places. In particular, this "binary" routine + * may be called when an -eofchar is set on the channel. * * Results: * Number of characters accumulated in the object or -1 if error, @@ -4936,8 +4985,8 @@ TclGetsObjBinary( ResetFlag(statePtr, CHANNEL_BLOCKED); while (1) { /* - * Subtract the number of bytes that were removed from channel - * buffer during last call. + * Subtract the number of bytes that were removed from channel buffer + * during last call. */ if (bufPtr != NULL) { @@ -4949,10 +4998,11 @@ TclGetsObjBinary( if ((bufPtr == NULL) || (bufPtr->nextAdded == BUFFER_PADDING)) { /* - * All channel buffers were exhausted and the caller still - * hasn't seen EOL. Need to read more bytes from the channel - * device. Side effect is to allocate another channel buffer. + * All channel buffers were exhausted and the caller still hasn't + * seen EOL. Need to read more bytes from the channel device. Side + * effect is to allocate another channel buffer. */ + if (GetInput(chanPtr) != 0) { goto restore; } @@ -4962,15 +5012,15 @@ TclGetsObjBinary( } } else { /* - * Incoming CHANNEL_STICKY_EOF is filtered out on entry. - * A new CHANNEL_STICKY_EOF set in this routine leads to - * return before coming back here. When we are not dealing - * with CHANNEL_STICKY_EOF, a CHANNEL_EOF implies an - * empty buffer. Here the buffer is non-empty so we know - * we're a non-EOF */ + * Incoming CHANNEL_STICKY_EOF is filtered out on entry. A new + * CHANNEL_STICKY_EOF set in this routine leads to return before + * coming back here. When we are not dealing with + * CHANNEL_STICKY_EOF, a CHANNEL_EOF implies an empty buffer. + * Here the buffer is non-empty so we know we're a non-EOF. + */ - assert ( !GotFlag(statePtr, CHANNEL_STICKY_EOF) ); - assert ( !GotFlag(statePtr, CHANNEL_EOF) ); + assert(!GotFlag(statePtr, CHANNEL_STICKY_EOF)); + assert(!GotFlag(statePtr, CHANNEL_EOF)); } dst = (unsigned char *) RemovePoint(bufPtr); @@ -5037,13 +5087,13 @@ TclGetsObjBinary( } /* - * Copy bytes from the channel buffer to the ByteArray. - * This may realloc space, so keep track of result. + * Copy bytes from the channel buffer to the ByteArray. This may + * realloc space, so keep track of result. */ rawLen = dstEnd - dst; byteArray = Tcl_SetByteArrayLength(objPtr, byteLen + rawLen); - memcpy(byteArray + byteLen, dst, (size_t) rawLen); + memcpy(byteArray + byteLen, dst, rawLen); byteLen += rawLen; } @@ -5060,7 +5110,7 @@ TclGetsObjBinary( rawLen = eol - dst; byteArray = Tcl_SetByteArrayLength(objPtr, byteLen + rawLen); - memcpy(byteArray + byteLen, dst, (size_t) rawLen); + memcpy(byteArray + byteLen, dst, rawLen); byteLen += rawLen; bufPtr->nextRemoved += rawLen + skip; @@ -5122,11 +5172,11 @@ TclGetsObjBinary( */ done: - assert(!GotFlag(statePtr, CHANNEL_EOF) - || GotFlag(statePtr, CHANNEL_STICKY_EOF) - || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0); - assert( !(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED) - == (CHANNEL_EOF|CHANNEL_BLOCKED)) ); + assert(!GotFlag(statePtr, CHANNEL_EOF) + || GotFlag(statePtr, CHANNEL_STICKY_EOF) + || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0); + assert(!(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED) + == (CHANNEL_EOF|CHANNEL_BLOCKED))); UpdateInterest(chanPtr); TclChannelRelease((Tcl_Channel)chanPtr); return copiedTotal; @@ -5259,15 +5309,15 @@ FilterInputBytes( } } else { /* - * Incoming CHANNEL_STICKY_EOF is filtered out on entry. - * A new CHANNEL_STICKY_EOF set in this routine leads to - * return before coming back here. When we are not dealing - * with CHANNEL_STICKY_EOF, a CHANNEL_EOF implies an - * empty buffer. Here the buffer is non-empty so we know - * we're a non-EOF */ + * Incoming CHANNEL_STICKY_EOF is filtered out on entry. A new + * CHANNEL_STICKY_EOF set in this routine leads to return before + * coming back here. When we are not dealing with CHANNEL_STICKY_EOF, + * a CHANNEL_EOF implies an empty buffer. Here the buffer is + * non-empty so we know we're a non-EOF. + */ - assert ( !GotFlag(statePtr, CHANNEL_STICKY_EOF) ); - assert ( !GotFlag(statePtr, CHANNEL_EOF) ); + assert(!GotFlag(statePtr, CHANNEL_STICKY_EOF)); + assert(!GotFlag(statePtr, CHANNEL_EOF)); } /* @@ -5597,7 +5647,9 @@ Tcl_ReadRaw( return -1; } - /* First read bytes from the push-back buffers. */ + /* + * First read bytes from the push-back buffers. + */ while (chanPtr->inQueueHead && bytesToRead > 0) { ChannelBuffer *bufPtr = chanPtr->inQueueHead; @@ -5605,15 +5657,19 @@ Tcl_ReadRaw( int toCopy = (bytesInBuffer < bytesToRead) ? bytesInBuffer : bytesToRead; - /* Copy the current chunk into the read buffer. */ + /* + * Copy the current chunk into the read buffer. + */ - memcpy(readBuf, RemovePoint(bufPtr), (size_t) toCopy); + memcpy(readBuf, RemovePoint(bufPtr), toCopy); bufPtr->nextRemoved += toCopy; copied += toCopy; readBuf += toCopy; bytesToRead -= toCopy; - /* If the current buffer is empty recycle it. */ + /* + * If the current buffer is empty recycle it. + */ if (IsBufferEmpty(bufPtr)) { chanPtr->inQueueHead = bufPtr->nextPtr; @@ -5625,37 +5681,40 @@ Tcl_ReadRaw( } /* - * Go to the driver only if we got nothing from pushback. - * Have to do it this way to avoid EOF mis-timings when we - * consider the ability that EOF may not be a permanent - * condition in the driver, and in that case we have to - * synchronize. + * Go to the driver only if we got nothing from pushback. Have to do it + * this way to avoid EOF mis-timings when we consider the ability that EOF + * may not be a permanent condition in the driver, and in that case we + * have to synchronize. */ if (copied) { return copied; } - /* This test not needed. */ - if (bytesToRead > 0) { + /* + * This test not needed. + */ + if (bytesToRead > 0) { int nread = ChanRead(chanPtr, readBuf, bytesToRead); if (nread > 0) { - /* Successful read (short is OK) - add to bytes copied */ + /* + * Successful read (short is OK) - add to bytes copied. + */ + copied += nread; } else if (nread < 0) { /* - * An error signaled. If CHANNEL_BLOCKED, then the error - * is not real, but an indication of blocked state. In - * that case, retain the flag and let caller receive the - * short read of copied bytes from the pushback. - * HOWEVER, if copied==0 bytes from pushback then repeat - * signalling the blocked state as an error to caller so - * there is no false report of an EOF. - * When !CHANNEL_BLOCKED, the error is real and passes on - * to caller. + * An error signaled. If CHANNEL_BLOCKED, then the error is not + * real, but an indication of blocked state. In that case, retain + * the flag and let caller receive the short read of copied bytes + * from the pushback. HOWEVER, if copied==0 bytes from pushback + * then repeat signalling the blocked state as an error to caller + * so there is no false report of an EOF. When !CHANNEL_BLOCKED, + * the error is real and passes on to caller. */ + if (!GotFlag(statePtr, CHANNEL_BLOCKED) || copied == 0) { copied = -1; } @@ -5792,21 +5851,23 @@ DoReadChars( /* * Early out when next read will see eofchar. * - * NOTE: See DoRead for argument that it's a bug (one we're keeping) - * to have this escape before the one for zero-char read request. + * NOTE: See DoRead for argument that it's a bug (one we're keeping) to + * have this escape before the one for zero-char read request. */ if (GotFlag(statePtr, CHANNEL_STICKY_EOF)) { SetFlag(statePtr, CHANNEL_EOF); - assert( statePtr->inputEncodingFlags & TCL_ENCODING_END ); - assert( !GotFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR) ); + assert(statePtr->inputEncodingFlags & TCL_ENCODING_END); + assert(!GotFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR)); /* TODO: We don't need this call? */ UpdateInterest(chanPtr); return 0; } - /* Special handling for zero-char read request. */ + /* + * Special handling for zero-char read request. + */ if (toRead == 0) { if (GotFlag(statePtr, CHANNEL_EOF)) { statePtr->inputEncodingFlags |= TCL_ENCODING_START; @@ -5825,7 +5886,10 @@ DoReadChars( chanPtr = statePtr->topChanPtr; TclChannelPreserve((Tcl_Channel)chanPtr); - /* Must clear the BLOCKED|EOF flags here since we check before reading */ + /* + * Must clear the BLOCKED|EOF flags here since we check before reading. + */ + if (GotFlag(statePtr, CHANNEL_EOF)) { statePtr->inputEncodingFlags |= TCL_ENCODING_START; } @@ -5883,10 +5947,11 @@ DoReadChars( } /* - * Failure to fill a channel buffer may have left channel reporting - * a "blocked" state, but so long as we fulfilled the request here, - * the caller does not consider us blocked. + * Failure to fill a channel buffer may have left channel reporting a + * "blocked" state, but so long as we fulfilled the request here, the + * caller does not consider us blocked. */ + if (toRead == 0) { ResetFlag(statePtr, CHANNEL_BLOCKED); } @@ -5895,6 +5960,7 @@ DoReadChars( * Regenerate the top channel, in case it was changed due to * self-modifying reflected transforms. */ + if (chanPtr != statePtr->topChanPtr) { TclChannelRelease((Tcl_Channel)chanPtr); chanPtr = statePtr->topChanPtr; @@ -5905,11 +5971,12 @@ DoReadChars( * Update the notifier state so we don't block while there is still data * in the buffers. */ - assert(!GotFlag(statePtr, CHANNEL_EOF) - || GotFlag(statePtr, CHANNEL_STICKY_EOF) - || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0); - assert( !(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED) - == (CHANNEL_EOF|CHANNEL_BLOCKED)) ); + + assert(!GotFlag(statePtr, CHANNEL_EOF) + || GotFlag(statePtr, CHANNEL_STICKY_EOF) + || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0); + assert(!(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED) + == (CHANNEL_EOF|CHANNEL_BLOCKED))); UpdateInterest(chanPtr); TclChannelRelease((Tcl_Channel)chanPtr); return copied; @@ -6026,11 +6093,10 @@ ReadChars( int numBytes, srcLen = BytesLeft(bufPtr); /* - * One src byte can yield at most one character. So when the - * number of src bytes we plan to read is less than the limit on - * character count to be read, clearly we will remain within that - * limit, and we can use the value of "srcLen" as a tighter limit - * for sizing receiving buffers. + * One src byte can yield at most one character. So when the number of + * src bytes we plan to read is less than the limit on character count to + * be read, clearly we will remain within that limit, and we can use the + * value of "srcLen" as a tighter limit for sizing receiving buffers. */ int toRead = ((charsToRead<0)||(charsToRead > srcLen)) ? srcLen : charsToRead; @@ -6048,6 +6114,7 @@ ReadChars( Tcl_AppendToObj(objPtr, NULL, dstLimit); if (toRead == srcLen) { unsigned int size; + dst = TclGetStringStorage(objPtr, &size) + numBytes; dstLimit = size - numBytes; } else { @@ -6055,19 +6122,18 @@ ReadChars( } /* - * This routine is burdened with satisfying several constraints. - * It cannot append more than 'charsToRead` chars onto objPtr. - * This is measured after encoding and translation transformations - * are completed. There is no precise number of src bytes that can - * be associated with the limit. Yet, when we are done, we must know - * precisely the number of src bytes that were consumed to produce - * the appended chars, so that all subsequent bytes are left in - * the buffers for future read operations. + * This routine is burdened with satisfying several constraints. It cannot + * append more than 'charsToRead` chars onto objPtr. This is measured + * after encoding and translation transformations are completed. There is + * no precise number of src bytes that can be associated with the limit. + * Yet, when we are done, we must know precisely the number of src bytes + * that were consumed to produce the appended chars, so that all + * subsequent bytes are left in the buffers for future read operations. * - * The consequence is that we have no choice but to implement a - * "trial and error" approach, where in general we may need to - * perform transformations and copies multiple times to achieve - * a consistent set of results. This takes the shape of a loop. + * The consequence is that we have no choice but to implement a "trial and + * error" approach, where in general we may need to perform + * transformations and copies multiple times to achieve a consistent set + * of results. This takes the shape of a loop. */ while (1) { @@ -6080,18 +6146,17 @@ ReadChars( } /* - * Perform the encoding transformation. Read no more than - * srcLen bytes, write no more than dstLimit bytes. + * Perform the encoding transformation. Read no more than srcLen + * bytes, write no more than dstLimit bytes. * - * Some trickiness with encoding flags here. We do not want - * the end of a buffer to be treated as the end of all input - * when the presence of bytes in a next buffer are already - * known to exist. This is checked with an assert() because - * so far no test case causing the assertion to be false has - * been created. The normal operations of channel reading - * appear to cause EOF and TCL_ENCODING_END setting to appear - * only in situations where there are no further bytes in - * any buffers. + * Some trickiness with encoding flags here. We do not want the end + * of a buffer to be treated as the end of all input when the presence + * of bytes in a next buffer are already known to exist. This is + * checked with an assert() because so far no test case causing the + * assertion to be false has been created. The normal operations of + * channel reading appear to cause EOF and TCL_ENCODING_END setting to + * appear only in situations where there are no further bytes in any + * buffers. */ assert(bufPtr->nextPtr == NULL || BytesLeft(bufPtr->nextPtr) == 0 @@ -6102,10 +6167,10 @@ ReadChars( dst, dstLimit, &srcRead, &dstDecoded, &numChars); /* - * Perform the translation transformation in place. Read no more - * than the dstDecoded bytes the encoding transformation actually - * produced. Capture the number of bytes written in dstWrote. - * Capture the number of bytes actually consumed in dstRead. + * Perform the translation transformation in place. Read no more than + * the dstDecoded bytes the encoding transformation actually produced. + * Capture the number of bytes written in dstWrote. Capture the number + * of bytes actually consumed in dstRead. */ dstWrote = dstLimit; @@ -6113,11 +6178,9 @@ ReadChars( TranslateInputEOL(statePtr, dst, dst, &dstWrote, &dstRead); if (dstRead < dstDecoded) { - /* - * The encoding transformation produced bytes that the - * translation transformation did not consume. Why did - * this happen? + * The encoding transformation produced bytes that the translation + * transformation did not consume. Why did this happen? */ if (statePtr->inEofChar && dst[dstRead] == statePtr->inEofChar) { @@ -6126,43 +6189,41 @@ ReadChars( * we saw it and stopped translating at that point. * * NOTE the bizarre spec of TranslateInputEOL in this case. - * Clearly the eof char had to be read in order to account - * for the stopping, but the value of dstRead does not - * include it. + * Clearly the eof char had to be read in order to account for + * the stopping, but the value of dstRead does not include it. * - * Also rather bizarre, our caller can only notice an - * EOF condition if we return the value -1 as the number - * of chars read. This forces us to perform a 2-call - * dance where the first call can read all the chars - * up to the eof char, and the second call is solely - * for consuming the encoded eof char then pointed at - * by src so that we can return that magic -1 value. - * This seems really wasteful, especially since - * the first decoding pass of each call is likely to - * decode many bytes beyond that eof char that's all we - * care about. + * Also rather bizarre, our caller can only notice an EOF + * condition if we return the value -1 as the number of chars + * read. This forces us to perform a 2-call dance where the + * first call can read all the chars up to the eof char, and + * the second call is solely for consuming the encoded eof + * char then pointed at by src so that we can return that + * magic -1 value. This seems really wasteful, especially + * since the first decoding pass of each call is likely to + * decode many bytes beyond that eof char that's all we care + * about. */ if (dstRead == 0) { /* - * Curious choice in the eof char handling. We leave - * the eof char in the buffer. So, no need to compute - * a proper srcRead value. At this point, there - * are no chars before the eof char in the buffer. + * Curious choice in the eof char handling. We leave the + * eof char in the buffer. So, no need to compute a proper + * srcRead value. At this point, there are no chars before + * the eof char in the buffer. */ + Tcl_SetObjLength(objPtr, numBytes); return -1; } { /* - * There are chars leading the buffer before the eof - * char. Adjust the dstLimit so we go back and read - * only those and do not encounter the eof char this - * time. + * There are chars leading the buffer before the eof char. + * Adjust the dstLimit so we go back and read only those + * and do not encounter the eof char this time. */ - dstLimit = dstRead - 1 + TCL_UTF_MAX; + dstLimit = dstRead + (TCL_UTF_MAX - 1); statePtr->flags = savedFlags; statePtr->inputEncodingFlags = savedIEFlags; statePtr->inputEncodingState = savedState; @@ -6171,10 +6232,9 @@ ReadChars( } /* - * 2) The other way to read fewer bytes than are decoded - * is when the final byte is \r and we're in a CRLF - * translation mode so we cannot decide whether to - * record \r or \n yet. + * 2) The other way to read fewer bytes than are decoded is when + * the final byte is \r and we're in a CRLF translation mode so + * we cannot decide whether to record \r or \n yet. */ assert(dst[dstRead] == '\r'); @@ -6182,13 +6242,13 @@ ReadChars( if (dstWrote > 0) { /* - * There are chars we can read before we hit the bare cr. - * Go back with a smaller dstLimit so we get them in the - * next pass, compute a matching srcRead, and don't end - * up back here in this call. + * There are chars we can read before we hit the bare CR. Go + * back with a smaller dstLimit so we get them in the next + * pass, compute a matching srcRead, and don't end up back + * here in this call. */ - dstLimit = dstRead - 1 + TCL_UTF_MAX; + dstLimit = dstRead + (TCL_UTF_MAX - 1); statePtr->flags = savedFlags; statePtr->inputEncodingFlags = savedIEFlags; statePtr->inputEncodingState = savedState; @@ -6199,9 +6259,9 @@ ReadChars( assert(dstRead == 0); /* - * We decoded only the bare cr, and we cannot read a - * translated char from that alone. We have to know what's - * next. So why do we only have the one decoded char? + * We decoded only the bare CR, and we cannot read a translated + * char from that alone. We have to know what's next. So why do + * we only have the one decoded char? */ if (code != TCL_OK) { @@ -6242,10 +6302,9 @@ ReadChars( } } else if (statePtr->flags & CHANNEL_EOF) { - /* - * The bare \r is the only char and we will never read - * a subsequent char to make the determination. + * The bare \r is the only char and we will never read a + * subsequent char to make the determination. */ dst[0] = '\r'; @@ -6255,8 +6314,8 @@ ReadChars( } /* - * Revise the dstRead value so that the numChars calc - * below correctly computes zero characters read. + * Revise the dstRead value so that the numChars calc below + * correctly computes zero characters read. */ dstRead = numChars; @@ -6265,9 +6324,9 @@ ReadChars( } /* - * The translation transformation can only reduce the number - * of chars when it converts \r\n into \n. The reduction in - * the number of chars is the difference in bytes read and written. + * The translation transformation can only reduce the number of chars + * when it converts \r\n into \n. The reduction in the number of chars + * is the difference in bytes read and written. */ numChars -= (dstRead - dstWrote); @@ -6277,13 +6336,12 @@ ReadChars( /* * TODO: This cannot happen anymore. * - * We read more chars than allowed. Reset limits to - * prevent that and try again. Don't forget the extra - * padding of TCL_UTF_MAX bytes demanded by the - * Tcl_ExternalToUtf() call! + * We read more chars than allowed. Reset limits to prevent that + * and try again. Don't forget the extra padding of TCL_UTF_MAX + * bytes demanded by the Tcl_ExternalToUtf() call! */ - dstLimit = Tcl_UtfAtIndex(dst, charsToRead) - 1 + TCL_UTF_MAX - dst; + dstLimit = Tcl_UtfAtIndex(dst, charsToRead) - dst + (TCL_UTF_MAX - 1); statePtr->flags = savedFlags; statePtr->inputEncodingFlags = savedIEFlags; statePtr->inputEncodingState = savedState; @@ -6293,18 +6351,19 @@ ReadChars( if (dstWrote == 0) { ChannelBuffer *nextPtr; - /* We were not able to read any chars. */ + /* + * We were not able to read any chars. + */ - assert (numChars == 0); + assert(numChars == 0); /* - * There is one situation where this is the correct final - * result. If the src buffer contains only a single \n - * byte, and we are in TCL_TRANSLATE_AUTO mode, and - * when the translation pass was made the INPUT_SAW_CR - * flag was set on the channel. In that case, the - * correct behavior is to consume that \n and produce the - * empty string. + * There is one situation where this is the correct final result. + * If the src buffer contains only a single \n byte, and we are in + * TCL_TRANSLATE_AUTO mode, and when the translation pass was made + * the INPUT_SAW_CR flag was set on the channel. In that case, the + * correct behavior is to consume that \n and produce the empty + * string. */ if (dstRead == 1 && dst[0] == '\n') { @@ -6313,12 +6372,13 @@ ReadChars( goto consume; } - /* Otherwise, reading zero characters indicates there's - * something incomplete at the end of the src buffer. - * Maybe there were not enough src bytes to decode into - * a char. Maybe a lone \r could not be translated (crlf - * mode). Need to combine any unused src bytes we have - * in the first buffer with subsequent bytes to try again. + /* + * Otherwise, reading zero characters indicates there's something + * incomplete at the end of the src buffer. Maybe there were not + * enough src bytes to decode into a char. Maybe a lone \r could + * not be translated (crlf mode). Need to combine any unused src + * bytes we have in the first buffer with subsequent bytes to try + * again. */ nextPtr = bufPtr->nextPtr; @@ -6333,15 +6393,15 @@ ReadChars( /* * Space is made at the beginning of the buffer to copy the - * previous unused bytes there. Check first if the buffer we - * are using actually has enough space at its beginning for - * the data we are copying. Because if not we will write over - * the buffer management information, especially the 'nextPtr'. + * previous unused bytes there. Check first if the buffer we are + * using actually has enough space at its beginning for the data + * we are copying. Because if not we will write over the buffer + * management information, especially the 'nextPtr'. * - * Note that the BUFFER_PADDING (See AllocChannelBuffer) is - * used to prevent exactly this situation. I.e. it should never - * happen. Therefore it is ok to panic should it happen despite - * the precautions. + * Note that the BUFFER_PADDING (See AllocChannelBuffer) is used + * to prevent exactly this situation. I.e. it should never happen. + * Therefore it is ok to panic should it happen despite the + * precautions. */ if (nextPtr->nextRemoved - srcLen < 0) { @@ -6349,7 +6409,7 @@ ReadChars( } nextPtr->nextRemoved -= srcLen; - memcpy(RemovePoint(nextPtr), src, (size_t) srcLen); + memcpy(RemovePoint(nextPtr), src, srcLen); RecycleBuffer(statePtr, bufPtr, 0); statePtr->inQueueHead = nextPtr; Tcl_SetObjLength(objPtr, numBytes); @@ -6360,10 +6420,12 @@ ReadChars( consume: bufPtr->nextRemoved += srcRead; + /* - * If this read contained multibyte characters, revise factorPtr - * so the next read will allocate bigger buffers. + * If this read contained multibyte characters, revise factorPtr so + * the next read will allocate bigger buffers. */ + if (numChars && numChars < srcRead) { *factorPtr = srcRead * UTF_EXPANSION_FACTOR / numChars; } @@ -6411,22 +6473,27 @@ TranslateInputEOL( int inEofChar = statePtr->inEofChar; /* - * Depending on the translation mode in use, there's no need - * to scan more srcLen bytes at srcStart than can possibly transform - * to dstLen bytes. This keeps the scan for eof char below from - * being pointlessly long. + * Depending on the translation mode in use, there's no need to scan more + * srcLen bytes at srcStart than can possibly transform to dstLen bytes. + * This keeps the scan for eof char below from being pointlessly long. */ switch (statePtr->inputTranslation) { case TCL_TRANSLATE_LF: case TCL_TRANSLATE_CR: if (srcLen > dstLen) { - /* In these modes, each src byte become a dst byte. */ + /* + * In these modes, each src byte become a dst byte. + */ + srcLen = dstLen; } break; default: - /* In other modes, at most 2 src bytes become a dst byte. */ + /* + * In other modes, at most 2 src bytes become a dst byte. + */ + if (srcLen/2 > dstLen) { srcLen = 2 * dstLen; } @@ -6448,7 +6515,7 @@ TranslateInputEOL( case TCL_TRANSLATE_LF: case TCL_TRANSLATE_CR: if (dstStart != srcStart) { - memcpy(dstStart, srcStart, (size_t) srcLen); + memcpy(dstStart, srcStart, srcLen); } if (statePtr->inputTranslation == TCL_TRANSLATE_CR) { char *dst = dstStart; @@ -6605,7 +6672,7 @@ Tcl_Ungets( statePtr->inputEncodingFlags &= ~TCL_ENCODING_END; bufPtr = AllocChannelBuffer(len); - memcpy(InsertPoint(bufPtr), str, (size_t) len); + memcpy(InsertPoint(bufPtr), str, len); bufPtr->nextAdded += len; if (statePtr->inQueueHead == NULL) { @@ -6759,7 +6826,7 @@ GetInput( * eofchar. */ - assert( !GotFlag(statePtr, CHANNEL_STICKY_EOF) ); + assert(!GotFlag(statePtr, CHANNEL_STICKY_EOF)); /* * Prevent reading from a dead channel -- a channel that has been closed @@ -6773,24 +6840,21 @@ GetInput( } /* - * WARNING: There was once a comment here claiming that it was - * a bad idea to make another call to the inputproc of a channel - * driver when EOF has already been detected on the channel. Through - * much of Tcl's history, this warning was then completely negated - * by having all (most?) read paths clear the EOF setting before - * reaching here. So we had a guard that was never triggered. + * WARNING: There was once a comment here claiming that it was a bad idea + * to make another call to the inputproc of a channel driver when EOF has + * already been detected on the channel. Through much of Tcl's history, + * this warning was then completely negated by having all (most?) read + * paths clear the EOF setting before reaching here. So we had a guard + * that was never triggered. + * + * Don't be tempted to restore the guard. Even if EOF is set on the + * channel, continue through and call the inputproc again. This is the + * way to enable the ability to [read] again beyond the EOF, which seems a + * strange thing to do, but for which use cases exist [Tcl Bug 5adc350683] + * and which may even be essential for channels representing things like + * ttys or other devices where the stream might take the logical form of a + * series of 'files' separated by an EOF condition. * - * Don't be tempted to restore the guard. Even if EOF is set on - * the channel, continue through and call the inputproc again. This - * is the way to enable the ability to [read] again beyond the EOF, - * which seems a strange thing to do, but for which use cases exist - * [Tcl Bug 5adc350683] and which may even be essential for channels - * representing things like ttys or other devices where the stream - * might take the logical form of a series of 'files' separated by - * an EOF condition. - */ - - /* * First check for more buffers in the pushback area of the topmost * channel in the stack and use them. They can be the result of a * transformation which went away without reading all the information @@ -6798,7 +6862,6 @@ GetInput( */ if (chanPtr->inQueueHead != NULL) { - /* TODO: Tests to cover this. */ assert(statePtr->inQueueHead == NULL); @@ -6828,8 +6891,9 @@ GetInput( /* * Check the actual buffersize against the requested buffersize. - * Saved buffers of the wrong size are squashed. This is done - * to honor dynamic changes of the buffersize made by the user. + * Saved buffers of the wrong size are squashed. This is done to honor + * dynamic changes of the buffersize made by the user. + * * TODO: Tests to cover this. */ @@ -6908,7 +6972,7 @@ Tcl_Seek( * non-blocking mode after the seek. */ if (CheckChannelErrors(statePtr, TCL_WRITABLE | TCL_READABLE) != 0) { - return Tcl_LongAsWide(-1); + return -1; } /* @@ -6919,7 +6983,7 @@ Tcl_Seek( */ if (CheckForDeadChannel(NULL, statePtr)) { - return Tcl_LongAsWide(-1); + return -1; } /* @@ -6935,7 +6999,7 @@ Tcl_Seek( if (chanPtr->typePtr->seekProc == NULL) { Tcl_SetErrno(EINVAL); - return Tcl_LongAsWide(-1); + return -1; } /* @@ -6948,7 +7012,7 @@ Tcl_Seek( if ((inputBuffered != 0) && (outputBuffered != 0)) { Tcl_SetErrno(EFAULT); - return Tcl_LongAsWide(-1); + return -1; } /* @@ -6991,7 +7055,7 @@ Tcl_Seek( wasAsync = 1; result = StackSetBlockMode(chanPtr, TCL_MODE_BLOCKING); if (result != 0) { - return Tcl_LongAsWide(-1); + return -1; } ResetFlag(statePtr, CHANNEL_NONBLOCKING); if (GotFlag(statePtr, BG_FLUSH_SCHEDULED)) { @@ -7016,7 +7080,7 @@ Tcl_Seek( */ curPos = ChanSeek(chanPtr, offset, mode, &result); - if (curPos == Tcl_LongAsWide(-1)) { + if (curPos == -1) { Tcl_SetErrno(result); } } @@ -7032,7 +7096,7 @@ Tcl_Seek( SetFlag(statePtr, CHANNEL_NONBLOCKING); result = StackSetBlockMode(chanPtr, TCL_MODE_NONBLOCKING); if (result != 0) { - return Tcl_LongAsWide(-1); + return -1; } } @@ -7072,7 +7136,7 @@ Tcl_Tell( Tcl_WideInt curPos; /* Position on device. */ if (CheckChannelErrors(statePtr, TCL_WRITABLE | TCL_READABLE) != 0) { - return Tcl_LongAsWide(-1); + return -1; } /* @@ -7083,7 +7147,7 @@ Tcl_Tell( */ if (CheckForDeadChannel(NULL, statePtr)) { - return Tcl_LongAsWide(-1); + return -1; } /* @@ -7099,7 +7163,7 @@ Tcl_Tell( if (chanPtr->typePtr->seekProc == NULL) { Tcl_SetErrno(EINVAL); - return Tcl_LongAsWide(-1); + return -1; } /* @@ -7116,10 +7180,10 @@ Tcl_Tell( * wideSeekProc if that is available and non-NULL... */ - curPos = ChanSeek(chanPtr, Tcl_LongAsWide(0), SEEK_CUR, &result); - if (curPos == Tcl_LongAsWide(-1)) { + curPos = ChanSeek(chanPtr, 0, SEEK_CUR, &result); + if (curPos == -1) { Tcl_SetErrno(result); - return Tcl_LongAsWide(-1); + return -1; } if (inputBuffered != 0) { @@ -7131,53 +7195,12 @@ 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. * * Results: - * TCL_OK on success, TCL_ERROR if the operation failed (e.g. is not + * TCL_OK on success, TCL_ERROR if the operation failed (e.g., is not * supported by the type of channel, or the underlying OS operation * failed in some way). * @@ -8459,9 +8482,9 @@ UpdateInterest( * * - Tcl drops READABLE here, because it has data in its own * buffers waiting to be read by the extension. - * - A READABLE event is syntesized via timer. + * - A READABLE event is synthesized via timer. * - The OS still reports the EXCEPTION condition on the file. - * - And the extension gets the EXCPTION event first, and handles + * - And the extension gets the EXCEPTION event first, and handles * this as EOF. * * End result ==> Premature end of reading from a file. @@ -8487,6 +8510,16 @@ UpdateInterest( } } } + + if (!statePtr->timer + && mask & TCL_WRITABLE + && GotFlag(statePtr, CHANNEL_NONBLOCKING)) { + + statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, + ChannelTimerProc,chanPtr); + } + + ChanWatch(chanPtr, mask); } @@ -8515,6 +8548,21 @@ ChannelTimerProc( ChannelState *statePtr = chanPtr->state; /* State info for channel */ + Tcl_Preserve(statePtr); + statePtr->timer = NULL; + if (statePtr->interestMask & TCL_WRITABLE + && GotFlag(statePtr, CHANNEL_NONBLOCKING) + && !GotFlag(statePtr, BG_FLUSH_SCHEDULED) + ) { + /* + * Restart the timer in case a channel handler reenters the event loop + * before UpdateInterest gets called by Tcl_NotifyChannel. + */ + statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, + ChannelTimerProc,chanPtr); + Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_WRITABLE); + } + if (!GotFlag(statePtr, CHANNEL_NEED_MORE_DATA) && (statePtr->interestMask & TCL_READABLE) && (statePtr->inQueueHead != NULL) @@ -8526,13 +8574,11 @@ ChannelTimerProc( statePtr->timer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, ChannelTimerProc,chanPtr); - Tcl_Preserve(statePtr); Tcl_NotifyChannel((Tcl_Channel) chanPtr, TCL_READABLE); - Tcl_Release(statePtr); } else { - statePtr->timer = NULL; UpdateInterest(chanPtr); } + Tcl_Release(statePtr); } /* @@ -9032,6 +9078,7 @@ ZeroTransferTimerProc( *---------------------------------------------------------------------- */ +#if !defined(TCL_NO_DEPRECATED) int TclCopyChannelOld( Tcl_Interp *interp, /* Current interpreter. */ @@ -9043,6 +9090,7 @@ TclCopyChannelOld( return TclCopyChannel(interp, inChan, outChan, (Tcl_WideInt) toRead, cmdPtr); } +#endif int TclCopyChannel( @@ -9537,7 +9585,10 @@ CopyData( } if (size == 0) { if (!GotFlag(inStatePtr, CHANNEL_NONBLOCKING)) { - /* We allowed a short read. Keep trying. */ + /* + * We allowed a short read. Keep trying. + */ + continue; } if (bufObj != NULL) { @@ -9751,7 +9802,7 @@ DoRead( ChannelState *statePtr = chanPtr->state; char *p = dst; - assert (bytesToRead >= 0); + assert(bytesToRead >= 0); /* * Early out when we know a read will get the eofchar. @@ -9767,15 +9818,18 @@ DoRead( if (GotFlag(statePtr, CHANNEL_STICKY_EOF)) { SetFlag(statePtr, CHANNEL_EOF); - assert( statePtr->inputEncodingFlags & TCL_ENCODING_END ); - assert( !GotFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR) ); + assert(statePtr->inputEncodingFlags & TCL_ENCODING_END); + assert(!GotFlag(statePtr, CHANNEL_BLOCKED|INPUT_SAW_CR)); /* TODO: Don't need this call */ UpdateInterest(chanPtr); return 0; } - /* Special handling for zero-char read request. */ + /* + * Special handling for zero-char read request. + */ + if (bytesToRead == 0) { if (GotFlag(statePtr, CHANNEL_EOF)) { statePtr->inputEncodingFlags |= TCL_ENCODING_START; @@ -9790,8 +9844,8 @@ DoRead( TclChannelPreserve((Tcl_Channel)chanPtr); while (bytesToRead) { /* - * Each pass through the loop is intended to process up to - * one channel buffer. + * Each pass through the loop is intended to process up to one channel + * buffer. */ int bytesRead, bytesWritten; @@ -9803,33 +9857,39 @@ DoRead( while (!bufPtr || /* We got no buffer! OR */ (!IsBufferFull(bufPtr) && /* Our buffer has room AND */ - (BytesLeft(bufPtr) < bytesToRead) ) ) { - /* Not enough bytes in it - * yet to fill the dst */ + (BytesLeft(bufPtr) < bytesToRead))) { + /* Not enough bytes in it yet + * to fill the dst */ int code; moreData: code = GetInput(chanPtr); bufPtr = statePtr->inQueueHead; - assert (bufPtr != NULL); + assert(bufPtr != NULL); if (GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED)) { - /* Further reads cannot do any more */ + /* + * Further reads cannot do any more. + */ + break; } if (code) { - /* Read error */ + /* + * Read error + */ + UpdateInterest(chanPtr); TclChannelRelease((Tcl_Channel)chanPtr); return -1; } - assert (IsBufferFull(bufPtr)); + assert(IsBufferFull(bufPtr)); } - assert (bufPtr != NULL); + assert(bufPtr != NULL); bytesRead = BytesLeft(bufPtr); bytesWritten = bytesToRead; @@ -9844,8 +9904,8 @@ DoRead( /* * Buffer is not empty. How can that be? * - * 0) We stopped early because we got all the bytes - * we were seeking. That's fine. + * 0) We stopped early because we got all the bytes we were + * seeking. That's fine. */ if (bytesToRead == 0) { @@ -9861,8 +9921,8 @@ DoRead( } /* - * 2) The buffer holds a \r while in CRLF translation, - * followed by the end of the buffer. + * 2) The buffer holds a \r while in CRLF translation, followed by + * the end of the buffer. */ assert(statePtr->inputTranslation == TCL_TRANSLATE_CRLF); @@ -9870,26 +9930,38 @@ DoRead( assert(BytesLeft(bufPtr) == 1); if (bufPtr->nextPtr == NULL) { - /* There's no more buffered data.... */ + /* + * There's no more buffered data... + */ if (statePtr->flags & CHANNEL_EOF) { - /* ...and there never will be. */ + /* + * ...and there never will be. + */ *p++ = '\r'; bytesToRead--; bufPtr->nextRemoved++; } else if (statePtr->flags & CHANNEL_BLOCKED) { - /* ...and we cannot get more now. */ + /* + * ...and we cannot get more now. + */ + SetFlag(statePtr, CHANNEL_NEED_MORE_DATA); break; } else { - /* ... so we need to get some. */ + /* + * ...so we need to get some. + */ + goto moreData; } } if (bufPtr->nextPtr) { - /* There's a next buffer. Shift orphan \r to it. */ + /* + * There's a next buffer. Shift orphan \r to it. + */ ChannelBuffer *nextPtr = bufPtr->nextPtr; @@ -9914,8 +9986,8 @@ DoRead( } /* - * When there's no buffered data to read, and we're at EOF, - * escape to the caller. + * When there's no buffered data to read, and we're at EOF, escape to + * the caller. */ if (GotFlag(statePtr, CHANNEL_EOF) @@ -9927,11 +9999,11 @@ DoRead( ResetFlag(statePtr, CHANNEL_BLOCKED); } - assert(!GotFlag(statePtr, CHANNEL_EOF) - || GotFlag(statePtr, CHANNEL_STICKY_EOF) - || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0); - assert( !(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED) - == (CHANNEL_EOF|CHANNEL_BLOCKED)) ); + assert(!GotFlag(statePtr, CHANNEL_EOF) + || GotFlag(statePtr, CHANNEL_STICKY_EOF) + || Tcl_InputBuffered((Tcl_Channel)chanPtr) == 0); + assert(!(GotFlag(statePtr, CHANNEL_EOF|CHANNEL_BLOCKED) + == (CHANNEL_EOF|CHANNEL_BLOCKED))); UpdateInterest(chanPtr); TclChannelRelease((Tcl_Channel)chanPtr); return (int)(p - dst); @@ -11168,11 +11240,11 @@ DupChannelIntRep( register Tcl_Obj *copyPtr) /* Object with internal rep to set. Must not * currently have an internal rep.*/ { - ResolvedChanName *resPtr = srcPtr->internalRep.twoPtrValue.ptr1; + ResolvedChanName *resPtr; - resPtr->refCount++; - copyPtr->internalRep.twoPtrValue.ptr1 = resPtr; - copyPtr->typePtr = srcPtr->typePtr; + ChanGetIntRep(srcPtr, resPtr); + assert(resPtr); + ChanSetIntRep(copyPtr, resPtr); } /* @@ -11195,10 +11267,11 @@ static void FreeChannelIntRep( Tcl_Obj *objPtr) /* Object with internal rep to free. */ { - ResolvedChanName *resPtr = objPtr->internalRep.twoPtrValue.ptr1; + ResolvedChanName *resPtr; - objPtr->typePtr = NULL; - if (--resPtr->refCount) { + ChanGetIntRep(objPtr, resPtr); + assert(resPtr); + if (resPtr->refCount-- > 1) { return; } Tcl_Release(resPtr->statePtr); diff --git a/generic/tclIO.h b/generic/tclIO.h index ffbfa31..d10f268 100644 --- a/generic/tclIO.h +++ b/generic/tclIO.h @@ -50,7 +50,7 @@ typedef struct ChannelBuffer { * structure. */ } ChannelBuffer; -#define CHANNELBUFFER_HEADER_SIZE TclOffset(ChannelBuffer, buf) +#define CHANNELBUFFER_HEADER_SIZE offsetof(ChannelBuffer, buf) /* * How much extra space to allocate in buffer to hold bytes from previous @@ -96,7 +96,7 @@ typedef struct EventScriptRecord { typedef struct Channel { struct ChannelState *state; /* Split out state information */ - ClientData instanceData; /* Instance-specific data provided by creator + void *instanceData; /* Instance-specific data provided by creator * of channel. */ const Tcl_ChannelType *typePtr; /* Pointer to channel type structure. */ struct Channel *downChanPtr;/* Refers to channel this one was stacked @@ -214,7 +214,7 @@ typedef struct ChannelState { * because it happened in the background. The * value is the chanMg, if any. #219's * companion to 'unreportedError'. */ - int epoch; /* Used to test validity of stored channelname + size_t epoch; /* Used to test validity of stored channelname * lookup results. */ } ChannelState; diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index 834f225..271fc57 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -16,7 +16,7 @@ */ typedef struct AcceptCallback { - char *script; /* Script to invoke. */ + Tcl_Obj *script; /* Script to invoke. */ Tcl_Interp *interp; /* Interpreter in which to run it. */ } AcceptCallback; @@ -25,7 +25,7 @@ typedef struct AcceptCallback { * It must be per-thread because of std channel limitations. */ -typedef struct ThreadSpecificData { +typedef struct { int initialized; /* Set to 1 when the module is initialized. */ Tcl_Obj *stdoutObjPtr; /* Cached stdout channel Tcl_Obj */ } ThreadSpecificData; @@ -37,8 +37,7 @@ static Tcl_ThreadDataKey dataKey; */ static void FinalizeIOCmdTSD(ClientData clientData); -static void AcceptCallbackProc(ClientData callbackData, - Tcl_Channel chan, char *address, int port); +static Tcl_TcpAcceptProc AcceptCallbackProc; static int ChanPendingObjCmd(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -114,7 +113,6 @@ Tcl_PutsObjCmd( int newline; /* Add a newline at end? */ int result; /* Result of puts operation. */ int mode; /* Mode in which channel is opened. */ - ThreadSpecificData *tsdPtr; switch (objc) { case 2: /* [puts $x] */ @@ -139,7 +137,7 @@ Tcl_PutsObjCmd( chanObjPtr = objv[2]; string = objv[3]; break; -#if TCL_MAJOR_VERSION < 9 +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 } else if (strcmp(TclGetString(objv[3]), "nonewline") == 0) { /* * The code below provides backwards compatibility with an old @@ -161,7 +159,7 @@ Tcl_PutsObjCmd( } if (chanObjPtr == NULL) { - tsdPtr = TCL_TSD_INIT(&dataKey); + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!tsdPtr->initialized) { tsdPtr->initialized = 1; @@ -441,7 +439,7 @@ Tcl_ReadObjCmd( if (i < objc) { if ((TclGetIntFromObj(interp, objv[i], &toRead) != TCL_OK) || (toRead < 0)) { -#if TCL_MAJOR_VERSION < 9 +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 /* * The code below provides backwards compatibility with an old * form of the command that is no longer recommended or @@ -456,7 +454,7 @@ Tcl_ReadObjCmd( TclGetString(objv[i]))); Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", NULL); return TCL_ERROR; -#if TCL_MAJOR_VERSION < 9 +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 } newline = 1; #endif @@ -561,7 +559,7 @@ Tcl_SeekObjCmd( TclChannelPreserve(chan); result = Tcl_Seek(chan, offset, mode); - if (result == Tcl_LongAsWide(-1)) { + if (result == -1) { /* * TIP #219. * Capture error messages put by the driver into the bypass area and @@ -954,7 +952,7 @@ Tcl_ExecObjCmd( */ argc = objc - skip; - argv = TclStackAlloc(interp, (unsigned)(argc + 1) * sizeof(char *)); + argv = TclStackAlloc(interp, (argc + 1) * sizeof(char *)); /* * Copy the string conversions of each (post option) object into the @@ -993,7 +991,7 @@ Tcl_ExecObjCmd( resultPtr = Tcl_NewObj(); if (Tcl_GetChannelHandle(chan, TCL_READABLE, NULL) == TCL_OK) { - if (Tcl_ReadChars(chan, resultPtr, -1, 0) < 0) { + if (Tcl_ReadChars(chan, resultPtr, -1, 0) == TCL_IO_FAILURE) { /* * TIP #219. * Capture error messages put by the driver into the bypass area @@ -1373,15 +1371,22 @@ AcceptCallbackProc( */ if (acceptCallbackPtr->interp != NULL) { - char portBuf[TCL_INTEGER_SPACE]; - char *script = acceptCallbackPtr->script; Tcl_Interp *interp = acceptCallbackPtr->interp; - int result; + Tcl_Obj *script, *objv[2]; + int result = TCL_OK; - Tcl_Preserve(script); - Tcl_Preserve(interp); + 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]); - TclFormatInt(portBuf, port); + Tcl_Preserve(interp); Tcl_RegisterChannel(interp, chan); /* @@ -1391,8 +1396,9 @@ AcceptCallbackProc( Tcl_RegisterChannel(NULL, chan); - result = Tcl_VarEval(interp, script, " ", Tcl_GetChannelName(chan), - " ", address, " ", portBuf, NULL); + result = Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT|TCL_EVAL_GLOBAL); + Tcl_DecrRefCount(script); + if (result != TCL_OK) { Tcl_BackgroundException(interp, result); Tcl_UnregisterChannel(interp, chan); @@ -1406,7 +1412,6 @@ 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 @@ -1450,7 +1455,7 @@ TcpServerCloseProc( UnregisterTcpServerInterpCleanupProc(acceptCallbackPtr->interp, acceptCallbackPtr); } - Tcl_EventuallyFree(acceptCallbackPtr->script, TCL_DYNAMIC); + Tcl_DecrRefCount(acceptCallbackPtr->script); ckfree(acceptCallbackPtr); } @@ -1479,13 +1484,18 @@ Tcl_SocketObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { static const char *const socketOptions[] = { - "-async", "-myaddr", "-myport", "-server", NULL + "-async", "-myaddr", "-myport", "-reuseaddr", "-reuseport", "-server", + NULL }; enum socketOptions { - SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_SERVER + SKT_ASYNC, SKT_MYADDR, SKT_MYPORT, SKT_REUSEADDR, SKT_REUSEPORT, + SKT_SERVER }; - int optionIndex, a, server = 0, port, myport = 0, async = 0; - const char *host, *script = NULL, *myaddr = NULL; + int optionIndex, a, server = 0, myport = 0, async = 0, reusep = -1, + reusea = -1; + unsigned int flags = 0; + const char *host, *port, *myaddr = NULL; + Tcl_Obj *script = NULL; Tcl_Channel chan; if (TclpHasSockets(interp) != TCL_OK) { @@ -1548,7 +1558,29 @@ Tcl_SocketObjCmd( "no argument given for -server option", -1)); return TCL_ERROR; } - script = TclGetString(objv[a]); + script = objv[a]; + break; + case SKT_REUSEADDR: + a++; + if (a >= objc) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "no argument given for -reuseaddr option", -1)); + return TCL_ERROR; + } + if (Tcl_GetBooleanFromObj(interp, objv[a], &reusea) != TCL_OK) { + return TCL_ERROR; + } + break; + case SKT_REUSEPORT: + a++; + if (a >= objc) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "no argument given for -reuseport option", -1)); + return TCL_ERROR; + } + if (Tcl_GetBooleanFromObj(interp, objv[a], &reusep) != TCL_OK) { + return TCL_ERROR; + } break; default: Tcl_Panic("Tcl_SocketObjCmd: bad option index to SocketOptions"); @@ -1573,32 +1605,63 @@ Tcl_SocketObjCmd( "?-myaddr addr? ?-myport myport? ?-async? host port"); iPtr->flags |= INTERP_ALTERNATE_WRONG_ARGS; Tcl_WrongNumArgs(interp, 1, objv, - "-server command ?-myaddr addr? port"); + "-server command ?-reuseaddr boolean? ?-reuseport boolean? " + "?-myaddr addr? port"); return TCL_ERROR; } - if (a == objc-1) { - if (TclSockGetPort(interp, TclGetString(objv[a]), "tcp", - &port) != TCL_OK) { - return TCL_ERROR; - } - } else { + if (!server && (reusea != -1 || reusep != -1)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "options -reuseaddr and -reuseport are only valid for servers", + -1)); + return TCL_ERROR; + } + + /* + * Set the options to their default value if the user didn't override + * their value. + */ + + if (reusep == -1) { + reusep = 0; + } + if (reusea == -1) { + reusea = 1; + } + + /* + * Build the bitset with the flags values. + */ + + if (reusea) { + flags |= TCL_TCPSERVER_REUSEADDR; + } + if (reusep) { + flags |= TCL_TCPSERVER_REUSEPORT; + } + + /* + * All the arguments should have been parsed by now, 'a' points to the + * last one, the port number. + */ + + if (a != objc-1) { goto wrongNumArgs; } + port = TclGetString(objv[a]); + if (server) { - AcceptCallback *acceptCallbackPtr = - ckalloc(sizeof(AcceptCallback)); - unsigned len = strlen(script) + 1; - char *copyScript = ckalloc(len); + AcceptCallback *acceptCallbackPtr = ckalloc(sizeof(AcceptCallback)); - memcpy(copyScript, script, len); - acceptCallbackPtr->script = copyScript; + Tcl_IncrRefCount(script); + acceptCallbackPtr->script = script; acceptCallbackPtr->interp = interp; - chan = Tcl_OpenTcpServer(interp, port, host, AcceptCallbackProc, - acceptCallbackPtr); + + chan = Tcl_OpenTcpServerEx(interp, port, host, flags, + AcceptCallbackProc, acceptCallbackPtr); if (chan == NULL) { - ckfree(copyScript); + Tcl_DecrRefCount(script); ckfree(acceptCallbackPtr); return TCL_ERROR; } @@ -1620,7 +1683,13 @@ Tcl_SocketObjCmd( Tcl_CreateCloseHandler(chan, TcpServerCloseProc, acceptCallbackPtr); } else { - chan = Tcl_OpenTcpClient(interp, port, host, myaddr, myport, async); + int portNum; + + if (TclSockGetPort(interp, port, "tcp", &portNum) != TCL_OK) { + return TCL_ERROR; + } + + chan = Tcl_OpenTcpClient(interp, portNum, host, myaddr, myport, async); if (chan == NULL) { return TCL_ERROR; } @@ -1844,7 +1913,7 @@ ChanTruncateObjCmd( */ length = Tcl_Tell(chan); - if (length == Tcl_WideAsLong(-1)) { + if (length == -1) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "could not determine current location in \"%s\": %s", TclGetString(objv[1]), Tcl_PosixError(interp))); diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c index 7f61def..9949a0e 100644 --- a/generic/tclIOGT.c +++ b/generic/tclIOGT.c @@ -211,7 +211,7 @@ struct TransformChannelData { * a transformation of incoming data. Also * serves as buffer of all data not yet * consumed by the reader. */ - int refCount; + size_t refCount; }; static void @@ -225,7 +225,7 @@ static void ReleaseData( TransformChannelData *dataPtr) { - if (--dataPtr->refCount) { + if (dataPtr->refCount-- > 1) { return; } ResultClear(&dataPtr->result); @@ -910,7 +910,7 @@ TransformWideSeekProc( Tcl_ChannelWideSeekProc(parentType); ClientData parentData = Tcl_GetChannelInstanceData(parent); - if ((offset == Tcl_LongAsWide(0)) && (mode == SEEK_CUR)) { + if ((offset == 0) && (mode == SEEK_CUR)) { /* * This is no seek but a request to tell the caller the current * location. Simply pass the request down. @@ -920,8 +920,7 @@ TransformWideSeekProc( return parentWideSeekProc(parentData, offset, mode, errorCodePtr); } - return Tcl_LongAsWide(parentSeekProc(parentData, 0, mode, - errorCodePtr)); + return parentSeekProc(parentData, 0, mode, errorCodePtr); } /* @@ -961,13 +960,13 @@ TransformWideSeekProc( * to go out of the representable range. */ - if (offset<Tcl_LongAsWide(LONG_MIN) || offset>Tcl_LongAsWide(LONG_MAX)) { + if (offset<LONG_MIN || offset>LONG_MAX) { *errorCodePtr = EOVERFLOW; - return Tcl_LongAsWide(-1); + return -1; } - return Tcl_LongAsWide(parentSeekProc(parentData, Tcl_WideAsLong(offset), - mode, errorCodePtr)); + return parentSeekProc(parentData, offset, + mode, errorCodePtr); } /* diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index e862761..23049fb 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -39,7 +39,7 @@ static int ReflectOutput(ClientData clientData, const char *buf, int toWrite, int *errorCodePtr); static void ReflectWatch(ClientData clientData, int mask); static int ReflectBlock(ClientData clientData, int mode); -#ifdef TCL_THREADS +#if TCL_THREADS static void ReflectThread(ClientData clientData, int action); static int ReflectEventRun(Tcl_Event *ev, int flags); static int ReflectEventDelete(Tcl_Event *ev, ClientData cd); @@ -54,6 +54,8 @@ static int ReflectGetOption(ClientData clientData, static int ReflectSetOption(ClientData clientData, Tcl_Interp *interp, const char *optionName, const char *newValue); +static void TimerRunRead(ClientData clientData); +static void TimerRunWrite(ClientData clientData); /* * The C layer channel type/driver definition used by the reflection. This is @@ -76,7 +78,7 @@ static const Tcl_ChannelType tclRChannelType = { NULL, /* Flush channel. Not used by core. NULL'able */ NULL, /* Handle events. NULL'able */ ReflectSeekWide, /* Move access point (64 bit). NULL'able */ -#ifdef TCL_THREADS +#if TCL_THREADS ReflectThread, /* thread action, tracking owner */ #else NULL, /* thread action */ @@ -97,7 +99,7 @@ typedef struct { * interpreter/thread containing its Tcl * command is gone. */ -#ifdef TCL_THREADS +#if TCL_THREADS Tcl_ThreadId thread; /* Thread the 'interp' belongs to. == Handler thread */ Tcl_ThreadId owner; /* Thread owning the structure. == Channel thread */ #endif @@ -112,6 +114,17 @@ typedef struct { int dead; /* Boolean signal that some operations * should no longer be attempted. */ + Tcl_TimerToken readTimer; /* + A token for the timer that is scheduled in + order to call Tcl_NotifyChannel when the + channel is readable + */ + Tcl_TimerToken writeTimer; /* + A token for the timer that is scheduled in + order to call Tcl_NotifyChannel when the + channel is writable + */ + /* * Note regarding the usage of timers. * @@ -121,11 +134,9 @@ typedef struct { * * See 'rechan', 'memchan', etc. * - * Here this is _not_ required. Interest in events is posted to the Tcl - * level via 'watch'. And posting of events is possible from the Tcl level - * as well, via 'chan postevent'. This means that the generation of all - * events, fake or not, timer based or not, is completely in the hands of - * the Tcl level. Therefore no timer here. + * A timer is used here as well in order to ensure at least on pass through + * the event loop when a channel becomes ready. See issues 67a5eabbd3d1 and + * ef28eb1f1516. */ } ReflectedChannel; @@ -201,7 +212,7 @@ typedef enum { #define NEGIMPL(a,b) #define HAS(x,f) (x & FLAG(f)) -#ifdef TCL_THREADS +#if TCL_THREADS /* * Thread specific types and structures. * @@ -236,7 +247,7 @@ typedef enum { * sharing problems. */ -typedef struct ForwardParamBase { +typedef struct { int code; /* O: Ok/Fail of the cmd handler */ char *msgStr; /* O: Error message for handler failure */ int mustFree; /* O: True if msgStr is allocated, false if @@ -311,7 +322,7 @@ typedef struct ForwardingResult ForwardingResult; * General event structure, with reference to operation specific data. */ -typedef struct ForwardingEvent { +typedef struct { Tcl_Event event; /* Basic event data, has to be first item */ ForwardingResult *resultPtr; ForwardedOperation op; /* Forwarded driver operation */ @@ -348,7 +359,7 @@ struct ForwardingResult { * results. */ }; -typedef struct ThreadSpecificData { +typedef struct { /* * Table of all reflected channels owned by this thread. This is the * per-thread version of the per-interpreter map. @@ -451,7 +462,7 @@ static const char *msg_read_toomuch = "{read delivered more than requested}"; static const char *msg_write_toomuch = "{write wrote more than requested}"; static const char *msg_write_nothing = "{write wrote nothing}"; static const char *msg_seek_beforestart = "{Tried to seek before origin}"; -#ifdef TCL_THREADS +#if TCL_THREADS static const char *msg_send_originlost = "{Channel thread lost}"; #endif /* TCL_THREADS */ static const char *msg_send_dstlost = "{Owner lost}"; @@ -593,7 +604,7 @@ TclChanCreateObjCmd( if (Tcl_ListObjGetElements(NULL, resObj, &listc, &listv) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s initialize\" returned non-list: %s", - Tcl_GetString(cmdObj), Tcl_GetString(resObj))); + TclGetString(cmdObj), TclGetString(resObj))); Tcl_DecrRefCount(resObj); goto error; } @@ -619,35 +630,35 @@ TclChanCreateObjCmd( if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s\" does not support all required methods", - Tcl_GetString(cmdObj))); + TclGetString(cmdObj))); goto error; } if ((mode & TCL_READABLE) && !HAS(methods, METH_READ)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s\" lacks a \"read\" method", - Tcl_GetString(cmdObj))); + TclGetString(cmdObj))); goto error; } if ((mode & TCL_WRITABLE) && !HAS(methods, METH_WRITE)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s\" lacks a \"write\" method", - Tcl_GetString(cmdObj))); + TclGetString(cmdObj))); goto error; } if (!IMPLIES(HAS(methods, METH_CGET), HAS(methods, METH_CGETALL))) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s\" supports \"cget\" but not \"cgetall\"", - Tcl_GetString(cmdObj))); + TclGetString(cmdObj))); goto error; } if (!IMPLIES(HAS(methods, METH_CGETALL), HAS(methods, METH_CGET))) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s\" supports \"cgetall\" but not \"cget\"", - Tcl_GetString(cmdObj))); + TclGetString(cmdObj))); goto error; } @@ -706,7 +717,7 @@ TclChanCreateObjCmd( Tcl_Panic("TclChanCreateObjCmd: duplicate channel names"); } Tcl_SetHashValue(hPtr, chan); -#ifdef TCL_THREADS +#if TCL_THREADS rcmPtr = GetThreadReflectedChannelMap(); hPtr = Tcl_CreateHashEntry(&rcmPtr->map, chanPtr->state->channelName, &isNew); @@ -725,7 +736,7 @@ TclChanCreateObjCmd( Tcl_DecrRefCount(rcPtr->name); Tcl_DecrRefCount(rcPtr->methods); Tcl_DecrRefCount(rcPtr->cmd); - ckfree((char*) rcPtr); + ckfree(rcPtr); return TCL_ERROR; #undef MODE @@ -750,8 +761,8 @@ TclChanCreateObjCmd( *---------------------------------------------------------------------- */ -#ifdef TCL_THREADS -typedef struct ReflectEvent { +#if TCL_THREADS +typedef struct { Tcl_Event header; ReflectedChannel *rcPtr; int events; @@ -855,11 +866,12 @@ TclChanPostEventObjCmd( } /* - * Note that the search above subsumes several of the older checks, namely: + * Note that the search above subsumes several of the older checks, + * namely: * - * (1) Does the channel handle refer to a reflected channel ? + * (1) Does the channel handle refer to a reflected channel? * (2) Is the post event issued from the interpreter holding the handler - * of the reflected channel ? + * of the reflected channel? * * A successful search answers yes to both. Because the map holds only * handles of reflected channels, and only of such whose handler is @@ -916,11 +928,22 @@ TclChanPostEventObjCmd( * We have the channel and the events to post. */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rcPtr->owner == rcPtr->thread) { #endif - Tcl_NotifyChannel(chan, events); -#ifdef TCL_THREADS + if (events & TCL_READABLE) { + if (rcPtr->readTimer == NULL) { + rcPtr->readTimer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, + TimerRunRead, rcPtr); + } + } + if (events & TCL_WRITABLE) { + if (rcPtr->writeTimer == NULL) { + rcPtr->writeTimer = Tcl_CreateTimerHandler(SYNTHETIC_EVENT_TIME, + TimerRunWrite, rcPtr); + } + } +#if TCL_THREADS } else { ReflectEvent *ev = ckalloc(sizeof(ReflectEvent)); @@ -943,7 +966,8 @@ TclChanPostEventObjCmd( (void) GetThreadReflectedChannelMap(); - /* XXX Race condition !! + /* + * XXX Race condition !! * XXX The destination thread may not exist anymore already. * XXX (Delayed postevent executed after channel got removed). * XXX Can we detect this ? (check the validity of the owner threadid ?) @@ -966,6 +990,24 @@ TclChanPostEventObjCmd( #undef EVENT } +static void +TimerRunRead( + ClientData clientData) +{ + ReflectedChannel *rcPtr = clientData; + rcPtr->readTimer = NULL; + Tcl_NotifyChannel(rcPtr->chan, TCL_READABLE); +} + +static void +TimerRunWrite( + ClientData clientData) +{ + ReflectedChannel *rcPtr = clientData; + rcPtr->writeTimer = NULL; + Tcl_NotifyChannel(rcPtr->chan, TCL_WRITABLE); +} + /* * Channel error message marshalling utilities. */ @@ -1135,7 +1177,7 @@ ReflectClose( * if lost? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -1156,9 +1198,15 @@ ReflectClose( tctPtr = ((Channel *)rcPtr->chan)->typePtr; if (tctPtr && tctPtr != &tclRChannelType) { - ckfree((char *)tctPtr); + ckfree(tctPtr); ((Channel *)rcPtr->chan)->typePtr = NULL; } + if (rcPtr->readTimer != NULL) { + Tcl_DeleteTimerHandler(rcPtr->readTimer); + } + if (rcPtr->writeTimer != NULL) { + Tcl_DeleteTimerHandler(rcPtr->writeTimer); + } Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); return EOK; } @@ -1167,7 +1215,7 @@ ReflectClose( * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -1214,7 +1262,7 @@ ReflectClose( Tcl_DeleteHashEntry(hPtr); } } -#ifdef TCL_THREADS +#if TCL_THREADS rcmPtr = GetThreadReflectedChannelMap(); hPtr = Tcl_FindHashEntry(&rcmPtr->map, Tcl_GetChannelName(rcPtr->chan)); @@ -1225,8 +1273,14 @@ ReflectClose( #endif tctPtr = ((Channel *)rcPtr->chan)->typePtr; if (tctPtr && tctPtr != &tclRChannelType) { - ckfree((char *)tctPtr); - ((Channel *)rcPtr->chan)->typePtr = NULL; + ckfree(tctPtr); + ((Channel *)rcPtr->chan)->typePtr = NULL; + } + if (rcPtr->readTimer != NULL) { + Tcl_DeleteTimerHandler(rcPtr->readTimer); + } + if (rcPtr->writeTimer != NULL) { + Tcl_DeleteTimerHandler(rcPtr->writeTimer); } Tcl_EventuallyFree(rcPtr, (Tcl_FreeProc *) FreeReflectedChannel); return (result == TCL_OK) ? EOK : EINVAL; @@ -1265,7 +1319,7 @@ ReflectInput( * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -1276,7 +1330,10 @@ ReflectInput( if (p.base.code != TCL_OK) { if (p.base.code < 0) { - /* No error message, this is an errno signal. */ + /* + * No error message, this is an errno signal. + */ + *errorCodePtr = -p.base.code; } else { PassReceivedError(rcPtr->chan, &p); @@ -1321,7 +1378,7 @@ ReflectInput( *errorCodePtr = EOK; if (bytec > 0) { - memcpy(buf, bytev, (size_t) bytec); + memcpy(buf, bytev, bytec); } stop: @@ -1368,7 +1425,7 @@ ReflectOutput( * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -1379,7 +1436,10 @@ ReflectOutput( if (p.base.code != TCL_OK) { if (p.base.code < 0) { - /* No error message, this is an errno signal. */ + /* + * No error message, this is an errno signal. + */ + *errorCodePtr = -p.base.code; } else { PassReceivedError(rcPtr->chan, &p); @@ -1430,8 +1490,8 @@ ReflectOutput( if ((written == 0) && (toWrite > 0)) { /* - * The handler claims to have written nothing of what it was - * given. That is bad. + * The handler claims to have written nothing of what it was given. + * That is bad. */ SetChannelErrorStr(rcPtr->chan, msg_write_nothing); @@ -1494,7 +1554,7 @@ ReflectSeekWide( * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -1536,7 +1596,7 @@ ReflectSeekWide( goto invalid; } - if (newLoc < Tcl_LongAsWide(0)) { + if (newLoc < 0) { SetChannelErrorStr(rcPtr->chan, msg_seek_beforestart); goto invalid; } @@ -1568,7 +1628,7 @@ ReflectSeek( * routine. */ - return (int) ReflectSeekWide(clientData, Tcl_LongAsWide(offset), seekMode, + return ReflectSeekWide(clientData, offset, seekMode, errorCodePtr); } @@ -1617,7 +1677,7 @@ ReflectWatch( * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -1675,7 +1735,7 @@ ReflectBlock( * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -1711,7 +1771,7 @@ ReflectBlock( return errorNum; } -#ifdef TCL_THREADS +#if TCL_THREADS /* *---------------------------------------------------------------------- * @@ -1781,7 +1841,7 @@ ReflectSetOption( * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -1860,7 +1920,7 @@ ReflectGetOption( * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rcPtr->thread != Tcl_GetCurrentThread()) { int opcode; ForwardParam p; @@ -1950,7 +2010,7 @@ ReflectGetOption( goto error; } else { int len; - const char *str = Tcl_GetStringFromObj(resObj, &len); + const char *str = TclGetStringFromObj(resObj, &len); if (len) { TclDStringAppendLiteral(dsPtr, " "); @@ -2123,7 +2183,9 @@ NewReflectedChannel( rcPtr->chan = NULL; rcPtr->interp = interp; rcPtr->dead = 0; -#ifdef TCL_THREADS + rcPtr->readTimer = 0; + rcPtr->writeTimer = 0; +#if TCL_THREADS rcPtr->thread = Tcl_GetCurrentThread(); #endif rcPtr->mode = mode; @@ -2323,7 +2385,7 @@ InvokeTclMethod( if (result != TCL_ERROR) { int cmdLen; - const char *cmdString = Tcl_GetStringFromObj(cmd, &cmdLen); + const char *cmdString = TclGetStringFromObj(cmd, &cmdLen); Tcl_IncrRefCount(cmd); Tcl_ResetResult(rcPtr->interp); @@ -2377,8 +2439,8 @@ InvokeTclMethod( * None. * * Users: - * ReflectInput/Output(), to enable the signaling of EAGAIN - * on 0-sized short reads/writes. + * ReflectInput/Output(), to enable the signaling of EAGAIN on 0-sized + * short reads/writes. * *---------------------------------------------------------------------- */ @@ -2402,7 +2464,7 @@ ErrnoReturn( if (((Tcl_GetIntFromObj(rcPtr->interp, resObj, &code) != TCL_OK) || (code >= 0))) { - if (strcmp("EAGAIN", Tcl_GetString(resObj)) == 0) { + if (strcmp("EAGAIN", TclGetString(resObj)) == 0) { code = -EAGAIN; } else { code = 0; @@ -2498,7 +2560,7 @@ DeleteReflectedChannelMap( Tcl_HashEntry *hPtr; /* Search variable. */ ReflectedChannel *rcPtr; Tcl_Channel chan; -#ifdef TCL_THREADS +#if TCL_THREADS ForwardingResult *resultPtr; ForwardingEvent *evPtr; ForwardParam *paramPtr; @@ -2528,7 +2590,7 @@ DeleteReflectedChannelMap( Tcl_DeleteHashTable(&rcmPtr->map); ckfree(&rcmPtr->map); -#ifdef TCL_THREADS +#if TCL_THREADS /* * The origin interpreter for one or more reflected channels is gone. */ @@ -2564,7 +2626,10 @@ DeleteReflectedChannelMap( evPtr = resultPtr->evPtr; - /* Basic crash safety until this routine can get revised [3411310] */ + /* + * Basic crash safety until this routine can get revised [3411310] + */ + if (evPtr == NULL) { continue; } @@ -2611,7 +2676,7 @@ DeleteReflectedChannelMap( #endif } -#ifdef TCL_THREADS +#if TCL_THREADS /* *---------------------------------------------------------------------- * @@ -2679,8 +2744,8 @@ DeleteThreadReflectedChannelMap( /* * Go through the list of pending results and cancel all whose events were - * destined for this thread. While this is in progress we block any - * other access to the list of pending results. + * destined for this thread. While this is in progress we block any other + * access to the list of pending results. */ Tcl_MutexLock(&rcForwardMutex); @@ -2711,7 +2776,10 @@ DeleteThreadReflectedChannelMap( evPtr = resultPtr->evPtr; - /* Basic crash safety until this routine can get revised [3411310] */ + /* + * Basic crash safety until this routine can get revised [3411310] + */ + if (evPtr == NULL ) { continue; } @@ -2765,8 +2833,8 @@ ForwardOpToHandlerThread( const void *param) /* Arguments */ { /* - * Core of the communication from OWNER to HANDLER thread. - * The receiver is ForwardProc() below. + * Core of the communication from OWNER to HANDLER thread. The receiver is + * ForwardProc() below. */ Tcl_ThreadId dst = rcPtr->thread; @@ -2816,7 +2884,10 @@ ForwardOpToHandlerThread( */ TclSpliceIn(resultPtr, forwardList); - /* Do not unlock here. That is done by the ConditionWait */ + + /* + * Do not unlock here. That is done by the ConditionWait. + */ /* * Ensure cleanup of the event if the origin thread exits while this event @@ -2892,7 +2963,7 @@ ForwardProc( * Notes regarding access to the referenced data. * * In principle the data belongs to the originating thread (see - * evPtr->src), however this thread is currently blocked at (*), i.e. + * evPtr->src), however this thread is currently blocked at (*), i.e., * quiescent. Because of this we can treat the data as belonging to us, * without fear of race conditions. I.e. we can read and write as we like. * @@ -2991,7 +3062,7 @@ ForwardProc( paramPtr->input.toRead = -1; } else { if (bytec > 0) { - memcpy(paramPtr->input.buf, bytev, (size_t) bytec); + memcpy(paramPtr->input.buf, bytev, bytec); } paramPtr->input.toRead = bytec; } @@ -3062,7 +3133,7 @@ ForwardProc( Tcl_WideInt newLoc; if (Tcl_GetWideIntFromObj(interp, resObj, &newLoc) == TCL_OK) { - if (newLoc < Tcl_LongAsWide(0)) { + if (newLoc < 0) { ForwardSetStaticError(paramPtr, msg_seek_beforestart); paramPtr->seek.offset = -1; } else { @@ -3178,7 +3249,7 @@ ForwardProc( ForwardSetDynamicError(paramPtr, buf); } else { int len; - const char *str = Tcl_GetStringFromObj(resObj, &len); + const char *str = TclGetStringFromObj(resObj, &len); if (len) { TclDStringAppendLiteral(paramPtr->getOpt.value, " "); @@ -3277,11 +3348,11 @@ ForwardSetObjError( Tcl_Obj *obj) { int len; - const char *msgStr = Tcl_GetStringFromObj(obj, &len); + const char *msgStr = TclGetStringFromObj(obj, &len); len++; ForwardSetDynamicError(paramPtr, ckalloc(len)); - memcpy(paramPtr->base.msgStr, msgStr, (unsigned) len); + memcpy(paramPtr->base.msgStr, msgStr, len); } #endif diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c index af86ba5..8e24cf7 100644 --- a/generic/tclIORTrans.c +++ b/generic/tclIORTrans.c @@ -87,7 +87,7 @@ static const Tcl_ChannelType tclRTransformType = { * layers upon reading from the channel, plus the functions to manage such. */ -typedef struct _ResultBuffer_ { +typedef struct { unsigned char *buf; /* Reference to the buffer area. */ int allocated; /* Allocated size of the buffer area. */ int used; /* Number of bytes in the buffer, @@ -127,7 +127,7 @@ typedef struct { * in the argv, see below. The separate field * gives us direct access, needed when working * with the reflection maps. */ -#ifdef TCL_THREADS +#if TCL_THREADS Tcl_ThreadId thread; /* Thread the 'interp' belongs to. */ #endif @@ -220,7 +220,7 @@ typedef enum { #define NEGIMPL(a,b) #define HAS(x,f) (x & FLAG(f)) -#ifdef TCL_THREADS +#if TCL_THREADS /* * Thread specific types and structures. * @@ -253,7 +253,7 @@ typedef enum { * sharing problems. */ -typedef struct ForwardParamBase { +typedef struct { int code; /* O: Ok/Fail of the cmd handler */ char *msgStr; /* O: Error message for handler failure */ int mustFree; /* O: True if msgStr is allocated, false if @@ -298,7 +298,7 @@ typedef struct ForwardingResult ForwardingResult; * General event structure, with reference to operation specific data. */ -typedef struct ForwardingEvent { +typedef struct { Tcl_Event event; /* Basic event data, has to be first item */ ForwardingResult *resultPtr; ForwardedOperation op; /* Forwarded driver operation */ @@ -329,7 +329,7 @@ struct ForwardingResult { * results. */ }; -typedef struct ThreadSpecificData { +typedef struct { /* * Table of all reflected transformations owned by this thread. */ @@ -438,7 +438,7 @@ static void DeleteReflectedTransformMap(ClientData clientData, static const char *msg_read_unsup = "{read not supported by Tcl driver}"; static const char *msg_write_unsup = "{write not supported by Tcl driver}"; -#ifdef TCL_THREADS +#if TCL_THREADS static const char *msg_send_originlost = "{Channel thread lost}"; static const char *msg_send_dstlost = "{Owner lost}"; #endif /* TCL_THREADS */ @@ -554,7 +554,7 @@ TclChanPushObjCmd( */ chanObj = objv[CHAN]; - parentChan = Tcl_GetChannel(interp, Tcl_GetString(chanObj), &mode); + parentChan = Tcl_GetChannel(interp, TclGetString(chanObj), &mode); if (parentChan == NULL) { return TCL_ERROR; } @@ -608,7 +608,7 @@ TclChanPushObjCmd( if (Tcl_ListObjGetElements(NULL, resObj, &listc, &listv) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s initialize\" returned non-list: %s", - Tcl_GetString(cmdObj), Tcl_GetString(resObj))); + TclGetString(cmdObj), TclGetString(resObj))); Tcl_DecrRefCount(resObj); goto error; } @@ -619,7 +619,7 @@ TclChanPushObjCmd( "method", TCL_EXACT, &methIndex) != TCL_OK) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s initialize\" returned %s", - Tcl_GetString(cmdObj), + TclGetString(cmdObj), Tcl_GetString(Tcl_GetObjResult(interp)))); Tcl_DecrRefCount(resObj); goto error; @@ -633,7 +633,7 @@ TclChanPushObjCmd( if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s\" does not support all required methods", - Tcl_GetString(cmdObj))); + TclGetString(cmdObj))); goto error; } @@ -655,7 +655,7 @@ TclChanPushObjCmd( if (!mode) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s\" makes the channel inaccessible", - Tcl_GetString(cmdObj))); + TclGetString(cmdObj))); goto error; } @@ -666,14 +666,14 @@ TclChanPushObjCmd( if (!IMPLIES(HAS(methods, METH_DRAIN), HAS(methods, METH_READ))) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s\" supports \"drain\" but not \"read\"", - Tcl_GetString(cmdObj))); + TclGetString(cmdObj))); goto error; } if (!IMPLIES(HAS(methods, METH_FLUSH), HAS(methods, METH_WRITE))) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s\" supports \"flush\" but not \"write\"", - Tcl_GetString(cmdObj))); + TclGetString(cmdObj))); goto error; } @@ -694,14 +694,14 @@ TclChanPushObjCmd( */ rtmPtr = GetReflectedTransformMap(interp); - hPtr = Tcl_CreateHashEntry(&rtmPtr->map, Tcl_GetString(rtId), &isNew); + hPtr = Tcl_CreateHashEntry(&rtmPtr->map, TclGetString(rtId), &isNew); if (!isNew && rtPtr != Tcl_GetHashValue(hPtr)) { Tcl_Panic("TclChanPushObjCmd: duplicate transformation handle"); } Tcl_SetHashValue(hPtr, rtPtr); -#ifdef TCL_THREADS +#if TCL_THREADS rtmPtr = GetThreadReflectedTransformMap(); - hPtr = Tcl_CreateHashEntry(&rtmPtr->map, Tcl_GetString(rtId), &isNew); + hPtr = Tcl_CreateHashEntry(&rtmPtr->map, TclGetString(rtId), &isNew); Tcl_SetHashValue(hPtr, rtPtr); #endif /* TCL_THREADS */ @@ -911,7 +911,7 @@ ReflectClose( * if lost? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -938,7 +938,7 @@ ReflectClose( if (HAS(rtPtr->methods, METH_DRAIN) && !rtPtr->readIsDrained) { if (!TransformDrain(rtPtr, &errorCode)) { -#ifdef TCL_THREADS +#if TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { Tcl_EventuallyFree(rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); @@ -952,7 +952,7 @@ ReflectClose( if (HAS(rtPtr->methods, METH_FLUSH)) { if (!TransformFlush(rtPtr, &errorCode, FLUSH_WRITE)) { -#ifdef TCL_THREADS +#if TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { Tcl_EventuallyFree(rtPtr, (Tcl_FreeProc *) FreeReflectedTransform); @@ -968,7 +968,7 @@ ReflectClose( * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -1025,9 +1025,9 @@ ReflectClose( * under a channel by deleting the owning thread. */ -#ifdef TCL_THREADS +#if TCL_THREADS rtmPtr = GetThreadReflectedTransformMap(); - hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle)); + hPtr = Tcl_FindHashEntry(&rtmPtr->map, TclGetString(rtPtr->handle)); if (hPtr) { Tcl_DeleteHashEntry(hPtr); } @@ -1340,7 +1340,7 @@ ReflectSeekWide( if (seekProc == NULL) { Tcl_SetErrno(EINVAL); - return Tcl_LongAsWide(-1); + return -1; } /* @@ -1390,16 +1390,15 @@ ReflectSeekWide( parent->typePtr->wideSeekProc != NULL) { curPos = parent->typePtr->wideSeekProc(parent->instanceData, offset, seekMode, errorCodePtr); - } else if (offset < Tcl_LongAsWide(LONG_MIN) || - offset > Tcl_LongAsWide(LONG_MAX)) { + } else if (offset < LONG_MIN || offset > LONG_MAX) { *errorCodePtr = EOVERFLOW; - curPos = Tcl_LongAsWide(-1); + curPos = -1; } else { - curPos = Tcl_LongAsWide(parent->typePtr->seekProc( - parent->instanceData, Tcl_WideAsLong(offset), seekMode, - errorCodePtr)); + curPos = parent->typePtr->seekProc( + parent->instanceData, offset, seekMode, + errorCodePtr); } - if (curPos == Tcl_LongAsWide(-1)) { + if (curPos == -1) { Tcl_SetErrno(*errorCodePtr); } @@ -1422,7 +1421,7 @@ ReflectSeek( * routine. */ - return (int) ReflectSeekWide(clientData, Tcl_LongAsWide(offset), seekMode, + return ReflectSeekWide(clientData, offset, seekMode, errorCodePtr); } @@ -1767,7 +1766,7 @@ NewReflectedTransform( rtPtr->chan = NULL; rtPtr->methods = 0; -#ifdef TCL_THREADS +#if TCL_THREADS rtPtr->thread = Tcl_GetCurrentThread(); #endif rtPtr->parent = parentChan; @@ -2043,7 +2042,7 @@ InvokeTclMethod( if (result != TCL_ERROR) { Tcl_Obj *cmd = Tcl_NewListObj(cmdc, rtPtr->argv); int cmdLen; - const char *cmdString = Tcl_GetStringFromObj(cmd, &cmdLen); + const char *cmdString = TclGetStringFromObj(cmd, &cmdLen); Tcl_IncrRefCount(cmd); Tcl_ResetResult(rtPtr->interp); @@ -2152,7 +2151,7 @@ DeleteReflectedTransformMap( Tcl_HashSearch hSearch; /* Search variable. */ Tcl_HashEntry *hPtr; /* Search variable. */ ReflectedTransform *rtPtr; -#ifdef TCL_THREADS +#if TCL_THREADS ForwardingResult *resultPtr; ForwardingEvent *evPtr; ForwardParam *paramPtr; @@ -2182,7 +2181,7 @@ DeleteReflectedTransformMap( Tcl_DeleteHashTable(&rtmPtr->map); ckfree(&rtmPtr->map); -#ifdef TCL_THREADS +#if TCL_THREADS /* * The origin interpreter for one or more reflected channels is gone. */ @@ -2254,7 +2253,7 @@ DeleteReflectedTransformMap( #endif /* TCL_THREADS */ } -#ifdef TCL_THREADS +#if TCL_THREADS /* *---------------------------------------------------------------------- * @@ -2568,7 +2567,7 @@ ForwardProc( */ rtmPtr = GetReflectedTransformMap(interp); - hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle)); + hPtr = Tcl_FindHashEntry(&rtmPtr->map, TclGetString(rtPtr->handle)); Tcl_DeleteHashEntry(hPtr); /* @@ -2578,7 +2577,7 @@ ForwardProc( */ rtmPtr = GetThreadReflectedTransformMap(); - hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle)); + hPtr = Tcl_FindHashEntry(&rtmPtr->map, TclGetString(rtPtr->handle)); Tcl_DeleteHashEntry(hPtr); FreeReflectedTransformArgs(rtPtr); @@ -2608,7 +2607,7 @@ ForwardProc( if (bytec > 0) { paramPtr->transform.buf = ckalloc(bytec); - memcpy(paramPtr->transform.buf, bytev, (size_t)bytec); + memcpy(paramPtr->transform.buf, bytev, bytec); } else { paramPtr->transform.buf = NULL; } @@ -2642,7 +2641,7 @@ ForwardProc( if (bytec > 0) { paramPtr->transform.buf = ckalloc(bytec); - memcpy(paramPtr->transform.buf, bytev, (size_t)bytec); + memcpy(paramPtr->transform.buf, bytev, bytec); } else { paramPtr->transform.buf = NULL; } @@ -2671,7 +2670,7 @@ ForwardProc( if (bytec > 0) { paramPtr->transform.buf = ckalloc(bytec); - memcpy(paramPtr->transform.buf, bytev, (size_t)bytec); + memcpy(paramPtr->transform.buf, bytev, bytec); } else { paramPtr->transform.buf = NULL; } @@ -2698,7 +2697,7 @@ ForwardProc( if (bytec > 0) { paramPtr->transform.buf = ckalloc(bytec); - memcpy(paramPtr->transform.buf, bytev, (size_t)bytec); + memcpy(paramPtr->transform.buf, bytev, bytec); } else { paramPtr->transform.buf = NULL; } @@ -2807,11 +2806,11 @@ ForwardSetObjError( Tcl_Obj *obj) { int len; - const char *msgStr = Tcl_GetStringFromObj(obj, &len); + const char *msgStr = TclGetStringFromObj(obj, &len); len++; ForwardSetDynamicError(paramPtr, ckalloc(len)); - memcpy(paramPtr->base.msgStr, msgStr, (unsigned) len); + memcpy(paramPtr->base.msgStr, msgStr, len); } #endif /* TCL_THREADS */ @@ -2955,7 +2954,7 @@ ResultClear( return; } - ckfree((char *) rPtr->buf); + ckfree(rPtr->buf); rPtr->buf = NULL; rPtr->allocated = 0; } @@ -3088,7 +3087,7 @@ TransformRead( * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -3144,7 +3143,7 @@ TransformWrite( * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -3210,7 +3209,7 @@ TransformDrain( * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -3260,7 +3259,7 @@ TransformFlush( * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -3315,7 +3314,7 @@ TransformClear( * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; @@ -3347,7 +3346,7 @@ TransformLimit( * Are we in the correct thread? */ -#ifdef TCL_THREADS +#if TCL_THREADS if (rtPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c index c5b7d28..12e2900 100644 --- a/generic/tclIOSock.c +++ b/generic/tclIOSock.c @@ -11,17 +11,22 @@ #include "tclInt.h" -#if defined(_WIN32) && defined(UNICODE) -/* On Windows, we need to do proper Unicode->UTF-8 conversion. */ +#if defined(_WIN32) +/* + * On Windows, we need to do proper Unicode->UTF-8 conversion. + */ -typedef struct ThreadSpecificData { +typedef struct { int initialized; Tcl_DString errorMsg; /* UTF-8 encoded error-message */ } ThreadSpecificData; static Tcl_ThreadDataKey dataKey; #undef gai_strerror -static const char *gai_strerror(int code) { +static const char * +gai_strerror( + int code) +{ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (tsdPtr->initialized) { @@ -56,8 +61,8 @@ static const char *gai_strerror(int code) { int TclSockGetPort( Tcl_Interp *interp, - const char *string, /* Integer or service name */ - const char *proto, /* "tcp" or "udp", typically */ + const char *string, /* Integer or service name */ + const char *proto, /* "tcp" or "udp", typically */ int *portPtr) /* Return port number */ { struct servent *sp; /* Protocol info for named services */ @@ -126,7 +131,7 @@ TclSockMinimumBuffers( } len = sizeof(int); getsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_RCVBUF, - (char *) ¤t, &len); + (char *) ¤t, &len); if (current < size) { len = sizeof(int); setsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_RCVBUF, @@ -154,15 +159,15 @@ TclSockMinimumBuffers( int TclCreateSocketAddress( - Tcl_Interp *interp, /* Interpreter for querying - * the desired socket family */ - struct addrinfo **addrlist, /* Socket address list */ - const char *host, /* Host. NULL implies INADDR_ANY */ - int port, /* Port number */ - int willBind, /* Is this an address to bind() to or - * to connect() to? */ - const char **errorMsgPtr) /* Place to store the error message - * detail, if available. */ + Tcl_Interp *interp, /* Interpreter for querying the desired socket + * family */ + struct addrinfo **addrlist, /* Socket address list */ + const char *host, /* Host. NULL implies INADDR_ANY */ + int port, /* Port number */ + int willBind, /* Is this an address to bind() to or to + * connect() to? */ + const char **errorMsgPtr) /* Place to store the error message detail, if + * available. */ { struct addrinfo hints; struct addrinfo *p; @@ -181,30 +186,31 @@ TclCreateSocketAddress( * Workaround for OSX's apparent inability to resolve "localhost", "0" * when the loopback device is the only available network interface. */ + if (host != NULL && port == 0) { - portstring = NULL; + portstring = NULL; } else { - TclFormatInt(portbuf, port); - portstring = portbuf; + TclFormatInt(portbuf, port); + portstring = portbuf; } (void) memset(&hints, 0, sizeof(hints)); hints.ai_family = AF_UNSPEC; /* - * Magic variable to enforce a certain address family - to be superseded - * by a TIP that adds explicit switches to [socket] + * Magic variable to enforce a certain address family; to be superseded + * by a TIP that adds explicit switches to [socket]. */ if (interp != NULL) { - family = Tcl_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; - } - } + family = Tcl_GetVar2(interp, "::tcl::unsupported::socketAF", NULL, 0); + if (family != NULL) { + if (strcmp(family, "inet") == 0) { + hints.ai_family = AF_INET; + } else if (strcmp(family, "inet6") == 0) { + hints.ai_family = AF_INET6; + } + } } hints.ai_socktype = SOCK_STREAM; @@ -214,7 +220,7 @@ TclCreateSocketAddress( * We found some problems when using AI_ADDRCONFIG, e.g. on systems that * have no networking besides the loopback interface and want to resolve * localhost. See [Bugs 3385024, 3382419, 3382431]. As the advantage of - * using AI_ADDRCONFIG in situations where it works, is probably low, + * using AI_ADDRCONFIG is probably low even in situations where it works, * we'll leave it out for now. After all, it is just an optimisation. * * Missing on: OpenBSD, NetBSD. @@ -251,6 +257,7 @@ TclCreateSocketAddress( * * There might be more elegant/efficient ways to do this. */ + if (willBind) { for (p = *addrlist; p != NULL; p = p->ai_next) { if (p->ai_family == AF_INET) { @@ -283,6 +290,38 @@ TclCreateSocketAddress( } /* + *---------------------------------------------------------------------- + * + * Tcl_OpenTcpServer -- + * + * Opens a TCP server socket and creates a channel around it. + * + * Results: + * The channel or NULL if failed. If an error occurred, an error message + * is left in the interp's result if interp is not NULL. + * + * Side effects: + * Opens a server socket and creates a new channel. + * + *---------------------------------------------------------------------- + */ + +Tcl_Channel +Tcl_OpenTcpServer( + Tcl_Interp *interp, + int port, + const char *host, + Tcl_TcpAcceptProc *acceptProc, + ClientData callbackData) +{ + char portbuf[TCL_INTEGER_SPACE]; + + TclFormatInt(portbuf, port); + return Tcl_OpenTcpServerEx(interp, portbuf, host, TCL_TCPSERVER_REUSEADDR, + acceptProc, callbackData); +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 28b65ff..3773159 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -57,7 +57,7 @@ typedef struct FilesystemRecord { * this information each time the corresponding epoch counter changes. */ -typedef struct ThreadSpecificData { +typedef struct { int initialized; size_t cwdPathEpoch; size_t filesystemEpoch; @@ -244,7 +244,7 @@ static Tcl_ThreadDataKey fsDataKey; * code. */ -typedef struct FsDivertLoad { +typedef struct { Tcl_LoadHandle loadHandle; Tcl_FSUnloadFileProc *unloadProcPtr; Tcl_Obj *divertedFile; @@ -275,8 +275,8 @@ Tcl_Stat( Tcl_WideInt tmp1, tmp2, tmp3 = 0; # define OUT_OF_RANGE(x) \ - (((Tcl_WideInt)(x)) < Tcl_LongAsWide(LONG_MIN) || \ - ((Tcl_WideInt)(x)) > Tcl_LongAsWide(LONG_MAX)) + (((Tcl_WideInt)(x)) < LONG_MIN || \ + ((Tcl_WideInt)(x)) > LONG_MAX) # define OUT_OF_URANGE(x) \ (((Tcl_WideUInt)(x)) > ((Tcl_WideUInt)ULONG_MAX)) @@ -542,8 +542,8 @@ TclFSCwdPointerEquals( int len1, len2; const char *str1, *str2; - str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1); - str2 = Tcl_GetStringFromObj(*pathPtrPtr, &len2); + str1 = TclGetStringFromObj(tsdPtr->cwdPathPtr, &len1); + str2 = TclGetStringFromObj(*pathPtrPtr, &len2); if ((len1 == len2) && !memcmp(str1, str2, len1)) { /* * They are equal, but different objects. Update so they will be @@ -609,6 +609,7 @@ FsRecacheFilesystemList(void) while (toFree) { FilesystemRecord *next = toFree->nextPtr; + toFree->fsPtr = NULL; ckfree(toFree); toFree = next; @@ -670,7 +671,6 @@ TclFSEpoch(void) return tsdPtr->filesystemEpoch; } - /* * If non-NULL, clientData is owned by us and must be freed later. @@ -686,7 +686,7 @@ FsUpdateCwd( ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); if (cwdObj != NULL) { - str = Tcl_GetStringFromObj(cwdObj, &len); + str = TclGetStringFromObj(cwdObj, &len); } Tcl_MutexLock(&cwdMutex); @@ -782,7 +782,9 @@ TclFinalizeFilesystem(void) while (fsRecPtr != NULL) { FilesystemRecord *tmpFsRecPtr = fsRecPtr->nextPtr; - /* The native filesystem is static, so we don't free it. */ + /* + * The native filesystem is static, so we don't free it. + */ if (fsRecPtr != &nativeFilesystemRecord) { ckfree(fsRecPtr); @@ -827,15 +829,6 @@ TclResetFilesystem(void) if (++theFilesystemEpoch == 0) { ++theFilesystemEpoch; } - -#ifdef _WIN32 - /* - * Cleans up the win32 API filesystem proc lookup table. This must happen - * very late in finalization so that deleting of copied dlls can occur. - */ - - TclWinResetInterfaces(); -#endif } /* @@ -945,7 +938,7 @@ Tcl_FSRegister( int Tcl_FSUnregister( - const Tcl_Filesystem *fsPtr) /* The filesystem record to remove. */ + const Tcl_Filesystem *fsPtr)/* The filesystem record to remove. */ { int retVal = TCL_ERROR; FilesystemRecord *fsRecPtr; @@ -1222,8 +1215,8 @@ FsAddMountsToGlobResult( if (norm != NULL) { const char *path, *mount; - mount = Tcl_GetStringFromObj(mElt, &mlen); - path = Tcl_GetStringFromObj(norm, &len); + mount = TclGetStringFromObj(mElt, &mlen); + path = TclGetStringFromObj(norm, &len); if (path[len-1] == '/') { /* * Deal with the root of the volume. @@ -1231,7 +1224,7 @@ FsAddMountsToGlobResult( len--; } - len++; /* account for '/' in the mElt [Bug 1602539] */ + len++; /* account for '/' in the mElt [Bug 1602539] */ mElt = TclNewFSPathObj(pathPtr, mount + len, mlen - len); Tcl_ListObjAppendElement(NULL, resultPtr, mElt); } @@ -1397,31 +1390,62 @@ TclFSNormalizeToUniquePath( { FilesystemRecord *fsRecPtr, *firstFsRecPtr; + int i; + int isVfsPath = 0; + const char *path; + /* - * Call each of the "normalise path" functions in succession. This is a - * special case, in which if we have a native filesystem handler, we call - * it first. This is because the root of Tcl's filesystem is always a - * native filesystem (i.e. '/' on unix is native). + * Paths starting with a UNC prefix whose final character is a colon + * are reserved for VFS use. These names can not conflict with real + * UNC paths per https://msdn.microsoft.com/en-us/library/gg465305.aspx + * and rfc3986's definition of reg-name. + * + * We check these first to avoid useless calls to the native filesystem's + * normalizePathProc. */ + path = Tcl_GetStringFromObj(pathPtr, &i); + + if ( (i >= 3) && ( (path[0] == '/' && path[1] == '/') + || (path[0] == '\\' && path[1] == '\\') ) ) { + for ( i = 2; ; i++) { + if (path[i] == '\0') break; + if (path[i] == path[0]) break; + } + --i; + if (path[i] == ':') isVfsPath = 1; + } + /* + * Call each of the "normalise path" functions in succession. + */ firstFsRecPtr = FsGetFirstFilesystem(); Claim(); - for (fsRecPtr=firstFsRecPtr; fsRecPtr!=NULL; fsRecPtr=fsRecPtr->nextPtr) { - if (fsRecPtr->fsPtr != &tclNativeFilesystem) { - continue; - } + + if (!isVfsPath) { /* - * TODO: Assume that we always find the native file system; it should - * always be there... + * If we have a native filesystem handler, we call it first. This is + * because the root of Tcl's filesystem is always a native filesystem + * (i.e., '/' on unix is native). */ - if (fsRecPtr->fsPtr->normalizePathProc != NULL) { - startAt = fsRecPtr->fsPtr->normalizePathProc(interp, pathPtr, - startAt); + for (fsRecPtr=firstFsRecPtr; fsRecPtr!=NULL; fsRecPtr=fsRecPtr->nextPtr) { + if (fsRecPtr->fsPtr != &tclNativeFilesystem) { + continue; + } + + /* + * TODO: Assume that we always find the native file system; it should + * always be there... + */ + + if (fsRecPtr->fsPtr->normalizePathProc != NULL) { + startAt = fsRecPtr->fsPtr->normalizePathProc(interp, pathPtr, + startAt); + } + break; } - break; } for (fsRecPtr=firstFsRecPtr; fsRecPtr!=NULL; fsRecPtr=fsRecPtr->nextPtr) { @@ -1523,7 +1547,7 @@ TclGetOpenModeEx( #define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR) /* - * Check for the simpler fopen-like access modes (e.g. "r"). They are + * Check for the simpler fopen-like access modes (e.g., "r"). They are * distinguished from the POSIX access modes by the presence of a * lower-case first letter. */ @@ -1783,7 +1807,7 @@ Tcl_FSEvalFileEx( * be handled especially. */ - if (Tcl_ReadChars(chan, objPtr, 1, 0) < 0) { + if (Tcl_ReadChars(chan, objPtr, 1, 0) == TCL_IO_FAILURE) { Tcl_Close(interp, chan); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", @@ -1798,7 +1822,7 @@ Tcl_FSEvalFileEx( */ if (Tcl_ReadChars(chan, objPtr, -1, - memcmp(string, "\xef\xbb\xbf", 3)) < 0) { + memcmp(string, "\xef\xbb\xbf", 3)) == TCL_IO_FAILURE) { Tcl_Close(interp, chan); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", @@ -1814,7 +1838,7 @@ Tcl_FSEvalFileEx( oldScriptFile = iPtr->scriptFile; iPtr->scriptFile = pathPtr; Tcl_IncrRefCount(iPtr->scriptFile); - string = Tcl_GetStringFromObj(objPtr, &length); + string = TclGetStringFromObj(objPtr, &length); /* * TIP #280 Force the evaluator to open a frame for a sourced file. @@ -1841,7 +1865,7 @@ Tcl_FSEvalFileEx( * Record information telling where the error occurred. */ - const char *pathString = Tcl_GetStringFromObj(pathPtr, &length); + const char *pathString = TclGetStringFromObj(pathPtr, &length); int limit = 150; int overflow = (length > limit); @@ -1888,6 +1912,7 @@ TclNREvalFile( Tcl_GetString(pathPtr), Tcl_PosixError(interp))); return TCL_ERROR; } + TclPkgFileSeen(interp, Tcl_GetString(pathPtr)); /* * The eofchar is \32 (^Z). This is the usual on Windows, but we effect @@ -1917,7 +1942,7 @@ TclNREvalFile( * be handled especially. */ - if (Tcl_ReadChars(chan, objPtr, 1, 0) < 0) { + if (Tcl_ReadChars(chan, objPtr, 1, 0) == TCL_IO_FAILURE) { Tcl_Close(interp, chan); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", @@ -1933,7 +1958,7 @@ TclNREvalFile( */ if (Tcl_ReadChars(chan, objPtr, -1, - memcmp(string, "\xef\xbb\xbf", 3)) < 0) { + memcmp(string, "\xef\xbb\xbf", 3)) == TCL_IO_FAILURE) { Tcl_Close(interp, chan); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", @@ -1992,7 +2017,7 @@ EvalFileCallback( */ int length; - const char *pathString = Tcl_GetStringFromObj(pathPtr, &length); + const char *pathString = TclGetStringFromObj(pathPtr, &length); const int limit = 150; int overflow = (length > limit); @@ -2668,6 +2693,7 @@ Tcl_FSGetCwd( fsRecPtr = fsRecPtr->nextPtr) { ClientData retCd; TclFSGetCwdProc2 *proc2; + if (fsRecPtr->fsPtr->getCwdProc == NULL) { continue; } @@ -2844,8 +2870,8 @@ Tcl_FSGetCwd( int len1, len2; const char *str1, *str2; - str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1); - str2 = Tcl_GetStringFromObj(norm, &len2); + str1 = TclGetStringFromObj(tsdPtr->cwdPathPtr, &len1); + str2 = TclGetStringFromObj(norm, &len2); if ((len1 == len2) && (strcmp(str1, str2) == 0)) { /* * If the paths were equal, we can be more efficient and @@ -3140,8 +3166,8 @@ Tcl_FSLoadFile( * Workaround for issue with modern HPUX which do allow the unlink (no ETXTBSY * error) yet somehow trash some internal data structures which prevents the * second and further shared libraries from getting properly loaded. Only the - * first is ok. We try to get around the issue by not unlinking, - * i.e. emulating the behaviour of the older HPUX which denied removal. + * first is ok. We try to get around the issue by not unlinking, i.e., + * emulating the behaviour of the older HPUX which denied removal. * * Doing the unlink is also an issue within docker containers, whose AUFS * bungles this as well, see @@ -3159,28 +3185,30 @@ Tcl_FSLoadFile( */ static int -skipUnlink (Tcl_Obj* shlibFile) +skipUnlink( + Tcl_Obj *shlibFile) { - /* Order of testing: + /* + * Order of testing: * 1. On hpux we generally want to skip unlink in general * * Outside of hpux then: - * 2. For a general user request (TCL_TEMPLOAD_NO_UNLINK present, non-empty, => int) + * 2. For a general user request (TCL_TEMPLOAD_NO_UNLINK present, + * non-empty, => int) * 3. For general AUFS environment (statfs, if available). * * Ad 2: This variable can disable/override the AUFS detection, i.e. for - * testing if a newer AUFS does not have the bug any more. + * testing if a newer AUFS does not have the bug any more. * - * Ad 3: This is conditionally compiled in. Condition currently must be set manually. - * This part needs proper tests in the configure(.in). + * Ad 3: This is conditionally compiled in. Condition currently must be + * set manually. This part needs proper tests in the configure(.in). */ #ifdef hpux return 1; #else - char* skipstr; + char *skipstr = getenv("TCL_TEMPLOAD_NO_UNLINK"); - skipstr = getenv ("TCL_TEMPLOAD_NO_UNLINK"); if (skipstr && (skipstr[0] != '\0')) { return atoi(skipstr); } @@ -3189,7 +3217,8 @@ skipUnlink (Tcl_Obj* shlibFile) #ifndef NO_FSTATFS { struct statfs fs; - /* Have fstatfs. May not have the AUFS super magic ... Indeed our build + /* + * Have fstatfs. May not have the AUFS super magic ... Indeed our build * box is too old to have it directly in the headers. Define taken from * http://mooon.googlecode.com/svn/trunk/linux_include/linux/aufs_type.h * http://aufs.sourceforge.net/ @@ -3198,16 +3227,18 @@ skipUnlink (Tcl_Obj* shlibFile) #ifndef AUFS_SUPER_MAGIC #define AUFS_SUPER_MAGIC ('a' << 24 | 'u' << 16 | 'f' << 8 | 's') #endif /* AUFS_SUPER_MAGIC */ - if ((statfs(Tcl_GetString (shlibFile), &fs) == 0) && - (fs.f_type == AUFS_SUPER_MAGIC)) { + if ((statfs(Tcl_GetString(shlibFile), &fs) == 0) + && (fs.f_type == AUFS_SUPER_MAGIC)) { return 1; } } #endif /* ... NO_FSTATFS */ #endif /* ... TCL_TEMPLOAD_NO_UNLINK */ - /* Fallback: !hpux, no EV override, no AUFS (detection, nor detected): - * Don't skip */ + /* + * Fallback: !hpux, no EV override, no AUFS (detection, nor detected): + * Don't skip + */ return 0; #endif /* hpux */ } @@ -3412,9 +3443,8 @@ Tcl_LoadFile( * avoids any worries about leaving the copy laying around on exit. */ - if ( - !skipUnlink (copyToPtr) && - (Tcl_FSDeleteFile(copyToPtr) == TCL_OK)) { + if (!skipUnlink(copyToPtr) && + (Tcl_FSDeleteFile(copyToPtr) == TCL_OK)) { Tcl_DecrRefCount(copyToPtr); /* @@ -4093,7 +4123,7 @@ TclGetPathType( * caller. */ { int pathLen; - const char *path = Tcl_GetStringFromObj(pathPtr, &pathLen); + const char *path = TclGetStringFromObj(pathPtr, &pathLen); Tcl_PathType type; type = TclFSNonnativePathType(path, pathLen, filesystemPtrPtr, @@ -4205,7 +4235,7 @@ TclFSNonnativePathType( numVolumes--; Tcl_ListObjIndex(NULL, thisFsVolumes, numVolumes, &vol); - strVol = Tcl_GetStringFromObj(vol,&len); + strVol = TclGetStringFromObj(vol,&len); if (pathLen < len) { continue; } @@ -4552,8 +4582,8 @@ Tcl_FSRemoveDirectory( Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr); if (normPath != NULL) { - normPathStr = Tcl_GetStringFromObj(normPath, &normLen); - cwdStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen); + normPathStr = TclGetStringFromObj(normPath, &normLen); + cwdStr = TclGetStringFromObj(cwdPtr, &cwdLen); if ((cwdLen >= normLen) && (strncmp(normPathStr, cwdStr, (size_t) normLen) == 0)) { /* @@ -4669,7 +4699,7 @@ Tcl_FSGetFileSystemForPath( * Tcl_FSGetNativePath -- * * This function is for use by the Win/Unix native filesystems, so that - * they can easily retrieve the native (char* or TCHAR*) representation + * they can easily retrieve the native (char* or WCHAR*) representation * of a path. Other filesystems will probably want to implement similar * functions. They basically act as a safety net around * Tcl_FSGetInternalRep. Normally your file-system functions will always diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 30c33f1..919db92 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -101,6 +101,7 @@ typedef struct { *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_GetIndexFromObj int Tcl_GetIndexFromObj( @@ -114,6 +115,7 @@ Tcl_GetIndexFromObj( int flags, /* 0 or TCL_EXACT */ int *indexPtr) /* Place to store resulting integer index. */ { + if (!(flags & INDEX_TEMP_TABLE)) { /* * See if there is a valid cached result from a previous lookup (doing the @@ -121,8 +123,10 @@ Tcl_GetIndexFromObj( * the common case where the result is cached). */ - if (objPtr->typePtr == &indexType) { - IndexRep *indexRep = objPtr->internalRep.twoPtrValue.ptr1; + const Tcl_ObjIntRep *irPtr = TclFetchIntRep(objPtr, &indexType); + + if (irPtr) { + IndexRep *indexRep = irPtr->twoPtrValue.ptr1; /* * Here's hoping we don't get hit by unfortunate packing constraints @@ -135,9 +139,11 @@ Tcl_GetIndexFromObj( return TCL_OK; } } + } return Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, sizeof(char *), msg, flags, indexPtr); } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -211,13 +217,8 @@ GetIndexFromObjList( tablePtr[objc] = NULL; result = Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, - sizeof(char *), msg, flags, indexPtr); - - /* - * The internal rep must be cleared since tablePtr will go away. - */ + sizeof(char *), msg, flags | INDEX_TEMP_TABLE, indexPtr); - TclFreeIntRep(objPtr); ckfree(tablePtr); return result; @@ -270,6 +271,7 @@ Tcl_GetIndexFromObjStruct( const char *const *entryPtr; Tcl_Obj *resultPtr; IndexRep *indexRep; + const Tcl_ObjIntRep *irPtr; /* Protect against invalid values, like -1 or 0. */ if (offset < (int)sizeof(char *)) { @@ -279,13 +281,16 @@ Tcl_GetIndexFromObjStruct( * See if there is a valid cached result from a previous lookup. */ - if (objPtr->typePtr == &indexType) { - indexRep = objPtr->internalRep.twoPtrValue.ptr1; + if (!(flags & INDEX_TEMP_TABLE)) { + irPtr = TclFetchIntRep(objPtr, &indexType); + if (irPtr) { + indexRep = irPtr->twoPtrValue.ptr1; if (indexRep->tablePtr==tablePtr && indexRep->offset==offset) { *indexPtr = indexRep->index; return TCL_OK; } } + } /* * Lookup the value of the object in the table. Accept unique @@ -340,17 +345,21 @@ Tcl_GetIndexFromObjStruct( * operation. */ - if (objPtr->typePtr == &indexType) { - indexRep = objPtr->internalRep.twoPtrValue.ptr1; + if (!(flags & INDEX_TEMP_TABLE)) { + irPtr = TclFetchIntRep(objPtr, &indexType); + if (irPtr) { + indexRep = irPtr->twoPtrValue.ptr1; } else { - TclFreeIntRep(objPtr); + Tcl_ObjIntRep ir; + indexRep = ckalloc(sizeof(IndexRep)); - objPtr->internalRep.twoPtrValue.ptr1 = indexRep; - objPtr->typePtr = &indexType; + ir.twoPtrValue.ptr1 = indexRep; + Tcl_StoreIntRep(objPtr, &indexType, &ir); } indexRep->tablePtr = (void *) tablePtr; indexRep->offset = offset; indexRep->index = index; + } *indexPtr = index; return TCL_OK; @@ -448,16 +457,10 @@ static void UpdateStringOfIndex( Tcl_Obj *objPtr) { - IndexRep *indexRep = objPtr->internalRep.twoPtrValue.ptr1; - register char *buf; - register unsigned len; + IndexRep *indexRep = TclFetchIntRep(objPtr, &indexType)->twoPtrValue.ptr1; register const char *indexStr = EXPAND_OF(indexRep); - len = strlen(indexStr); - buf = ckalloc(len + 1); - memcpy(buf, indexStr, len+1); - objPtr->bytes = buf; - objPtr->length = len; + Tcl_InitStringRep(objPtr, indexStr, strlen(indexStr)); } /* @@ -483,12 +486,14 @@ DupIndex( Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { - IndexRep *srcIndexRep = srcPtr->internalRep.twoPtrValue.ptr1; + Tcl_ObjIntRep ir; IndexRep *dupIndexRep = ckalloc(sizeof(IndexRep)); - memcpy(dupIndexRep, srcIndexRep, sizeof(IndexRep)); - dupPtr->internalRep.twoPtrValue.ptr1 = dupIndexRep; - dupPtr->typePtr = &indexType; + memcpy(dupIndexRep, TclFetchIntRep(srcPtr, &indexType)->twoPtrValue.ptr1, + sizeof(IndexRep)); + + ir.twoPtrValue.ptr1 = dupIndexRep; + Tcl_StoreIntRep(dupPtr, &indexType, &ir); } /* @@ -512,7 +517,7 @@ static void FreeIndex( Tcl_Obj *objPtr) { - ckfree(objPtr->internalRep.twoPtrValue.ptr1); + ckfree(TclFetchIntRep(objPtr, &indexType)->twoPtrValue.ptr1); objPtr->typePtr = NULL; } @@ -712,10 +717,10 @@ PrefixAllObjCmd( return result; } resultPtr = Tcl_NewListObj(0, NULL); - string = Tcl_GetStringFromObj(objv[2], &length); + string = TclGetStringFromObj(objv[2], &length); for (t = 0; t < tableObjc; t++) { - elemString = Tcl_GetStringFromObj(tableObjv[t], &elemLength); + elemString = TclGetStringFromObj(tableObjv[t], &elemLength); /* * A prefix cannot match if it is longest. @@ -768,13 +773,13 @@ PrefixLongestObjCmd( if (result != TCL_OK) { return result; } - string = Tcl_GetStringFromObj(objv[2], &length); + string = TclGetStringFromObj(objv[2], &length); resultString = NULL; resultLength = 0; for (t = 0; t < tableObjc; t++) { - elemString = Tcl_GetStringFromObj(tableObjv[t], &elemLength); + elemString = TclGetStringFromObj(tableObjv[t], &elemLength); /* * First check if the prefix string matches the element. A prefix @@ -959,10 +964,10 @@ Tcl_WrongNumArgs( /* * Add the element, quoting it if necessary. */ + const Tcl_ObjIntRep *irPtr; - if (origObjv[i]->typePtr == &indexType) { - register IndexRep *indexRep = - origObjv[i]->internalRep.twoPtrValue.ptr1; + if ((irPtr = TclFetchIntRep(origObjv[i], &indexType))) { + register IndexRep *indexRep = irPtr->twoPtrValue.ptr1; elementStr = EXPAND_OF(indexRep); elemLen = strlen(elementStr); @@ -973,8 +978,7 @@ Tcl_WrongNumArgs( len = TclScanElement(elementStr, elemLen, &flags); if (MAY_QUOTE_WORD && len != elemLen) { - char *quotedElementStr = TclStackAlloc(interp, - (unsigned)len + 1); + char *quotedElementStr = TclStackAlloc(interp, len + 1); len = TclConvertElement(elementStr, elemLen, quotedElementStr, flags); @@ -1009,9 +1013,10 @@ Tcl_WrongNumArgs( * the correct error message even if the subcommand was abbreviated. * Otherwise, just use the string rep. */ + const Tcl_ObjIntRep *irPtr; - if (objv[i]->typePtr == &indexType) { - register IndexRep *indexRep = objv[i]->internalRep.twoPtrValue.ptr1; + if ((irPtr = TclFetchIntRep(objv[i], &indexType))) { + register IndexRep *indexRep = irPtr->twoPtrValue.ptr1; Tcl_AppendStringsToObj(objPtr, EXPAND_OF(indexRep), NULL); } else { @@ -1024,8 +1029,7 @@ Tcl_WrongNumArgs( len = TclScanElement(elementStr, elemLen, &flags); if (MAY_QUOTE_WORD && len != elemLen) { - char *quotedElementStr = TclStackAlloc(interp, - (unsigned) len + 1); + char *quotedElementStr = TclStackAlloc(interp, len + 1); len = TclConvertElement(elementStr, elemLen, quotedElementStr, flags); @@ -1149,7 +1153,7 @@ Tcl_ParseArgsObjv( curArg = objv[srcIndex]; srcIndex++; objc--; - str = Tcl_GetStringFromObj(curArg, &length); + str = TclGetStringFromObj(curArg, &length); if (length > 0) { c = str[1]; } else { @@ -1458,7 +1462,7 @@ TclGetCompletionCodeFromObj( "ok", "error", "return", "break", "continue", NULL }; - if ((value->typePtr != &indexType) + if (!TclHasIntRep(value, &indexType) && TclGetIntFromObj(NULL, value, codePtr) == TCL_OK) { return TCL_OK; } diff --git a/generic/tclInt.decls b/generic/tclInt.decls index e9af34a..556da28 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -50,7 +50,7 @@ declare 6 { declare 7 { int TclCopyAndCollapse(int count, const char *src, char *dst) } -declare 8 { +declare 8 {deprecated {}} { int TclCopyChannelOld(Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr) } @@ -73,7 +73,7 @@ declare 11 { declare 12 { void TclDeleteVars(Interp *iPtr, TclVarHashTable *tablePtr) } -# Removed in 8.5 +# Removed in 8.5: #declare 13 { # int TclDoGlob(Tcl_Interp *interp, char *separators, # Tcl_DString *headPtr, char *tail, Tcl_GlobTypeData *types) @@ -88,7 +88,7 @@ declare 14 { declare 16 { void TclExprFloatError(Tcl_Interp *interp, double value) } -# Removed in 8.4 +# Removed in 8.4: #declare 17 { # int TclFileAttrsCmd(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) #} @@ -114,7 +114,7 @@ declare 23 { } # Replaced with macro (see tclInt.h) in Tcl 8.5.0, restored in 8.5.10 declare 24 { - int TclFormatInt(char *buffer, long n) + int TclFormatInt(char *buffer, Tcl_WideInt n) } declare 25 { void TclFreePackageInfo(Interp *iPtr) @@ -123,7 +123,7 @@ declare 25 { # declare 26 { # char *TclGetCwd(Tcl_Interp *interp) # } -# Removed in 8.5 +# Removed in 8.5: #declare 27 { # int TclGetDate(char *p, unsigned long now, long zone, # unsigned long *timePtr) @@ -147,11 +147,11 @@ declare 32 { int TclGetFrame(Tcl_Interp *interp, const char *str, CallFrame **framePtrPtr) } -# Removed in Tcl 8.5 +# Removed in 8.5: #declare 33 { # TclCmdProcType TclGetInterpProc(void) #} -declare 34 { +declare 34 {deprecated {Use Tcl_GetIntForIndex}} { int TclGetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr, int endValue, int *indexPtr) } @@ -160,7 +160,7 @@ declare 34 { # Tcl_Obj *TclGetIndexedScalar(Tcl_Interp *interp, int localIndex, # int flags) #} -# Removed in 8.6a2 +# Removed in 8.6a2: #declare 36 { # int TclGetLong(Tcl_Interp *interp, const char *str, long *longPtr) #} @@ -185,9 +185,9 @@ declare 41 { declare 42 { CONST86 char *TclpGetUserHome(const char *name, Tcl_DString *bufferPtr) } -# Removed in Tcl 8.5a2 +# Removed in 8.5a2: #declare 43 { -# int TclGlobalInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv, +# int TclGlobalInvoke(Tcl_Interp *interp, int argc, const char **argv, # int flags) #} declare 44 { @@ -220,14 +220,14 @@ declare 50 { declare 51 { int TclInterpInit(Tcl_Interp *interp) } -# Removed in Tcl 8.5a2 +# Removed in 8.5a2: #declare 52 { -# int TclInvoke(Tcl_Interp *interp, int argc, CONST84 char **argv, +# int TclInvoke(Tcl_Interp *interp, int argc, const char **argv, # int flags) #} declare 53 { int TclInvokeObjectCommand(ClientData clientData, Tcl_Interp *interp, - int argc, CONST84 char **argv) + int argc, const char **argv) } declare 54 { int TclInvokeStringCommand(ClientData clientData, Tcl_Interp *interp, @@ -273,7 +273,7 @@ declare 64 { int TclObjInvoke(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int flags) } -# Removed in Tcl 8.5a2 +# Removed in 8.5a2: #declare 65 { # int TclObjInvokeGlobal(Tcl_Interp *interp, int objc, # Tcl_Obj *const objv[], int flags) @@ -313,9 +313,7 @@ declare 75 { declare 76 { unsigned long TclpGetSeconds(void) } - -# deprecated -declare 77 { +declare 77 {deprecated {}} { void TclpGetTime(Tcl_Time *time) } # Removed in 8.6: @@ -357,7 +355,7 @@ declare 81 { # declare 87 { # void TclPlatformInit(Tcl_Interp *interp) # } -declare 88 { +declare 88 {deprecated {}} { char *TclPrecTraceProc(ClientData clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags) } @@ -380,7 +378,7 @@ declare 92 { declare 93 { void TclProcDeleteProc(ClientData clientData) } -# Removed in Tcl 8.5: +# Removed in 8.5: #declare 94 { # int TclProcInterpProc(ClientData clientData, Tcl_Interp *interp, # int argc, const char **argv) @@ -419,7 +417,7 @@ declare 103 { int TclSockGetPort(Tcl_Interp *interp, const char *str, const char *proto, int *portPtr) } -declare 104 { +declare 104 {deprecated {}} { int TclSockMinimumBuffersOld(int sock, int size) } # Replaced by Tcl_FSStat in 8.4: @@ -455,26 +453,26 @@ declare 111 { Tcl_ResolveCompiledVarProc *compiledVarProc) } declare 112 { - int Tcl_AppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + int TclAppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr) } declare 113 { - Tcl_Namespace *Tcl_CreateNamespace(Tcl_Interp *interp, const char *name, + Tcl_Namespace *TclCreateNamespace(Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc) } declare 114 { - void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr) + void TclDeleteNamespace(Tcl_Namespace *nsPtr) } declare 115 { - int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + int TclExport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst) } declare 116 { - Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, const char *name, + Tcl_Command TclFindCommand(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags) } declare 117 { - Tcl_Namespace *Tcl_FindNamespace(Tcl_Interp *interp, const char *name, + Tcl_Namespace *TclFindNamespace(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags) } declare 118 { @@ -490,28 +488,28 @@ declare 120 { Tcl_Namespace *contextNsPtr, int flags) } declare 121 { - int Tcl_ForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + int TclForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern) } declare 122 { - Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr) + Tcl_Command TclGetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr) } declare 123 { - void Tcl_GetCommandFullName(Tcl_Interp *interp, Tcl_Command command, + void TclGetCommandFullName(Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr) } declare 124 { - Tcl_Namespace *Tcl_GetCurrentNamespace(Tcl_Interp *interp) + Tcl_Namespace *TclGetCurrentNamespace_(Tcl_Interp *interp) } declare 125 { - Tcl_Namespace *Tcl_GetGlobalNamespace(Tcl_Interp *interp) + Tcl_Namespace *TclGetGlobalNamespace_(Tcl_Interp *interp) } declare 126 { void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr) } declare 127 { - int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + int TclImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int allowOverwrite) } declare 128 { @@ -532,7 +530,7 @@ declare 131 { declare 132 { int TclpHasSockets(Tcl_Interp *interp) } -declare 133 { +declare 133 {deprecated {}} { struct tm *TclpGetDate(const time_t *time, int useGMT) } # Removed in 8.5 @@ -550,7 +548,7 @@ declare 133 { # int TclpChdir(const char *dirName) #} declare 138 { - CONST84_RETURN char *TclGetEnv(const char *name, Tcl_DString *valuePtr) + const char *TclGetEnv(const char *name, Tcl_DString *valuePtr) } #declare 139 { # int TclpLoadFile(Tcl_Interp *interp, char *fileName, char *sym1, @@ -562,7 +560,7 @@ declare 138 { #} # This is used by TclX, but should otherwise be considered private declare 141 { - CONST84_RETURN char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr) + const char *TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr) } declare 142 { int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr, @@ -625,12 +623,10 @@ declare 156 { declare 157 { Var *TclVarTraceExists(Tcl_Interp *interp, const char *varName) } -# REMOVED (except from stub table) - use public Tcl_SetStartupScript() -declare 158 { +declare 158 {deprecated {use public Tcl_SetStartupScript()}} { void TclSetStartupScriptFileName(const char *filename) } -# REMOVED (except from stub table) - use public Tcl_GetStartupScript() -declare 159 { +declare 159 {deprecated {use public Tcl_GetStartupScript()}} { const char *TclGetStartupScriptFileName(void) } #declare 160 { @@ -676,13 +672,10 @@ declare 166 { int index, Tcl_Obj *valuePtr) } -# VFS-aware versions of Tcl*StartupScriptFileName (158 and 159 above) -# REMOVED (except from stub table) - use public Tcl_SetStartupScript() -declare 167 { +declare 167 {deprecated {use public Tcl_SetStartupScript()}} { void TclSetStartupScriptPath(Tcl_Obj *pathPtr) } -# REMOVED (except from stub table) - use public Tcl_GetStartupScript() -declare 168 { +declare 168 {deprecated {use public Tcl_GetStartupScript()}} { Tcl_Obj *TclGetStartupScriptPath(void) } # variant of Tcl_UtfNCmp that takes n as bytes, not chars @@ -730,12 +723,11 @@ declare 177 { void TclVarErrMsg(Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason) } -# TIP 338 made these public - now declared in tcl.h too declare 178 { - void Tcl_SetStartupScript(Tcl_Obj *pathPtr, const char *encodingName) + void TclSetStartupScript(Tcl_Obj *pathPtr, const char *encodingName) } declare 179 { - Tcl_Obj *Tcl_GetStartupScript(const char **encodingNamePtr) + Tcl_Obj *TclGetStartupScript(const char **encodingNamePtr) } # REMOVED @@ -748,12 +740,10 @@ declare 179 { # const char *file, int line) #} -# TclpGmtime and TclpLocaltime promoted to the generic interface from unix - -declare 182 { +declare 182 {deprecated {}} { struct tm *TclpLocaltime(const time_t *clock) } -declare 183 { +declare 183 {deprecated {}} { struct tm *TclpGmtime(const time_t *clock) } @@ -937,10 +927,7 @@ declare 234 { declare 235 { void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr) } - - -# TIP 337 made this one public -declare 236 { +declare 236 {deprecated {use Tcl_BackgroundException}} { void TclBackgroundException(Tcl_Interp *interp, int code) } @@ -1009,7 +996,7 @@ declare 250 { # Allow extensions for optimization declare 251 { int TclRegisterLiteral(void *envPtr, - char *bytes, int length, int flags) + const char *bytes, int length, int flags) } # Exporting of the internal API to variables. @@ -1037,6 +1024,16 @@ declare 256 { int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags) } +declare 257 { + void TclStaticPackage(Tcl_Interp *interp, const char *pkgName, + Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc) +} + +# TIP 431: temporary directory creation function +declare 258 { + Tcl_Obj *TclpCreateTemporaryDirectory(Tcl_Obj *dirObj, + Tcl_Obj *basenameObj) +} ############################################################################## @@ -1090,7 +1087,7 @@ declare 9 win { declare 10 win { Tcl_DirEntry *TclpReaddir(TclDIR *dir) } -# Removed in 8.3.1 (for Win32s only) +# Removed in 8.3.1 (for Win32s only): #declare 10 win { # int TclWinSynchSpawn(void *args, int type, void **trans, Tcl_Pid *pidPtr) #} @@ -1140,7 +1137,6 @@ declare 19 win { declare 20 win { void TclWinAddProcess(HANDLE hProcess, DWORD id) } -# new for 8.4.20+/8.5.12+ declare 21 win { char *TclpInetNtoa(struct in_addr addr) } @@ -1272,7 +1268,7 @@ declare 19 macosx { } declare 29 {win unix} { - int TclWinCPUID(unsigned int index, unsigned int *regs) + int TclWinCPUID(int index, int *regs) } # Added in 8.6; core of TclpOpenTemporaryFile declare 30 {win unix} { diff --git a/generic/tclInt.h b/generic/tclInt.h index 62fd71b..d75d3fa 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -26,6 +26,36 @@ #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 + + +/* + * Used to tag functions that are only to be visible within the module being + * built and not outside it (where this is supported by the linker). + * Also used in the platform-specific *Port.h files. + */ + +#ifndef MODULE_SCOPE +# ifdef __cplusplus +# define MODULE_SCOPE extern "C" +# else +# define MODULE_SCOPE extern +# endif +#endif + + + +/* * 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 @@ -48,12 +78,12 @@ #else #include <string.h> #endif -#if defined(STDC_HEADERS) || defined(__STDC__) || defined(__C99__FUNC__) \ - || defined(__cplusplus) || defined(_MSC_VER) || defined(__ICC) -#include <stddef.h> -#else +#if !defined(STDC_HEADERS) && !defined(__STDC__) && !defined(__C99__FUNC__) \ + && !defined(__cplusplus) && !defined(_MSC_VER) && !defined(__ICC) typedef int ptrdiff_t; #endif +#include <stddef.h> +#include <locale.h> /* * Ensure WORDS_BIGENDIAN is defined correctly: @@ -82,19 +112,6 @@ typedef int ptrdiff_t; #endif /* - * Used to tag functions that are only to be visible within the module being - * built and not outside it (where this is supported by the linker). - */ - -#ifndef MODULE_SCOPE -# ifdef __cplusplus -# define MODULE_SCOPE extern "C" -# else -# define MODULE_SCOPE extern -# endif -#endif - -/* * Macros used to cast between pointers and integers (e.g. when storing an int * in ClientData), on 64-bit architectures they avoid gcc warning about "cast * to/from pointer from/to integer of different size". @@ -103,19 +120,19 @@ typedef int ptrdiff_t; #if !defined(INT2PTR) && !defined(PTR2INT) # if defined(HAVE_INTPTR_T) || defined(intptr_t) # define INT2PTR(p) ((void *)(intptr_t)(p)) -# define PTR2INT(p) ((int)(intptr_t)(p)) +# define PTR2INT(p) ((intptr_t)(p)) # else # define INT2PTR(p) ((void *)(p)) -# define PTR2INT(p) ((int)(p)) +# define PTR2INT(p) ((long)(p)) # endif #endif #if !defined(UINT2PTR) && !defined(PTR2UINT) # if defined(HAVE_UINTPTR_T) || defined(uintptr_t) # define UINT2PTR(p) ((void *)(uintptr_t)(p)) -# define PTR2UINT(p) ((unsigned int)(uintptr_t)(p)) +# define PTR2UINT(p) ((uintptr_t)(p)) # else # define UINT2PTR(p) ((void *)(p)) -# define PTR2UINT(p) ((unsigned int)(p)) +# define PTR2UINT(p) ((unsigned long)(p)) # endif #endif @@ -123,6 +140,26 @@ typedef int ptrdiff_t; # define vsnprintf _vsnprintf #endif +#if !defined(TCL_THREADS) +# define TCL_THREADS 1 +#endif +#if !TCL_THREADS +# undef TCL_DECLARE_MUTEX +# define TCL_DECLARE_MUTEX(name) +# undef Tcl_MutexLock +# define Tcl_MutexLock(mutexPtr) +# undef Tcl_MutexUnlock +# define Tcl_MutexUnlock(mutexPtr) +# undef Tcl_MutexFinalize +# define Tcl_MutexFinalize(mutexPtr) +# undef Tcl_ConditionNotify +# define Tcl_ConditionNotify(condPtr) +# undef Tcl_ConditionWait +# define Tcl_ConditionWait(condPtr, mutexPtr, timePtr) +# undef Tcl_ConditionFinalize +# define Tcl_ConditionFinalize(condPtr) +#endif + /* * The following procedures allow namespaces to be customized to support * special name resolution rules for commands/variables. @@ -147,13 +184,13 @@ typedef struct Tcl_ResolvedVarInfo { } Tcl_ResolvedVarInfo; typedef int (Tcl_ResolveCompiledVarProc)(Tcl_Interp *interp, - CONST84 char *name, int length, Tcl_Namespace *context, + const char *name, int length, Tcl_Namespace *context, Tcl_ResolvedVarInfo **rPtr); -typedef int (Tcl_ResolveVarProc)(Tcl_Interp *interp, CONST84 char *name, +typedef int (Tcl_ResolveVarProc)(Tcl_Interp *interp, const char *name, Tcl_Namespace *context, int flags, Tcl_Var *rPtr); -typedef int (Tcl_ResolveCmdProc)(Tcl_Interp *interp, CONST84 char *name, +typedef int (Tcl_ResolveCmdProc)(Tcl_Interp *interp, const char *name, Tcl_Namespace *context, int flags, Tcl_Command *rPtr); typedef struct Tcl_ResolverInfo { @@ -235,7 +272,7 @@ typedef struct Namespace { * synonym. */ char *fullName; /* The namespace's fully qualified name. This * starts with ::. */ - ClientData clientData; /* An arbitrary value associated with this + void *clientData; /* An arbitrary value associated with this * namespace. */ Tcl_NamespaceDeleteProc *deleteProc; /* Procedure invoked when deleting the @@ -252,7 +289,7 @@ typedef struct Namespace { * strings; values have type (Namespace *). If * NULL, there are no children. */ #endif - long nsId; /* Unique id for the namespace. */ + unsigned long nsId; /* Unique id for the namespace. */ Tcl_Interp *interp; /* The interpreter containing this * namespace. */ int flags; /* OR-ed combination of the namespace status @@ -261,7 +298,7 @@ typedef struct Namespace { * frames for this namespace that are on the * Tcl call stack. The namespace won't be * freed until activationCount becomes zero. */ - int refCount; /* Count of references by namespaceName + unsigned int refCount; /* Count of references by namespaceName * objects. The namespace can't be freed until * refCount becomes zero. */ Tcl_HashTable cmdTable; /* Contains all the commands currently @@ -286,12 +323,12 @@ typedef struct Namespace { * registered using "namespace export". */ int maxExportPatterns; /* Mumber of export patterns for which space * is currently allocated. */ - int cmdRefEpoch; /* Incremented if a newly added command + unsigned 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. */ - int resolverEpoch; /* Incremented whenever (a) the name + unsigned 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 @@ -318,7 +355,7 @@ typedef struct Namespace { * LookupCompiledLocal to resolve variable * references within the namespace at compile * time. */ - int exportLookupEpoch; /* Incremented whenever a command is added to + unsigned 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 @@ -419,7 +456,7 @@ typedef struct EnsembleConfig { * if the command has been deleted (or never * existed; the global namespace never has an * ensemble command.) */ - int epoch; /* The epoch at which this ensemble's table of + unsigned 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 @@ -506,7 +543,7 @@ typedef struct EnsembleConfig { typedef struct VarTrace { Tcl_VarTraceProc *traceProc;/* Procedure to call when operations given by * flags are performed on variable. */ - ClientData clientData; /* Argument to pass to proc. */ + void *clientData; /* Argument to pass to proc. */ int flags; /* What events the trace procedure is * interested in: OR-ed combination of * TCL_TRACE_READS, TCL_TRACE_WRITES, @@ -525,14 +562,14 @@ typedef struct CommandTrace { Tcl_CommandTraceProc *traceProc; /* Procedure to call when operations given by * flags are performed on command. */ - ClientData clientData; /* Argument to pass to proc. */ + void *clientData; /* Argument to pass to proc. */ int flags; /* What events the trace procedure is * interested in: OR-ed combination of * TCL_TRACE_RENAME, TCL_TRACE_DELETE. */ struct CommandTrace *nextPtr; /* Next in list of traces associated with a * particular command. */ - int refCount; /* Used to ensure this structure is not + unsigned 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. */ @@ -605,7 +642,7 @@ typedef struct Var { typedef struct VarInHash { Var var; - int refCount; /* Counts number of active uses of this + unsigned int refCount; /* Counts number of active uses of this * variable: 1 for the entry in the hash * table, 1 for each additional variable whose * linkPtr points here, 1 for each nested @@ -917,7 +954,7 @@ typedef struct CompiledLocal { /* Customized variable resolution info * supplied by the Tcl_ResolveCompiledVarProc * associated with a namespace. Each variable - * is marked by a unique ClientData tag during + * is marked by a unique tag during * compilation, and that same tag is used to * find the variable at runtime. */ char name[1]; /* Name of the local variable starts here. If @@ -936,7 +973,7 @@ typedef struct CompiledLocal { typedef struct Proc { struct Interp *iPtr; /* Interpreter for which this command is * defined. */ - int refCount; /* Reference count: 1 if still present in + unsigned int refCount; /* Reference count: 1 if still present in * command table plus 1 for each call to the * procedure that is currently active. This * structure can be freed when refCount @@ -978,7 +1015,7 @@ typedef struct Trace { int level; /* Only trace commands at nesting level less * than or equal to this. */ Tcl_CmdObjTraceProc *proc; /* Procedure to call to trace command. */ - ClientData clientData; /* Arbitrary value to pass to proc. */ + void *clientData; /* Arbitrary value to pass to proc. */ struct Trace *nextPtr; /* Next in list of traces for this interp. */ int flags; /* Flags governing the trace - see * Tcl_CreateObjTrace for details. */ @@ -1030,7 +1067,7 @@ typedef struct ActiveInterpTrace { typedef struct AssocData { Tcl_InterpDeleteProc *proc; /* Proc to call when deleting. */ - ClientData clientData; /* Value to pass to proc. */ + void *clientData; /* Value to pass to proc. */ } AssocData; /* @@ -1053,7 +1090,7 @@ typedef struct AssocData { */ typedef struct LocalCache { - int refCount; + unsigned int refCount; int numVars; Tcl_Obj *varName0; } LocalCache; @@ -1108,7 +1145,7 @@ typedef struct CallFrame { * recognized by the compiler. The compiler * emits code that refers to these variables * using an index into this array. */ - ClientData clientData; /* Pointer to some context that is used by + void *clientData; /* Pointer to some context that is used by * object systems. The meaning of the contents * of this field is defined by the code that * sets it, and it should only ever be set by @@ -1132,6 +1169,10 @@ typedef struct CallFrame { * field contains an Object reference that has * been confirmed to refer to a class. Part of * TIP#257. */ +#define FRAME_IS_PRIVATE_DEFINE 0x10 + /* Marks this frame as being used for private + * declarations with [oo::define]. Usually + * OR'd with FRAME_IS_OO_DEFINE. TIP#500. */ /* * TIP #280 @@ -1215,7 +1256,7 @@ typedef struct CmdFrame { typedef struct CFWord { CmdFrame *framePtr; /* CmdFrame to access. */ int word; /* Index of the word in the command. */ - int refCount; /* Number of times the word is on the + unsigned int refCount; /* Number of times the word is on the * stack. */ } CFWord; @@ -1292,13 +1333,13 @@ typedef struct ContLineLoc { * by [info frame]. Contains a sub-structure for each extra field. */ -typedef Tcl_Obj * (GetFrameInfoValueProc)(ClientData clientData); +typedef Tcl_Obj * (GetFrameInfoValueProc)(void *clientData); typedef struct { const char *name; /* Name of this field. */ GetFrameInfoValueProc *proc; /* Function to generate a Tcl_Obj* from the * clientData, or just use the clientData * directly (after casting) if NULL. */ - ClientData clientData; /* Context for above function, or Tcl_Obj* if + void *clientData; /* Context for above function, or Tcl_Obj* if * proc field is NULL. */ } ExtraFrameInfoField; typedef struct { @@ -1343,7 +1384,7 @@ MODULE_SCOPE void TclThreadDataKeySet(Tcl_ThreadDataKey *keyPtr, */ #define TCL_TSD_INIT(keyPtr) \ - (ThreadSpecificData *)Tcl_GetThreadData((keyPtr), sizeof(ThreadSpecificData)) + (ThreadSpecificData *)Tcl_GetThreadData((keyPtr), sizeof(ThreadSpecificData)) /* *---------------------------------------------------------------- @@ -1478,11 +1519,11 @@ typedef struct LiteralEntry { * NULL if end of chain. */ Tcl_Obj *objPtr; /* Points to Tcl object that holds the * literal's bytes and length. */ - int refCount; /* If in an interpreter's global literal + unsigned int refCount; /* If in an interpreter's global literal * table, the number of ByteCode structures * that share the literal object; the literal * entry can be freed when refCount drops to - * 0. If in a local literal table, -1. */ + * 0. If in a local literal table, (unsigned)-1. */ Namespace *nsPtr; /* Namespace in which this literal is used. We * try to avoid sharing literal non-FQ command * names among different namespaces to reduce @@ -1496,13 +1537,13 @@ typedef struct LiteralTable { LiteralEntry *staticBuckets[TCL_SMALL_HASH_TABLE]; /* Bucket array used for small tables to avoid * mallocs and frees. */ - int numBuckets; /* Total number of buckets allocated at + unsigned int numBuckets; /* Total number of buckets allocated at * **buckets. */ - int numEntries; /* Total number of entries present in + unsigned int numEntries; /* Total number of entries present in * table. */ - int rebuildSize; /* Enlarge table when numEntries gets to be + unsigned int rebuildSize; /* Enlarge table when numEntries gets to be * this large. */ - int mask; /* Mask value used in hashing function. */ + unsigned int mask; /* Mask value used in hashing function. */ } LiteralTable; /* @@ -1513,10 +1554,10 @@ typedef struct LiteralTable { #ifdef TCL_COMPILE_STATS typedef struct ByteCodeStats { - long numExecutions; /* Number of ByteCodes executed. */ - long numCompilations; /* Number of ByteCodes created. */ - long numByteCodesFreed; /* Number of ByteCodes destroyed. */ - long instructionCount[256]; /* Number of times each instruction was + size_t numExecutions; /* Number of ByteCodes executed. */ + size_t numCompilations; /* Number of ByteCodes created. */ + size_t numByteCodesFreed; /* Number of ByteCodes destroyed. */ + size_t instructionCount[256]; /* Number of times each instruction was * executed. */ double totalSrcBytes; /* Total source bytes ever compiled. */ @@ -1524,10 +1565,10 @@ typedef struct ByteCodeStats { double currentSrcBytes; /* Src bytes for all current ByteCodes. */ double currentByteCodeBytes;/* Code bytes in all current ByteCodes. */ - long srcCount[32]; /* Source size distribution: # of srcs of + size_t srcCount[32]; /* Source size distribution: # of srcs of * size [2**(n-1)..2**n), n in [0..32). */ - long byteCodeCount[32]; /* ByteCode size distribution. */ - long lifetimeCount[32]; /* ByteCode lifetime distribution (ms). */ + size_t byteCodeCount[32]; /* ByteCode size distribution. */ + size_t lifetimeCount[32]; /* ByteCode lifetime distribution (ms). */ double currentInstBytes; /* Instruction bytes-current ByteCodes. */ double currentLitBytes; /* Current literal bytes. */ @@ -1535,11 +1576,11 @@ typedef struct ByteCodeStats { double currentAuxBytes; /* Current auxiliary information bytes. */ double currentCmdMapBytes; /* Current src<->code map bytes. */ - long numLiteralsCreated; /* Total literal objects ever compiled. */ + size_t numLiteralsCreated; /* Total literal objects ever compiled. */ double totalLitStringBytes; /* Total string bytes in all literals. */ double currentLitStringBytes; /* String bytes in current literals. */ - long literalCount[32]; /* Distribution of literal string sizes. */ + size_t literalCount[32]; /* Distribution of literal string sizes. */ } ByteCodeStats; #endif /* TCL_COMPILE_STATS */ @@ -1554,7 +1595,7 @@ typedef struct { Tcl_ObjCmdProc *proc; /* The implementation of the subcommand. */ CompileProc *compileProc; /* The compiler for the subcommand. */ Tcl_ObjCmdProc *nreProc; /* NRE implementation of this command. */ - ClientData clientData; /* Any clientData to give the command. */ + void *clientData; /* Any clientData to give the command. */ int unsafe; /* Whether this command is to be hidden by * default in a safe interpreter. */ } EnsembleImplMap; @@ -1620,24 +1661,24 @@ typedef struct Command { * recreated). */ Namespace *nsPtr; /* Points to the namespace containing this * command. */ - int refCount; /* 1 if in command hashtable plus 1 for each + unsigned int refCount; /* 1 if in command hashtable plus 1 for each * reference from a CmdName Tcl object * representing a command's name in a ByteCode * instruction sequence. This structure can be * freed when refCount becomes zero. */ - int cmdEpoch; /* Incremented to invalidate any references + unsigned 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 * if no compile proc exists for command. */ Tcl_ObjCmdProc *objProc; /* Object-based command procedure. */ - ClientData objClientData; /* Arbitrary value passed to object proc. */ + void *objClientData; /* Arbitrary value passed to object proc. */ Tcl_CmdProc *proc; /* String-based command procedure. */ - ClientData clientData; /* Arbitrary value passed to string proc. */ + void *clientData; /* Arbitrary value passed to string proc. */ Tcl_CmdDeleteProc *deleteProc; /* Procedure invoked when deleting command to, * e.g., free all client data. */ - ClientData deleteData; /* Arbitrary value passed to deleteProc. */ + void *deleteData; /* Arbitrary value passed to deleteProc. */ int flags; /* Miscellaneous bits of information about * command. See below for definitions. */ ImportRef *importRefPtr; /* List of each imported Command created in @@ -1803,7 +1844,7 @@ typedef struct Interp { /* Hash table used by tclBasic.c to keep track * of hidden commands on a per-interp * basis. */ - ClientData interpInfo; /* Information used by tclInterp.c to keep + void *interpInfo; /* Information used by tclInterp.c to keep * track of master/slave interps on a * per-interp basis. */ union { @@ -1848,6 +1889,7 @@ typedef struct Interp { * See Tcl_AppendResult code for details. */ +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 char *appendResult; /* Storage space for results generated by * Tcl_AppendResult. Ckalloc-ed. NULL means * not yet allocated. */ @@ -1855,6 +1897,11 @@ typedef struct Interp { * partialResult. */ int appendUsed; /* Number of non-null bytes currently stored * at partialResult. */ +#else + char *appendResultDontUse; + int appendAvlDontUse; + int appendUsedDontUse; +#endif /* * Information about packages. Used only in tclPkg.c. @@ -1884,7 +1931,7 @@ typedef struct Interp { * compiled by the interpreter. Indexed by the * string representations of literals. Used to * avoid creating duplicate objects. */ - int compileEpoch; /* Holds the current "compilation epoch" for + unsigned int compileEpoch; /* Holds the current "compilation epoch" for * this interpreter. This is incremented to * invalidate existing ByteCodes when, e.g., a * command with a compile procedure is @@ -1916,8 +1963,14 @@ typedef struct Interp { * string. Returned by Tcl_ObjSetVar2 when * variable traces change a variable in a * gross way. */ - char resultSpace[TCL_RESULT_SIZE+1]; +#if TCL_MAJOR_VERSION < 9 +# if !defined(TCL_NO_DEPRECATED) + char resultSpace[TCL_DSTRING_STATIC_SIZE+1]; /* Static space holding small results. */ +# else + char resultSpaceDontUse[TCL_DSTRING_STATIC_SIZE+1]; +# endif +#endif Tcl_Obj *objResultPtr; /* If the last command returned an object * result, this points to it. Should not be * accessed directly; see comment above. */ @@ -2311,6 +2364,13 @@ typedef struct Interp { #define TCL_ALIGN(x) (((int)(x) + 7) & ~7) /* + * A common panic alert when memory allocation fails. + */ + +#define TclOOM(ptr, size) \ + ((size) && ((ptr)||(Tcl_Panic("unable to alloc %u bytes", (size)),1))) + +/* * The following enum values are used to specify the runtime platform setting * of the tclPlatform variable. */ @@ -2361,7 +2421,7 @@ typedef enum TclEolTranslation { */ typedef struct List { - int refCount; + unsigned int refCount; int maxElemCount; /* Total number of element array slots. */ int elemCount; /* Current number of list elements. */ int canonicalFlag; /* Set if the string representation was @@ -2384,12 +2444,6 @@ typedef struct List { #define ListRepPtr(listPtr) \ ((List *) (listPtr)->internalRep.twoPtrValue.ptr1) -#define ListSetIntRep(objPtr, listRepPtr) \ - (objPtr)->internalRep.twoPtrValue.ptr1 = (void *)(listRepPtr), \ - (objPtr)->internalRep.twoPtrValue.ptr2 = NULL, \ - (listRepPtr)->refCount++, \ - (objPtr)->typePtr = &tclListType - #define ListObjGetElements(listPtr, objc, objv) \ ((objv) = &(ListRepPtr(listPtr)->elements), \ (objc) = ListRepPtr(listPtr)->elemCount) @@ -2422,40 +2476,46 @@ typedef struct List { #define TCL_EACH_COLLECT 1 /* Collect iteration result like [lmap] */ /* - * Macros providing a faster path to integers: Tcl_GetLongFromObj, - * Tcl_GetIntFromObj and TclGetIntForIndex. + * Macros providing a faster path to booleans and integers: + * Tcl_GetBooleanFromObj, Tcl_GetLongFromObj, Tcl_GetIntFromObj + * and Tcl_GetIntForIndex. * * WARNING: these macros eval their args more than once. */ +#define TclGetBooleanFromObj(interp, objPtr, boolPtr) \ + (((objPtr)->typePtr == &tclIntType) \ + ? (*(boolPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK) \ + : ((objPtr)->typePtr == &tclBooleanType) \ + ? (*(boolPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \ + : Tcl_GetBooleanFromObj((interp), (objPtr), (boolPtr))) + +#ifdef TCL_WIDE_INT_IS_LONG #define TclGetLongFromObj(interp, objPtr, longPtr) \ (((objPtr)->typePtr == &tclIntType) \ - ? ((*(longPtr) = (objPtr)->internalRep.longValue), TCL_OK) \ + ? ((*(longPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \ : Tcl_GetLongFromObj((interp), (objPtr), (longPtr))) - -#if (LONG_MAX == INT_MAX) -#define TclGetIntFromObj(interp, objPtr, intPtr) \ - (((objPtr)->typePtr == &tclIntType) \ - ? ((*(intPtr) = (objPtr)->internalRep.longValue), TCL_OK) \ - : Tcl_GetIntFromObj((interp), (objPtr), (intPtr))) -#define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \ - (((objPtr)->typePtr == &tclIntType) \ - ? ((*(idxPtr) = (objPtr)->internalRep.longValue), TCL_OK) \ - : TclGetIntForIndex((interp), (objPtr), (endValue), (idxPtr))) #else +#define TclGetLongFromObj(interp, objPtr, longPtr) \ + (((objPtr)->typePtr == &tclIntType \ + && (objPtr)->internalRep.wideValue >= (Tcl_WideInt)(LONG_MIN) \ + && (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(LONG_MAX)) \ + ? ((*(longPtr) = (long)(objPtr)->internalRep.wideValue), TCL_OK) \ + : Tcl_GetLongFromObj((interp), (objPtr), (longPtr))) +#endif + #define TclGetIntFromObj(interp, objPtr, intPtr) \ (((objPtr)->typePtr == &tclIntType \ - && (objPtr)->internalRep.longValue >= -(Tcl_WideInt)(UINT_MAX) \ - && (objPtr)->internalRep.longValue <= (Tcl_WideInt)(UINT_MAX)) \ - ? ((*(intPtr) = (objPtr)->internalRep.longValue), TCL_OK) \ + && (objPtr)->internalRep.wideValue >= (Tcl_WideInt)(INT_MIN) \ + && (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(INT_MAX)) \ + ? ((*(intPtr) = (int)(objPtr)->internalRep.wideValue), TCL_OK) \ : Tcl_GetIntFromObj((interp), (objPtr), (intPtr))) #define TclGetIntForIndexM(interp, objPtr, endValue, idxPtr) \ (((objPtr)->typePtr == &tclIntType \ - && (objPtr)->internalRep.longValue >= INT_MIN \ - && (objPtr)->internalRep.longValue <= INT_MAX) \ - ? ((*(idxPtr) = (objPtr)->internalRep.longValue), TCL_OK) \ - : TclGetIntForIndex((interp), (objPtr), (endValue), (idxPtr))) -#endif + && (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(INT_MAX)) \ + ? ((*(idxPtr) = ((objPtr)->internalRep.wideValue >= 0) \ + ? (int)(objPtr)->internalRep.wideValue : TCL_INDEX_NONE), TCL_OK) \ + : Tcl_GetIntForIndex((interp), (objPtr), (endValue), (idxPtr))) /* * Macro used to save a function call for common uses of @@ -2465,21 +2525,11 @@ typedef struct List { * Tcl_WideInt *wideIntPtr); */ -#ifdef TCL_WIDE_INT_IS_LONG #define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \ (((objPtr)->typePtr == &tclIntType) \ - ? (*(wideIntPtr) = (Tcl_WideInt) \ - ((objPtr)->internalRep.longValue), TCL_OK) : \ - Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr))) -#else /* !TCL_WIDE_INT_IS_LONG */ -#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \ - (((objPtr)->typePtr == &tclWideIntType) \ - ? (*(wideIntPtr) = (objPtr)->internalRep.wideValue, TCL_OK) : \ - ((objPtr)->typePtr == &tclIntType) \ - ? (*(wideIntPtr) = (Tcl_WideInt) \ - ((objPtr)->internalRep.longValue), TCL_OK) : \ + ? (*(wideIntPtr) = \ + ((objPtr)->internalRep.wideValue), TCL_OK) : \ Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr))) -#endif /* TCL_WIDE_INT_IS_LONG */ /* * Flag values for TclTraceDictPath(). @@ -2545,6 +2595,15 @@ 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. */ @@ -2594,7 +2653,7 @@ typedef Tcl_ObjCmdProc *TclObjCmdProcType; *---------------------------------------------------------------- */ -typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, int *lengthPtr, +typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, unsigned int *lengthPtr, Tcl_Encoding *encodingPtr); /* @@ -2606,9 +2665,9 @@ typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, int *lengthPtr, */ typedef struct ProcessGlobalValue { - int epoch; /* Epoch counter to detect changes in the + unsigned int epoch; /* Epoch counter to detect changes in the * master value. */ - int numBytes; /* Length of the master string. */ + unsigned int numBytes; /* Length of the master string. */ char *value; /* The master string value. */ Tcl_Encoding encoding; /* system encoding when master string was * initialized. */ @@ -2651,8 +2710,11 @@ typedef struct ProcessGlobalValue { *---------------------------------------------------------------------- */ -#define TCL_NUMBER_LONG 1 -#define TCL_NUMBER_WIDE 2 +#define TCL_NUMBER_INT 2 +#if (TCL_MAJOR_VERSION < 9) && !defined(TCL_NO_DEPRECATED) +# define TCL_NUMBER_LONG 1 /* deprecated, not used any more */ +# define TCL_NUMBER_WIDE TCL_NUMBER_INT /* deprecated */ +#endif #define TCL_NUMBER_BIG 3 #define TCL_NUMBER_DOUBLE 4 #define TCL_NUMBER_NAN 5 @@ -2689,17 +2751,12 @@ MODULE_SCOPE const Tcl_ObjType tclBooleanType; MODULE_SCOPE const Tcl_ObjType tclByteArrayType; MODULE_SCOPE const Tcl_ObjType tclByteCodeType; MODULE_SCOPE const Tcl_ObjType tclDoubleType; -MODULE_SCOPE const Tcl_ObjType tclEndOffsetType; MODULE_SCOPE const Tcl_ObjType tclIntType; 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; -#endif MODULE_SCOPE const Tcl_ObjType tclRegexpType; MODULE_SCOPE Tcl_ObjType tclCmdNameType; @@ -2720,10 +2777,10 @@ MODULE_SCOPE const Tcl_HashKeyType tclObjHashKeyType; MODULE_SCOPE Tcl_Obj * tclFreeObjList; #ifdef TCL_COMPILE_STATS -MODULE_SCOPE long tclObjsAlloced; -MODULE_SCOPE long tclObjsFreed; +MODULE_SCOPE size_t tclObjsAlloced; +MODULE_SCOPE size_t tclObjsFreed; #define TCL_MAX_SHARED_OBJ_STATS 5 -MODULE_SCOPE long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS]; +MODULE_SCOPE size_t tclObjsShared[TCL_MAX_SHARED_OBJ_STATS]; #endif /* TCL_COMPILE_STATS */ /* @@ -2732,7 +2789,6 @@ MODULE_SCOPE long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS]; * shared by all new objects allocated by Tcl_NewObj. */ -MODULE_SCOPE char * tclEmptyStringRep; MODULE_SCOPE char tclEmptyString; enum CheckEmptyStringResult { @@ -2805,7 +2861,7 @@ typedef struct ForIterData { typedef void* TclFindSymbolProc(Tcl_Interp* interp, Tcl_LoadHandle loadHandle, const char* symbol); struct Tcl_LoadHandle_ { - ClientData clientData; /* Client data is the load handle in the + void *clientData; /* Client data is the load handle in the * native filesystem if a module was loaded * there, or an opaque pointer to a structure * for further bookkeeping on load-from-VFS @@ -2821,8 +2877,6 @@ struct Tcl_LoadHandle_ { #define TCL_DD_SHORTEST 0x4 /* Use the shortest possible string */ -#define TCL_DD_STEELE 0x5 - /* Use the original Steele&White algorithm */ #define TCL_DD_E_FORMAT 0x2 /* Use a fixed-length string of digits, * suitable for E format*/ @@ -2838,10 +2892,6 @@ struct Tcl_LoadHandle_ { #define TCL_DD_CONVERSION_TYPE_MASK 0x3 /* Mask to isolate the conversion type */ -#define TCL_DD_STEELE0 0x1 - /* 'Steele&White' after masking */ -#define TCL_DD_SHORTEST0 0x0 - /* 'Shortest possible' after masking */ /* *---------------------------------------------------------------- @@ -2884,6 +2934,8 @@ MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp, Tcl_Channel chan); MODULE_SCOPE Tcl_ObjCmdProc TclChannelNamesCmd; MODULE_SCOPE Tcl_NRPostProc TclClearRootEnsemble; +MODULE_SCOPE int TclCompareTwoNumbers(Tcl_Obj *valuePtr, + Tcl_Obj *value2Ptr); MODULE_SCOPE ContLineLoc *TclContinuationsEnter(Tcl_Obj *objPtr, int num, int *loc); MODULE_SCOPE void TclContinuationsEnterDerived(Tcl_Obj *objPtr, @@ -2893,25 +2945,19 @@ MODULE_SCOPE void TclContinuationsCopy(Tcl_Obj *objPtr, Tcl_Obj *originObjPtr); MODULE_SCOPE int TclConvertElement(const char *src, int length, char *dst, int flags); -MODULE_SCOPE Tcl_Command TclCreateObjCommandInNs ( - Tcl_Interp *interp, - const char *cmdName, - Tcl_Namespace *nsPtr, - Tcl_ObjCmdProc *proc, - ClientData clientData, +MODULE_SCOPE Tcl_Command TclCreateObjCommandInNs(Tcl_Interp *interp, + const char *cmdName, Tcl_Namespace *nsPtr, + Tcl_ObjCmdProc *proc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); -MODULE_SCOPE Tcl_Command TclCreateEnsembleInNs( - Tcl_Interp *interp, - const char *name, - Tcl_Namespace *nameNamespacePtr, - Tcl_Namespace *ensembleNamespacePtr, - int flags); +MODULE_SCOPE Tcl_Command TclCreateEnsembleInNs(Tcl_Interp *interp, + const char *name, Tcl_Namespace *nameNamespacePtr, + Tcl_Namespace *ensembleNamespacePtr, int flags); MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr); MODULE_SCOPE int TclFindDictElement(Tcl_Interp *interp, const char *dict, int dictLength, const char **elementPtr, const char **nextPtr, int *sizePtr, int *literalPtr); -/* TIP #280 - Modified token based evulation, with line information. */ +/* TIP #280 - Modified token based evaluation, with line information. */ MODULE_SCOPE int TclEvalEx(Tcl_Interp *interp, const char *script, int numBytes, int flags, int line, int *clNextOuter, const char *outerScript); @@ -2922,6 +2968,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclFileLinkCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileMakeDirsCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileReadLinkCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileRenameCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclFileTempDirCmd; MODULE_SCOPE Tcl_ObjCmdProc TclFileTemporaryCmd; MODULE_SCOPE void TclCreateLateExitHandler(Tcl_ExitProc *proc, ClientData clientData); @@ -2932,12 +2979,10 @@ MODULE_SCOPE char * TclDStringAppendObj(Tcl_DString *dsPtr, MODULE_SCOPE char * TclDStringAppendDString(Tcl_DString *dsPtr, Tcl_DString *toAppendPtr); MODULE_SCOPE Tcl_Obj * TclDStringToObj(Tcl_DString *dsPtr); -MODULE_SCOPE Tcl_Obj *const * TclFetchEnsembleRoot(Tcl_Interp *interp, +MODULE_SCOPE Tcl_Obj *const *TclFetchEnsembleRoot(Tcl_Interp *interp, Tcl_Obj *const *objv, int objc, int *objcPtr); -MODULE_SCOPE Tcl_Namespace * TclEnsureNamespace( - Tcl_Interp *interp, +MODULE_SCOPE Tcl_Namespace *TclEnsureNamespace(Tcl_Interp *interp, Tcl_Namespace *namespacePtr); - MODULE_SCOPE void TclFinalizeAllocSubsystem(void); MODULE_SCOPE void TclFinalizeAsync(void); MODULE_SCOPE void TclFinalizeDoubleConversion(void); @@ -2955,6 +3000,7 @@ MODULE_SCOPE void TclFinalizeNotifier(void); MODULE_SCOPE void TclFinalizeObjects(void); MODULE_SCOPE void TclFinalizePreserve(void); MODULE_SCOPE void TclFinalizeSynchronization(void); +MODULE_SCOPE void TclInitThreadAlloc(void); MODULE_SCOPE void TclFinalizeThreadAlloc(void); MODULE_SCOPE void TclFinalizeThreadAllocThread(void); MODULE_SCOPE void TclFinalizeThreadData(int quick); @@ -2963,15 +3009,11 @@ MODULE_SCOPE double TclFloor(const mp_int *a); MODULE_SCOPE void TclFormatNaN(double value, char *buffer); MODULE_SCOPE int TclFSFileAttrIndex(Tcl_Obj *pathPtr, const char *attributeName, int *indexPtr); -MODULE_SCOPE Tcl_Command TclNRCreateCommandInNs ( - Tcl_Interp *interp, - const char *cmdName, - Tcl_Namespace *nsPtr, - Tcl_ObjCmdProc *proc, - Tcl_ObjCmdProc *nreProc, +MODULE_SCOPE Tcl_Command TclNRCreateCommandInNs(Tcl_Interp *interp, + const char *cmdName, Tcl_Namespace *nsPtr, + Tcl_ObjCmdProc *proc, Tcl_ObjCmdProc *nreProc, ClientData clientData, Tcl_CmdDeleteProc *deleteProc); - MODULE_SCOPE int TclNREvalFile(Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *encodingName); MODULE_SCOPE void TclFSUnloadTempFile(Tcl_LoadHandle loadHandle); @@ -2983,6 +3025,8 @@ MODULE_SCOPE int TclGetChannelFromObj(Tcl_Interp *interp, MODULE_SCOPE CmdFrame * TclGetCmdFrameForProcedure(Proc *procPtr); MODULE_SCOPE int TclGetCompletionCodeFromObj(Tcl_Interp *interp, Tcl_Obj *value, int *code); +MODULE_SCOPE Proc * TclGetLambdaFromObj(Tcl_Interp *interp, + Tcl_Obj *objPtr, Tcl_Obj **nsObjPtrPtr); MODULE_SCOPE int TclGetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, ClientData *clientDataPtr, int *typePtr); @@ -2994,6 +3038,11 @@ 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 TclGetWideBitsFromObj(Tcl_Interp *, Tcl_Obj *, + Tcl_WideInt *); MODULE_SCOPE int TclGlob(Tcl_Interp *interp, char *pattern, Tcl_Obj *unquotedPrefix, int globFlags, Tcl_GlobTypeData *types); @@ -3013,6 +3062,8 @@ MODULE_SCOPE int TclInfoLocalsCmd(ClientData dummy, Tcl_Interp *interp, MODULE_SCOPE int TclInfoVarsCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE void TclInitAlloc(void); +MODULE_SCOPE void TclInitBignumFromWideInt(mp_int *, Tcl_WideInt); +MODULE_SCOPE void TclInitBignumFromWideUInt(mp_int *, Tcl_WideUInt); MODULE_SCOPE void TclInitDbCkalloc(void); MODULE_SCOPE void TclInitDoubleConversion(void); MODULE_SCOPE void TclInitEmbeddedConfigurationInformation( @@ -3039,6 +3090,8 @@ MODULE_SCOPE Tcl_Obj * TclLindexFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, MODULE_SCOPE void TclListLines(Tcl_Obj *listObj, int line, int n, int *lines, Tcl_Obj *const *elems); MODULE_SCOPE Tcl_Obj * TclListObjCopy(Tcl_Interp *interp, Tcl_Obj *listPtr); +MODULE_SCOPE Tcl_Obj * TclListObjRange(Tcl_Obj *listPtr, int fromIdx, + int toIdx); MODULE_SCOPE Tcl_Obj * TclLsetList(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *indexPtr, Tcl_Obj *valuePtr); MODULE_SCOPE Tcl_Obj * TclLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, @@ -3054,7 +3107,6 @@ MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc, MODULE_SCOPE Tcl_Obj * TclNoErrorStack(Tcl_Interp *interp, Tcl_Obj *options); MODULE_SCOPE int TclNokia770Doubles(void); MODULE_SCOPE void TclNsDecrRefCount(Namespace *nsPtr); -MODULE_SCOPE void TclNsDecrRefCount(Namespace *nsPtr); MODULE_SCOPE int TclNamespaceDeleted(Namespace *nsPtr); MODULE_SCOPE void TclObjVarErrMsg(Tcl_Interp *interp, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const char *operation, @@ -3095,7 +3147,7 @@ MODULE_SCOPE int TclpThreadCreate(Tcl_ThreadId *idPtr, int stackSize, int flags); MODULE_SCOPE int TclpFindVariable(const char *name, int *lengthPtr); MODULE_SCOPE void TclpInitLibraryPath(char **valuePtr, - int *lengthPtr, Tcl_Encoding *encodingPtr); + unsigned int *lengthPtr, Tcl_Encoding *encodingPtr); MODULE_SCOPE void TclpInitLock(void); MODULE_SCOPE void TclpInitPlatform(void); MODULE_SCOPE void TclpInitUnlock(void); @@ -3123,16 +3175,17 @@ 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, Tcl_DString *linkPtr); -MODULE_SCOPE void TclpSetInterfaces(void); MODULE_SCOPE void TclpSetVariables(Tcl_Interp *interp); MODULE_SCOPE void * TclThreadStorageKeyGet(Tcl_ThreadDataKey *keyPtr); MODULE_SCOPE void TclThreadStorageKeySet(Tcl_ThreadDataKey *keyPtr, void *data); -MODULE_SCOPE void TclpThreadExit(int status); +MODULE_SCOPE TCL_NORETURN void TclpThreadExit(int status); MODULE_SCOPE void TclRememberCondition(Tcl_Condition *mutex); MODULE_SCOPE void TclRememberJoinableThread(Tcl_ThreadId id); MODULE_SCOPE void TclRememberMutex(Tcl_Mutex *mutex); @@ -3146,7 +3199,8 @@ MODULE_SCOPE void TclSetBgErrorHandler(Tcl_Interp *interp, Tcl_Obj *cmdPrefix); MODULE_SCOPE void TclSetBignumIntRep(Tcl_Obj *objPtr, mp_int *bignumValue); -MODULE_SCOPE int TclSetBooleanFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); +MODULE_SCOPE int TclSetBooleanFromAny(Tcl_Interp *interp, + Tcl_Obj *objPtr); MODULE_SCOPE void TclSetCmdNameObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Command *cmdPtr); MODULE_SCOPE void TclSetDuplicateObj(Tcl_Obj *dupPtr, Tcl_Obj *objPtr); @@ -3158,17 +3212,16 @@ MODULE_SCOPE void TclSpellFix(Tcl_Interp *interp, Tcl_Obj *bad, Tcl_Obj *fix); MODULE_SCOPE void * TclStackRealloc(Tcl_Interp *interp, void *ptr, int numBytes); - typedef int (*memCmpFn_t)(const void*, const void*, size_t); -MODULE_SCOPE int TclStringCmp (Tcl_Obj *value1Ptr, Tcl_Obj *value2Ptr, +MODULE_SCOPE int TclStringCmp(Tcl_Obj *value1Ptr, Tcl_Obj *value2Ptr, int checkEq, int nocase, int reqlength); -MODULE_SCOPE int TclStringCmpOpts (Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], - int *nocase, int *reqlength); +MODULE_SCOPE int TclStringCmpOpts(Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[], int *nocase, + int *reqlength); 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 void TclSubstCompile(Tcl_Interp *interp, const char *bytes, int numBytes, int flags, int line, struct CompileEnv *envPtr); @@ -3186,7 +3239,24 @@ MODULE_SCOPE int TclTrimLeft(const char *bytes, int numBytes, const char *trim, int numTrim); MODULE_SCOPE int TclTrimRight(const char *bytes, int numBytes, const char *trim, int numTrim); +MODULE_SCOPE const char*TclGetCommandTypeName(Tcl_Command command); +MODULE_SCOPE void TclRegisterCommandTypeName( + Tcl_ObjCmdProc *implementationProc, + const char *nameStr); +#if (TCL_UTF_MAX > 4) && (defined(__CYGWIN__) || defined(_WIN32)) +MODULE_SCOPE int TclUtfToWChar(const char *src, WCHAR *chPtr); +MODULE_SCOPE char * TclWCharToUtfDString(const WCHAR *uniStr, + int uniLength, Tcl_DString *dsPtr); +MODULE_SCOPE WCHAR * TclUtfToWCharDString(const char *src, + int length, Tcl_DString *dsPtr); +#else +# define TclUtfToWChar TclUtfToUniChar +# define TclWCharToUtfDString Tcl_UniCharToUtfDString +# define TclUtfToWCharDString Tcl_UtfToUniCharDString +#endif +MODULE_SCOPE int TclUtfCmp(const char *cs, const char *ct); 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, @@ -3230,8 +3300,11 @@ MODULE_SCOPE void * TclpThreadCreateKey(void); MODULE_SCOPE void TclpThreadDeleteKey(void *keyPtr); MODULE_SCOPE void TclpThreadSetMasterTSD(void *tsdKeyPtr, void *ptr); MODULE_SCOPE void * TclpThreadGetMasterTSD(void *tsdKeyPtr); +MODULE_SCOPE void TclErrorStackResetIf(Tcl_Interp *interp, + const char *msg, int length); +/* Tip 430 */ +MODULE_SCOPE int TclZipfs_Init(Tcl_Interp *interp); -MODULE_SCOPE void TclErrorStackResetIf(Tcl_Interp *interp, const char *msg, int length); /* *---------------------------------------------------------------- @@ -3253,9 +3326,11 @@ MODULE_SCOPE Tcl_Command TclInitBinaryCmd(Tcl_Interp *interp); MODULE_SCOPE int Tcl_BreakObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 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[]); @@ -3275,7 +3350,7 @@ MODULE_SCOPE int TclChanPushObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE void TclClockInit(Tcl_Interp *interp); MODULE_SCOPE int TclClockOldscanObjCmd( - ClientData clientData, Tcl_Interp *interp, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_CloseObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, @@ -3311,7 +3386,6 @@ MODULE_SCOPE int TclNRAssembleObjCmd(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[]); @@ -3340,7 +3414,6 @@ MODULE_SCOPE int Tcl_FcopyObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE Tcl_Command TclInitFileCmd(Tcl_Interp *interp); -MODULE_SCOPE int TclMakeFileCommandSafe(Tcl_Interp *interp); MODULE_SCOPE int Tcl_FileEventObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -3402,9 +3475,15 @@ MODULE_SCOPE int Tcl_LmapObjCmd(ClientData clientData, MODULE_SCOPE int Tcl_LoadObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_LpopObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LrangeObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); +MODULE_SCOPE int Tcl_LremoveObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); MODULE_SCOPE int Tcl_LrepeatObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -3579,6 +3658,9 @@ MODULE_SCOPE int TclCompileDictForCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileDictGetCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileDictGetWithDefaultCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileDictIncrCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); @@ -3741,6 +3823,9 @@ MODULE_SCOPE int TclCompileStringFirstCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileStringIndexCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStringInsertCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileStringIsCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); @@ -3970,12 +4055,47 @@ MODULE_SCOPE int TclCompileEqOpCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileStreqOpCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStrLtOpCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStrLeOpCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStrGtOpCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileStrGeOpCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileAssembleCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); /* + * Routines that provide the [string] ensemble functionality. Possible + * candidates for public interface. + */ + +MODULE_SCOPE Tcl_Obj * TclStringCat(Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[], int flags); +MODULE_SCOPE int TclStringFirst(Tcl_Obj *needle, Tcl_Obj *haystack, + int start); +MODULE_SCOPE int TclStringLast(Tcl_Obj *needle, Tcl_Obj *haystack, + int last); +MODULE_SCOPE Tcl_Obj * TclStringRepeat(Tcl_Interp *interp, Tcl_Obj *objPtr, + int count, int flags); +MODULE_SCOPE Tcl_Obj * TclStringReplace(Tcl_Interp *interp, Tcl_Obj *objPtr, + int first, int count, Tcl_Obj *insertPtr, + int flags); +MODULE_SCOPE Tcl_Obj * TclStringReverse(Tcl_Obj *objPtr, int flags); + +/* Flag values for the [string] ensemble functions. */ + +#define TCL_STRING_MATCH_NOCASE TCL_MATCH_NOCASE /* (1<<0) in tcl.h */ +#define TCL_STRING_IN_PLACE (1<<1) + +/* * 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. @@ -4025,12 +4145,57 @@ MODULE_SCOPE int TclObjCallVarTraces(Interp *iPtr, Var *arrayPtr, */ MODULE_SCOPE int TclCompareObjKeys(void *keyPtr, Tcl_HashEntry *hPtr); +MODULE_SCOPE void TclFreeObj(Tcl_Obj *objPtr); MODULE_SCOPE void TclFreeObjEntry(Tcl_HashEntry *hPtr); -MODULE_SCOPE unsigned TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr); +MODULE_SCOPE TCL_HASH_TYPE TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr); MODULE_SCOPE int TclFullFinalizationRequested(void); /* + * Just for the purposes of command-type registration. + */ + +MODULE_SCOPE Tcl_ObjCmdProc TclEnsembleImplementationCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclAliasObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclLocalAliasObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclSlaveObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclInvokeImportedCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOOPublicObjectCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOOPrivateObjectCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclOOMyClassObjCmd; + +/* + * TIP #462. + */ + +/* + * The following enum values give the status of a spawned process. + */ + +typedef enum TclProcessWaitStatus { + TCL_PROCESS_ERROR = -1, /* Error waiting for process to exit */ + TCL_PROCESS_UNCHANGED = 0, /* No change since the last call. */ + TCL_PROCESS_EXITED = 1, /* Process has exited. */ + TCL_PROCESS_SIGNALED = 2, /* Child killed because of a signal. */ + TCL_PROCESS_STOPPED = 3, /* Child suspended because of a signal. */ + TCL_PROCESS_UNKNOWN_STATUS = 4 + /* Child wait status didn't make sense. */ +} TclProcessWaitStatus; + +MODULE_SCOPE Tcl_Command TclInitProcessCmd(Tcl_Interp *interp); +MODULE_SCOPE void TclProcessCreated(Tcl_Pid pid); +MODULE_SCOPE TclProcessWaitStatus TclProcessWait(Tcl_Pid pid, int options, + int *codePtr, Tcl_Obj **msgObjPtr, + Tcl_Obj **errorObjPtr); + +/* + * TIP #508: [array default] + */ + +MODULE_SCOPE void TclInitArrayVar(Var *arrayPtr); +MODULE_SCOPE Tcl_Obj * TclGetArrayDefault(Var *arrayPtr); + +/* * Utility routines for encoding index values as integers. Used by both * some of the command compilers and by [lsort] and [lsearch]. */ @@ -4041,9 +4206,7 @@ MODULE_SCOPE int TclIndexDecode(int encoded, int endValue); /* Constants used in index value encoding routines. */ #define TCL_INDEX_END (-2) -#define TCL_INDEX_BEFORE (-1) #define TCL_INDEX_START (0) -#define TCL_INDEX_AFTER (INT_MAX) /* *---------------------------------------------------------------- @@ -4102,7 +4265,7 @@ MODULE_SCOPE int TclIndexDecode(int encoded, int endValue); TclIncrObjsAllocated(); \ TclAllocObjStorage(objPtr); \ (objPtr)->refCount = 0; \ - (objPtr)->bytes = tclEmptyStringRep; \ + (objPtr)->bytes = &tclEmptyString; \ (objPtr)->length = 0; \ (objPtr)->typePtr = NULL; \ TCL_DTRACE_OBJ_CREATE(objPtr) @@ -4119,8 +4282,8 @@ MODULE_SCOPE int TclIndexDecode(int encoded, int endValue); if (!(objPtr)->typePtr || !(objPtr)->typePtr->freeIntRepProc) { \ TCL_DTRACE_OBJ_FREE(objPtr); \ if ((objPtr)->bytes \ - && ((objPtr)->bytes != tclEmptyStringRep)) { \ - ckfree((char *) (objPtr)->bytes); \ + && ((objPtr)->bytes != &tclEmptyString)) { \ + ckfree((objPtr)->bytes); \ } \ (objPtr)->length = -1; \ TclFreeObjStorage(objPtr); \ @@ -4130,6 +4293,10 @@ MODULE_SCOPE int TclIndexDecode(int encoded, int endValue); } \ } +#if TCL_THREADS && !defined(USE_THREAD_ALLOC) +# define USE_THREAD_ALLOC 1 +#endif + #if defined(PURIFY) /* @@ -4143,11 +4310,11 @@ MODULE_SCOPE int TclIndexDecode(int encoded, int endValue); (objPtr) = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj)) # define TclFreeObjStorageEx(interp, objPtr) \ - ckfree((char *) (objPtr)) + ckfree(objPtr) #undef USE_THREAD_ALLOC #undef USE_TCLALLOC -#elif defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) +#elif TCL_THREADS && defined(USE_THREAD_ALLOC) /* * The TCL_THREADS mode is like the regular mode but allocates Tcl_Obj's from @@ -4161,6 +4328,7 @@ 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 *); /* @@ -4211,7 +4379,7 @@ MODULE_SCOPE void TclpFreeAllocCache(void *); # define USE_TCLALLOC 0 #endif -#ifdef TCL_THREADS +#if TCL_THREADS /* declared in tclObj.c */ MODULE_SCOPE Tcl_Mutex tclObjMutex; #endif @@ -4279,11 +4447,11 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, #define TclInitStringRep(objPtr, bytePtr, len) \ if ((len) == 0) { \ - (objPtr)->bytes = tclEmptyStringRep; \ + (objPtr)->bytes = &tclEmptyString; \ (objPtr)->length = 0; \ } else { \ - (objPtr)->bytes = (char *) ckalloc((unsigned) ((len) + 1)); \ - memcpy((objPtr)->bytes, (bytePtr), (unsigned) (len)); \ + (objPtr)->bytes = (char *) ckalloc((len) + 1); \ + memcpy((objPtr)->bytes, (bytePtr) ? (bytePtr) : &tclEmptyString, (len)); \ (objPtr)->bytes[len] = '\0'; \ (objPtr)->length = (len); \ } @@ -4301,7 +4469,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 \ @@ -4336,15 +4504,52 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, */ #define TclInvalidateStringRep(objPtr) \ - if (objPtr->bytes != NULL) { \ - if (objPtr->bytes != tclEmptyStringRep) { \ - ckfree((char *) objPtr->bytes); \ + if ((objPtr)->bytes != NULL) { \ + if ((objPtr)->bytes != &tclEmptyString) { \ + ckfree((objPtr)->bytes); \ } \ - objPtr->bytes = NULL; \ + (objPtr)->bytes = NULL; \ } /* *---------------------------------------------------------------- + * Macro used by the Tcl core to test whether an object has a + * string representation (or is a 'pure' internal value). + * The ANSI C "prototype" for this macro is: + * + * MODULE_SCOPE int TclHasStringRep(Tcl_Obj *objPtr); + *---------------------------------------------------------------- + */ + +#define TclHasStringRep(objPtr) ((objPtr)->bytes != NULL) + +/* + *---------------------------------------------------------------- + * Macro used by the Tcl core to get the bignum out of the bignum + * representation of a Tcl_Obj. + * The ANSI C "prototype" for this macro is: + * + * MODULE_SCOPE void TclUnpackBignum(Tcl_Obj *objPtr, mp_int bignum); + *---------------------------------------------------------------- + */ + +#define TclUnpackBignum(objPtr, bignum) \ + do { \ + Tcl_Obj *bignumObj = (objPtr); \ + int bignumPayload = \ + PTR2INT(bignumObj->internalRep.twoPtrValue.ptr2); \ + if (bignumPayload == -1) { \ + (bignum) = *((mp_int *) bignumObj->internalRep.twoPtrValue.ptr1); \ + } else { \ + (bignum).dp = bignumObj->internalRep.twoPtrValue.ptr1; \ + (bignum).sign = bignumPayload >> 30; \ + (bignum).alloc = (bignumPayload >> 15) & 0x7fff; \ + (bignum).used = bignumPayload & 0x7fff; \ + } \ + } while (0) + +/* + *---------------------------------------------------------------- * Macros used by the Tcl core to grow Tcl_Token arrays. They use the same * growth algorithm as used in tclStringObj.c for growing strings. The ANSI C * "prototype" for this macro is: @@ -4391,19 +4596,19 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, allocated = TCL_MAX_TOKENS; \ } \ newPtr = (Tcl_Token *) attemptckrealloc((char *) oldPtr, \ - (unsigned int) (allocated * sizeof(Tcl_Token))); \ + allocated * sizeof(Tcl_Token)); \ if (newPtr == NULL) { \ allocated = _needed + (append) + TCL_MIN_TOKEN_GROWTH; \ if (allocated > TCL_MAX_TOKENS) { \ allocated = TCL_MAX_TOKENS; \ } \ newPtr = (Tcl_Token *) ckrealloc((char *) oldPtr, \ - (unsigned int) (allocated * sizeof(Tcl_Token))); \ + allocated * sizeof(Tcl_Token)); \ } \ (available) = allocated; \ if (oldPtr == NULL) { \ memcpy(newPtr, staticPtr, \ - (size_t) ((used) * sizeof(Tcl_Token))); \ + (used) * sizeof(Tcl_Token)); \ } \ (tokenPtr) = newPtr; \ } \ @@ -4427,7 +4632,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, */ #define TclUtfToUniChar(str, chPtr) \ - ((((unsigned char) *(str)) < 0xC0) ? \ + ((((unsigned char) *(str)) < 0x80) ? \ ((*(chPtr) = (unsigned char) *(str)), 1) \ : Tcl_UtfToUniChar(str, chPtr)) @@ -4470,13 +4675,14 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, *---------------------------------------------------------------- */ -#define TclIsPureByteArray(objPtr) \ - (((objPtr)->typePtr==&tclByteArrayType) && ((objPtr)->bytes==NULL)) +MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr); #define TclIsPureDict(objPtr) \ (((objPtr)->bytes==NULL) && ((objPtr)->typePtr==&tclDictType)) +#define TclHasIntRep(objPtr, type) \ + ((objPtr)->typePtr == (type)) +#define TclFetchIntRep(objPtr, type) \ + (TclHasIntRep((objPtr), (type)) ? &((objPtr)->internalRep) : NULL) -#define TclIsPureList(objPtr) \ - (((objPtr)->bytes==NULL) && ((objPtr)->typePtr==&tclListType)) /* *---------------------------------------------------------------- @@ -4558,51 +4764,25 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; * core. They should only be called on unshared objects. The ANSI C * "prototypes" for these macros are: * - * MODULE_SCOPE void TclSetIntObj(Tcl_Obj *objPtr, int intValue); - * MODULE_SCOPE void TclSetLongObj(Tcl_Obj *objPtr, long longValue); - * MODULE_SCOPE void TclSetBooleanObj(Tcl_Obj *objPtr, long boolValue); - * MODULE_SCOPE void TclSetWideIntObj(Tcl_Obj *objPtr, Tcl_WideInt w); + * MODULE_SCOPE void TclSetIntObj(Tcl_Obj *objPtr, Tcl_WideInt w); * MODULE_SCOPE void TclSetDoubleObj(Tcl_Obj *objPtr, double d); *---------------------------------------------------------------- */ -#define TclSetLongObj(objPtr, i) \ +#define TclSetIntObj(objPtr, i) \ do { \ + Tcl_ObjIntRep ir; \ + ir.wideValue = (Tcl_WideInt) i; \ TclInvalidateStringRep(objPtr); \ - TclFreeIntRep(objPtr); \ - (objPtr)->internalRep.longValue = (long)(i); \ - (objPtr)->typePtr = &tclIntType; \ + Tcl_StoreIntRep(objPtr, &tclIntType, &ir); \ } while (0) -#define TclSetIntObj(objPtr, l) \ - TclSetLongObj(objPtr, l) - -/* - * NOTE: There is to be no such thing as a "pure" boolean. Boolean values set - * programmatically go straight to being "int" Tcl_Obj's, with value 0 or 1. - * The only "boolean" Tcl_Obj's shall be those holding the cached boolean - * value of strings like: "yes", "no", "true", "false", "on", "off". - */ - -#define TclSetBooleanObj(objPtr, b) \ - TclSetLongObj(objPtr, (b)!=0); - -#ifndef TCL_WIDE_INT_IS_LONG -#define TclSetWideIntObj(objPtr, w) \ - do { \ - TclInvalidateStringRep(objPtr); \ - TclFreeIntRep(objPtr); \ - (objPtr)->internalRep.wideValue = (Tcl_WideInt)(w); \ - (objPtr)->typePtr = &tclWideIntType; \ - } while (0) -#endif - #define TclSetDoubleObj(objPtr, d) \ - do { \ - TclInvalidateStringRep(objPtr); \ - TclFreeIntRep(objPtr); \ - (objPtr)->internalRep.doubleValue = (double)(d); \ - (objPtr)->typePtr = &tclDoubleType; \ + do { \ + Tcl_ObjIntRep ir; \ + ir.doubleValue = (double) d; \ + TclInvalidateStringRep(objPtr); \ + Tcl_StoreIntRep(objPtr, &tclDoubleType, &ir); \ } while (0) /* @@ -4611,39 +4791,26 @@ 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 TclNewIntObj(Tcl_Obj *objPtr, Tcl_WideInt w); * MODULE_SCOPE void TclNewDoubleObj(Tcl_Obj *objPtr, double d); - * MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, char *s, int len); - * MODULE_SCOPE void TclNewLiteralStringObj(Tcl_Obj*objPtr, char*sLiteral); + * MODULE_SCOPE void TclNewStringObj(Tcl_Obj *objPtr, const char *s, int len); + * MODULE_SCOPE void TclNewLiteralStringObj(Tcl_Obj*objPtr, const char *sLiteral); * *---------------------------------------------------------------- */ #ifndef TCL_MEM_DEBUG -#define TclNewLongObj(objPtr, i) \ +#define TclNewIntObj(objPtr, i) \ do { \ TclIncrObjsAllocated(); \ TclAllocObjStorage(objPtr); \ (objPtr)->refCount = 0; \ (objPtr)->bytes = NULL; \ - (objPtr)->internalRep.longValue = (long)(i); \ + (objPtr)->internalRep.wideValue = (Tcl_WideInt)(i); \ (objPtr)->typePtr = &tclIntType; \ TCL_DTRACE_OBJ_CREATE(objPtr); \ } while (0) -#define TclNewIntObj(objPtr, l) \ - TclNewLongObj(objPtr, l) - -/* - * NOTE: There is to be no such thing as a "pure" boolean. - * See comment above TclSetBooleanObj macro above. - */ -#define TclNewBooleanObj(objPtr, b) \ - TclNewLongObj((objPtr), (b)!=0) - #define TclNewDoubleObj(objPtr, d) \ do { \ TclIncrObjsAllocated(); \ @@ -4666,14 +4833,8 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; } while (0) #else /* TCL_MEM_DEBUG */ -#define TclNewIntObj(objPtr, i) \ - (objPtr) = Tcl_NewIntObj(i) - -#define TclNewLongObj(objPtr, l) \ - (objPtr) = Tcl_NewLongObj(l) - -#define TclNewBooleanObj(objPtr, b) \ - (objPtr) = Tcl_NewBooleanObj(b) +#define TclNewIntObj(objPtr, w) \ + (objPtr) = Tcl_NewWideIntObj(w) #define TclNewDoubleObj(objPtr, d) \ (objPtr) = Tcl_NewDoubleObj(d) @@ -4726,15 +4887,16 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; #endif /* - * ---------------------------------------------------------------------- - * Macro to use to find the offset of a field in a structure. Computes number - * of bytes from beginning of structure to a given field. + * Macro to use to find the offset of a field in astructure. + * Computes number of bytes from beginning of structure to a given field. */ -#ifdef offsetof -#define TclOffset(type, field) ((int) offsetof(type, field)) -#else -#define TclOffset(type, field) ((int) ((char *) &((type *) 0)->field)) +#ifndef TCL_NO_DEPRECATED +# define TclOffset(type, field) ((int) offsetof(type, field)) +#endif +/* Workaround for platforms missing offsetof(), e.g. VC++ 6.0 */ +#ifndef offsetof +# define offsetof(type, field) ((size_t) ((char *) &((type *) 0)->field)) #endif /* @@ -4756,7 +4918,7 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit; #define TclCleanupCommandMacro(cmdPtr) \ if ((cmdPtr)->refCount-- <= 1) { \ - ckfree((char *) (cmdPtr));\ + ckfree(cmdPtr);\ } /* @@ -4914,7 +5076,7 @@ typedef struct NRE_callback { #else #define TCLNR_ALLOC(interp, ptr) \ (ptr = ((ClientData) ckalloc(sizeof(NRE_callback)))) -#define TCLNR_FREE(interp, ptr) ckfree((char *) (ptr)) +#define TCLNR_FREE(interp, ptr) ckfree(ptr) #endif #if NRE_ENABLE_ASSERTS diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 1991c21..16bcdf8 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -27,21 +27,22 @@ # endif #endif -/* [Bug #803489] Tcl_FindNamespace problem in the Stubs table */ -#undef Tcl_CreateNamespace -#undef Tcl_DeleteNamespace -#undef Tcl_AppendExportList -#undef Tcl_Export -#undef Tcl_Import -#undef Tcl_ForgetImport -#undef Tcl_GetCurrentNamespace -#undef Tcl_GetGlobalNamespace -#undef Tcl_FindNamespace -#undef Tcl_FindCommand -#undef Tcl_GetCommandFromObj -#undef Tcl_GetCommandFullName -#undef Tcl_SetStartupScript -#undef Tcl_GetStartupScript +#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9) +# define tclGetIntForIndex tcl_GetIntForIndex +/* Those macro's are especially for Itcl 3.4 compatibility */ +# define tclCreateNamespace tcl_CreateNamespace +# define tclDeleteNamespace tcl_DeleteNamespace +# define tclAppendExportList tcl_AppendExportList +# define tclExport tcl_Export +# define tclImport tcl_Import +# define tclForgetImport tcl_ForgetImport +# define tclGetCurrentNamespace_ tcl_GetCurrentNamespace +# define tclGetGlobalNamespace_ tcl_GetGlobalNamespace +# define tclFindNamespace tcl_FindNamespace +# define tclFindCommand tcl_FindCommand +# define tclGetCommandFromObj tcl_GetCommandFromObj +# define tclGetCommandFullName tcl_GetCommandFullName +#endif /* !defined(TCL_NO_DEPRECATED) */ /* * WARNING: This file is automatically generated by the tools/genStubs.tcl @@ -74,7 +75,8 @@ EXTERN void TclCleanupCommand(Command *cmdPtr); EXTERN int TclCopyAndCollapse(int count, const char *src, char *dst); /* 8 */ -EXTERN int TclCopyChannelOld(Tcl_Interp *interp, +TCL_DEPRECATED("") +int TclCopyChannelOld(Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr); /* 9 */ @@ -112,7 +114,7 @@ EXTERN int TclFindElement(Tcl_Interp *interp, /* 23 */ EXTERN Proc * TclFindProc(Interp *iPtr, const char *procName); /* 24 */ -EXTERN int TclFormatInt(char *buffer, long n); +EXTERN int TclFormatInt(char *buffer, Tcl_WideInt n); /* 25 */ EXTERN void TclFreePackageInfo(Interp *iPtr); /* Slot 26 is reserved */ @@ -128,7 +130,8 @@ EXTERN int TclGetFrame(Tcl_Interp *interp, const char *str, CallFrame **framePtrPtr); /* Slot 33 is reserved */ /* 34 */ -EXTERN int TclGetIntForIndex(Tcl_Interp *interp, +TCL_DEPRECATED("Use Tcl_GetIntForIndex") +int TclGetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr, int endValue, int *indexPtr); /* Slot 35 is reserved */ /* Slot 36 is reserved */ @@ -172,7 +175,7 @@ EXTERN int TclInterpInit(Tcl_Interp *interp); /* 53 */ EXTERN int TclInvokeObjectCommand(ClientData clientData, Tcl_Interp *interp, int argc, - CONST84 char **argv); + const char **argv); /* 54 */ EXTERN int TclInvokeStringCommand(ClientData clientData, Tcl_Interp *interp, int objc, @@ -217,7 +220,8 @@ EXTERN unsigned long TclpGetClicks(void); /* 76 */ EXTERN unsigned long TclpGetSeconds(void); /* 77 */ -EXTERN void TclpGetTime(Tcl_Time *time); +TCL_DEPRECATED("") +void TclpGetTime(Tcl_Time *time); /* Slot 78 is reserved */ /* Slot 79 is reserved */ /* Slot 80 is reserved */ @@ -230,7 +234,8 @@ EXTERN char * TclpRealloc(char *ptr, unsigned int size); /* Slot 86 is reserved */ /* Slot 87 is reserved */ /* 88 */ -EXTERN char * TclPrecTraceProc(ClientData clientData, +TCL_DEPRECATED("") +char * TclPrecTraceProc(ClientData clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags); /* 89 */ @@ -266,7 +271,8 @@ EXTERN void TclSetupEnv(Tcl_Interp *interp); EXTERN int TclSockGetPort(Tcl_Interp *interp, const char *str, const char *proto, int *portPtr); /* 104 */ -EXTERN int TclSockMinimumBuffersOld(int sock, int size); +TCL_DEPRECATED("") +int TclSockMinimumBuffersOld(int sock, int size); /* Slot 105 is reserved */ /* Slot 106 is reserved */ /* Slot 107 is reserved */ @@ -283,22 +289,22 @@ EXTERN void Tcl_AddInterpResolvers(Tcl_Interp *interp, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 112 */ -EXTERN int Tcl_AppendExportList(Tcl_Interp *interp, +EXTERN int TclAppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 113 */ -EXTERN Tcl_Namespace * Tcl_CreateNamespace(Tcl_Interp *interp, +EXTERN Tcl_Namespace * TclCreateNamespace(Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 114 */ -EXTERN void Tcl_DeleteNamespace(Tcl_Namespace *nsPtr); +EXTERN void TclDeleteNamespace(Tcl_Namespace *nsPtr); /* 115 */ -EXTERN int Tcl_Export(Tcl_Interp *interp, Tcl_Namespace *nsPtr, +EXTERN int TclExport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst); /* 116 */ -EXTERN Tcl_Command Tcl_FindCommand(Tcl_Interp *interp, const char *name, +EXTERN Tcl_Command TclFindCommand(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 117 */ -EXTERN Tcl_Namespace * Tcl_FindNamespace(Tcl_Interp *interp, +EXTERN Tcl_Namespace * TclFindNamespace(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 118 */ @@ -313,23 +319,23 @@ EXTERN Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 121 */ -EXTERN int Tcl_ForgetImport(Tcl_Interp *interp, +EXTERN int TclForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern); /* 122 */ -EXTERN Tcl_Command Tcl_GetCommandFromObj(Tcl_Interp *interp, +EXTERN Tcl_Command TclGetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr); /* 123 */ -EXTERN void Tcl_GetCommandFullName(Tcl_Interp *interp, +EXTERN void TclGetCommandFullName(Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 124 */ -EXTERN Tcl_Namespace * Tcl_GetCurrentNamespace(Tcl_Interp *interp); +EXTERN Tcl_Namespace * TclGetCurrentNamespace_(Tcl_Interp *interp); /* 125 */ -EXTERN Tcl_Namespace * Tcl_GetGlobalNamespace(Tcl_Interp *interp); +EXTERN Tcl_Namespace * TclGetGlobalNamespace_(Tcl_Interp *interp); /* 126 */ EXTERN void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr); /* 127 */ -EXTERN int Tcl_Import(Tcl_Interp *interp, Tcl_Namespace *nsPtr, +EXTERN int TclImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int allowOverwrite); /* 128 */ EXTERN void Tcl_PopCallFrame(Tcl_Interp *interp); @@ -349,19 +355,18 @@ EXTERN void Tcl_SetNamespaceResolvers( /* 132 */ EXTERN int TclpHasSockets(Tcl_Interp *interp); /* 133 */ -EXTERN struct tm * TclpGetDate(const time_t *time, int useGMT); +TCL_DEPRECATED("") +struct tm * TclpGetDate(const time_t *time, int useGMT); /* Slot 134 is reserved */ /* Slot 135 is reserved */ /* Slot 136 is reserved */ /* Slot 137 is reserved */ /* 138 */ -EXTERN CONST84_RETURN char * TclGetEnv(const char *name, - Tcl_DString *valuePtr); +EXTERN const char * TclGetEnv(const char *name, Tcl_DString *valuePtr); /* Slot 139 is reserved */ /* Slot 140 is reserved */ /* 141 */ -EXTERN CONST84_RETURN char * TclpGetCwd(Tcl_Interp *interp, - Tcl_DString *cwdPtr); +EXTERN const char * TclpGetCwd(Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 142 */ EXTERN int TclSetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr, CompileHookProc *hookProc, @@ -400,9 +405,11 @@ EXTERN void TclRegError(Tcl_Interp *interp, const char *msg, EXTERN Var * TclVarTraceExists(Tcl_Interp *interp, const char *varName); /* 158 */ -EXTERN void TclSetStartupScriptFileName(const char *filename); +TCL_DEPRECATED("use public Tcl_SetStartupScript()") +void TclSetStartupScriptFileName(const char *filename); /* 159 */ -EXTERN const char * TclGetStartupScriptFileName(void); +TCL_DEPRECATED("use public Tcl_GetStartupScript()") +const char * TclGetStartupScriptFileName(void); /* Slot 160 is reserved */ /* 161 */ EXTERN int TclChannelTransform(Tcl_Interp *interp, @@ -421,9 +428,11 @@ EXTERN int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj *valuePtr); /* 167 */ -EXTERN void TclSetStartupScriptPath(Tcl_Obj *pathPtr); +TCL_DEPRECATED("use public Tcl_SetStartupScript()") +void TclSetStartupScriptPath(Tcl_Obj *pathPtr); /* 168 */ -EXTERN Tcl_Obj * TclGetStartupScriptPath(void); +TCL_DEPRECATED("use public Tcl_GetStartupScript()") +Tcl_Obj * TclGetStartupScriptPath(void); /* 169 */ EXTERN int TclpUtfNcmp2(const char *s1, const char *s2, unsigned long n); @@ -456,16 +465,18 @@ EXTERN void TclVarErrMsg(Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason); /* 178 */ -EXTERN void Tcl_SetStartupScript(Tcl_Obj *pathPtr, +EXTERN void TclSetStartupScript(Tcl_Obj *pathPtr, const char *encodingName); /* 179 */ -EXTERN Tcl_Obj * Tcl_GetStartupScript(const char **encodingNamePtr); +EXTERN Tcl_Obj * TclGetStartupScript(const char **encodingNamePtr); /* Slot 180 is reserved */ /* Slot 181 is reserved */ /* 182 */ -EXTERN struct tm * TclpLocaltime(const time_t *clock); +TCL_DEPRECATED("") +struct tm * TclpLocaltime(const time_t *clock); /* 183 */ -EXTERN struct tm * TclpGmtime(const time_t *clock); +TCL_DEPRECATED("") +struct tm * TclpGmtime(const time_t *clock); /* Slot 184 is reserved */ /* Slot 185 is reserved */ /* Slot 186 is reserved */ @@ -569,7 +580,8 @@ EXTERN Var * TclVarHashCreateVar(TclVarHashTable *tablePtr, EXTERN void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr); /* 236 */ -EXTERN void TclBackgroundException(Tcl_Interp *interp, int code); +TCL_DEPRECATED("use Tcl_BackgroundException") +void TclBackgroundException(Tcl_Interp *interp, int code); /* 237 */ EXTERN int TclResetCancellation(Tcl_Interp *interp, int force); /* 238 */ @@ -614,7 +626,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, char *bytes, +EXTERN int TclRegisterLiteral(void *envPtr, const char *bytes, int length, int flags); /* 252 */ EXTERN Tcl_Obj * TclPtrGetVar(Tcl_Interp *interp, Tcl_Var varPtr, @@ -638,6 +650,14 @@ EXTERN int TclPtrObjMakeUpvar(Tcl_Interp *interp, EXTERN int TclPtrUnsetVar(Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); +/* 257 */ +EXTERN void TclStaticPackage(Tcl_Interp *interp, + const char *pkgName, + Tcl_PackageInitProc *initProc, + Tcl_PackageInitProc *safeInitProc); +/* 258 */ +EXTERN Tcl_Obj * TclpCreateTemporaryDirectory(Tcl_Obj *dirObj, + Tcl_Obj *basenameObj); typedef struct TclIntStubs { int magic; @@ -651,7 +671,7 @@ typedef struct TclIntStubs { int (*tclCleanupChildren) (Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan); /* 5 */ void (*tclCleanupCommand) (Command *cmdPtr); /* 6 */ int (*tclCopyAndCollapse) (int count, const char *src, char *dst); /* 7 */ - int (*tclCopyChannelOld) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr); /* 8 */ + TCL_DEPRECATED_API("") int (*tclCopyChannelOld) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr); /* 8 */ int (*tclCreatePipeline) (Tcl_Interp *interp, int argc, const char **argv, Tcl_Pid **pidArrayPtr, TclFile *inPipePtr, TclFile *outPipePtr, TclFile *errFilePtr); /* 9 */ int (*tclCreateProc) (Tcl_Interp *interp, Namespace *nsPtr, const char *procName, Tcl_Obj *argsPtr, Tcl_Obj *bodyPtr, Proc **procPtrPtr); /* 10 */ void (*tclDeleteCompiledLocalVars) (Interp *iPtr, CallFrame *framePtr); /* 11 */ @@ -667,7 +687,7 @@ typedef struct TclIntStubs { void (*reserved21)(void); int (*tclFindElement) (Tcl_Interp *interp, const char *listStr, int listLength, const char **elementPtr, const char **nextPtr, int *sizePtr, int *bracePtr); /* 22 */ Proc * (*tclFindProc) (Interp *iPtr, const char *procName); /* 23 */ - int (*tclFormatInt) (char *buffer, long n); /* 24 */ + int (*tclFormatInt) (char *buffer, Tcl_WideInt n); /* 24 */ void (*tclFreePackageInfo) (Interp *iPtr); /* 25 */ void (*reserved26)(void); void (*reserved27)(void); @@ -677,7 +697,7 @@ typedef struct TclIntStubs { const char * (*tclGetExtension) (const char *name); /* 31 */ int (*tclGetFrame) (Tcl_Interp *interp, const char *str, CallFrame **framePtrPtr); /* 32 */ void (*reserved33)(void); - int (*tclGetIntForIndex) (Tcl_Interp *interp, Tcl_Obj *objPtr, int endValue, int *indexPtr); /* 34 */ + TCL_DEPRECATED_API("Use Tcl_GetIntForIndex") int (*tclGetIntForIndex) (Tcl_Interp *interp, Tcl_Obj *objPtr, int endValue, int *indexPtr); /* 34 */ void (*reserved35)(void); void (*reserved36)(void); int (*tclGetLoadedPackages) (Tcl_Interp *interp, const char *targetName); /* 37 */ @@ -696,7 +716,7 @@ typedef struct TclIntStubs { void (*tclInitCompiledLocals) (Tcl_Interp *interp, CallFrame *framePtr, Namespace *nsPtr); /* 50 */ int (*tclInterpInit) (Tcl_Interp *interp); /* 51 */ void (*reserved52)(void); - int (*tclInvokeObjectCommand) (ClientData clientData, Tcl_Interp *interp, int argc, CONST84 char **argv); /* 53 */ + int (*tclInvokeObjectCommand) (ClientData clientData, Tcl_Interp *interp, int argc, const char **argv); /* 53 */ int (*tclInvokeStringCommand) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 54 */ Proc * (*tclIsProc) (Command *cmdPtr); /* 55 */ void (*reserved56)(void); @@ -720,7 +740,7 @@ typedef struct TclIntStubs { void (*tclpFree) (char *ptr); /* 74 */ unsigned long (*tclpGetClicks) (void); /* 75 */ unsigned long (*tclpGetSeconds) (void); /* 76 */ - void (*tclpGetTime) (Tcl_Time *time); /* 77 */ + TCL_DEPRECATED_API("") void (*tclpGetTime) (Tcl_Time *time); /* 77 */ void (*reserved78)(void); void (*reserved79)(void); void (*reserved80)(void); @@ -731,7 +751,7 @@ typedef struct TclIntStubs { void (*reserved85)(void); void (*reserved86)(void); void (*reserved87)(void); - char * (*tclPrecTraceProc) (ClientData clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags); /* 88 */ + TCL_DEPRECATED_API("") char * (*tclPrecTraceProc) (ClientData clientData, Tcl_Interp *interp, const char *name1, const char *name2, int flags); /* 88 */ int (*tclPreventAliasLoop) (Tcl_Interp *interp, Tcl_Interp *cmdInterp, Tcl_Command cmd); /* 89 */ void (*reserved90)(void); void (*tclProcCleanupProc) (Proc *procPtr); /* 91 */ @@ -747,7 +767,7 @@ typedef struct TclIntStubs { CONST86 char * (*tclSetPreInitScript) (const char *string); /* 101 */ void (*tclSetupEnv) (Tcl_Interp *interp); /* 102 */ int (*tclSockGetPort) (Tcl_Interp *interp, const char *str, const char *proto, int *portPtr); /* 103 */ - int (*tclSockMinimumBuffersOld) (int sock, int size); /* 104 */ + TCL_DEPRECATED_API("") int (*tclSockMinimumBuffersOld) (int sock, int size); /* 104 */ void (*reserved105)(void); void (*reserved106)(void); void (*reserved107)(void); @@ -755,36 +775,36 @@ typedef struct TclIntStubs { int (*tclUpdateReturnInfo) (Interp *iPtr); /* 109 */ int (*tclSockMinimumBuffers) (void *sock, int size); /* 110 */ void (*tcl_AddInterpResolvers) (Tcl_Interp *interp, const char *name, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 111 */ - int (*tcl_AppendExportList) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 112 */ - Tcl_Namespace * (*tcl_CreateNamespace) (Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 113 */ - void (*tcl_DeleteNamespace) (Tcl_Namespace *nsPtr); /* 114 */ - int (*tcl_Export) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst); /* 115 */ - Tcl_Command (*tcl_FindCommand) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 116 */ - Tcl_Namespace * (*tcl_FindNamespace) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 117 */ + int (*tclAppendExportList) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 112 */ + Tcl_Namespace * (*tclCreateNamespace) (Tcl_Interp *interp, const char *name, ClientData clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 113 */ + void (*tclDeleteNamespace) (Tcl_Namespace *nsPtr); /* 114 */ + int (*tclExport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst); /* 115 */ + Tcl_Command (*tclFindCommand) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 116 */ + Tcl_Namespace * (*tclFindNamespace) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 117 */ int (*tcl_GetInterpResolvers) (Tcl_Interp *interp, const char *name, Tcl_ResolverInfo *resInfo); /* 118 */ int (*tcl_GetNamespaceResolvers) (Tcl_Namespace *namespacePtr, Tcl_ResolverInfo *resInfo); /* 119 */ Tcl_Var (*tcl_FindNamespaceVar) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 120 */ - int (*tcl_ForgetImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern); /* 121 */ - Tcl_Command (*tcl_GetCommandFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 122 */ - void (*tcl_GetCommandFullName) (Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 123 */ - Tcl_Namespace * (*tcl_GetCurrentNamespace) (Tcl_Interp *interp); /* 124 */ - Tcl_Namespace * (*tcl_GetGlobalNamespace) (Tcl_Interp *interp); /* 125 */ + int (*tclForgetImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern); /* 121 */ + Tcl_Command (*tclGetCommandFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 122 */ + void (*tclGetCommandFullName) (Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 123 */ + Tcl_Namespace * (*tclGetCurrentNamespace_) (Tcl_Interp *interp); /* 124 */ + Tcl_Namespace * (*tclGetGlobalNamespace_) (Tcl_Interp *interp); /* 125 */ void (*tcl_GetVariableFullName) (Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr); /* 126 */ - int (*tcl_Import) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int allowOverwrite); /* 127 */ + int (*tclImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int allowOverwrite); /* 127 */ void (*tcl_PopCallFrame) (Tcl_Interp *interp); /* 128 */ int (*tcl_PushCallFrame) (Tcl_Interp *interp, Tcl_CallFrame *framePtr, Tcl_Namespace *nsPtr, int isProcCallFrame); /* 129 */ int (*tcl_RemoveInterpResolvers) (Tcl_Interp *interp, const char *name); /* 130 */ void (*tcl_SetNamespaceResolvers) (Tcl_Namespace *namespacePtr, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 131 */ int (*tclpHasSockets) (Tcl_Interp *interp); /* 132 */ - struct tm * (*tclpGetDate) (const time_t *time, int useGMT); /* 133 */ + TCL_DEPRECATED_API("") struct tm * (*tclpGetDate) (const time_t *time, int useGMT); /* 133 */ void (*reserved134)(void); void (*reserved135)(void); void (*reserved136)(void); void (*reserved137)(void); - CONST84_RETURN char * (*tclGetEnv) (const char *name, Tcl_DString *valuePtr); /* 138 */ + const char * (*tclGetEnv) (const char *name, Tcl_DString *valuePtr); /* 138 */ void (*reserved139)(void); void (*reserved140)(void); - CONST84_RETURN char * (*tclpGetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 141 */ + const char * (*tclpGetCwd) (Tcl_Interp *interp, Tcl_DString *cwdPtr); /* 141 */ int (*tclSetByteCodeFromAny) (Tcl_Interp *interp, Tcl_Obj *objPtr, CompileHookProc *hookProc, ClientData clientData); /* 142 */ int (*tclAddLiteralObj) (struct CompileEnv *envPtr, Tcl_Obj *objPtr, LiteralEntry **litPtrPtr); /* 143 */ void (*tclHideLiteral) (Tcl_Interp *interp, struct CompileEnv *envPtr, int index); /* 144 */ @@ -801,8 +821,8 @@ typedef struct TclIntStubs { void (*reserved155)(void); void (*tclRegError) (Tcl_Interp *interp, const char *msg, int status); /* 156 */ Var * (*tclVarTraceExists) (Tcl_Interp *interp, const char *varName); /* 157 */ - void (*tclSetStartupScriptFileName) (const char *filename); /* 158 */ - const char * (*tclGetStartupScriptFileName) (void); /* 159 */ + TCL_DEPRECATED_API("use public Tcl_SetStartupScript()") void (*tclSetStartupScriptFileName) (const char *filename); /* 158 */ + TCL_DEPRECATED_API("use public Tcl_GetStartupScript()") const char * (*tclGetStartupScriptFileName) (void); /* 159 */ void (*reserved160)(void); int (*tclChannelTransform) (Tcl_Interp *interp, Tcl_Channel chan, Tcl_Obj *cmdObjPtr); /* 161 */ void (*tclChannelEventScriptInvoker) (ClientData clientData, int flags); /* 162 */ @@ -810,8 +830,8 @@ typedef struct TclIntStubs { void (*tclExpandCodeArray) (void *envPtr); /* 164 */ void (*tclpSetInitialEncodings) (void); /* 165 */ int (*tclListObjSetElement) (Tcl_Interp *interp, Tcl_Obj *listPtr, int index, Tcl_Obj *valuePtr); /* 166 */ - void (*tclSetStartupScriptPath) (Tcl_Obj *pathPtr); /* 167 */ - Tcl_Obj * (*tclGetStartupScriptPath) (void); /* 168 */ + TCL_DEPRECATED_API("use public Tcl_SetStartupScript()") void (*tclSetStartupScriptPath) (Tcl_Obj *pathPtr); /* 167 */ + TCL_DEPRECATED_API("use public Tcl_GetStartupScript()") Tcl_Obj * (*tclGetStartupScriptPath) (void); /* 168 */ int (*tclpUtfNcmp2) (const char *s1, const char *s2, unsigned long n); /* 169 */ int (*tclCheckInterpTraces) (Tcl_Interp *interp, const char *command, int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 170 */ int (*tclCheckExecutionTraces) (Tcl_Interp *interp, const char *command, int numChars, Command *cmdPtr, int result, int traceFlags, int objc, Tcl_Obj *const objv[]); /* 171 */ @@ -821,12 +841,12 @@ typedef struct TclIntStubs { int (*tclCallVarTraces) (Interp *iPtr, Var *arrayPtr, Var *varPtr, const char *part1, const char *part2, int flags, int leaveErrMsg); /* 175 */ void (*tclCleanupVar) (Var *varPtr, Var *arrayPtr); /* 176 */ void (*tclVarErrMsg) (Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason); /* 177 */ - void (*tcl_SetStartupScript) (Tcl_Obj *pathPtr, const char *encodingName); /* 178 */ - Tcl_Obj * (*tcl_GetStartupScript) (const char **encodingNamePtr); /* 179 */ + void (*tclSetStartupScript) (Tcl_Obj *pathPtr, const char *encodingName); /* 178 */ + Tcl_Obj * (*tclGetStartupScript) (const char **encodingNamePtr); /* 179 */ void (*reserved180)(void); void (*reserved181)(void); - struct tm * (*tclpLocaltime) (const time_t *clock); /* 182 */ - struct tm * (*tclpGmtime) (const time_t *clock); /* 183 */ + TCL_DEPRECATED_API("") struct tm * (*tclpLocaltime) (const time_t *clock); /* 182 */ + TCL_DEPRECATED_API("") struct tm * (*tclpGmtime) (const time_t *clock); /* 183 */ void (*reserved184)(void); void (*reserved185)(void); void (*reserved186)(void); @@ -879,7 +899,7 @@ typedef struct TclIntStubs { void (*tclGetSrcInfoForPc) (CmdFrame *contextPtr); /* 233 */ Var * (*tclVarHashCreateVar) (TclVarHashTable *tablePtr, const char *key, int *newPtr); /* 234 */ void (*tclInitVarHashTable) (TclVarHashTable *tablePtr, Namespace *nsPtr); /* 235 */ - void (*tclBackgroundException) (Tcl_Interp *interp, int code); /* 236 */ + TCL_DEPRECATED_API("use Tcl_BackgroundException") void (*tclBackgroundException) (Tcl_Interp *interp, int code); /* 236 */ int (*tclResetCancellation) (Tcl_Interp *interp, int force); /* 237 */ int (*tclNRInterpProc) (ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* 238 */ int (*tclNRInterpProcCore) (Tcl_Interp *interp, Tcl_Obj *procNameObj, int skip, ProcErrorProc *errorProc); /* 239 */ @@ -894,12 +914,14 @@ 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, char *bytes, int length, int flags); /* 251 */ + int (*tclRegisterLiteral) (void *envPtr, const char *bytes, int length, int flags); /* 251 */ Tcl_Obj * (*tclPtrGetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 252 */ Tcl_Obj * (*tclPtrSetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *newValuePtr, const int flags); /* 253 */ Tcl_Obj * (*tclPtrIncrObjVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, Tcl_Obj *incrPtr, const int flags); /* 254 */ int (*tclPtrObjMakeUpvar) (Tcl_Interp *interp, Tcl_Var otherPtr, Tcl_Obj *myNamePtr, int myFlags); /* 255 */ int (*tclPtrUnsetVar) (Tcl_Interp *interp, Tcl_Var varPtr, Tcl_Var arrayPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, const int flags); /* 256 */ + void (*tclStaticPackage) (Tcl_Interp *interp, const char *pkgName, Tcl_PackageInitProc *initProc, Tcl_PackageInitProc *safeInitProc); /* 257 */ + Tcl_Obj * (*tclpCreateTemporaryDirectory) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj); /* 258 */ } TclIntStubs; extern const TclIntStubs *tclIntStubsPtr; @@ -1087,38 +1109,38 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclSockMinimumBuffers) /* 110 */ #define Tcl_AddInterpResolvers \ (tclIntStubsPtr->tcl_AddInterpResolvers) /* 111 */ -#define Tcl_AppendExportList \ - (tclIntStubsPtr->tcl_AppendExportList) /* 112 */ -#define Tcl_CreateNamespace \ - (tclIntStubsPtr->tcl_CreateNamespace) /* 113 */ -#define Tcl_DeleteNamespace \ - (tclIntStubsPtr->tcl_DeleteNamespace) /* 114 */ -#define Tcl_Export \ - (tclIntStubsPtr->tcl_Export) /* 115 */ -#define Tcl_FindCommand \ - (tclIntStubsPtr->tcl_FindCommand) /* 116 */ -#define Tcl_FindNamespace \ - (tclIntStubsPtr->tcl_FindNamespace) /* 117 */ +#define TclAppendExportList \ + (tclIntStubsPtr->tclAppendExportList) /* 112 */ +#define TclCreateNamespace \ + (tclIntStubsPtr->tclCreateNamespace) /* 113 */ +#define TclDeleteNamespace \ + (tclIntStubsPtr->tclDeleteNamespace) /* 114 */ +#define TclExport \ + (tclIntStubsPtr->tclExport) /* 115 */ +#define TclFindCommand \ + (tclIntStubsPtr->tclFindCommand) /* 116 */ +#define TclFindNamespace \ + (tclIntStubsPtr->tclFindNamespace) /* 117 */ #define Tcl_GetInterpResolvers \ (tclIntStubsPtr->tcl_GetInterpResolvers) /* 118 */ #define Tcl_GetNamespaceResolvers \ (tclIntStubsPtr->tcl_GetNamespaceResolvers) /* 119 */ #define Tcl_FindNamespaceVar \ (tclIntStubsPtr->tcl_FindNamespaceVar) /* 120 */ -#define Tcl_ForgetImport \ - (tclIntStubsPtr->tcl_ForgetImport) /* 121 */ -#define Tcl_GetCommandFromObj \ - (tclIntStubsPtr->tcl_GetCommandFromObj) /* 122 */ -#define Tcl_GetCommandFullName \ - (tclIntStubsPtr->tcl_GetCommandFullName) /* 123 */ -#define Tcl_GetCurrentNamespace \ - (tclIntStubsPtr->tcl_GetCurrentNamespace) /* 124 */ -#define Tcl_GetGlobalNamespace \ - (tclIntStubsPtr->tcl_GetGlobalNamespace) /* 125 */ +#define TclForgetImport \ + (tclIntStubsPtr->tclForgetImport) /* 121 */ +#define TclGetCommandFromObj \ + (tclIntStubsPtr->tclGetCommandFromObj) /* 122 */ +#define TclGetCommandFullName \ + (tclIntStubsPtr->tclGetCommandFullName) /* 123 */ +#define TclGetCurrentNamespace_ \ + (tclIntStubsPtr->tclGetCurrentNamespace_) /* 124 */ +#define TclGetGlobalNamespace_ \ + (tclIntStubsPtr->tclGetGlobalNamespace_) /* 125 */ #define Tcl_GetVariableFullName \ (tclIntStubsPtr->tcl_GetVariableFullName) /* 126 */ -#define Tcl_Import \ - (tclIntStubsPtr->tcl_Import) /* 127 */ +#define TclImport \ + (tclIntStubsPtr->tclImport) /* 127 */ #define Tcl_PopCallFrame \ (tclIntStubsPtr->tcl_PopCallFrame) /* 128 */ #define Tcl_PushCallFrame \ @@ -1209,10 +1231,10 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclCleanupVar) /* 176 */ #define TclVarErrMsg \ (tclIntStubsPtr->tclVarErrMsg) /* 177 */ -#define Tcl_SetStartupScript \ - (tclIntStubsPtr->tcl_SetStartupScript) /* 178 */ -#define Tcl_GetStartupScript \ - (tclIntStubsPtr->tcl_GetStartupScript) /* 179 */ +#define TclSetStartupScript \ + (tclIntStubsPtr->tclSetStartupScript) /* 178 */ +#define TclGetStartupScript \ + (tclIntStubsPtr->tclGetStartupScript) /* 179 */ /* Slot 180 is reserved */ /* Slot 181 is reserved */ #define TclpLocaltime \ @@ -1341,6 +1363,10 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclPtrObjMakeUpvar) /* 255 */ #define TclPtrUnsetVar \ (tclIntStubsPtr->tclPtrUnsetVar) /* 256 */ +#define TclStaticPackage \ + (tclIntStubsPtr->tclStaticPackage) /* 257 */ +#define TclpCreateTemporaryDirectory \ + (tclIntStubsPtr->tclpCreateTemporaryDirectory) /* 258 */ #endif /* defined(USE_TCL_STUBS) */ @@ -1349,58 +1375,31 @@ extern const TclIntStubs *tclIntStubsPtr; #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT -#undef TclGetStartupScriptFileName -#undef TclSetStartupScriptFileName -#undef TclGetStartupScriptPath -#undef TclSetStartupScriptPath -#undef TclBackgroundException - -#if defined(USE_TCL_STUBS) && defined(TCL_NO_DEPRECATED) -# undef Tcl_SetStartupScript -# define Tcl_SetStartupScript \ - (tclStubsPtr->tcl_SetStartupScript) /* 622 */ -# undef Tcl_GetStartupScript -# define Tcl_GetStartupScript \ - (tclStubsPtr->tcl_GetStartupScript) /* 623 */ -# undef Tcl_CreateNamespace -# define Tcl_CreateNamespace \ - (tclStubsPtr->tcl_CreateNamespace) /* 506 */ -# undef Tcl_DeleteNamespace -# define Tcl_DeleteNamespace \ - (tclStubsPtr->tcl_DeleteNamespace) /* 507 */ -# undef Tcl_AppendExportList -# define Tcl_AppendExportList \ - (tclStubsPtr->tcl_AppendExportList) /* 508 */ -# undef Tcl_Export -# define Tcl_Export \ - (tclStubsPtr->tcl_Export) /* 509 */ -# undef Tcl_Import -# define Tcl_Import \ - (tclStubsPtr->tcl_Import) /* 510 */ -# undef Tcl_ForgetImport -# define Tcl_ForgetImport \ - (tclStubsPtr->tcl_ForgetImport) /* 511 */ -# undef Tcl_GetCurrentNamespace -# define Tcl_GetCurrentNamespace \ - (tclStubsPtr->tcl_GetCurrentNamespace) /* 512 */ -# undef Tcl_GetGlobalNamespace -# define Tcl_GetGlobalNamespace \ - (tclStubsPtr->tcl_GetGlobalNamespace) /* 513 */ -# undef Tcl_FindNamespace -# define Tcl_FindNamespace \ - (tclStubsPtr->tcl_FindNamespace) /* 514 */ -# undef Tcl_FindCommand -# define Tcl_FindCommand \ - (tclStubsPtr->tcl_FindCommand) /* 515 */ -# undef Tcl_GetCommandFromObj -# define Tcl_GetCommandFromObj \ - (tclStubsPtr->tcl_GetCommandFromObj) /* 516 */ -# undef Tcl_GetCommandFullName -# define Tcl_GetCommandFullName \ - (tclStubsPtr->tcl_GetCommandFullName) /* 517 */ +#if defined(USE_TCL_STUBS) +# undef TclGetStartupScriptFileName +# undef TclSetStartupScriptFileName +# undef TclGetStartupScriptPath +# undef TclSetStartupScriptPath +# undef TclBackgroundException +# undef TclSetStartupScript +# undef TclGetStartupScript +# undef TclGetIntForIndex +# undef TclCreateNamespace +# undef TclDeleteNamespace +# undef TclAppendExportList +# undef TclExport +# undef TclImport +# undef TclForgetImport +# undef TclGetCurrentNamespace_ +# undef TclGetGlobalNamespace_ +# undef TclFindNamespace +# undef TclFindCommand +# undef TclGetCommandFromObj +# undef TclGetCommandFullName +# undef TclCopyChannelOld +# undef TclSockMinimumBuffersOld +# undef Tcl_StaticPackage +# define Tcl_StaticPackage (tclIntStubsPtr->tclStaticPackage) #endif -#undef TclCopyChannelOld -#undef TclSockMinimumBuffersOld - #endif /* _TCLINTDECLS */ diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index 903327f..51d2f65 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -93,7 +93,7 @@ EXTERN int TclUnixCopyFile(const char *src, const char *dst, /* Slot 27 is reserved */ /* Slot 28 is reserved */ /* 29 */ -EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs); +EXTERN int TclWinCPUID(int index, int *regs); /* 30 */ EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, @@ -168,7 +168,7 @@ EXTERN void TclWinFlushDirtyChannels(void); /* 28 */ EXTERN void TclWinResetInterfaces(void); /* 29 */ -EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs); +EXTERN int TclWinCPUID(int index, int *regs); /* 30 */ EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, @@ -242,7 +242,7 @@ EXTERN void TclMacOSXNotifierAddRunLoopMode( /* Slot 27 is reserved */ /* Slot 28 is reserved */ /* 29 */ -EXTERN int TclWinCPUID(unsigned int index, unsigned int *regs); +EXTERN int TclWinCPUID(int index, int *regs); /* 30 */ EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, @@ -283,7 +283,7 @@ typedef struct TclIntPlatStubs { void (*reserved26)(void); void (*reserved27)(void); void (*reserved28)(void); - int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */ + int (*tclWinCPUID) (int index, int *regs); /* 29 */ int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ #endif /* UNIX */ #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ @@ -316,7 +316,7 @@ typedef struct TclIntPlatStubs { void (*tclWinSetInterfaces) (int wide); /* 26 */ void (*tclWinFlushDirtyChannels) (void); /* 27 */ void (*tclWinResetInterfaces) (void); /* 28 */ - int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */ + int (*tclWinCPUID) (int index, int *regs); /* 29 */ int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ #endif /* WIN */ #ifdef MAC_OSX_TCL /* MACOSX */ @@ -349,7 +349,7 @@ typedef struct TclIntPlatStubs { void (*reserved26)(void); void (*reserved27)(void); void (*reserved28)(void); - int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */ + int (*tclWinCPUID) (int index, int *regs); /* 29 */ int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ #endif /* MACOSX */ } TclIntPlatStubs; @@ -550,10 +550,18 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; # undef TclWinGetServByName # undef TclWinGetSockOpt # undef TclWinSetSockOpt -# define TclWinNToHS ntohs -# define TclWinGetServByName getservbyname -# define TclWinGetSockOpt getsockopt -# define TclWinSetSockOpt setsockopt +# undef TclWinGetPlatformId +# undef TclWinResetInterfaces +# undef TclWinSetInterfaces +# if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 +# define TclWinNToHS ntohs +# define TclWinGetServByName getservbyname +# define TclWinGetSockOpt getsockopt +# define TclWinSetSockOpt setsockopt +# define TclWinGetPlatformId() (2) /* VER_PLATFORM_WIN32_NT */ +# define TclWinResetInterfaces() /* nop */ +# define TclWinSetInterfaces(dummy) /* nop */ +# endif /* TCL_NO_DEPRECATED */ #else # undef TclpGetPid # define TclpGetPid(pid) ((unsigned long) (pid)) diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 8a0d653..92c6159 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -222,9 +222,6 @@ static int AliasDelete(Tcl_Interp *interp, static int AliasDescribe(Tcl_Interp *interp, Tcl_Interp *slaveInterp, Tcl_Obj *objPtr); static int AliasList(Tcl_Interp *interp, Tcl_Interp *slaveInterp); -static int AliasObjCmd(ClientData dummy, - Tcl_Interp *currentInterp, int objc, - Tcl_Obj *const objv[]); static int AliasNRCmd(ClientData dummy, Tcl_Interp *currentInterp, int objc, Tcl_Obj *const objv[]); @@ -257,8 +254,6 @@ static int SlaveInvokeHidden(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int SlaveMarkTrusted(Tcl_Interp *interp, Tcl_Interp *slaveInterp); -static int SlaveObjCmd(ClientData dummy, Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[]); static void SlaveObjCmdDeleteProc(ClientData clientData); static int SlaveRecursionLimit(Tcl_Interp *interp, Tcl_Interp *slaveInterp, int objc, @@ -331,13 +326,24 @@ TclSetPreInitScript( *---------------------------------------------------------------------- */ +typedef struct PkgName { + struct PkgName *nextPtr; /* Next in list of package names being initialized. */ + char name[4]; +} PkgName; + int Tcl_Init( Tcl_Interp *interp) /* Interpreter to initialize. */ { + PkgName pkgName = {NULL, "Tcl"}; + PkgName **names = TclInitPkgFiles(interp); + int result = TCL_ERROR; + + pkgName.nextPtr = *names; + *names = &pkgName; if (tclPreInitScript != NULL) { - if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) { - return TCL_ERROR; + if (Tcl_EvalEx(interp, tclPreInitScript, -1, 0) == TCL_ERROR) { + goto end; } } @@ -382,7 +388,7 @@ Tcl_Init( * alternate tclInit command before calling Tcl_Init(). */ - return Tcl_Eval(interp, + result = Tcl_EvalEx(interp, "if {[namespace which -command tclInit] eq \"\"} {\n" " proc tclInit {} {\n" " global tcl_libPath tcl_library env tclDefaultLibrary\n" @@ -403,6 +409,7 @@ Tcl_Init( " } else {\n" " lappend scripts {::tcl::pkgconfig get scriptdir,runtime}\n" " }\n" +" lappend scripts {::tcl::zipfs::tcl_library_init}\n" " lappend scripts {\n" "set parentDir [file dirname [file dirname [info nameofexecutable]]]\n" "set grandParentDir [file dirname $parentDir]\n" @@ -410,6 +417,7 @@ Tcl_Init( " {file join $grandParentDir lib tcl[info tclversion]} \\\n" " {file join $parentDir library} \\\n" " {file join $grandParentDir library} \\\n" +" {file join $grandParentDir tcl[info tclversion] library} \\\n" " {file join $grandParentDir tcl[info patchlevel] library} \\\n" " {\n" "file join [file dirname $grandParentDir] tcl[info patchlevel] library}\n" @@ -444,7 +452,11 @@ Tcl_Init( " error $msg\n" " }\n" "}\n" -"tclInit"); +"tclInit", -1, 0); + +end: + *names = (*names)->nextPtr; + return result; } /* @@ -1176,7 +1188,7 @@ Tcl_CreateAlias( int i; int result; - objv = TclStackAlloc(slaveInterp, (unsigned) sizeof(Tcl_Obj *) * argc); + objv = TclStackAlloc(slaveInterp, sizeof(Tcl_Obj *) * argc); for (i = 0; i < argc; i++) { objv[i] = Tcl_NewStringObj(argv[i], -1); Tcl_IncrRefCount(objv[i]); @@ -1402,7 +1414,8 @@ TclPreventAliasLoop( * create or rename the command. */ - if (cmdPtr->objProc != AliasObjCmd) { + if (cmdPtr->objProc != TclAliasObjCmd + && cmdPtr->objProc != TclLocalAliasObjCmd) { return TCL_OK; } @@ -1457,7 +1470,8 @@ TclPreventAliasLoop( * Otherwise we do not have a loop. */ - if (aliasCmdPtr->objProc != AliasObjCmd) { + if (aliasCmdPtr->objProc != TclAliasObjCmd + && aliasCmdPtr->objProc != TclLocalAliasObjCmd) { return TCL_OK; } nextAliasPtr = aliasCmdPtr->objClientData; @@ -1523,12 +1537,12 @@ AliasCreate( if (slaveInterp == masterInterp) { aliasPtr->slaveCmd = Tcl_NRCreateCommand(slaveInterp, - TclGetString(namePtr), AliasObjCmd, AliasNRCmd, aliasPtr, - AliasObjCmdDeleteProc); + TclGetString(namePtr), TclLocalAliasObjCmd, AliasNRCmd, + aliasPtr, AliasObjCmdDeleteProc); } else { - aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp, - TclGetString(namePtr), AliasObjCmd, aliasPtr, - AliasObjCmdDeleteProc); + aliasPtr->slaveCmd = Tcl_CreateObjCommand(slaveInterp, + TclGetString(namePtr), TclAliasObjCmd, aliasPtr, + AliasObjCmdDeleteProc); } if (TclPreventAliasLoop(interp, slaveInterp, @@ -1764,7 +1778,7 @@ AliasList( /* *---------------------------------------------------------------------- * - * AliasObjCmd -- + * TclAliasObjCmd, TclLocalAliasObjCmd -- * * This is the function that services invocations of aliases in a slave * interpreter. One such command exists for each alias. When invoked, @@ -1772,6 +1786,11 @@ AliasList( * master interpreter as designated by the Alias record associated with * this command. * + * TclLocalAliasObjCmd is a stripped down version used when the source + * and target interpreters of the alias are the same. That lets a number + * of safety precautions be avoided: the state is much more precisely + * known. + * * Results: * A standard Tcl result. * @@ -1807,13 +1826,13 @@ AliasNRCmd( cmdc = prefc + objc - 1; listPtr = Tcl_NewListObj(cmdc, NULL); - listRep = listPtr->internalRep.twoPtrValue.ptr1; + listRep = ListRepPtr(listPtr); listRep->elemCount = cmdc; cmdv = &listRep->elements; prefv = &aliasPtr->objPtr; - memcpy(cmdv, prefv, (size_t) (prefc * sizeof(Tcl_Obj *))); - memcpy(cmdv+prefc, objv+1, (size_t) ((objc-1) * sizeof(Tcl_Obj *))); + memcpy(cmdv, prefv, prefc * sizeof(Tcl_Obj *)); + memcpy(cmdv+prefc, objv+1, (objc-1) * sizeof(Tcl_Obj *)); for (i=0; i<cmdc; i++) { Tcl_IncrRefCount(cmdv[i]); @@ -1831,8 +1850,8 @@ AliasNRCmd( return Tcl_NREvalObj(interp, listPtr, flags); } -static int -AliasObjCmd( +int +TclAliasObjCmd( ClientData clientData, /* Alias record. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ @@ -1861,8 +1880,8 @@ AliasObjCmd( cmdv = TclStackAlloc(interp, cmdc * sizeof(Tcl_Obj *)); } - memcpy(cmdv, prefv, (size_t) (prefc * sizeof(Tcl_Obj *))); - memcpy(cmdv+prefc, objv+1, (size_t) ((objc-1) * sizeof(Tcl_Obj *))); + memcpy(cmdv, prefv, prefc * sizeof(Tcl_Obj *)); + memcpy(cmdv+prefc, objv+1, (objc-1) * sizeof(Tcl_Obj *)); Tcl_ResetResult(targetInterp); @@ -1921,6 +1940,73 @@ AliasObjCmd( return result; #undef ALIAS_CMDV_PREALLOC } + +int +TclLocalAliasObjCmd( + ClientData clientData, /* Alias record. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument vector. */ +{ +#define ALIAS_CMDV_PREALLOC 10 + Alias *aliasPtr = clientData; + int result, prefc, cmdc, i; + Tcl_Obj **prefv, **cmdv; + Tcl_Obj *cmdArr[ALIAS_CMDV_PREALLOC]; + Interp *iPtr = (Interp *) interp; + int isRootEnsemble; + + /* + * Append the arguments to the command prefix and invoke the command in + * the global namespace. + */ + + prefc = aliasPtr->objc; + prefv = &aliasPtr->objPtr; + cmdc = prefc + objc - 1; + if (cmdc <= ALIAS_CMDV_PREALLOC) { + cmdv = cmdArr; + } else { + cmdv = TclStackAlloc(interp, cmdc * sizeof(Tcl_Obj *)); + } + + memcpy(cmdv, prefv, prefc * sizeof(Tcl_Obj *)); + memcpy(cmdv+prefc, objv+1, (objc-1) * sizeof(Tcl_Obj *)); + + for (i=0; i<cmdc; i++) { + Tcl_IncrRefCount(cmdv[i]); + } + + /* + * Use the ensemble rewriting machinery to ensure correct error messages: + * only the source command should show, not the full target prefix. + */ + + isRootEnsemble = TclInitRewriteEnsemble((Tcl_Interp *)iPtr, 1, prefc, objv); + + /* + * Execute the target command in the target interpreter. + */ + + result = Tcl_EvalObjv(interp, cmdc, cmdv, TCL_EVAL_INVOKE); + + /* + * Clean up the ensemble rewrite info if we set it in the first place. + */ + + if (isRootEnsemble) { + TclResetRewriteEnsemble((Tcl_Interp *)iPtr, 1); + } + + for (i=0; i<cmdc; i++) { + Tcl_DecrRefCount(cmdv[i]); + } + if (cmdv != cmdArr) { + TclStackFree(interp, cmdv); + } + return result; +#undef ALIAS_CMDV_PREALLOC +} /* *---------------------------------------------------------------------- @@ -2360,10 +2446,10 @@ SlaveCreate( slavePtr->slaveEntryPtr = hPtr; slavePtr->slaveInterp = slaveInterp; slavePtr->interpCmd = Tcl_NRCreateCommand(masterInterp, path, - SlaveObjCmd, NRSlaveCmd, slaveInterp, SlaveObjCmdDeleteProc); + TclSlaveObjCmd, NRSlaveCmd, slaveInterp, SlaveObjCmdDeleteProc); Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); Tcl_SetHashValue(hPtr, slavePtr); - Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); + Tcl_SetVar2(slaveInterp, "tcl_interactive", NULL, "0", TCL_GLOBAL_ONLY); /* * Inherit the recursion limit. @@ -2428,7 +2514,7 @@ SlaveCreate( /* *---------------------------------------------------------------------- * - * SlaveObjCmd -- + * TclSlaveObjCmd -- * * Command to manipulate an interpreter, e.g. to send commands to it to * be evaluated. One such command exists for each slave interpreter. @@ -2442,8 +2528,8 @@ SlaveCreate( *---------------------------------------------------------------------- */ -static int -SlaveObjCmd( +int +TclSlaveObjCmd( ClientData clientData, /* Slave interpreter. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ @@ -2475,7 +2561,7 @@ NRSlaveCmd( }; if (slaveInterp == NULL) { - Tcl_Panic("SlaveObjCmd: interpreter has been deleted"); + Tcl_Panic("TclSlaveObjCmd: interpreter has been deleted"); } if (objc < 2) { @@ -2921,7 +3007,7 @@ SlaveRecursionLimit( return TCL_OK; } else { limit = Tcl_SetRecursionLimit(slaveInterp, 0); - Tcl_SetObjResult(interp, Tcl_NewIntObj(limit)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(limit)); return TCL_OK; } } @@ -3190,12 +3276,8 @@ Tcl_MakeSafe( * Assume these functions all work. [Bug 2895741] */ - (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, - "::tcl::mathfunc::max", 0, NULL); + (void) Tcl_EvalEx(interp, + "namespace eval ::tcl {namespace eval mathfunc {}}", -1, 0); } iPtr->flags |= SAFE_INTERP; @@ -3517,9 +3599,6 @@ Tcl_LimitAddHandler( if (deleteProc == (Tcl_LimitHandlerDeleteProc *) TCL_DYNAMIC) { deleteProc = (Tcl_LimitHandlerDeleteProc *) Tcl_Free; } - if (deleteProc == (Tcl_LimitHandlerDeleteProc *) TCL_STATIC) { - deleteProc = NULL; - } /* * Allocate a handler record. @@ -4437,12 +4516,12 @@ SlaveCommandLimitCmd( Tcl_NewStringObj(options[0], -1), empty); } Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1), - Tcl_NewIntObj(Tcl_LimitGetGranularity(slaveInterp, + Tcl_NewWideIntObj(Tcl_LimitGetGranularity(slaveInterp, TCL_LIMIT_COMMANDS))); if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_COMMANDS)) { Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[2], -1), - Tcl_NewIntObj(Tcl_LimitGetCommands(slaveInterp))); + Tcl_NewWideIntObj(Tcl_LimitGetCommands(slaveInterp))); } else { Tcl_Obj *empty; @@ -4470,13 +4549,13 @@ SlaveCommandLimitCmd( } break; case OPT_GRAN: - Tcl_SetObjResult(interp, Tcl_NewIntObj( + Tcl_SetObjResult(interp, Tcl_NewWideIntObj( Tcl_LimitGetGranularity(slaveInterp, TCL_LIMIT_COMMANDS))); break; case OPT_VAL: if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_COMMANDS)) { Tcl_SetObjResult(interp, - Tcl_NewIntObj(Tcl_LimitGetCommands(slaveInterp))); + Tcl_NewWideIntObj(Tcl_LimitGetCommands(slaveInterp))); } break; } @@ -4497,7 +4576,7 @@ SlaveCommandLimitCmd( switch ((enum Options) index) { case OPT_CMD: scriptObj = objv[i+1]; - (void) Tcl_GetStringFromObj(objv[i+1], &scriptLen); + (void) TclGetStringFromObj(scriptObj, &scriptLen); break; case OPT_GRAN: granObj = objv[i+1]; @@ -4514,7 +4593,7 @@ SlaveCommandLimitCmd( break; case OPT_VAL: limitObj = objv[i+1]; - (void) Tcl_GetStringFromObj(objv[i+1], &limitLen); + (void) TclGetStringFromObj(objv[i+1], &limitLen); if (limitLen == 0) { break; } @@ -4624,7 +4703,7 @@ SlaveTimeLimitCmd( Tcl_NewStringObj(options[0], -1), empty); } Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[1], -1), - Tcl_NewIntObj(Tcl_LimitGetGranularity(slaveInterp, + Tcl_NewWideIntObj(Tcl_LimitGetGranularity(slaveInterp, TCL_LIMIT_TIME))); if (Tcl_LimitTypeEnabled(slaveInterp, TCL_LIMIT_TIME)) { @@ -4632,9 +4711,9 @@ SlaveTimeLimitCmd( Tcl_LimitGetTime(slaveInterp, &limitMoment); Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[2], -1), - Tcl_NewLongObj(limitMoment.usec/1000)); + Tcl_NewWideIntObj(limitMoment.usec/1000)); Tcl_DictObjPut(NULL, dictPtr, Tcl_NewStringObj(options[3], -1), - Tcl_NewLongObj(limitMoment.sec)); + Tcl_NewWideIntObj(limitMoment.sec)); } else { Tcl_Obj *empty; @@ -4664,7 +4743,7 @@ SlaveTimeLimitCmd( } break; case OPT_GRAN: - Tcl_SetObjResult(interp, Tcl_NewIntObj( + Tcl_SetObjResult(interp, Tcl_NewWideIntObj( Tcl_LimitGetGranularity(slaveInterp, TCL_LIMIT_TIME))); break; case OPT_MILLI: @@ -4673,7 +4752,7 @@ SlaveTimeLimitCmd( Tcl_LimitGetTime(slaveInterp, &limitMoment); Tcl_SetObjResult(interp, - Tcl_NewLongObj(limitMoment.usec/1000)); + Tcl_NewWideIntObj(limitMoment.usec/1000)); } break; case OPT_SEC: @@ -4681,7 +4760,7 @@ SlaveTimeLimitCmd( Tcl_Time limitMoment; Tcl_LimitGetTime(slaveInterp, &limitMoment); - Tcl_SetObjResult(interp, Tcl_NewLongObj(limitMoment.sec)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(limitMoment.sec)); } break; } @@ -4706,7 +4785,7 @@ SlaveTimeLimitCmd( switch ((enum Options) index) { case OPT_CMD: scriptObj = objv[i+1]; - (void) Tcl_GetStringFromObj(objv[i+1], &scriptLen); + (void) TclGetStringFromObj(objv[i+1], &scriptLen); break; case OPT_GRAN: granObj = objv[i+1]; @@ -4723,7 +4802,7 @@ SlaveTimeLimitCmd( break; case OPT_MILLI: milliObj = objv[i+1]; - (void) Tcl_GetStringFromObj(objv[i+1], &milliLen); + (void) TclGetStringFromObj(objv[i+1], &milliLen); if (milliLen == 0) { break; } @@ -4741,7 +4820,7 @@ SlaveTimeLimitCmd( break; case OPT_SEC: secObj = objv[i+1]; - (void) Tcl_GetStringFromObj(objv[i+1], &secLen); + (void) TclGetStringFromObj(objv[i+1], &secLen); if (secLen == 0) { break; } diff --git a/generic/tclLink.c b/generic/tclLink.c index 4850d02..030e471 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -8,12 +8,16 @@ * * Copyright (c) 1993 The Regents of the University of California. * Copyright (c) 1994-1997 Sun Microsystems, Inc. + * Copyright (c) 2008 Rene Zaumseil + * Copyright (c) 2019 Donal K. Fellows * * 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 "tommath.h" +#include <math.h> /* * For each linked variable there is a data structure of the following type, @@ -28,7 +32,12 @@ typedef struct Link { * needed during trace callbacks, since the * actual variable may be aliased at that time * via upvar. */ - char *addr; /* Location of C variable. */ + void *addr; /* Location of C variable. */ + int bytes; /* Size of C variable array. This is 0 when + * single variables, and >0 used for array + * variables. */ + int numElems; /* Number of elements in C variable array. + * Zero for single variables. */ int type; /* Type of link (TCL_LINK_INT, etc.). */ union { char c; @@ -37,12 +46,27 @@ 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; double d; + void *aryPtr; /* Generic array. */ + char *cPtr; /* char array */ + unsigned char *ucPtr; /* unsigned char array */ + short *sPtr; /* short array */ + unsigned short *usPtr; /* unsigned short array */ + int *iPtr; /* int array */ + unsigned int *uiPtr; /* unsigned int array */ + long *lPtr; /* long array */ + unsigned long *ulPtr; /* unsigned long array */ + Tcl_WideInt *wPtr; /* wide (long long) array */ + Tcl_WideUInt *uwPtr; /* unsigned wide (long long) array */ + float *fPtr; /* float array */ + double *dPtr; /* double array */ } lastValue; /* Last known value of C variable; used to * avoid string conversions. */ int flags; /* Miscellaneous one-bit values; see below for @@ -56,10 +80,16 @@ typedef struct Link { * LINK_BEING_UPDATED - 1 means that a call to Tcl_UpdateLinkedVar is * in progress for this variable, so trace * callbacks on the variable should be ignored. + * LINK_ALLOC_ADDR - 1 means linkPtr->addr was allocated on the + * heap. + * LINK_ALLOC_LAST - 1 means linkPtr->valueLast.p was allocated on + * the heap. */ #define LINK_READ_ONLY 1 #define LINK_BEING_UPDATED 2 +#define LINK_ALLOC_ADDR 4 +#define LINK_ALLOC_LAST 8 /* * Forward references to functions defined later in this file: @@ -68,9 +98,24 @@ typedef struct Link { static char * LinkTraceProc(ClientData clientData,Tcl_Interp *interp, const char *name1, const char *name2, int flags); static Tcl_Obj * ObjValue(Link *linkPtr); +static void LinkFree(Link *linkPtr); static int GetInvalidIntFromObj(Tcl_Obj *objPtr, int *intPtr); -static int GetInvalidWideFromObj(Tcl_Obj *objPtr, Tcl_WideInt *widePtr); -static int GetInvalidDoubleFromObj(Tcl_Obj *objPtr, double *doublePtr); +static int GetInvalidDoubleFromObj(Tcl_Obj *objPtr, + double *doublePtr); +static int SetInvalidRealFromAny(Tcl_Interp *interp, + Tcl_Obj *objPtr); + +/* + * A marker type used to flag weirdnesses so we can pass them around right. + */ + +static Tcl_ObjType invalidRealType = { + "invalidReal", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + NULL, /* updateStringProc */ + NULL /* setFromAnyProc */ +}; /* * Convenience macro for accessing the value of the C variable pointed to by a @@ -107,7 +152,7 @@ int Tcl_LinkVar( Tcl_Interp *interp, /* Interpreter in which varName exists. */ const char *varName, /* Name of a global variable in interp. */ - char *addr, /* Address of a C variable to be linked to + void *addr, /* Address of a C variable to be linked to * varName. */ int type) /* Type of C variable: TCL_LINK_INT, etc. Also * may have TCL_LINK_READ_ONLY OR'ed in. */ @@ -133,16 +178,26 @@ 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 { linkPtr->flags = 0; } + linkPtr->bytes = 0; + linkPtr->numElems = 0; objPtr = ObjValue(linkPtr); if (Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr, TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { Tcl_DecrRefCount(linkPtr->varName); - ckfree(linkPtr); + LinkFree(linkPtr); return TCL_ERROR; } @@ -155,8 +210,188 @@ Tcl_LinkVar( LinkTraceProc, linkPtr); if (code != TCL_OK) { Tcl_DecrRefCount(linkPtr->varName); - TclNsDecrRefCount(linkPtr->nsPtr); - ckfree(linkPtr); + LinkFree(linkPtr); + } + return code; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_LinkArray -- + * + * Link a C variable array to a Tcl variable so that changes to either + * one causes the other to change. + * + * Results: + * The return value is TCL_OK if everything went well or TCL_ERROR if an + * error occurred (the interp's result is also set after errors). + * + * Side effects: + * The value at *addr is linked to the Tcl variable "varName", using + * "type" to convert between string values for Tcl and binary values for + * *addr. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_LinkArray( + Tcl_Interp *interp, /* Interpreter in which varName exists. */ + const char *varName, /* Name of a global variable in interp. */ + void *addr, /* Address of a C variable to be linked to + * varName. If NULL then the necessary space + * will be allocated and returned as the + * interpreter result. */ + int type, /* Type of C variable: TCL_LINK_INT, etc. Also + * may have TCL_LINK_READ_ONLY OR'ed in. */ + int size) /* Size of C variable array, >1 if array */ +{ + Tcl_Obj *objPtr; + Link *linkPtr; + Namespace *dummy; + const char *name; + int code; + + if (size < 1) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "wrong array size given", -1)); + return TCL_ERROR; + } + + linkPtr = ckalloc(sizeof(Link)); + linkPtr->type = type & ~TCL_LINK_READ_ONLY; + linkPtr->numElems = size; + if (type & TCL_LINK_READ_ONLY) { + linkPtr->flags = LINK_READ_ONLY; + } else { + linkPtr->flags = 0; + } + + switch (linkPtr->type) { + case TCL_LINK_INT: + case TCL_LINK_BOOLEAN: + linkPtr->bytes = size * sizeof(int); + break; + case TCL_LINK_DOUBLE: + linkPtr->bytes = size * sizeof(double); + break; + case TCL_LINK_WIDE_INT: + linkPtr->bytes = size * sizeof(Tcl_WideInt); + break; + case TCL_LINK_WIDE_UINT: + linkPtr->bytes = size * sizeof(Tcl_WideUInt); + break; + case TCL_LINK_CHAR: + linkPtr->bytes = size * sizeof(char); + break; + case TCL_LINK_UCHAR: + linkPtr->bytes = size * sizeof(unsigned char); + break; + case TCL_LINK_SHORT: + linkPtr->bytes = size * sizeof(short); + break; + case TCL_LINK_USHORT: + linkPtr->bytes = size * sizeof(unsigned short); + break; + case TCL_LINK_UINT: + linkPtr->bytes = size * sizeof(unsigned int); + break; +#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) + case TCL_LINK_LONG: + linkPtr->bytes = size * sizeof(long); + break; + case TCL_LINK_ULONG: + linkPtr->bytes = size * sizeof(unsigned long); + break; +#endif + case TCL_LINK_FLOAT: + linkPtr->bytes = size * sizeof(float); + break; + case TCL_LINK_STRING: + linkPtr->bytes = size * sizeof(char); + size = 1; /* This is a variable length string, no need + * to check last value. */ + + /* + * If no address is given create one and use as address the + * not needed linkPtr->lastValue + */ + + if (addr == NULL) { + linkPtr->lastValue.aryPtr = ckalloc(linkPtr->bytes); + linkPtr->flags |= LINK_ALLOC_LAST; + addr = (char *) &linkPtr->lastValue.cPtr; + } + break; + case TCL_LINK_CHARS: + case TCL_LINK_BINARY: + linkPtr->bytes = size * sizeof(char); + break; + default: + LinkFree(linkPtr); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad linked array variable type", -1)); + return TCL_ERROR; + } + + /* + * Allocate C variable space in case no address is given + */ + + if (addr == NULL) { + linkPtr->addr = ckalloc(linkPtr->bytes); + linkPtr->flags |= LINK_ALLOC_ADDR; + } else { + linkPtr->addr = addr; + } + + /* + * If necessary create space for last used value. + */ + + if (size > 1) { + linkPtr->lastValue.aryPtr = ckalloc(linkPtr->bytes); + linkPtr->flags |= LINK_ALLOC_LAST; + } + + /* + * Initialize allocated space. + */ + + if (linkPtr->flags & LINK_ALLOC_ADDR) { + memset(linkPtr->addr, 0, linkPtr->bytes); + } + if (linkPtr->flags & LINK_ALLOC_LAST) { + memset(linkPtr->lastValue.aryPtr, 0, linkPtr->bytes); + } + + /* + * Set common structure values. + */ + + linkPtr->interp = interp; + linkPtr->varName = Tcl_NewStringObj(varName, -1); + Tcl_IncrRefCount(linkPtr->varName); + + TclGetNamespaceForQualName(interp, varName, NULL, TCL_GLOBAL_ONLY, + &(linkPtr->nsPtr), &dummy, &dummy, &name); + linkPtr->nsPtr->refCount++; + + objPtr = ObjValue(linkPtr); + if (Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr, + TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) { + Tcl_DecrRefCount(linkPtr->varName); + LinkFree(linkPtr); + return TCL_ERROR; + } + + code = Tcl_TraceVar2(interp, varName, NULL, + TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + LinkTraceProc, linkPtr); + if (code != TCL_OK) { + Tcl_DecrRefCount(linkPtr->varName); + LinkFree(linkPtr); } return code; } @@ -194,10 +429,7 @@ Tcl_UnlinkVar( TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc, linkPtr); Tcl_DecrRefCount(linkPtr->varName); - if (linkPtr->nsPtr) { - TclNsDecrRefCount(linkPtr->nsPtr); - } - ckfree(linkPtr); + LinkFree(linkPtr); } /* @@ -248,6 +480,241 @@ Tcl_UpdateLinkedVar( /* *---------------------------------------------------------------------- * + * GetInt, GetWide, GetUWide, GetDouble, EqualDouble, IsSpecial -- + * + * Helper functions for LinkTraceProc and ObjValue. These are all + * factored out here to make those functions simpler. + * + *---------------------------------------------------------------------- + */ + +static inline int +GetInt( + Tcl_Obj *objPtr, + int *intPtr) +{ + return (Tcl_GetIntFromObj(NULL, objPtr, intPtr) != TCL_OK + && GetInvalidIntFromObj(objPtr, intPtr) != TCL_OK); +} + +static inline int +GetWide( + Tcl_Obj *objPtr, + Tcl_WideInt *widePtr) +{ + if (Tcl_GetWideIntFromObj(NULL, objPtr, widePtr) != TCL_OK) { + int intValue; + + if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) { + return 1; + } + *widePtr = intValue; + } + return 0; +} + +static inline int +GetUWide( + Tcl_Obj *objPtr, + Tcl_WideUInt *uwidePtr) +{ + Tcl_WideInt *widePtr = (Tcl_WideInt *) uwidePtr; + ClientData clientData; + int type, intValue; + + if (TclGetNumberFromObj(NULL, objPtr, &clientData, &type) == TCL_OK) { + if (type == TCL_NUMBER_INT) { + *widePtr = *((const Tcl_WideInt *) clientData); + return (*widePtr < 0); + } else if (type == TCL_NUMBER_BIG) { + mp_int *numPtr = clientData; + Tcl_WideUInt value = 0; + union { + Tcl_WideUInt value; + unsigned char bytes[sizeof(Tcl_WideUInt)]; + } scratch; + unsigned long numBytes = sizeof(Tcl_WideUInt); + unsigned char *bytes = scratch.bytes; + + if (numPtr->sign || (MP_OKAY != mp_to_unsigned_bin_n(numPtr, + bytes, &numBytes))) { + /* + * If the sign bit is set (a negative value) or if the value + * can't possibly fit in the bits of an unsigned wide, there's + * no point in doing further conversion. + */ + return 1; + } +#ifdef WORDS_BIGENDIAN + while (numBytes-- > 0) { + value = (value << CHAR_BIT) | *bytes++; + } +#else /* !WORDS_BIGENDIAN */ + /* + * Little-endian can read the value directly. + */ + value = scratch.value; +#endif /* WORDS_BIGENDIAN */ + *uwidePtr = value; + return 0; + } + } + + /* + * Evil edge case fallback. + */ + + if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) { + return 1; + } + *uwidePtr = intValue; + return 0; +} + +static inline int +GetDouble( + Tcl_Obj *objPtr, + double *dblPtr) +{ + if (Tcl_GetDoubleFromObj(NULL, objPtr, dblPtr) == TCL_OK) { + return 0; + } else { +#ifdef ACCEPT_NAN + Tcl_ObjIntRep *irPtr = TclFetchIntRep(objPtr, &tclDoubleType); + + if (irPtr != NULL) { + *dblPtr = irPtr->doubleValue; + return 0; + } +#endif /* ACCEPT_NAN */ + return GetInvalidDoubleFromObj(objPtr, dblPtr) != TCL_OK; + } +} + +static inline int +EqualDouble( + double a, + double b) +{ + return (a == b) +#ifdef ACCEPT_NAN + || (TclIsNaN(a) && TclIsNaN(b)) +#endif /* ACCEPT_NAN */ + ; +} + +static inline int +IsSpecial( + double a) +{ + return TclIsInfinite(a) +#ifdef ACCEPT_NAN + || TclIsNaN(a) +#endif /* ACCEPT_NAN */ + ; +} + +/* + * Mark an object as holding a weird double. + */ + +static int +SetInvalidRealFromAny( + Tcl_Interp *interp, + Tcl_Obj *objPtr) +{ + const char *str; + const char *endPtr; + + str = TclGetString(objPtr); + if ((objPtr->length == 1) && (str[0] == '.')) { + objPtr->typePtr = &invalidRealType; + objPtr->internalRep.doubleValue = 0.0; + return TCL_OK; + } + if (TclParseNumber(NULL, objPtr, NULL, str, objPtr->length, &endPtr, + TCL_PARSE_DECIMAL_ONLY) == TCL_OK) { + /* + * If number is followed by [eE][+-]?, then it is an invalid + * double, but it could be the start of a valid double. + */ + + if (*endPtr == 'e' || *endPtr == 'E') { + ++endPtr; + if (*endPtr == '+' || *endPtr == '-') { + ++endPtr; + } + if (*endPtr == 0) { + double doubleValue = 0.0; + + Tcl_GetDoubleFromObj(NULL, objPtr, &doubleValue); + TclFreeIntRep(objPtr); + objPtr->typePtr = &invalidRealType; + objPtr->internalRep.doubleValue = doubleValue; + return TCL_OK; + } + } + } + return TCL_ERROR; +} + +/* + * This function checks for integer representations, which are valid + * when linking with C variables, but which are invalid in other + * contexts in Tcl. Handled are "+", "-", "", "0x", "0b", "0d" and "0o" + * (upperand lowercase). See bug [39f6304c2e]. + */ + +static int +GetInvalidIntFromObj( + Tcl_Obj *objPtr, + int *intPtr) +{ + const char *str = TclGetString(objPtr); + + if ((objPtr->length == 0) || ((objPtr->length == 2) && (str[0] == '0') + && strchr("xXbBoOdD", str[1]))) { + *intPtr = 0; + return TCL_OK; + } else if ((objPtr->length == 1) && strchr("+-", str[0])) { + *intPtr = (str[0] == '+'); + return TCL_OK; + } + return TCL_ERROR; +} + +/* + * This function checks for double representations, which are valid + * when linking with C variables, but which are invalid in other + * contexts in Tcl. Handled are "+", "-", "", ".", "0x", "0b" and "0o" + * (upper- and lowercase) and sequences like "1e-". See bug [39f6304c2e]. + */ + +static int +GetInvalidDoubleFromObj( + Tcl_Obj *objPtr, + double *doublePtr) +{ + int intValue; + + if (TclHasIntRep(objPtr, &invalidRealType)) { + goto gotdouble; + } + if (GetInvalidIntFromObj(objPtr, &intValue) == TCL_OK) { + *doublePtr = (double) intValue; + return TCL_OK; + } + if (SetInvalidRealFromAny(NULL, objPtr) == TCL_OK) { + gotdouble: + *doublePtr = objPtr->internalRep.doubleValue; + return TCL_OK; + } + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * * LinkTraceProc -- * * This function is invoked when a linked Tcl variable is read, written, @@ -276,13 +743,17 @@ LinkTraceProc( { Link *linkPtr = clientData; int changed; - size_t valueLength; + int valueLength; const char *value; char **pp; Tcl_Obj *valueObj; int valueInt; Tcl_WideInt valueWide; + Tcl_WideUInt valueUWide; double valueDouble; + int objc; + Tcl_Obj **objv; + int i; /* * If the variable is being unset, then just re-create it (with a trace) @@ -292,10 +763,7 @@ LinkTraceProc( if (flags & TCL_TRACE_UNSETS) { if (Tcl_InterpDeleted(interp) || TclNamespaceDeleted(linkPtr->nsPtr)) { Tcl_DecrRefCount(linkPtr->varName); - if (linkPtr->nsPtr) { - TclNsDecrRefCount(linkPtr->nsPtr); - } - ckfree(linkPtr); + LinkFree(linkPtr); } else if (flags & TCL_TRACE_DESTROYED) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), TCL_GLOBAL_ONLY); @@ -322,49 +790,64 @@ LinkTraceProc( */ if (flags & TCL_TRACE_READS) { - switch (linkPtr->type) { - case TCL_LINK_INT: - case TCL_LINK_BOOLEAN: - changed = (LinkedVar(int) != linkPtr->lastValue.i); - break; - case TCL_LINK_DOUBLE: - changed = (LinkedVar(double) != linkPtr->lastValue.d); - break; - case TCL_LINK_WIDE_INT: - changed = (LinkedVar(Tcl_WideInt) != linkPtr->lastValue.w); - break; - case TCL_LINK_WIDE_UINT: - changed = (LinkedVar(Tcl_WideUInt) != linkPtr->lastValue.uw); - break; - case TCL_LINK_CHAR: - changed = (LinkedVar(char) != linkPtr->lastValue.c); - break; - case TCL_LINK_UCHAR: - changed = (LinkedVar(unsigned char) != linkPtr->lastValue.uc); - break; - case TCL_LINK_SHORT: - changed = (LinkedVar(short) != linkPtr->lastValue.s); - break; - case TCL_LINK_USHORT: - changed = (LinkedVar(unsigned short) != linkPtr->lastValue.us); - break; - case TCL_LINK_UINT: - changed = (LinkedVar(unsigned int) != linkPtr->lastValue.ui); - break; - case TCL_LINK_LONG: - changed = (LinkedVar(long) != linkPtr->lastValue.l); - break; - case TCL_LINK_ULONG: - changed = (LinkedVar(unsigned long) != linkPtr->lastValue.ul); - break; - case TCL_LINK_FLOAT: - changed = (LinkedVar(float) != linkPtr->lastValue.f); - break; - case TCL_LINK_STRING: - changed = 1; - break; - default: - return (char *) "internal error: bad linked variable type"; + /* + * Variable arrays + */ + + if (linkPtr->flags & LINK_ALLOC_LAST) { + changed = memcmp(linkPtr->addr, linkPtr->lastValue.aryPtr, + linkPtr->bytes); + } else { + /* single variables */ + switch (linkPtr->type) { + case TCL_LINK_INT: + case TCL_LINK_BOOLEAN: + changed = (LinkedVar(int) != linkPtr->lastValue.i); + break; + case TCL_LINK_DOUBLE: + changed = !EqualDouble(LinkedVar(double), linkPtr->lastValue.d); + break; + case TCL_LINK_WIDE_INT: + changed = (LinkedVar(Tcl_WideInt) != linkPtr->lastValue.w); + break; + case TCL_LINK_WIDE_UINT: + changed = (LinkedVar(Tcl_WideUInt) != linkPtr->lastValue.uw); + break; + case TCL_LINK_CHAR: + changed = (LinkedVar(char) != linkPtr->lastValue.c); + break; + case TCL_LINK_UCHAR: + changed = (LinkedVar(unsigned char) != linkPtr->lastValue.uc); + break; + case TCL_LINK_SHORT: + changed = (LinkedVar(short) != linkPtr->lastValue.s); + break; + case TCL_LINK_USHORT: + changed = (LinkedVar(unsigned short) != linkPtr->lastValue.us); + break; + 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 = !EqualDouble(LinkedVar(float), linkPtr->lastValue.f); + break; + case TCL_LINK_STRING: + case TCL_LINK_CHARS: + case TCL_LINK_BINARY: + changed = 1; + break; + default: + changed = 0; + /* return (char *) "internal error: bad linked variable type"; */ + } } if (changed) { Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), @@ -396,167 +879,377 @@ LinkTraceProc( return (char *) "internal error: linked variable couldn't be read"; } + /* + * Special cases. + */ + + switch (linkPtr->type) { + case TCL_LINK_STRING: + value = TclGetString(valueObj); + valueLength = valueObj->length + 1; + pp = (char **) linkPtr->addr; + + *pp = ckrealloc(*pp, valueLength); + memcpy(*pp, value, valueLength); + return NULL; + + case TCL_LINK_CHARS: + value = (char *) Tcl_GetStringFromObj(valueObj, &valueLength); + valueLength++; /* include end of string char */ + if (valueLength > linkPtr->bytes) { + return (char *) "wrong size of char* value"; + } + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, value, (size_t) valueLength); + memcpy(linkPtr->addr, value, (size_t) valueLength); + } else { + linkPtr->lastValue.c = '\0'; + LinkedVar(char) = linkPtr->lastValue.c; + } + return NULL; + + case TCL_LINK_BINARY: + value = (char *) Tcl_GetByteArrayFromObj(valueObj, &valueLength); + if (valueLength != linkPtr->bytes) { + return (char *) "wrong size of binary value"; + } + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, value, (size_t) valueLength); + memcpy(linkPtr->addr, value, (size_t) valueLength); + } else { + linkPtr->lastValue.uc = (unsigned char) *value; + LinkedVar(unsigned char) = linkPtr->lastValue.uc; + } + return NULL; + } + + /* + * A helper macro. Writing this as a function is messy because of type + * variance. + */ + +#define InRange(lowerLimit, value, upperLimit) \ + ((value) >= (lowerLimit) && (value) <= (upperLimit)) + + /* + * If we're working with an array of numbers, extract the Tcl list. + */ + + if (linkPtr->flags & LINK_ALLOC_LAST) { + if (Tcl_ListObjGetElements(NULL, (valueObj), &objc, &objv) == TCL_ERROR + || objc != linkPtr->numElems) { + return (char *) "wrong dimension"; + } + } + switch (linkPtr->type) { case TCL_LINK_INT: - if (Tcl_GetIntFromObj(NULL, valueObj, &linkPtr->lastValue.i) != TCL_OK - && GetInvalidIntFromObj(valueObj, &linkPtr->lastValue.i) != TCL_OK) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have integer value"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + for (i=0; i < objc; i++) { + int *varPtr = &linkPtr->lastValue.iPtr[i]; + + if (GetInt(objv[i], varPtr)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable array must have integer values"; + } + } + } else { + int *varPtr = &linkPtr->lastValue.i; + + if (GetInt(valueObj, varPtr)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable must have integer value"; + } + LinkedVar(int) = *varPtr; } - LinkedVar(int) = linkPtr->lastValue.i; break; case TCL_LINK_WIDE_INT: - if (Tcl_GetWideIntFromObj(NULL, valueObj, &linkPtr->lastValue.w) != TCL_OK - && GetInvalidWideFromObj(valueObj, &linkPtr->lastValue.w) != TCL_OK) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have integer value"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + for (i=0; i < objc; i++) { + Tcl_WideInt *varPtr = &linkPtr->lastValue.wPtr[i]; + + if (GetWide(objv[i], varPtr)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) + "variable array must have wide integer value"; + } + } + } else { + Tcl_WideInt *varPtr = &linkPtr->lastValue.w; + + if (GetWide(valueObj, varPtr)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable must have wide integer value"; + } + LinkedVar(Tcl_WideInt) = *varPtr; } - LinkedVar(Tcl_WideInt) = linkPtr->lastValue.w; break; case TCL_LINK_DOUBLE: - if (Tcl_GetDoubleFromObj(NULL, valueObj, &linkPtr->lastValue.d) != TCL_OK) { -#ifdef ACCEPT_NAN - if (valueObj->typePtr != &tclDoubleType) { -#endif - if (GetInvalidDoubleFromObj(valueObj, &linkPtr->lastValue.d) != TCL_OK) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have real value"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + for (i=0; i < objc; i++) { + if (GetDouble(objv[i], &linkPtr->lastValue.dPtr[i])) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable array must have real value"; } -#ifdef ACCEPT_NAN } - linkPtr->lastValue.d = valueObj->internalRep.doubleValue; -#endif + } else { + double *varPtr = &linkPtr->lastValue.d; + + if (GetDouble(valueObj, varPtr)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable must have real value"; + } + LinkedVar(double) = *varPtr; } - LinkedVar(double) = linkPtr->lastValue.d; break; case TCL_LINK_BOOLEAN: - if (Tcl_GetBooleanFromObj(NULL, valueObj, &linkPtr->lastValue.i) != TCL_OK) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have boolean value"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + for (i=0; i < objc; i++) { + int *varPtr = &linkPtr->lastValue.iPtr[i]; + + if (Tcl_GetBooleanFromObj(NULL, objv[i], varPtr) != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable array must have boolean value"; + } + } + } else { + int *varPtr = &linkPtr->lastValue.i; + + if (Tcl_GetBooleanFromObj(NULL, valueObj, varPtr) != TCL_OK) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable must have boolean value"; + } + LinkedVar(int) = *varPtr; } - LinkedVar(int) = linkPtr->lastValue.i; break; case TCL_LINK_CHAR: - if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK - && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) - || valueInt < SCHAR_MIN || valueInt > SCHAR_MAX) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have char value"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + for (i=0; i < objc; i++) { + if (GetInt(objv[i], &valueInt) + || !InRange(SCHAR_MIN, valueInt, SCHAR_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable array must have char value"; + } + linkPtr->lastValue.cPtr[i] = (char) valueInt; + } + } else { + if (GetInt(valueObj, &valueInt) + || !InRange(SCHAR_MIN, valueInt, SCHAR_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable must have char value"; + } + LinkedVar(char) = linkPtr->lastValue.c = (char) valueInt; } - LinkedVar(char) = linkPtr->lastValue.c = (char)valueInt; break; case TCL_LINK_UCHAR: - if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK - && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) - || valueInt < 0 || valueInt > UCHAR_MAX) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have unsigned char value"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + for (i=0; i < objc; i++) { + if (GetInt(objv[i], &valueInt) + || !InRange(0, valueInt, UCHAR_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) + "variable array must have unsigned char value"; + } + linkPtr->lastValue.ucPtr[i] = (unsigned char) valueInt; + } + } else { + if (GetInt(valueObj, &valueInt) + || !InRange(0, valueInt, UCHAR_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable must have unsigned char value"; + } + LinkedVar(unsigned char) = linkPtr->lastValue.uc = + (unsigned char) valueInt; } - LinkedVar(unsigned char) = linkPtr->lastValue.uc = (unsigned char) valueInt; break; case TCL_LINK_SHORT: - if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK - && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) - || valueInt < SHRT_MIN || valueInt > SHRT_MAX) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have short value"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + for (i=0; i < objc; i++) { + if (GetInt(objv[i], &valueInt) + || !InRange(SHRT_MIN, valueInt, SHRT_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable array must have short value"; + } + linkPtr->lastValue.sPtr[i] = (short) valueInt; + } + } else { + if (GetInt(valueObj, &valueInt) + || !InRange(SHRT_MIN, valueInt, SHRT_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable must have short value"; + } + LinkedVar(short) = linkPtr->lastValue.s = (short) valueInt; } - LinkedVar(short) = linkPtr->lastValue.s = (short)valueInt; break; case TCL_LINK_USHORT: - if ((Tcl_GetIntFromObj(NULL, valueObj, &valueInt) != TCL_OK - && GetInvalidIntFromObj(valueObj, &valueInt) != TCL_OK) - || valueInt < 0 || valueInt > USHRT_MAX) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have unsigned short value"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + for (i=0; i < objc; i++) { + if (GetInt(objv[i], &valueInt) + || !InRange(0, valueInt, USHRT_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) + "variable array must have unsigned short value"; + } + linkPtr->lastValue.usPtr[i] = (unsigned short) valueInt; + } + } else { + if (GetInt(valueObj, &valueInt) + || !InRange(0, valueInt, USHRT_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable must have unsigned short value"; + } + LinkedVar(unsigned short) = linkPtr->lastValue.us = + (unsigned short) valueInt; } - LinkedVar(unsigned short) = linkPtr->lastValue.us = (unsigned short)valueInt; break; case TCL_LINK_UINT: - if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK - && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK) - || valueWide < 0 || valueWide > UINT_MAX) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have unsigned int value"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + for (i=0; i < objc; i++) { + if (GetWide(objv[i], &valueWide) + || !InRange(0, valueWide, UINT_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) + "variable array must have unsigned int value"; + } + linkPtr->lastValue.uiPtr[i] = (unsigned int) valueWide; + } + } else { + if (GetWide(valueObj, &valueWide) + || !InRange(0, valueWide, UINT_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable must have unsigned int value"; + } + LinkedVar(unsigned int) = linkPtr->lastValue.ui = + (unsigned int) valueWide; } - 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) - || valueWide < LONG_MIN || valueWide > LONG_MAX) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have long value"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + for (i=0; i < objc; i++) { + if (GetWide(objv[i], &valueWide) + || !InRange(LONG_MIN, valueWide, LONG_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable array must have long value"; + } + linkPtr->lastValue.lPtr[i] = (long) valueWide; + } + } else { + if (GetWide(valueObj, &valueWide) + || !InRange(LONG_MIN, valueWide, LONG_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable must have long value"; + } + LinkedVar(long) = linkPtr->lastValue.l = (long) valueWide; } - LinkedVar(long) = linkPtr->lastValue.l = (long)valueWide; break; case TCL_LINK_ULONG: - if ((Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK - && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK) - || valueWide < 0 || (Tcl_WideUInt) valueWide > ULONG_MAX) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have unsigned long value"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + for (i=0; i < objc; i++) { + if (GetUWide(objv[i], &valueUWide) + || !InRange(0, valueUWide, ULONG_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) + "variable array must have unsigned long value"; + } + linkPtr->lastValue.ulPtr[i] = (unsigned long) valueUWide; + } + } else { + if (GetUWide(valueObj, &valueUWide) + || !InRange(0, valueUWide, ULONG_MAX)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable must have unsigned long value"; + } + LinkedVar(unsigned long) = linkPtr->lastValue.ul = + (unsigned long) valueUWide; } - LinkedVar(unsigned long) = linkPtr->lastValue.ul = (unsigned long)valueWide; break; +#endif case TCL_LINK_WIDE_UINT: - /* - * FIXME: represent as a bignum. - */ - if (Tcl_GetWideIntFromObj(NULL, valueObj, &valueWide) != TCL_OK - && GetInvalidWideFromObj(valueObj, &valueWide) != TCL_OK) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have unsigned wide int value"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + for (i=0; i < objc; i++) { + if (GetUWide(objv[i], &valueUWide)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) + "variable array must have unsigned wide int value"; + } + linkPtr->lastValue.uwPtr[i] = valueUWide; + } + } else { + if (GetUWide(valueObj, &valueUWide)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable must have unsigned wide int value"; + } + LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw = valueUWide; } - LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw = (Tcl_WideUInt)valueWide; break; case TCL_LINK_FLOAT: - if ((Tcl_GetDoubleFromObj(NULL, valueObj, &valueDouble) != TCL_OK - && GetInvalidDoubleFromObj(valueObj, &valueDouble) != TCL_OK) - || valueDouble < -FLT_MAX || valueDouble > FLT_MAX) { - Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr), - TCL_GLOBAL_ONLY); - return (char *) "variable must have float value"; + if (linkPtr->flags & LINK_ALLOC_LAST) { + for (i=0; i < objc; i++) { + if (GetDouble(objv[i], &valueDouble) + && !InRange(FLT_MIN, fabs(valueDouble), FLT_MAX) + && !IsSpecial(valueDouble)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable array must have float value"; + } + linkPtr->lastValue.fPtr[i] = (float) valueDouble; + } + } else { + if (GetDouble(valueObj, &valueDouble) + && !InRange(FLT_MIN, fabs(valueDouble), FLT_MAX) + && !IsSpecial(valueDouble)) { + Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, + ObjValue(linkPtr), TCL_GLOBAL_ONLY); + return (char *) "variable must have float value"; + } + LinkedVar(float) = linkPtr->lastValue.f = (float) valueDouble; } - LinkedVar(float) = linkPtr->lastValue.f = (float)valueDouble; - break; - - case TCL_LINK_STRING: - value = TclGetString(valueObj); - valueLength = valueObj->length + 1; - pp = (char **) linkPtr->addr; - - *pp = ckrealloc(*pp, valueLength); - memcpy(*pp, value, valueLength); break; default: return (char *) "internal error: bad linked variable type"; } + + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->addr, linkPtr->lastValue.aryPtr, linkPtr->bytes); + } return NULL; } @@ -583,51 +1276,183 @@ ObjValue( Link *linkPtr) /* Structure describing linked variable. */ { char *p; - Tcl_Obj *resultObj; + Tcl_Obj *resultObj, **objv; + int i; switch (linkPtr->type) { case TCL_LINK_INT: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { + objv[i] = Tcl_NewIntObj(linkPtr->lastValue.iPtr[i]); + } + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + ckfree(objv); + return resultObj; + } linkPtr->lastValue.i = LinkedVar(int); return Tcl_NewIntObj(linkPtr->lastValue.i); case TCL_LINK_WIDE_INT: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { + objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.wPtr[i]); + } + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + ckfree(objv); + return resultObj; + } linkPtr->lastValue.w = LinkedVar(Tcl_WideInt); return Tcl_NewWideIntObj(linkPtr->lastValue.w); case TCL_LINK_DOUBLE: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { + objv[i] = Tcl_NewDoubleObj(linkPtr->lastValue.dPtr[i]); + } + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + ckfree(objv); + return resultObj; + } linkPtr->lastValue.d = LinkedVar(double); return Tcl_NewDoubleObj(linkPtr->lastValue.d); case TCL_LINK_BOOLEAN: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { + objv[i] = Tcl_NewBooleanObj(linkPtr->lastValue.iPtr[i] != 0); + } + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + ckfree(objv); + return resultObj; + } linkPtr->lastValue.i = LinkedVar(int); - return Tcl_NewBooleanObj(linkPtr->lastValue.i != 0); + return Tcl_NewBooleanObj(linkPtr->lastValue.i); case TCL_LINK_CHAR: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { + objv[i] = Tcl_NewIntObj(linkPtr->lastValue.cPtr[i]); + } + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + ckfree(objv); + return resultObj; + } linkPtr->lastValue.c = LinkedVar(char); return Tcl_NewIntObj(linkPtr->lastValue.c); case TCL_LINK_UCHAR: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { + objv[i] = Tcl_NewIntObj(linkPtr->lastValue.ucPtr[i]); + } + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + ckfree(objv); + return resultObj; + } linkPtr->lastValue.uc = LinkedVar(unsigned char); return Tcl_NewIntObj(linkPtr->lastValue.uc); case TCL_LINK_SHORT: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { + objv[i] = Tcl_NewIntObj(linkPtr->lastValue.sPtr[i]); + } + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + ckfree(objv); + return resultObj; + } linkPtr->lastValue.s = LinkedVar(short); return Tcl_NewIntObj(linkPtr->lastValue.s); case TCL_LINK_USHORT: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { + objv[i] = Tcl_NewIntObj(linkPtr->lastValue.usPtr[i]); + } + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + ckfree(objv); + return resultObj; + } linkPtr->lastValue.us = LinkedVar(unsigned short); return Tcl_NewIntObj(linkPtr->lastValue.us); case TCL_LINK_UINT: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { + objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.uiPtr[i]); + } + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + ckfree(objv); + return resultObj; + } 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: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { + objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.lPtr[i]); + } + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + ckfree(objv); + return resultObj; + } linkPtr->lastValue.l = LinkedVar(long); return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.l); case TCL_LINK_ULONG: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { + objv[i] = Tcl_NewWideIntObj(linkPtr->lastValue.ulPtr[i]); + } + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + ckfree(objv); + return resultObj; + } linkPtr->lastValue.ul = LinkedVar(unsigned long); return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.ul); +#endif case TCL_LINK_FLOAT: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { + objv[i] = Tcl_NewDoubleObj(linkPtr->lastValue.fPtr[i]); + } + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + ckfree(objv); + return resultObj; + } linkPtr->lastValue.f = LinkedVar(float); return Tcl_NewDoubleObj(linkPtr->lastValue.f); case TCL_LINK_WIDE_UINT: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + objv = ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { + objv[i] = Tcl_NewWideIntObj((Tcl_WideInt) + linkPtr->lastValue.uwPtr[i]); + } + resultObj = Tcl_NewListObj(linkPtr->numElems, objv); + ckfree(objv); + return resultObj; + } linkPtr->lastValue.uw = LinkedVar(Tcl_WideUInt); - /* - * FIXME: represent as a bignum. - */ return Tcl_NewWideIntObj((Tcl_WideInt) linkPtr->lastValue.uw); + case TCL_LINK_STRING: p = LinkedVar(char *); if (p == NULL) { @@ -636,6 +1461,25 @@ ObjValue( } return Tcl_NewStringObj(p, -1); + case TCL_LINK_CHARS: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + linkPtr->lastValue.cPtr[linkPtr->bytes-1] = '\0'; + /* take care of proper string end */ + return Tcl_NewStringObj(linkPtr->lastValue.cPtr, linkPtr->bytes); + } + linkPtr->lastValue.c = '\0'; + return Tcl_NewStringObj(&linkPtr->lastValue.c, 1); + + case TCL_LINK_BINARY: + if (linkPtr->flags & LINK_ALLOC_LAST) { + memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); + return Tcl_NewByteArrayObj((unsigned char *) linkPtr->addr, + linkPtr->bytes); + } + linkPtr->lastValue.uc = LinkedVar(unsigned char); + return Tcl_NewByteArrayObj(&linkPtr->lastValue.uc, 1); + /* * This code only gets executed if the link type is unknown (shouldn't * ever happen). @@ -646,110 +1490,37 @@ ObjValue( return resultObj; } } - -static int SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); - -static Tcl_ObjType invalidRealType = { - "invalidReal", /* name */ - NULL, /* freeIntRepProc */ - NULL, /* dupIntRepProc */ - NULL, /* updateStringProc */ - NULL /* setFromAnyProc */ -}; - -static int -SetInvalidRealFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr) { - int length; - const char *str; - const char *endPtr; - - 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, length, &endPtr, - TCL_PARSE_DECIMAL_ONLY) == TCL_OK) { - /* If number is followed by [eE][+-]?, then it is an invalid - * double, but it could be the start of a valid double. */ - if (*endPtr == 'e' || *endPtr == 'E') { - ++endPtr; - if (*endPtr == '+' || *endPtr == '-') ++endPtr; - if (*endPtr == 0) { - double doubleValue = 0.0; - Tcl_GetDoubleFromObj(NULL, objPtr, &doubleValue); - if (objPtr->typePtr->freeIntRepProc) objPtr->typePtr->freeIntRepProc(objPtr); - objPtr->typePtr = &invalidRealType; - objPtr->internalRep.doubleValue = doubleValue; - return TCL_OK; - } - } - } - return TCL_ERROR; -} - - + /* - * This function checks for integer representations, which are valid - * when linking with C variables, but which are invalid in other - * contexts in Tcl. Handled are "+", "-", "", "0x", "0b" and "0o" - * (upperand lowercase). See bug [39f6304c2e]. + *---------------------------------------------------------------------- + * + * LinkFree -- + * + * Free's allocated space of given link and link structure. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- */ -int -GetInvalidIntFromObj(Tcl_Obj *objPtr, - int *intPtr) -{ - const char *str = TclGetString(objPtr); - if ((objPtr->length == 0) || - ((objPtr->length == 2) && (str[0] == '0') && strchr("xXbBoO", str[1]))) { - *intPtr = 0; - return TCL_OK; - } else if ((objPtr->length == 1) && strchr("+-", str[0])) { - *intPtr = (str[0] == '+'); - return TCL_OK; - } - return TCL_ERROR; -} - -int -GetInvalidWideFromObj(Tcl_Obj *objPtr, Tcl_WideInt *widePtr) -{ - int intValue; - - if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) { - return TCL_ERROR; - } - *widePtr = intValue; - return TCL_OK; -} - -/* - * This function checks for double representations, which are valid - * when linking with C variables, but which are invalid in other - * contexts in Tcl. Handled are "+", "-", "", ".", "0x", "0b" and "0o" - * (upper- and lowercase) and sequences like "1e-". See bug [39f6304c2e]. - */ -int -GetInvalidDoubleFromObj(Tcl_Obj *objPtr, - double *doublePtr) +static void +LinkFree( + Link *linkPtr) /* Structure describing linked variable. */ { - int intValue; - - if (objPtr->typePtr == &invalidRealType) { - goto gotdouble; + if (linkPtr->nsPtr) { + TclNsDecrRefCount(linkPtr->nsPtr); } - if (GetInvalidIntFromObj(objPtr, &intValue) == TCL_OK) { - *doublePtr = (double) intValue; - return TCL_OK; + if (linkPtr->flags & LINK_ALLOC_ADDR) { + ckfree(linkPtr->addr); } - if (SetInvalidRealFromAny(NULL, objPtr) == TCL_OK) { - gotdouble: - *doublePtr = objPtr->internalRep.doubleValue; - return TCL_OK; + if (linkPtr->flags & LINK_ALLOC_LAST) { + ckfree(linkPtr->lastValue.aryPtr); } - return TCL_ERROR; + ckfree((char *) linkPtr); } /* diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 6eb6780..ad64971 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -12,6 +12,7 @@ */ #include "tclInt.h" +#include <assert.h> /* * Prototypes for functions defined later in this file: @@ -46,6 +47,27 @@ const Tcl_ObjType tclListType = { SetListFromAny /* setFromAnyProc */ }; +/* Macros to manipulate the List internal rep */ + +#define ListSetIntRep(objPtr, listRepPtr) \ + do { \ + Tcl_ObjIntRep ir; \ + ir.twoPtrValue.ptr1 = (listRepPtr); \ + ir.twoPtrValue.ptr2 = NULL; \ + (listRepPtr)->refCount++; \ + Tcl_StoreIntRep((objPtr), &tclListType, &ir); \ + } while (0) + +#define ListGetIntRep(objPtr, listRepPtr) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = TclFetchIntRep((objPtr), &tclListType); \ + (listRepPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + } while (0) + +#define ListResetIntRep(objPtr, listRepPtr) \ + TclFetchIntRep((objPtr), &tclListType)->twoPtrValue.ptr1 = (listRepPtr) + #ifndef TCL_MIN_ELEMENT_GROWTH #define TCL_MIN_ELEMENT_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Obj *) #endif @@ -55,22 +77,20 @@ const Tcl_ObjType tclListType = { * * NewListIntRep -- * - * Creates a 'List' structure with space for 'objc' elements. 'objc' must - * be > 0. If 'objv' is not NULL, The list is initialized with first - * 'objc' values in that array. Otherwise the list is initialized to have - * 0 elements, with space to add 'objc' more. Flag value 'p' indicates + * Creates a list internal rep with space for objc elements. objc + * must be > 0. If objv!=NULL, initializes with the first objc values + * in that array. If objv==NULL, initalize list internal rep to have + * 0 elements, with space to add objc more. Flag value "p" indicates * how to behave on failure. * - * Value - * - * A new 'List' structure with refCount 0. If some failure - * prevents this NULL is returned if 'p' is 0 , and 'Tcl_Panic' - * is called if it is not. - * - * Effect + * Results: + * A new List struct with refCount 0 is returned. If some failure + * prevents this then if p=0, NULL is returned and otherwise the + * routine panics. * - * The refCount of each value in 'objv' is incremented as it is added - * to the list. + * Side effects: + * The ref counts of the elements in objv are incremented since the + * resulting list now refers to them. * *---------------------------------------------------------------------- */ @@ -134,9 +154,21 @@ NewListIntRep( /* *---------------------------------------------------------------------- * - * AttemptNewList -- + * AttemptNewList -- * - * Like NewListIntRep, but additionally sets an error message on failure. + * Creates a list internal rep with space for objc elements. objc + * must be > 0. If objv!=NULL, initializes with the first objc values + * in that array. If objv==NULL, initalize list internal rep to have + * 0 elements, with space to add objc more. + * + * Results: + * A new List struct with refCount 0 is returned. If some failure + * prevents this then NULL is returned, and an error message is left + * in the interp result, unless interp is NULL. + * + * Side effects: + * The ref counts of the elements in objv are incremented since the + * resulting list now refers to them. * *---------------------------------------------------------------------- */ @@ -169,20 +201,23 @@ AttemptNewList( * * Tcl_NewListObj -- * - * Creates a new list object and adds values to it. When TCL_MEM_DEBUG is - * defined, 'Tcl_DbNewListObj' is called instead. - * - * Value + * This function is normally called when not debugging: i.e., when + * TCL_MEM_DEBUG is not defined. It creates a new list object from an + * (objc,objv) array: that is, each of the objc elements of the array + * referenced by objv is inserted as an element into a new Tcl object. * - * A new list 'Tcl_Obj' to which is appended values from 'objv', or if - * 'objc' is less than or equal to zero, a list 'Tcl_Obj' having no - * elements. The string representation of the new 'Tcl_Obj' is set to - * NULL. The refCount of the list is 0. + * When TCL_MEM_DEBUG is defined, this function just returns the result + * of calling the debugging version Tcl_DbNewListObj. * - * Effect + * Results: + * A new list object is returned that is initialized from the object + * pointers in objv. If objc is less than or equal to zero, an empty + * object is returned. The new object's string representation is left + * NULL. The resulting new list object has ref count 0. * - * The refCount of each elements in 'objv' is incremented as it is added - * to the list. + * Side effects: + * The ref counts of the elements in objv are incremented since the + * resulting list now refers to them. * *---------------------------------------------------------------------- */ @@ -233,14 +268,28 @@ Tcl_NewListObj( /* *---------------------------------------------------------------------- * - * Tcl_DbNewListObj -- + * Tcl_DbNewListObj -- * - * Like 'Tcl_NewListObj', but it calls Tcl_DbCkalloc directly with the - * file name and line number from its caller. This simplifies debugging - * since the [memory active] command will report the correct file - * name and line number when reporting objects that haven't been freed. + * This function is normally called when debugging: i.e., when + * TCL_MEM_DEBUG is defined. It creates new list objects. It is the same + * as the Tcl_NewListObj function above except that it calls + * Tcl_DbCkalloc directly with the file name and line number from its + * caller. This simplifies debugging since then the [memory active] + * command will report the correct file name and line number when + * reporting objects that haven't been freed. * - * When TCL_MEM_DEBUG is not defined, 'Tcl_NewListObj' is called instead. + * When TCL_MEM_DEBUG is not defined, this function just returns the + * result of calling Tcl_NewListObj. + * + * Results: + * A new list object is returned that is initialized from the object + * pointers in objv. If objc is less than or equal to zero, an empty + * object is returned. The new object's string representation is left + * NULL. The new list object has ref count 0. + * + * Side effects: + * The ref counts of the elements in objv are incremented since the + * resulting list now refers to them. * *---------------------------------------------------------------------- */ @@ -301,8 +350,19 @@ Tcl_DbNewListObj( * * Tcl_SetListObj -- * - * Like 'Tcl_NewListObj', but operates on an existing 'Tcl_Obj'instead of - * creating a new one. + * Modify an object to be a list containing each of the objc elements of + * the object array referenced by objv. + * + * Results: + * None. + * + * Side effects: + * The object is made a list object and is initialized from the object + * pointers in objv. If objc is less than or equal to zero, an empty + * object is returned. The new object's string representation is left + * NULL. The ref counts of the elements in objv are incremented since the + * list now refers to them. The object's old string and internal + * representations are freed and its type is set NULL. * *---------------------------------------------------------------------- */ @@ -336,8 +396,7 @@ Tcl_SetListObj( listRepPtr = NewListIntRep(objc, objv, 1); ListSetIntRep(objPtr, listRepPtr); } else { - objPtr->bytes = tclEmptyStringRep; - objPtr->length = 0; + Tcl_InitStringRep(objPtr, NULL, 0); } } @@ -346,20 +405,18 @@ Tcl_SetListObj( * * TclListObjCopy -- * - * Creates a new 'Tcl_Obj' which is a pure copy of a list value. This - * provides for the C level a counterpart of the [lrange $list 0 end] - * command, while using internals details to be as efficient as possible. - * - * Value - * - * The address of the new 'Tcl_Obj' which shares its internal - * representation with 'listPtr', and whose refCount is 0. If 'listPtr' - * is not actually a list, the value is NULL, and an error message is left - * in 'interp' if it is not NULL. + * Makes a "pure list" copy of a list value. This provides for the C + * level a counterpart of the [lrange $list 0 end] command, while using + * internals details to be as efficient as possible. * - * Effect + * Results: + * Normally returns a pointer to a new Tcl_Obj, that contains the same + * list value as *listPtr does. The returned Tcl_Obj has a refCount of + * zero. If *listPtr does not hold a list, NULL is returned, and if + * interp is non-NULL, an error message is recorded there. * - * 'listPtr' is converted to a list if it isn't one already. + * Side effects: + * None. * *---------------------------------------------------------------------- */ @@ -371,8 +428,10 @@ TclListObjCopy( * to be returned. */ { Tcl_Obj *copyPtr; + List *listRepPtr; - if (listPtr->typePtr != &tclListType) { + ListGetIntRep(listPtr, listRepPtr); + if (NULL == listRepPtr) { if (SetListFromAny(interp, listPtr) != TCL_OK) { return NULL; } @@ -387,32 +446,110 @@ TclListObjCopy( /* *---------------------------------------------------------------------- * - * Tcl_ListObjGetElements -- + * TclListObjRange -- * - * Retreive the elements in a list 'Tcl_Obj'. + * Makes a slice of a list value. + * *listPtr must be known to be a valid list. * - * Value + * Results: + * Returns a pointer to the sliced list. + * This may be a new object or the same object if not shared. * - * TCL_OK + * Side effects: + * The possible conversion of the object referenced by listPtr + * to a list object. * - * A count of list elements is stored, 'objcPtr', And a pointer to the - * array of elements in the list is stored in 'objvPtr'. + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclListObjRange( + Tcl_Obj *listPtr, /* List object to take a range from. */ + int fromIdx, /* Index of first element to include. */ + int toIdx) /* Index of last element to include. */ +{ + Tcl_Obj **elemPtrs; + int listLen, i, newLen; + List *listRepPtr; + + TclListObjGetElements(NULL, listPtr, &listLen, &elemPtrs); + + if (fromIdx < 0) { + fromIdx = 0; + } + if (toIdx >= listLen) { + toIdx = listLen-1; + } + if (fromIdx > toIdx) { + return Tcl_NewObj(); + } + + newLen = toIdx - fromIdx + 1; + + if (Tcl_IsShared(listPtr) || + ((ListRepPtr(listPtr)->refCount > 1))) { + return Tcl_NewListObj(newLen, &elemPtrs[fromIdx]); + } + + /* + * In-place is possible. + */ + + /* + * Even if nothing below cause any changes, we still want the + * string-canonizing effect of [lrange 0 end]. + */ + + TclInvalidateStringRep(listPtr); + + /* + * Delete elements that should not be included. + */ + + for (i = 0; i < fromIdx; i++) { + TclDecrRefCount(elemPtrs[i]); + } + for (i = toIdx + 1; i < listLen; i++) { + TclDecrRefCount(elemPtrs[i]); + } + + if (fromIdx > 0) { + memmove(elemPtrs, &elemPtrs[fromIdx], + (size_t) newLen * sizeof(Tcl_Obj*)); + } + + listRepPtr = ListRepPtr(listPtr); + listRepPtr->elemCount = newLen; + + return listPtr; +} + +/* + *---------------------------------------------------------------------- * - * The elements accessible via 'objvPtr' should be treated as readonly - * and the refCount for each object is _not_ incremented; the caller - * must do that if it holds on to a reference. Furthermore, the - * pointer and length returned by this function may change as soon as - * any function is called on the list object. Be careful about - * retaining the pointer in a local data structure. + * Tcl_ListObjGetElements -- * - * TCL_ERROR + * This function returns an (objc,objv) array of the elements in a list + * object. * - * 'listPtr' is not a valid list. An error message is left in the - * interpreter's result if 'interp' is not NULL. + * Results: + * The return value is normally TCL_OK; in this case *objcPtr is set to + * the count of list elements and *objvPtr is set to a pointer to an + * array of (*objcPtr) pointers to each list element. If listPtr does not + * refer to a list object and the object can not be converted to one, + * TCL_ERROR is returned and an error message will be left in the + * interpreter's result if interp is not NULL. * - * Effect + * The objects referenced by the returned array should be treated as + * readonly and their ref counts are _not_ incremented; the caller must + * do that if it holds on to a reference. Furthermore, the pointer and + * length returned by this function may change as soon as any function is + * called on the list object; be careful about retaining the pointer in a + * local data structure. * - * 'listPtr' is converted to a list object if it isn't one already. + * Side effects: + * The possible conversion of the object referenced by listPtr + * to a list object. * *---------------------------------------------------------------------- */ @@ -429,10 +566,13 @@ Tcl_ListObjGetElements( { register List *listRepPtr; - if (listPtr->typePtr != &tclListType) { - int result; + ListGetIntRep(listPtr, listRepPtr); - if (listPtr->bytes == tclEmptyStringRep) { + if (listRepPtr == NULL) { + int result, length; + + (void) Tcl_GetStringFromObj(listPtr, &length); + if (length == 0) { *objcPtr = 0; *objvPtr = NULL; return TCL_OK; @@ -441,8 +581,8 @@ Tcl_ListObjGetElements( if (result != TCL_OK) { return result; } + ListGetIntRep(listPtr, listRepPtr); } - listRepPtr = ListRepPtr(listPtr); *objcPtr = listRepPtr->elemCount; *objvPtr = &listRepPtr->elements; return TCL_OK; @@ -453,27 +593,20 @@ Tcl_ListObjGetElements( * * Tcl_ListObjAppendList -- * - * Appends the elements of elemListPtr to those of listPtr. - * - * Value - * - * TCL_OK - * - * Success. - * - * TCL_ERROR + * This function appends the elements in the list value referenced by + * elemListPtr to the list value referenced by listPtr. * - * 'listPtr' or 'elemListPtr' are not valid lists. An error - * message is left in the interpreter's result if 'interp' is not NULL. + * Results: + * The return value is normally TCL_OK. If listPtr or elemListPtr do not + * refer to list values, TCL_ERROR is returned and an error message is + * left in the interpreter's result if interp is not NULL. * - * Effect - * - * The reference count of each element of 'elemListPtr' as it is added to - * 'listPtr'. 'listPtr' and 'elemListPtr' are converted to 'tclListType' - * if they are not already. Appending the new elements may cause the - * array of element pointers in 'listObj' to grow. If any objects are - * appended to 'listPtr'. Any preexisting string representation of - * 'listPtr' is invalidated. + * Side effects: + * The reference counts of the elements in elemListPtr are incremented + * since the list now refers to them. listPtr and elemListPtr are + * converted, if necessary, to list objects. Also, appending the new + * elements may cause listObj's array of element pointers to grow. + * listPtr's old string representation, if any, is invalidated. * *---------------------------------------------------------------------- */ @@ -512,27 +645,24 @@ Tcl_ListObjAppendList( * * Tcl_ListObjAppendElement -- * - * Like 'Tcl_ListObjAppendList', but Appends a single value to a list. - * - * Value - * - * TCL_OK - * - * 'objPtr' is appended to the elements of 'listPtr'. - * - * TCL_ERROR - * - * listPtr does not refer to a list object and the object can not be - * converted to one. An error message will be left in the - * interpreter's result if interp is not NULL. - * - * Effect - * - * If 'listPtr' is not already of type 'tclListType', it is converted. - * The 'refCount' of 'objPtr' is incremented as it is added to 'listPtr'. - * Appending the new element may cause the the array of element pointers - * in 'listObj' to grow. Any preexisting string representation of - * 'listPtr' is invalidated. + * This function is a special purpose version of Tcl_ListObjAppendList: + * it appends a single object referenced by objPtr to the list object + * referenced by listPtr. If listPtr is not already a list object, an + * attempt will be made to convert it to one. + * + * Results: + * The return value is normally TCL_OK; in this case objPtr is added to + * the end of listPtr's list. If listPtr does not refer to a list object + * and the object can not be converted to one, TCL_ERROR is returned and + * an error message will be left in the interpreter's result if interp is + * not NULL. + * + * Side effects: + * The ref count of objPtr is incremented since the list now refers to + * it. listPtr will be converted, if necessary, to a list object. Also, + * appending the new element may cause listObj's array of element + * pointers to grow. listPtr's old string representation, if any, is + * invalidated. * *---------------------------------------------------------------------- */ @@ -549,10 +679,13 @@ Tcl_ListObjAppendElement( if (Tcl_IsShared(listPtr)) { Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendElement"); } - if (listPtr->typePtr != &tclListType) { - int result; - if (listPtr->bytes == tclEmptyStringRep) { + ListGetIntRep(listPtr, listRepPtr); + if (listRepPtr == NULL) { + int result, length; + + (void) Tcl_GetStringFromObj(listPtr, &length); + if (length == 0) { Tcl_SetListObj(listPtr, 1, &objPtr); return TCL_OK; } @@ -560,9 +693,9 @@ Tcl_ListObjAppendElement( if (result != TCL_OK) { return result; } + ListGetIntRep(listPtr, listRepPtr); } - listRepPtr = ListRepPtr(listPtr); numElems = listRepPtr->elemCount; numRequired = numElems + 1 ; needGrow = (numRequired > listRepPtr->maxElemCount); @@ -653,12 +786,16 @@ Tcl_ListObjAppendElement( * Old intrep to be freed, re-use refCounts. */ - memcpy(dst, src, (size_t) numElems * sizeof(Tcl_Obj *)); + memcpy(dst, src, numElems * sizeof(Tcl_Obj *)); ckfree(listRepPtr); } listRepPtr = newPtr; } - listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr; + ListResetIntRep(listPtr, listRepPtr); + listRepPtr->refCount++; + TclFreeIntRep(listPtr); + ListSetIntRep(listPtr, listRepPtr); + listRepPtr->refCount--; /* * Add objPtr to the end of listPtr's array of element pointers. Increment @@ -683,27 +820,23 @@ Tcl_ListObjAppendElement( * * Tcl_ListObjIndex -- * - * Retrieve a pointer to the element of 'listPtr' at 'index'. The index - * of the first element is 0. - * - * Value - * - * TCL_OK - * - * A pointer to the element at 'index' is stored in 'objPtrPtr'. If - * 'index' is out of range, NULL is stored in 'objPtrPtr'. This - * object should be treated as readonly and its 'refCount' is _not_ - * incremented. The caller must do that if it holds on to the - * reference. + * This function returns a pointer to the index'th object from the list + * referenced by listPtr. The first element has index 0. If index is + * negative or greater than or equal to the number of elements in the + * list, a NULL is returned. If listPtr is not a list object, an attempt + * will be made to convert it to a list. * - * TCL_ERROR + * Results: + * The return value is normally TCL_OK; in this case objPtrPtr is set to + * the Tcl_Obj pointer for the index'th list element or NULL if index is + * out of range. This object should be treated as readonly and its ref + * count is _not_ incremented; the caller must do that if it holds on to + * the reference. If listPtr does not refer to a list and can't be + * converted to one, TCL_ERROR is returned and an error message is left + * in the interpreter's result if interp is not NULL. * - * 'listPtr' is not a valid list. An an error message is left in the - * interpreter's result if 'interp' is not NULL. - * - * Effect - * - * If 'listPtr' is not already of type 'tclListType', it is converted. + * Side effects: + * listPtr will be converted, if necessary, to a list object. * *---------------------------------------------------------------------- */ @@ -717,10 +850,12 @@ Tcl_ListObjIndex( { register List *listRepPtr; - if (listPtr->typePtr != &tclListType) { - int result; + ListGetIntRep(listPtr, listRepPtr); + if (listRepPtr == NULL) { + int result, length; - if (listPtr->bytes == tclEmptyStringRep) { + (void) Tcl_GetStringFromObj(listPtr, &length); + if (length == 0) { *objPtrPtr = NULL; return TCL_OK; } @@ -728,9 +863,9 @@ Tcl_ListObjIndex( if (result != TCL_OK) { return result; } + ListGetIntRep(listPtr, listRepPtr); } - listRepPtr = ListRepPtr(listPtr); if ((index < 0) || (index >= listRepPtr->elemCount)) { *objPtrPtr = NULL; } else { @@ -745,20 +880,19 @@ Tcl_ListObjIndex( * * Tcl_ListObjLength -- * - * Retrieve the number of elements in a list. - * - * Value - * - * TCL_OK + * This function returns the number of elements in a list object. If the + * object is not already a list object, an attempt will be made to + * convert it to one. * - * A count of list elements is stored at the address provided by - * 'intPtr'. If 'listPtr' is not already of type 'tclListPtr', it is - * converted. + * Results: + * The return value is normally TCL_OK; in this case *intPtr will be set + * to the integer count of list elements. If listPtr does not refer to a + * list object and the object can not be converted to one, TCL_ERROR is + * returned and an error message will be left in the interpreter's result + * if interp is not NULL. * - * TCL_ERROR - * - * 'listPtr' is not a valid list. An error message will be left in - * the interpreter's result if 'interp' is not NULL. + * Side effects: + * The possible conversion of the argument object to a list object. * *---------------------------------------------------------------------- */ @@ -771,10 +905,12 @@ Tcl_ListObjLength( { register List *listRepPtr; - if (listPtr->typePtr != &tclListType) { - int result; + ListGetIntRep(listPtr, listRepPtr); + if (listRepPtr == NULL) { + int result, length; - if (listPtr->bytes == tclEmptyStringRep) { + (void) Tcl_GetStringFromObj(listPtr, &length); + if (length == 0) { *intPtr = 0; return TCL_OK; } @@ -782,9 +918,9 @@ Tcl_ListObjLength( if (result != TCL_OK) { return result; } + ListGetIntRep(listPtr, listRepPtr); } - listRepPtr = ListRepPtr(listPtr); *intPtr = listRepPtr->elemCount; return TCL_OK; } @@ -794,36 +930,35 @@ Tcl_ListObjLength( * * Tcl_ListObjReplace -- * - * Replace values in a list. - * - * If 'first' is zero or negative, it refers to the first element. If - * 'first' outside the range of elements in the list, no elements are - * deleted. - * - * If 'count' is zero or negative no elements are deleted, and any new - * elements are inserted at the beginning of the list. - * - * Value - * - * TCL_OK - * - * The first 'objc' values of 'objv' replaced 'count' elements in 'listPtr' - * starting at 'first'. If 'objc' 0, no new elements are added. - * - * TCL_ERROR - * - * 'listPtr' is not a valid list. An error message is left in the - * interpreter's result if 'interp' is not NULL. - * - * Effect - * - * If 'listPtr' is not of type 'tclListType', it is converted if possible. - * - * The 'refCount' of each element appended to the list is incremented. - * Similarly, the 'refCount' for each replaced element is decremented. - * - * If 'listPtr' is modified, any previous string representation is - * invalidated. + * This function replaces zero or more elements of the list referenced by + * listPtr with the objects from an (objc,objv) array. The objc elements + * of the array referenced by objv replace the count elements in listPtr + * starting at first. + * + * If the argument first is zero or negative, it refers to the first + * element. If first is greater than or equal to the number of elements + * in the list, then no elements are deleted; the new elements are + * appended to the list. Count gives the number of elements to replace. + * If count is zero or negative then no elements are deleted; the new + * elements are simply inserted before first. + * + * The argument objv refers to an array of objc pointers to the new + * elements to be added to listPtr in place of those that were deleted. + * If objv is NULL, no new elements are added. If listPtr is not a list + * object, an attempt will be made to convert it to one. + * + * Results: + * The return value is normally TCL_OK. If listPtr does not refer to a + * list object and can not be converted to one, TCL_ERROR is returned and + * an error message will be left in the interpreter's result if interp is + * not NULL. + * + * Side effects: + * The ref counts of the objc elements in objv are incremented since the + * resulting list now refers to them. Similarly, the ref counts for + * replaced objects are decremented. listPtr is converted, if necessary, + * to a list object. listPtr's old string representation, if any, is + * freed. * *---------------------------------------------------------------------- */ @@ -845,9 +980,14 @@ Tcl_ListObjReplace( if (Tcl_IsShared(listPtr)) { Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace"); } - if (listPtr->typePtr != &tclListType) { - if (listPtr->bytes == tclEmptyStringRep) { - if (!objc) { + + ListGetIntRep(listPtr, listRepPtr); + if (listRepPtr == NULL) { + int length; + + (void) Tcl_GetStringFromObj(listPtr, &length); + if (length == 0) { + if (objc == 0) { return TCL_OK; } Tcl_SetListObj(listPtr, objc, NULL); @@ -858,6 +998,7 @@ Tcl_ListObjReplace( return result; } } + ListGetIntRep(listPtr, listRepPtr); } /* @@ -868,7 +1009,6 @@ Tcl_ListObjReplace( * Resist any temptation to optimize this case. */ - listRepPtr = ListRepPtr(listPtr); elemPtrs = &listRepPtr->elements; numElems = listRepPtr->elemCount; @@ -922,7 +1062,7 @@ Tcl_ListObjReplace( } if (newPtr) { listRepPtr = newPtr; - listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr; + ListResetIntRep(listPtr, listRepPtr); elemPtrs = &listRepPtr->elements; listRepPtr->maxElemCount = attempt; needGrow = numRequired > listRepPtr->maxElemCount; @@ -965,7 +1105,7 @@ Tcl_ListObjReplace( Tcl_Obj **oldPtrs = elemPtrs; int newMax; - if (needGrow){ + if (needGrow) { newMax = 2 * numRequired; } else { newMax = listRepPtr->maxElemCount; @@ -995,7 +1135,7 @@ Tcl_ListObjReplace( } } - listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr; + ListResetIntRep(listPtr, listRepPtr); listRepPtr->refCount++; elemPtrs = &listRepPtr->elements; @@ -1024,7 +1164,7 @@ Tcl_ListObjReplace( */ if (first > 0) { - memcpy(elemPtrs, oldPtrs, (size_t) first * sizeof(Tcl_Obj *)); + memcpy(elemPtrs, oldPtrs, first * sizeof(Tcl_Obj *)); } /* @@ -1068,10 +1208,15 @@ Tcl_ListObjReplace( listRepPtr->elemCount = numRequired; /* - * Invalidate and free any old string representation since it no longer - * reflects the list's internal representation. + * Invalidate and free any old representations that may not agree + * with the revised list's internal representation. */ + listRepPtr->refCount++; + TclFreeIntRep(listPtr); + ListSetIntRep(listPtr, listRepPtr); + listRepPtr->refCount--; + TclInvalidateStringRep(listPtr); return TCL_OK; } @@ -1081,19 +1226,22 @@ Tcl_ListObjReplace( * * TclLindexList -- * - * Implements the 'lindex' command when objc==3. - * - * Implemented entirely as a wrapper around 'TclLindexFlat'. Reconfigures - * the argument format into required form while taking care to manage - * shimmering so as to tend to keep the most useful intreps - * and/or avoid the most expensive conversions. + * This procedure handles the 'lindex' command when objc==3. * - * Value + * Results: + * Returns a pointer to the object extracted, or NULL if an error + * occurred. The returned object already includes one reference count for + * the pointer returned. * - * A pointer to the specified element, with its 'refCount' incremented, or - * NULL if an error occurred. + * Side effects: + * None. * - * Notes + * Notes: + * This procedure is implemented entirely as a wrapper around + * TclLindexFlat. All it does is reconfigure the argument format into the + * form required by TclLindexFlat, while taking care to manage shimmering + * in such a way that we tend to keep the most useful intreps and/or + * avoid the most expensive conversions. * *---------------------------------------------------------------------- */ @@ -1107,6 +1255,7 @@ TclLindexList( int index; /* Index into the list. */ Tcl_Obj *indexListCopy; + List *listRepPtr; /* * Determine whether argPtr designates a list or a single index. We have @@ -1114,7 +1263,8 @@ TclLindexList( * shimmering; see TIP#22 and TIP#33 for the details. */ - if (argPtr->typePtr != &tclListType + ListGetIntRep(argPtr, listRepPtr); + if ((listRepPtr == NULL) && TclGetIntForIndexM(NULL , argPtr, 0, &index) == TCL_OK) { /* * argPtr designates a single index. @@ -1145,13 +1295,12 @@ TclLindexList( return TclLindexFlat(interp, listPtr, 1, &argPtr); } - { - int indexCount = -1; /* Size of the array of list indices. */ - Tcl_Obj **indices = NULL; /* Array of list indices. */ + ListGetIntRep(indexListCopy, listRepPtr); - TclListObjGetElements(NULL, indexListCopy, &indexCount, &indices); - listPtr = TclLindexFlat(interp, listPtr, indexCount, indices); - } + assert(listRepPtr != NULL); + + listPtr = TclLindexFlat(interp, listPtr, listRepPtr->elemCount, + &listRepPtr->elements); Tcl_DecrRefCount(indexListCopy); return listPtr; } @@ -1159,20 +1308,25 @@ TclLindexList( /* *---------------------------------------------------------------------- * - * TclLindexFlat -- - * - * The core of the 'lindex' command, with all index - * arguments presented as a flat list. + * TclLindexFlat -- * - * Value + * This procedure is the core of the 'lindex' command, with all index + * arguments presented as a flat list. * - * A pointer to the object extracted, with its 'refCount' incremented, or - * NULL if an error occurred. Thus, the calling code will usually do - * something like: + * Results: + * Returns a pointer to the object extracted, or NULL if an error + * occurred. The returned object already includes one reference count for + * the pointer returned. * - * Tcl_SetObjResult(interp, result); - * Tcl_DecrRefCount(result); + * Side effects: + * None. * + * Notes: + * The reference count of the returned object includes one reference + * corresponding to the pointer returned. Thus, the calling code will + * usually do something like: + * Tcl_SetObjResult(interp, result); + * Tcl_DecrRefCount(result); * *---------------------------------------------------------------------- */ @@ -1248,16 +1402,24 @@ TclLindexFlat( * * TclLsetList -- * - * The core of [lset] when objc == 4. Objv[2] may be either a + * Core of the 'lset' command when objc == 4. Objv[2] may be either a * scalar index or a list of indices. + * It also handles 'lpop' when given a NULL value. * - * Implemented entirely as a wrapper around 'TclLindexFlat', as described - * for 'TclLindexList'. + * Results: + * Returns the new value of the list variable, or NULL if there was an + * error. The returned object includes one reference count for the + * pointer returned. * - * Value + * Side effects: + * None. * - * The new list, with the 'refCount' of 'valuPtr' incremented, or NULL if - * there was an error. + * Notes: + * This procedure is implemented entirely as a wrapper around + * TclLsetFlat. All it does is reconfigure the argument format into the + * form required by TclLsetFlat, while taking care to manage shimmering + * in such a way that we tend to keep the most useful intreps and/or + * avoid the most expensive conversions. * *---------------------------------------------------------------------- */ @@ -1267,13 +1429,14 @@ TclLsetList( Tcl_Interp *interp, /* Tcl interpreter. */ Tcl_Obj *listPtr, /* Pointer to the list being modified. */ Tcl_Obj *indexArgPtr, /* Index or index-list arg to 'lset'. */ - Tcl_Obj *valuePtr) /* Value arg to 'lset'. */ + Tcl_Obj *valuePtr) /* Value arg to 'lset' or NULL to 'lpop'. */ { int indexCount = 0; /* Number of indices in the index list. */ Tcl_Obj **indices = NULL; /* Vector of indices in the index list. */ Tcl_Obj *retValuePtr; /* Pointer to the list to be returned. */ int index; /* Current index in the list - discarded. */ Tcl_Obj *indexListCopy; + List *listRepPtr; /* * Determine whether the index arg designates a list or a single index. @@ -1281,7 +1444,8 @@ TclLsetList( * shimmering; see TIP #22 and #23 for details. */ - if (indexArgPtr->typePtr != &tclListType + ListGetIntRep(indexArgPtr, listRepPtr); + if (listRepPtr == NULL && TclGetIntForIndexM(NULL, indexArgPtr, 0, &index) == TCL_OK) { /* * indexArgPtr designates a single index. @@ -1318,40 +1482,38 @@ TclLsetList( * TclLsetFlat -- * * Core engine of the 'lset' command. - * - * Value - * - * The resulting list - * - * The 'refCount' of 'valuePtr' is incremented. If 'listPtr' was not - * duplicated, its 'refCount' is incremented. The reference count of - * an unduplicated object is therefore 2 (one for the returned pointer - * and one for the variable that holds it). The reference count of a - * duplicate object is 1, reflecting that result is the only active - * reference. The caller is expected to store the result in the - * variable and decrement its reference count. (INST_STORE_* does - * exactly this.) - * - * NULL - * - * An error occurred. If 'listPtr' was duplicated, the reference - * count on the duplicate is decremented so that it is 0, causing any - * memory allocated by this function to be freed. - * - * - * Effect - * - * On entry, the reference count of 'listPtr' does not reflect any - * references held on the stack. The first action of this function is to - * determine whether 'listPtr' is shared and to create a duplicate - * unshared copy if it is. The reference count of the duplicate is - * incremented. At this point, the reference count is 1 in either case so - * that the object is considered unshared. - * - * The unshared list is altered directly to produce the result. - * 'TclLsetFlat' maintains a linked list of 'Tcl_Obj' values whose string + * It also handles 'lpop' when given a NULL value. + * + * Results: + * Returns the new value of the list variable, or NULL if an error + * occurred. The returned object includes one reference count for the + * pointer returned. + * + * Side effects: + * On entry, the reference count of the variable value does not reflect + * any references held on the stack. The first action of this function is + * to determine whether the object is shared, and to duplicate it if it + * is. The reference count of the duplicate is incremented. At this + * point, the reference count will be 1 for either case, so that the + * object will appear to be unshared. + * + * If an error occurs, and the object has been duplicated, the reference + * count on the duplicate is decremented so that it is now 0: this + * dismisses any memory that was allocated by this function. + * + * If no error occurs, the reference count of the original object is + * incremented if the object has not been duplicated, and nothing is done + * to a reference count of the duplicate. Now the reference count of an + * unduplicated object is 2 (the returned pointer, plus the one stored in + * the variable). The reference count of a duplicate object is 1, + * reflecting that the returned pointer is the only active reference. The + * caller is expected to store the returned value back in the variable + * and decrement its reference count. (INST_STORE_* does exactly this.) + * + * Surgery is performed on the unshared list value to produce the result. + * TclLsetFlat maintains a linked list of Tcl_Obj's whose string * representations must be spoilt by threading via 'ptr2' of the - * two-pointer internal representation. On entry to 'TclLsetFlat', the + * two-pointer internal representation. On entry to TclLsetFlat, the * values of 'ptr2' are immaterial; on exit, the 'ptr2' field of any * Tcl_Obj that has been modified is set to NULL. * @@ -1365,18 +1527,22 @@ TclLsetFlat( int indexCount, /* Number of index args. */ Tcl_Obj *const indexArray[], /* Index args. */ - Tcl_Obj *valuePtr) /* Value arg to 'lset'. */ + Tcl_Obj *valuePtr) /* Value arg to 'lset' or NULL to 'lpop'. */ { int index, result, len; Tcl_Obj *subListPtr, *retValuePtr, *chainPtr; + Tcl_ObjIntRep *irPtr; /* * If there are no indices, simply return the new value. (Without * indices, [lset] is a synonym for [set]. + * [lpop] does not use this but protect for NULL valuePtr just in case. */ if (indexCount == 0) { - Tcl_IncrRefCount(valuePtr); + if (valuePtr != NULL) { + Tcl_IncrRefCount(valuePtr); + } return valuePtr; } @@ -1436,12 +1602,14 @@ TclLsetFlat( } indexArray++; - if (index < 0 || index > elemCount) { + if (index < 0 || index > elemCount + || (valuePtr == NULL && index >= elemCount)) { /* ...the index points outside the sublist. */ if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("list index out of range", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET", + Tcl_SetErrorCode(interp, "TCL", "OPERATION", + valuePtr == NULL ? "LPOP" : "LSET", "BADINDEX", NULL); } result = TCL_ERROR; @@ -1499,7 +1667,8 @@ TclLsetFlat( * them at that time. */ - parentList->internalRep.twoPtrValue.ptr2 = chainPtr; + irPtr = TclFetchIntRep(parentList, &tclListType); + irPtr->twoPtrValue.ptr2 = chainPtr; chainPtr = parentList; } } while (indexCount > 0); @@ -1513,22 +1682,32 @@ TclLsetFlat( while (chainPtr) { Tcl_Obj *objPtr = chainPtr; + List *listRepPtr; + + /* + * Clear away our intrep surgery mess. + */ + + irPtr = TclFetchIntRep(objPtr, &tclListType); + listRepPtr = irPtr->twoPtrValue.ptr1; + chainPtr = irPtr->twoPtrValue.ptr2; if (result == TCL_OK) { + /* * We're going to store valuePtr, so spoil string reps of all * containing lists. */ + listRepPtr->refCount++; + TclFreeIntRep(objPtr); + ListSetIntRep(objPtr, listRepPtr); + listRepPtr->refCount--; + TclInvalidateStringRep(objPtr); + } else { + irPtr->twoPtrValue.ptr2 = NULL; } - - /* - * Clear away our intrep surgery mess. - */ - - chainPtr = objPtr->internalRep.twoPtrValue.ptr2; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; } if (result != TCL_OK) { @@ -1551,12 +1730,14 @@ TclLsetFlat( len = -1; TclListObjLength(NULL, subListPtr, &len); - if (index == len) { + if (valuePtr == NULL) { + Tcl_ListObjReplace(NULL, subListPtr, index, 1, 0, NULL); + } else if (index == len) { Tcl_ListObjAppendElement(NULL, subListPtr, valuePtr); } else { TclListObjSetElement(NULL, subListPtr, index, valuePtr); + TclInvalidateStringRep(subListPtr); } - TclInvalidateStringRep(subListPtr); Tcl_IncrRefCount(retValuePtr); return retValuePtr; } @@ -1566,38 +1747,26 @@ TclLsetFlat( * * TclListObjSetElement -- * - * Set a single element of a list to a specified value. - * - * It is the caller's responsibility to invalidate the string - * representation of the 'listPtr'. - * - * Value - * - * TCL_OK - * - * Success. - * - * TCL_ERROR - * - * 'listPtr' does not refer to a list object and cannot be converted - * to one. An error message will be left in the interpreter result if - * interp is not NULL. - * - * TCL_ERROR - * - * An index designates an element outside the range [0..listLength-1], - * where 'listLength' is the count of elements in the list object - * designated by 'listPtr'. An error message is left in the - * interpreter result. + * Set a single element of a list to a specified value * - * Effect + * Results: + * The return value is normally TCL_OK. If listPtr does not refer to a + * list object and cannot be converted to one, TCL_ERROR is returned and + * an error message will be left in the interpreter result if interp is + * not NULL. Similarly, if index designates an element outside the range + * [0..listLength-1], where listLength is the count of elements in the + * list object designated by listPtr, TCL_ERROR is returned and an error + * message is left in the interpreter result. * - * If 'listPtr' designates a shared object, 'Tcl_Panic' is called. If - * 'listPtr' is not already of type 'tclListType', it is converted and the - * internal representation is unshared. The 'refCount' of the element at - * 'index' is decremented and replaced in the list with the 'valuePtr', - * whose 'refCount' in turn is incremented. + * Side effects: + * Tcl_Panic if listPtr designates a shared object. Otherwise, attempts + * to convert it to a list with a non-shared internal rep. Decrements the + * ref count of the object at the specified index within the list, + * replaces with the object designated by valuePtr, and increments the + * ref count of the replacement object. * + * It is the caller's responsibility to invalidate the string + * representation of the object. * *---------------------------------------------------------------------- */ @@ -1624,10 +1793,13 @@ TclListObjSetElement( if (Tcl_IsShared(listPtr)) { Tcl_Panic("%s called with shared object", "TclListObjSetElement"); } - if (listPtr->typePtr != &tclListType) { - int result; - if (listPtr->bytes == tclEmptyStringRep) { + ListGetIntRep(listPtr, listRepPtr); + if (listRepPtr == NULL) { + int result, length; + + (void) Tcl_GetStringFromObj(listPtr, &length); + if (length == 0) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("list index out of range", -1)); @@ -1640,9 +1812,9 @@ TclListObjSetElement( if (result != TCL_OK) { return result; } + ListGetIntRep(listPtr, listRepPtr); } - listRepPtr = ListRepPtr(listPtr); elemCount = listRepPtr->elemCount; /* @@ -1685,7 +1857,8 @@ TclListObjSetElement( listRepPtr->refCount--; - listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr = newPtr; + listRepPtr = newPtr; + ListResetIntRep(listPtr, listRepPtr); } elemPtrs = &listRepPtr->elements; @@ -1707,6 +1880,18 @@ TclListObjSetElement( elemPtrs[index] = valuePtr; + /* + * Invalidate outdated intreps. + */ + + ListGetIntRep(listPtr, listRepPtr); + listRepPtr->refCount++; + TclFreeIntRep(listPtr); + ListSetIntRep(listPtr, listRepPtr); + listRepPtr->refCount--; + + TclInvalidateStringRep(listPtr); + return TCL_OK; } @@ -1715,14 +1900,15 @@ TclListObjSetElement( * * FreeListInternalRep -- * - * Deallocate the storage associated with the internal representation of a - * a list object. + * Deallocate the storage associated with a list object's internal + * representation. * - * Effect + * Results: + * None. * - * The storage for the internal 'List' pointer of 'listPtr' is freed, the - * 'internalRep.twoPtrValue.ptr1' of 'listPtr' is set to NULL, and the 'refCount' - * of each element of the list is decremented. + * Side effects: + * Frees listPtr's List* internal representation, if no longer shared. + * May decrement the ref counts of element objects, which may free them. * *---------------------------------------------------------------------- */ @@ -1731,7 +1917,10 @@ static void FreeListInternalRep( Tcl_Obj *listPtr) /* List object with internal rep to free. */ { - List *listRepPtr = ListRepPtr(listPtr); + List *listRepPtr; + + ListGetIntRep(listPtr, listRepPtr); + assert(listRepPtr != NULL); if (listRepPtr->refCount-- <= 1) { Tcl_Obj **elemPtrs = &listRepPtr->elements; @@ -1742,8 +1931,6 @@ FreeListInternalRep( } ckfree(listRepPtr); } - - listPtr->typePtr = NULL; } /* @@ -1751,12 +1938,14 @@ FreeListInternalRep( * * DupListInternalRep -- * - * Initialize the internal representation of a list 'Tcl_Obj' to share the + * Initialize the internal representation of a list Tcl_Obj to share the * internal representation of an existing list object. * - * Effect + * Results: + * None. * - * The 'refCount' of the List internal rep is incremented. + * Side effects: + * The reference count of the List internal rep is incremented. * *---------------------------------------------------------------------- */ @@ -1766,8 +1955,10 @@ DupListInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - List *listRepPtr = ListRepPtr(srcPtr); + List *listRepPtr; + ListGetIntRep(srcPtr, listRepPtr); + assert(listRepPtr != NULL); ListSetIntRep(copyPtr, listRepPtr); } @@ -1776,20 +1967,16 @@ DupListInternalRep( * * SetListFromAny -- * - * Convert any object to a list. - * - * Value + * Attempt to generate a list internal form for the Tcl object "objPtr". * - * TCL_OK - * - * Success. The internal representation of 'objPtr' is set, and the type - * of 'objPtr' is 'tclListType'. - * - * TCL_ERROR - * - * An error occured during conversion. An error message is left in the - * interpreter's result if 'interp' is not NULL. + * Results: + * The return value is TCL_OK or TCL_ERROR. If an error occurs during + * conversion, an error message is left in the interpreter's result + * unless "interp" is NULL. * + * Side effects: + * If no error occurs, a list is stored as "objPtr"s internal + * representation. * *---------------------------------------------------------------------- */ @@ -1810,7 +1997,7 @@ SetListFromAny( * describe duplicate keys). */ - if (objPtr->typePtr == &tclDictType && !objPtr->bytes) { + if (!TclHasStringRep(objPtr) && TclHasIntRep(objPtr, &tclDictType)) { Tcl_Obj *keyPtr, *valuePtr; Tcl_DictSearch search; int done, size; @@ -1868,28 +2055,37 @@ SetListFromAny( while (nextElem < limit) { const char *elemStart; + char *check; int elemSize, literal; if (TCL_OK != TclFindElement(interp, nextElem, limit - nextElem, &elemStart, &nextElem, &elemSize, &literal)) { + fail: while (--elemPtrs >= &listRepPtr->elements) { Tcl_DecrRefCount(*elemPtrs); } - ckfree((char *) listRepPtr); + ckfree(listRepPtr); return TCL_ERROR; } if (elemStart == limit) { break; } - /* TODO: replace panic with error on alloc failure? */ - if (literal) { - TclNewStringObj(*elemPtrs, elemStart, elemSize); - } else { - TclNewObj(*elemPtrs); - (*elemPtrs)->bytes = ckalloc((unsigned) elemSize + 1); - (*elemPtrs)->length = TclCopyAndCollapse(elemSize, elemStart, - (*elemPtrs)->bytes); + TclNewObj(*elemPtrs); + TclInvalidateStringRep(*elemPtrs); + check = Tcl_InitStringRep(*elemPtrs, literal ? elemStart : NULL, + elemSize); + if (elemSize && check == NULL) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "cannot construct list, out of memory", -1)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + goto fail; + } + if (!literal) { + Tcl_InitStringRep(*elemPtrs, NULL, + TclCopyAndCollapse(elemSize, elemStart, check)); } Tcl_IncrRefCount(*elemPtrs++);/* Since list now holds ref to it. */ @@ -1899,12 +2095,11 @@ SetListFromAny( } /* - * Free the old internalRep before setting the new one. We do this as late + * Store the new internalRep. We do this as late * as possible to allow the conversion code, in particular - * Tcl_GetStringFromObj, to use that old internalRep. + * Tcl_GetStringFromObj, to use the old internalRep. */ - TclFreeIntRep(objPtr); ListSetIntRep(objPtr, listRepPtr); return TCL_OK; } @@ -1914,16 +2109,18 @@ SetListFromAny( * * UpdateStringOfList -- * - * Update the string representation for a list object. - * - * Any previously-exising string representation is not invalidated, so - * storage is lost if this has not been taken care of. + * Update the string representation for a list object. Note: This + * function does not invalidate an existing old string rep so storage + * will be lost if this has not already been done. * - * Effect + * Results: + * None. * - * The string representation of 'listPtr' is set to the resulting string. - * This string will be empty if the list has no elements. It is assumed - * that the list internal representation is not NULL. + * Side effects: + * The object's string is set to a valid string that results from the + * list-to-string conversion. This string will be empty if the list has + * no elements. The list internal representation should not be NULL and + * we assume it is not NULL. * *---------------------------------------------------------------------- */ @@ -1934,12 +2131,17 @@ UpdateStringOfList( { # define LOCAL_SIZE 64 char localFlags[LOCAL_SIZE], *flagPtr = NULL; - List *listRepPtr = ListRepPtr(listPtr); - int numElems = listRepPtr->elemCount; - int i, length, bytesNeeded = 0; - const char *elem; + int numElems, i, length, bytesNeeded = 0; + const char *elem, *start; char *dst; Tcl_Obj **elemPtrs; + List *listRepPtr; + + ListGetIntRep(listPtr, listRepPtr); + + assert(listRepPtr != NULL); + + numElems = listRepPtr->elemCount; /* * Mark the list as being canonical; although it will now have a string @@ -1954,8 +2156,7 @@ UpdateStringOfList( */ if (numElems == 0) { - listPtr->bytes = tclEmptyStringRep; - listPtr->length = 0; + Tcl_InitStringRep(listPtr, NULL, 0); return; } @@ -1984,39 +2185,23 @@ UpdateStringOfList( if (bytesNeeded > INT_MAX - numElems + 1) { Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } - bytesNeeded += numElems; + bytesNeeded += numElems - 1; /* * Pass 2: copy into string rep buffer. */ - /* - * We used to set the string length here, relying on a presumed - * guarantee that the number of bytes TclScanElement() calls reported - * to be needed was a precise count and not an over-estimate, so long - * as the same flag values were passed to TclConvertElement(). - * - * Then we saw [35a8f1c04a], where a bug in TclScanElement() caused - * that guarantee to fail. Rather than trust there are no more bugs, - * we set the length after the loop based on what was actually written, - * an not on what was predicted. - * - listPtr->length = bytesNeeded - 1; - * - */ - - listPtr->bytes = ckalloc(bytesNeeded); - dst = listPtr->bytes; + start = dst = Tcl_InitStringRep(listPtr, NULL, bytesNeeded); + TclOOM(dst, bytesNeeded); for (i = 0; i < numElems; i++) { flagPtr[i] |= (i ? TCL_DONT_QUOTE_HASH : 0); elem = TclGetStringFromObj(elemPtrs[i], &length); dst += TclConvertElement(elem, length, dst, flagPtr[i]); *dst++ = ' '; } - dst[-1] = '\0'; - /* Here is the safe setting of the string length. */ - listPtr->length = dst - 1 - listPtr->bytes; + /* Set the string length to what was actually written, the safe choice */ + (void) Tcl_InitStringRep(listPtr, NULL, dst - 1 - start); if (flagPtr != localFlags) { ckfree(flagPtr); diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index 16185e6..83eee07 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -104,7 +104,7 @@ TclDeleteLiteralTable( { LiteralEntry *entryPtr, *nextPtr; Tcl_Obj *objPtr; - int i; + size_t i; /* * Release remaining literals in the table. Note that releasing a literal @@ -174,7 +174,7 @@ TclDeleteLiteralTable( Tcl_Obj * TclCreateLiteral( Interp *iPtr, - char *bytes, /* The start of the string. Note that this is + const 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 @@ -186,7 +186,7 @@ TclCreateLiteral( { LiteralTable *globalTablePtr = &iPtr->literalTable; LiteralEntry *globalPtr; - int globalHash; + unsigned int globalHash; Tcl_Obj *objPtr; /* @@ -209,11 +209,11 @@ TclCreateLiteral( */ int objLength; - char *objBytes = TclGetStringFromObj(objPtr, &objLength); + const char *objBytes = TclGetStringFromObj(objPtr, &objLength); if ((objLength == length) && ((length == 0) || ((objBytes[0] == bytes[0]) - && (memcmp(objBytes, bytes, (unsigned) length) == 0)))) { + && (memcmp(objBytes, bytes, length) == 0)))) { /* * A literal was found: return it */ @@ -227,7 +227,9 @@ TclCreateLiteral( if (flags & LITERAL_ON_HEAP) { ckfree(bytes); } - globalPtr->refCount++; + if (globalPtr->refCount != (unsigned) -1) { + globalPtr->refCount++; + } return objPtr; } } @@ -240,20 +242,22 @@ TclCreateLiteral( } /* - * The literal is new to the interpreter. Add it to the global literal - * table. + * The literal is new to the interpreter. */ TclNewObj(objPtr); if ((flags & LITERAL_ON_HEAP)) { - objPtr->bytes = bytes; + objPtr->bytes = (char *) 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) { @@ -262,6 +266,9 @@ 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", @@ -291,7 +298,8 @@ TclCreateLiteral( TclVerifyGlobalLiteralTable(iPtr); { LiteralEntry *entryPtr; - int found, i; + int found; + size_t i; found = 0; for (i=0 ; i<globalTablePtr->numBuckets ; i++) { @@ -381,7 +389,7 @@ int TclRegisterLiteral( void *ePtr, /* Points to the CompileEnv in whose object * array an object is found or created. */ - register char *bytes, /* Points to string for which to find or + register const 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 @@ -399,7 +407,8 @@ TclRegisterLiteral( LiteralEntry *globalPtr, *localPtr; Tcl_Obj *objPtr; unsigned hash; - int localHash, objIndex, new; + unsigned int localHash; + int objIndex, isNew; Namespace *nsPtr; if (length < 0) { @@ -418,7 +427,7 @@ TclRegisterLiteral( objPtr = localPtr->objPtr; if ((objPtr->length == length) && ((length == 0) || ((objPtr->bytes[0] == bytes[0]) - && (memcmp(objPtr->bytes, bytes, (unsigned) length) == 0)))) { + && (memcmp(objPtr->bytes, bytes, length) == 0)))) { if ((flags & LITERAL_ON_HEAP)) { ckfree(bytes); } @@ -453,12 +462,12 @@ TclRegisterLiteral( */ globalPtr = NULL; - objPtr = TclCreateLiteral(iPtr, bytes, length, hash, &new, nsPtr, flags, + objPtr = TclCreateLiteral(iPtr, bytes, length, hash, &isNew, nsPtr, flags, &globalPtr); objIndex = AddLocalLiteralEntry(envPtr, objPtr, localHash); #ifdef TCL_COMPILE_DEBUG - if (globalPtr != NULL && globalPtr->refCount < 1) { + if (globalPtr != NULL && globalPtr->refCount + 1 < 2) { Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %d", "TclRegisterLiteral", (length>60? 60 : length), bytes, globalPtr->refCount); @@ -543,7 +552,8 @@ TclHideLiteral( { LiteralEntry **nextPtrPtr, *entryPtr, *lPtr; LiteralTable *localTablePtr = &envPtr->localLitTable; - int localHash, length; + unsigned int localHash; + int length; const char *bytes; Tcl_Obj *newObjPtr; @@ -562,7 +572,7 @@ TclHideLiteral( lPtr->objPtr = newObjPtr; bytes = TclGetStringFromObj(newObjPtr, &length); - localHash = (HashString(bytes, length) & localTablePtr->mask); + localHash = HashString(bytes, length) & localTablePtr->mask; nextPtrPtr = &localTablePtr->buckets[localHash]; for (entryPtr=*nextPtrPtr ; entryPtr!=NULL ; entryPtr=*nextPtrPtr) { @@ -618,7 +628,7 @@ TclAddLiteralObj( lPtr = &envPtr->literalArrayPtr[objIndex]; lPtr->objPtr = objPtr; Tcl_IncrRefCount(objPtr); - lPtr->refCount = -1; /* i.e., unused */ + lPtr->refCount = (unsigned) -1; /* i.e., unused */ lPtr->nextPtr = NULL; if (litPtrPtr) { @@ -680,7 +690,8 @@ AddLocalLiteralEntry( TclVerifyLocalLiteralTable(envPtr); { char *bytes; - int length, found, i; + int length, found; + size_t i; found = 0; for (i=0 ; i<localTablePtr->numBuckets ; i++) { @@ -693,7 +704,7 @@ AddLocalLiteralEntry( } if (!found) { - bytes = Tcl_GetStringFromObj(objPtr, &length); + bytes = TclGetStringFromObj(objPtr, &length); Tcl_Panic("%s: literal \"%.*s\" wasn't found locally", "AddLocalLiteralEntry", (length>60? 60 : length), bytes); } @@ -734,15 +745,15 @@ ExpandLocalLiteralArray( */ LiteralTable *localTablePtr = &envPtr->localLitTable; - int currElems = envPtr->literalArrayNext; + size_t currElems = envPtr->literalArrayNext; size_t currBytes = (currElems * sizeof(LiteralEntry)); LiteralEntry *currArrayPtr = envPtr->literalArrayPtr; LiteralEntry *newArrayPtr; - int i; - unsigned int newSize = (currBytes <= UINT_MAX / 2) ? 2*currBytes : UINT_MAX; + size_t i; + size_t newSize = (currBytes <= UINT_MAX / 2) ? 2*currBytes : UINT_MAX; if (currBytes == newSize) { - Tcl_Panic("max size of Tcl literal array (%d literals) exceeded", + Tcl_Panic("max size of Tcl literal array (%" TCL_Z_MODIFIER "u literals) exceeded", currElems); } @@ -815,7 +826,8 @@ TclReleaseLiteral( LiteralTable *globalTablePtr; register LiteralEntry *entryPtr, *prevPtr; const char *bytes; - int length, index; + int length; + unsigned int index; if (iPtr == NULL) { goto done; @@ -834,15 +846,13 @@ TclReleaseLiteral( for (prevPtr=NULL, entryPtr=globalTablePtr->buckets[index]; entryPtr!=NULL ; prevPtr=entryPtr, entryPtr=entryPtr->nextPtr) { if (entryPtr->objPtr == objPtr) { - entryPtr->refCount--; - /* * If the literal is no longer being used by any ByteCode, delete * the entry then remove the reference corresponding to the global * literal table entry (decrement the ref count of the object). */ - if (entryPtr->refCount == 0) { + if ((entryPtr->refCount != (unsigned)-1) && (entryPtr->refCount-- <= 1)) { if (prevPtr == NULL) { globalTablePtr->buckets[index] = entryPtr->nextPtr; } else { @@ -960,8 +970,8 @@ RebuildLiteralTable( register LiteralEntry *entryPtr; LiteralEntry **bucketPtr; const char *bytes; - unsigned int oldSize; - int count, index, length; + unsigned int oldSize, index; + int count, length; oldSize = tablePtr->numBuckets; oldBuckets = tablePtr->buckets; @@ -1047,11 +1057,11 @@ TclInvalidateCmdLiteral( * invalidate a cmd literal. */ { Interp *iPtr = (Interp *) interp; - Tcl_Obj *literalObjPtr = TclCreateLiteral(iPtr, (char *) name, + Tcl_Obj *literalObjPtr = TclCreateLiteral(iPtr, name, strlen(name), -1, NULL, nsPtr, 0, NULL); if (literalObjPtr != NULL) { - if (literalObjPtr->typePtr == &tclCmdNameType) { + if (TclHasIntRep(literalObjPtr, &tclCmdNameType)) { TclFreeIntRep(literalObjPtr); } /* Balance the refcount effects of TclCreateLiteral() above */ @@ -1084,7 +1094,9 @@ TclLiteralStats( LiteralTable *tablePtr) /* Table for which to produce stats. */ { #define NUM_COUNTERS 10 - int count[NUM_COUNTERS], overflow, i, j; + size_t count[NUM_COUNTERS]; + int overflow; + size_t i, j; double average, tmp; register LiteralEntry *entryPtr; char *result, *p; @@ -1123,7 +1135,7 @@ TclLiteralStats( tablePtr->numEntries, tablePtr->numBuckets); p = result + strlen(result); for (i=0 ; i<NUM_COUNTERS ; i++) { - sprintf(p, "number of buckets with %d entries: %d\n", + sprintf(p, "number of buckets with %" TCL_Z_MODIFIER "u entries: %" TCL_Z_MODIFIER "u\n", i, count[i]); p += strlen(p); } @@ -1160,17 +1172,17 @@ TclVerifyLocalLiteralTable( register LiteralTable *localTablePtr = &envPtr->localLitTable; register LiteralEntry *localPtr; char *bytes; - register int i; - int length, count; + size_t i, count; + int length; count = 0; for (i=0 ; i<localTablePtr->numBuckets ; i++) { for (localPtr=localTablePtr->buckets[i] ; localPtr!=NULL; localPtr=localPtr->nextPtr) { count++; - if (localPtr->refCount != -1) { - bytes = Tcl_GetStringFromObj(localPtr->objPtr, &length); - Tcl_Panic("%s: local literal \"%.*s\" had bad refCount %d", + if (localPtr->refCount != (unsigned)-1) { + bytes = TclGetStringFromObj(localPtr->objPtr, &length); + Tcl_Panic("%s: local literal \"%.*s\" had bad refCount %u", "TclVerifyLocalLiteralTable", (length>60? 60 : length), bytes, localPtr->refCount); } @@ -1181,7 +1193,7 @@ TclVerifyLocalLiteralTable( } } if (count != localTablePtr->numEntries) { - Tcl_Panic("%s: local literal table had %d entries, should be %d", + Tcl_Panic("%s: local literal table had %" TCL_Z_MODIFIER "u entries, should be %u", "TclVerifyLocalLiteralTable", count, localTablePtr->numEntries); } @@ -1211,16 +1223,16 @@ TclVerifyGlobalLiteralTable( register LiteralTable *globalTablePtr = &iPtr->literalTable; register LiteralEntry *globalPtr; char *bytes; - register int i; - int length, count; + size_t i, count; + int length; count = 0; for (i=0 ; i<globalTablePtr->numBuckets ; i++) { for (globalPtr=globalTablePtr->buckets[i] ; globalPtr!=NULL; globalPtr=globalPtr->nextPtr) { count++; - if (globalPtr->refCount < 1) { - bytes = Tcl_GetStringFromObj(globalPtr->objPtr, &length); + if (globalPtr->refCount + 1 < 2) { + bytes = TclGetStringFromObj(globalPtr->objPtr, &length); Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %d", "TclVerifyGlobalLiteralTable", (length>60? 60 : length), bytes, globalPtr->refCount); @@ -1232,7 +1244,7 @@ TclVerifyGlobalLiteralTable( } } if (count != globalTablePtr->numEntries) { - Tcl_Panic("%s: global literal table had %d entries, should be %d", + Tcl_Panic("%s: global literal table had %" TCL_Z_MODIFIER "u entries, should be %u", "TclVerifyGlobalLiteralTable", count, globalTablePtr->numEntries); } diff --git a/generic/tclLoad.c b/generic/tclLoad.c index f1bd248..add4f6f 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -405,7 +405,7 @@ Tcl_LoadObjCmd( len = strlen(fullFileName) + 1; pkgPtr->fileName = ckalloc(len); memcpy(pkgPtr->fileName, fullFileName, len); - len = (unsigned) Tcl_DStringLength(&pkgName) + 1; + len = Tcl_DStringLength(&pkgName) + 1; pkgPtr->packageName = ckalloc(len); memcpy(pkgPtr->packageName, Tcl_DStringValue(&pkgName), len); pkgPtr->loadHandle = loadHandle; @@ -470,6 +470,19 @@ Tcl_LoadObjCmd( */ if (code != TCL_OK) { +#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 + Interp *iPtr = (Interp *) target; + if (iPtr->result && *(iPtr->result) && !iPtr->freeProc) { + /* + * A call to Tcl_InitStubs() determined the caller extension and + * this interp are incompatible in their stubs mechanisms, and + * recorded the error in the oldest legacy place we have to do so. + */ + Tcl_SetObjResult(target, Tcl_NewStringObj(iPtr->result, -1)); + iPtr->result = &tclEmptyString; + iPtr->freeProc = NULL; + } +#endif /* defined(TCL_NO_DEPRECATED) */ Tcl_TransferResult(target, code, interp); goto done; } @@ -998,7 +1011,7 @@ Tcl_StaticPackage( } /* - * Package isn't loade in the current interp yet. Mark it as now being + * Package isn't loaded in the current interp yet. Mark it as now being * loaded. */ @@ -1012,10 +1025,10 @@ Tcl_StaticPackage( /* *---------------------------------------------------------------------- * - * TclGetLoadedPackages -- + * TclGetLoadedPackages, TclGetLoadedPackagesEx -- * * This function returns information about all of the files that are - * loaded (either in a particular intepreter, or for all interpreters). + * loaded (either in a particular interpreter, or for all interpreters). * * Results: * The return value is a standard Tcl completion code. If successful, a @@ -1039,16 +1052,27 @@ TclGetLoadedPackages( * otherwise, just return info about this * interpreter. */ { + return TclGetLoadedPackagesEx(interp, targetName, NULL); +} + +int +TclGetLoadedPackagesEx( + Tcl_Interp *interp, /* Interpreter in which to return information + * or error message. */ + const char *targetName, /* Name of target interpreter or NULL. If + * NULL, return info about all interps; + * otherwise, just return info about this + * interpreter. */ + const char *packageName) /* Package name or NULL. If NULL, return info + * for all packages. + */ +{ Tcl_Interp *target; LoadedPackage *pkgPtr; InterpPackage *ipPtr; Tcl_Obj *resultObj, *pkgDesc[2]; if (targetName == NULL) { - /* - * Return information about all of the available packages. - */ - resultObj = Tcl_NewObj(); Tcl_MutexLock(&packageMutex); for (pkgPtr = firstPackagePtr; pkgPtr != NULL; @@ -1063,16 +1087,38 @@ TclGetLoadedPackages( return TCL_OK; } - /* - * Return information about only the packages that are loaded in a given - * interpreter. - */ - target = Tcl_GetSlave(interp, targetName); if (target == NULL) { return TCL_ERROR; } ipPtr = Tcl_GetAssocData(target, "tclLoad", NULL); + + /* + * Return information about all of the available packages. + */ + if (packageName) { + resultObj = NULL; + + for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { + pkgPtr = ipPtr->pkgPtr; + + if (!strcmp(packageName, pkgPtr->packageName)) { + resultObj = Tcl_NewStringObj(pkgPtr->fileName, -1); + break; + } + } + + if (resultObj) { + Tcl_SetObjResult(interp, resultObj); + } + return TCL_OK; + } + + /* + * Return information about only the packages that are loaded in a given + * interpreter. + */ + resultObj = Tcl_NewObj(); for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) { pkgPtr = ipPtr->pkgPtr; diff --git a/generic/tclMain.c b/generic/tclMain.c index 927de7e..4b8fa8c 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -59,20 +59,27 @@ * encoding to UTF-8). */ -#ifdef UNICODE +#if defined(UNICODE) && (TCL_UTF_MAX <= 4) # define NewNativeObj Tcl_NewUnicodeObj -#else /* !UNICODE */ +#else /* !UNICODE || (TCL_UTF_MAX > 4) */ static inline Tcl_Obj * NewNativeObj( - char *string, + TCHAR *string, int length) { Tcl_DString ds; - Tcl_ExternalToUtfDString(NULL, string, length, &ds); +#ifdef UNICODE + if (length > 0) { + length *= sizeof(WCHAR); + } + Tcl_WinTCharToUtf(string, length, &ds); +#else + Tcl_ExternalToUtfDString(NULL, (char *) string, length, &ds); +#endif return TclDStringToObj(&ds); } -#endif /* !UNICODE */ +#endif /* !UNICODE || (TCL_UTF_MAX > 4) */ /* * Declarations for various library functions and variables (don't want to @@ -112,7 +119,7 @@ typedef enum { PROMPT_CONTINUE /* Print prompt for command continuation */ } PromptType; -typedef struct InteractiveState { +typedef struct { Tcl_Channel input; /* The standard input channel from which lines * are read. */ int tty; /* Non-zero means standard input is a @@ -246,7 +253,7 @@ Tcl_SourceRCFile( const char *fileName; Tcl_Channel chan; - fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY); + fileName = Tcl_GetVar2(interp, "tcl_rcFileName", NULL, TCL_GLOBAL_ONLY); if (fileName != NULL) { Tcl_Channel c; const char *fullName; @@ -283,7 +290,7 @@ Tcl_SourceRCFile( /*---------------------------------------------------------------------- * - * Tcl_Main, Tcl_MainEx -- + * Tcl_MainEx -- * * Main program for tclsh and most other Tcl-based applications. * @@ -532,7 +539,7 @@ Tcl_MainEx( * error messages troubles deeper in, so lop it back off. */ - Tcl_GetStringFromObj(is.commandPtr, &length); + TclGetStringFromObj(is.commandPtr, &length); Tcl_SetObjLength(is.commandPtr, --length); code = Tcl_RecordAndEvalObj(interp, is.commandPtr, TCL_EVAL_GLOBAL); @@ -549,7 +556,7 @@ Tcl_MainEx( } else if (is.tty) { resultPtr = Tcl_GetObjResult(interp); Tcl_IncrRefCount(resultPtr); - Tcl_GetStringFromObj(resultPtr, &length); + TclGetStringFromObj(resultPtr, &length); chan = Tcl_GetStdChannel(TCL_STDOUT); if ((length > 0) && chan) { Tcl_WriteObj(chan, resultPtr); @@ -634,21 +641,6 @@ 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 @@ -808,7 +800,7 @@ StdinProc( goto prompt; } isPtr->prompt = PROMPT_START; - Tcl_GetStringFromObj(commandPtr, &length); + TclGetStringFromObj(commandPtr, &length); Tcl_SetObjLength(commandPtr, --length); /* @@ -839,7 +831,7 @@ StdinProc( chan = Tcl_GetStdChannel(TCL_STDOUT); Tcl_IncrRefCount(resultPtr); - Tcl_GetStringFromObj(resultPtr, &length); + TclGetStringFromObj(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 cf4ecc4..bbe357d 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -25,14 +25,15 @@ #include "tclInt.h" #include "tclCompile.h" /* for TclLogCommandInfo visibility */ +#include <assert.h> /* * Thread-local storage used to avoid having a global lock on data that is not * limited to a single interpreter. */ -typedef struct ThreadSpecificData { - long numNsCreated; /* Count of the number of namespaces created +typedef struct { + unsigned 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 +60,7 @@ typedef struct ResolvedNsName { * the name was resolved. NULL if the name is * fully qualified and thus the resolution * does not depend on the context. */ - int refCount; /* Reference count: 1 for each nsName object + size_t refCount; /* Reference count: 1 for each nsName object * that has a pointer to this ResolvedNsName * structure as its internal rep. This * structure can be freed when refCount @@ -89,8 +90,6 @@ static char * EstablishErrorInfoTraces(ClientData clientData, static void FreeNsNameInternalRep(Tcl_Obj *objPtr); static int GetNamespaceFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Namespace **nsPtrPtr); -static int InvokeImportedCmd(ClientData clientData, - Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static int InvokeImportedNRCmd(ClientData clientData, Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]); static int NamespaceChildrenCmd(ClientData dummy, @@ -154,6 +153,22 @@ static const Tcl_ObjType nsNameType = { SetNsNameFromAny /* setFromAnyProc */ }; +#define NsNameSetIntRep(objPtr, nnPtr) \ + do { \ + Tcl_ObjIntRep ir; \ + (nnPtr)->refCount++; \ + ir.twoPtrValue.ptr1 = (nnPtr); \ + ir.twoPtrValue.ptr2 = NULL; \ + Tcl_StoreIntRep((objPtr), &nsNameType, &ir); \ + } while (0) + +#define NsNameGetIntRep(objPtr, nnPtr) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = TclFetchIntRep((objPtr), &nsNameType); \ + (nnPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + } while (0) + /* * Array of values describing how to implement each standard subcommand of the * "namespace" command. @@ -402,7 +417,7 @@ Tcl_PopCallFrame( } if (framePtr->numCompiledLocals > 0) { TclDeleteCompiledLocalVars(iPtr, framePtr); - if (--framePtr->localCachePtr->refCount == 0) { + if (framePtr->localCachePtr->refCount-- <= 1) { TclFreeLocalCache(interp, framePtr->localCachePtr); } framePtr->localCachePtr = NULL; @@ -861,7 +876,7 @@ Tcl_CreateNamespace( name = Tcl_DStringValue(namePtr); nameLen = Tcl_DStringLength(namePtr); nsPtr->fullName = ckalloc(nameLen + 1); - memcpy(nsPtr->fullName, name, (unsigned) nameLen + 1); + memcpy(nsPtr->fullName, name, nameLen + 1); Tcl_DStringFree(&buffer1); Tcl_DStringFree(&buffer2); @@ -1330,8 +1345,7 @@ void TclNsDecrRefCount( Namespace *nsPtr) { - nsPtr->refCount--; - if ((nsPtr->refCount == 0) && (nsPtr->flags & NS_DEAD)) { + if ((nsPtr->refCount-- <= 1) && (nsPtr->flags & NS_DEAD)) { NamespaceFree(nsPtr); } } @@ -1455,7 +1469,7 @@ Tcl_Export( len = strlen(pattern); patternCpy = ckalloc(len + 1); - memcpy(patternCpy, pattern, (unsigned) len + 1); + memcpy(patternCpy, pattern, len + 1); nsPtr->exportArrayPtr[nsPtr->numExportPatterns] = patternCpy; nsPtr->numExportPatterns++; @@ -1774,7 +1788,7 @@ DoImport( dataPtr = ckalloc(sizeof(ImportedCmdData)); importedCmd = Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), - InvokeImportedCmd, InvokeImportedNRCmd, dataPtr, + TclInvokeImportedCmd, InvokeImportedNRCmd, dataPtr, DeleteImportedCmd); dataPtr->realCmdPtr = cmdPtr; dataPtr->selfPtr = (Command *) importedCmd; @@ -1995,7 +2009,7 @@ TclGetOriginalCommand( /* *---------------------------------------------------------------------- * - * InvokeImportedCmd -- + * TclInvokeImportedCmd -- * * Invoked by Tcl whenever the user calls an imported command that was * created by Tcl_Import. Finds the "real" command (in another @@ -2026,8 +2040,8 @@ InvokeImportedNRCmd( return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NOERR, realCmdPtr); } -static int -InvokeImportedCmd( +int +TclInvokeImportedCmd( ClientData clientData, /* Points to the imported command's * ImportedCmdData structure. */ Tcl_Interp *interp, /* Current interpreter. */ @@ -2908,26 +2922,29 @@ GetNamespaceFromObj( Tcl_Namespace **nsPtrPtr) /* Result namespace pointer goes here. */ { ResolvedNsName *resNamePtr; - Namespace *nsPtr, *refNsPtr; - if (objPtr->typePtr == &nsNameType) { + NsNameGetIntRep(objPtr, resNamePtr); + if (resNamePtr) { + Namespace *nsPtr, *refNsPtr; + /* * Check that the ResolvedNsName is still valid; avoid letting the ref * cross interps. */ - resNamePtr = objPtr->internalRep.twoPtrValue.ptr1; nsPtr = resNamePtr->nsPtr; refNsPtr = resNamePtr->refNsPtr; - if (!(nsPtr->flags & NS_DYING) && (interp == nsPtr->interp) && - (!refNsPtr || ((interp == refNsPtr->interp) && - (refNsPtr== (Namespace *) Tcl_GetCurrentNamespace(interp))))){ + if (!(nsPtr->flags & NS_DYING) && (interp == nsPtr->interp) + && (!refNsPtr || (refNsPtr == + (Namespace *) TclGetCurrentNamespace(interp)))) { *nsPtrPtr = (Tcl_Namespace *) nsPtr; return TCL_OK; } + Tcl_StoreIntRep(objPtr, &nsNameType, NULL); } if (SetNsNameFromAny(interp, objPtr) == TCL_OK) { - resNamePtr = objPtr->internalRep.twoPtrValue.ptr1; + NsNameGetIntRep(objPtr, resNamePtr); + assert(resNamePtr != NULL); *nsPtrPtr = (Tcl_Namespace *) resNamePtr->nsPtr; return TCL_OK; } @@ -4697,15 +4714,17 @@ FreeNsNameInternalRep( register Tcl_Obj *objPtr) /* nsName object with internal representation * to free. */ { - ResolvedNsName *resNamePtr = objPtr->internalRep.twoPtrValue.ptr1; + ResolvedNsName *resNamePtr; + + NsNameGetIntRep(objPtr, resNamePtr); + assert(resNamePtr != NULL); /* * Decrement the reference count of the namespace. If there are no more * references, free it up. */ - resNamePtr->refCount--; - if (resNamePtr->refCount == 0) { + if (resNamePtr->refCount-- <= 1) { /* * Decrement the reference count for the cached namespace. If the * namespace is dead, and there are no more references to it, free @@ -4715,7 +4734,6 @@ FreeNsNameInternalRep( TclNsDecrRefCount(resNamePtr->nsPtr); ckfree(resNamePtr); } - objPtr->typePtr = NULL; } /* @@ -4742,11 +4760,11 @@ DupNsNameInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ register Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - ResolvedNsName *resNamePtr = srcPtr->internalRep.twoPtrValue.ptr1; + ResolvedNsName *resNamePtr; - copyPtr->internalRep.twoPtrValue.ptr1 = resNamePtr; - resNamePtr->refCount++; - copyPtr->typePtr = &nsNameType; + NsNameGetIntRep(srcPtr, resNamePtr); + assert(resNamePtr != NULL); + NsNameSetIntRep(copyPtr, resNamePtr); } /* @@ -4791,36 +4809,25 @@ SetNsNameFromAny( TclGetNamespaceForQualName(interp, name, NULL, TCL_FIND_ONLY_NS, &nsPtr, &dummy1Ptr, &dummy2Ptr, &dummy); + if ((nsPtr == NULL) || (nsPtr->flags & NS_DYING)) { + return TCL_ERROR; + } + /* * If we found a namespace, then create a new ResolvedNsName structure * that holds a reference to it. */ - if ((nsPtr == NULL) || (nsPtr->flags & NS_DYING)) { - /* - * Our failed lookup proves any previously cached nsName intrep is no - * longer valid. Get rid of it so we no longer waste memory storing - * it, nor time determining its invalidity again and again. - */ - - if (objPtr->typePtr == &nsNameType) { - TclFreeIntRep(objPtr); - } - return TCL_ERROR; - } - nsPtr->refCount++; resNamePtr = ckalloc(sizeof(ResolvedNsName)); resNamePtr->nsPtr = nsPtr; if ((name[0] == ':') && (name[1] == ':')) { resNamePtr->refNsPtr = NULL; } else { - resNamePtr->refNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); + resNamePtr->refNsPtr = (Namespace *) TclGetCurrentNamespace(interp); } - resNamePtr->refCount = 1; - TclFreeIntRep(objPtr); - objPtr->internalRep.twoPtrValue.ptr1 = resNamePtr; - objPtr->typePtr = &nsNameType; + resNamePtr->refCount = 0; + NsNameSetIntRep(objPtr, resNamePtr); return TCL_OK; } diff --git a/generic/tclOO.c b/generic/tclOO.c index 1c2277e..e9cc0f0 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -26,11 +26,13 @@ static const struct { int flag; } defineCmds[] = { {"constructor", TclOODefineConstructorObjCmd, 0}, + {"definitionnamespace", TclOODefineDefnNsObjCmd, 0}, {"deletemethod", TclOODefineDeleteMethodObjCmd, 0}, {"destructor", TclOODefineDestructorObjCmd, 0}, {"export", TclOODefineExportObjCmd, 0}, {"forward", TclOODefineForwardObjCmd, 0}, {"method", TclOODefineMethodObjCmd, 0}, + {"private", TclOODefinePrivateObjCmd, 0}, {"renamemethod", TclOODefineRenameMethodObjCmd, 0}, {"self", TclOODefineSelfObjCmd, 0}, {"unexport", TclOODefineUnexportObjCmd, 0}, @@ -41,7 +43,9 @@ static const struct { {"export", TclOODefineExportObjCmd, 1}, {"forward", TclOODefineForwardObjCmd, 1}, {"method", TclOODefineMethodObjCmd, 1}, + {"private", TclOODefinePrivateObjCmd, 1}, {"renamemethod", TclOODefineRenameMethodObjCmd, 1}, + {"self", TclOODefineObjSelfObjCmd, 0}, {"unexport", TclOODefineUnexportObjCmd, 1}, {NULL, NULL, 0} }; @@ -69,7 +73,9 @@ static void DeletedHelpersNamespace(ClientData clientData); static Tcl_NRPostProc FinalizeAlloc; static Tcl_NRPostProc FinalizeNext; static Tcl_NRPostProc FinalizeObjectCall; -static void initClassPath(Tcl_Interp * interp, Class *clsPtr); +static inline void InitClassPath(Tcl_Interp * interp, Class *clsPtr); +static void InitClassSystemRoots(Tcl_Interp *interp, + Foundation *fPtr); static int InitFoundation(Tcl_Interp *interp); static void KillFoundation(ClientData clientData, Tcl_Interp *interp); @@ -78,22 +84,20 @@ static void ObjectNamespaceDeleted(ClientData clientData); static void ObjectRenamedTrace(ClientData clientData, Tcl_Interp *interp, const char *oldName, const char *newName, int flags); +static inline void RemoveClass(Class **list, int num, int idx); +static inline void RemoveObject(Object **list, int num, int idx); static inline void SquelchCachedName(Object *oPtr); -static int PublicObjectCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const *objv); static int PublicNRObjectCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -static int PrivateObjectCmd(ClientData clientData, +static int PrivateNRObjectCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -static int PrivateNRObjectCmd(ClientData clientData, +static int MyClassNRObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); -static void RemoveClass(Class ** list, int num, int idx); -static void RemoveObject(Object ** list, int num, int idx); +static void MyClassDeleted(ClientData clientData); /* * Methods in the oo::object and oo::class classes. First, we define a helper @@ -144,65 +148,10 @@ static const char *initScript = /* " tcloo.tcl OO_LIBRARY oo::library;"; */ /* - * The scripted part of the definitions of slots. + * The scripted part of the definitions of TclOO. */ -static const char *slotScript = -"::oo::define ::oo::Slot {\n" -" method Get {} {error unimplemented}\n" -" method Set list {error unimplemented}\n" -" method -set args {\n" -" uplevel 1 [list [namespace which my] Set $args]\n" -" }\n" -" method -append args {\n" -" uplevel 1 [list [namespace which my] Set [list" -" {*}[uplevel 1 [list [namespace which my] Get]] {*}$args]]\n" -" }\n" -" method -clear {} {uplevel 1 [list [namespace which my] Set {}]}\n" -" forward --default-operation my -append\n" -" method unknown {args} {\n" -" set def --default-operation\n" -" if {[llength $args] == 0} {\n" -" return [uplevel 1 [list [namespace which my] $def]]\n" -" } elseif {![string match -* [lindex $args 0]]} {\n" -" return [uplevel 1 [list [namespace which my] $def {*}$args]]\n" -" }\n" -" next {*}$args\n" -" }\n" -" export -set -append -clear\n" -" unexport unknown destroy\n" -"}\n" -"::oo::objdefine ::oo::define::superclass forward --default-operation my -set\n" -"::oo::objdefine ::oo::define::mixin forward --default-operation my -set\n" -"::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set\n"; - -/* - * The body of the <cloned> method of oo::object. - */ - -static const char *clonedBody = -"foreach p [info procs [info object namespace $originObject]::*] {" -" set args [info args $p];" -" set idx -1;" -" foreach a $args {" -" lset args [incr idx] " -" [if {[info default $p $a d]} {list $a $d} {list $a}]" -" };" -" set b [info body $p];" -" set p [namespace tail $p];" -" proc $p $args $b;" -"};" -"foreach v [info vars [info object namespace $originObject]::*] {" -" upvar 0 $v vOrigin;" -" namespace upvar [namespace current] [namespace tail $v] vNew;" -" if {[info exists vOrigin]} {" -" if {[array exists vOrigin]} {" -" array set vNew [array get vOrigin];" -" } else {" -" set vNew $vOrigin;" -" }" -" }" -"}"; +#include "tclOOScript.h" /* * The actual definition of the variable holding the TclOO stub table. @@ -232,14 +181,50 @@ MODULE_SCOPE const TclOOStubs tclOOStubs; #define IsRoot(ocPtr) ((ocPtr)->flags & (ROOT_OBJECT|ROOT_CLASS)) #define RemoveItem(type, lst, i) \ - do { \ - Remove ## type ((lst).list, (lst).num, i); \ - (lst).num--; \ + do { \ + Remove ## type ((lst).list, (lst).num, i); \ + (lst).num--; \ } while (0) /* * ---------------------------------------------------------------------- * + * RemoveClass, RemoveObject -- + * + * Helpers for the RemoveItem macro for deleting a class or object from a + * list. Setting the "empty" location to NULL makes debugging a little + * easier. + * + * ---------------------------------------------------------------------- + */ + +static inline void +RemoveClass( + Class **list, + int num, + int idx) +{ + for (; idx < num - 1; idx++) { + list[idx] = list[idx + 1]; + } + list[idx] = NULL; +} + +static inline void +RemoveObject( + Object **list, + int num, + int idx) +{ + for (; idx < num - 1; idx++) { + list[idx] = list[idx + 1]; + } + list[idx] = NULL; +} + +/* + * ---------------------------------------------------------------------- + * * TclOOInit -- * * Called to initialise the OO system within an interpreter. @@ -271,7 +256,7 @@ TclOOInit( * to be fully provided. */ - if (Tcl_Eval(interp, initScript) != TCL_OK) { + if (Tcl_EvalEx(interp, initScript, -1, 0) != TCL_OK) { return TCL_ERROR; } @@ -316,11 +301,7 @@ InitFoundation( ThreadLocalData *tsdPtr = Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData)); Foundation *fPtr = ckalloc(sizeof(Foundation)); - Tcl_Obj *namePtr, *argsPtr, *bodyPtr; - - Class fakeCls; - Object fakeObject; - + Tcl_Obj *namePtr; Tcl_DString buffer; Command *cmdPtr; int i; @@ -383,28 +364,98 @@ InitFoundation( Tcl_CallWhenDeleted(interp, KillFoundation, NULL); /* - * Create the objects at the core of the object system. These need to be - * spliced manually. + * Create the special objects at the core of the object system. */ + InitClassSystemRoots(interp, fPtr); + /* - * Stand up a phony class for bootstrapping. + * Basic method declarations for the core classes. */ - fPtr->objectCls = &fakeCls; + for (i = 0 ; objMethods[i].name ; i++) { + TclOONewBasicMethod(interp, fPtr->objectCls, &objMethods[i]); + } + for (i = 0 ; clsMethods[i].name ; i++) { + TclOONewBasicMethod(interp, fPtr->classCls, &clsMethods[i]); + } /* - * Referenced in TclOOAllocClass to increment the refCount. + * Finish setting up the class of classes by marking the 'new' method as + * private; classes, unlike general objects, must have explicit names. We + * also need to create the constructor for classes. */ - fakeCls.thisPtr = &fakeObject; + TclNewLiteralStringObj(namePtr, "new"); + Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr, + namePtr /* keeps ref */, 0 /* private */, NULL, NULL); + fPtr->classCls->constructorPtr = (Method *) Tcl_NewMethod(interp, + (Tcl_Class) fPtr->classCls, NULL, 0, &classConstructor, NULL); - fPtr->objectCls = TclOOAllocClass(interp, - AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL)); /* - * Corresponding TclOODecrRefCount in KillFoudation. + * Create non-object commands and plug ourselves into the Tcl [info] + * ensemble. */ + cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::next", + NULL, TclOONextObjCmd, NULL, NULL); + cmdPtr->compileProc = TclCompileObjectNextCmd; + cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::nextto", + NULL, TclOONextToObjCmd, NULL, NULL); + cmdPtr->compileProc = TclCompileObjectNextToCmd; + cmdPtr = (Command *) Tcl_CreateObjCommand(interp, "::oo::Helpers::self", + TclOOSelfObjCmd, NULL, NULL); + cmdPtr->compileProc = TclCompileObjectSelfCmd; + Tcl_CreateObjCommand(interp, "::oo::define", TclOODefineObjCmd, NULL, + NULL); + Tcl_CreateObjCommand(interp, "::oo::objdefine", TclOOObjDefObjCmd, NULL, + NULL); + Tcl_CreateObjCommand(interp, "::oo::copy", TclOOCopyObjectCmd, NULL,NULL); + TclOOInitInfo(interp); + + /* + * Now make the class of slots. + */ + + if (TclOODefineSlots(fPtr) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Evaluate the remaining definitions, which are a compiled-in Tcl script. + */ + + return Tcl_EvalEx(interp, tclOOSetupScript, -1, 0); +} + +/* + * ---------------------------------------------------------------------- + * + * InitClassSystemRoots -- + * + * Creates the objects at the core of the object system. These need to be + * spliced manually. + * + * ---------------------------------------------------------------------- + */ + +static void +InitClassSystemRoots( + Tcl_Interp *interp, + Foundation *fPtr) +{ + Class fakeCls; + Object fakeObject; + Tcl_Obj *defNsName; + + /* Stand up a phony class for bootstrapping. */ + fPtr->objectCls = &fakeCls; + /* referenced in TclOOAllocClass to increment the refCount. */ + fakeCls.thisPtr = &fakeObject; + + fPtr->objectCls = TclOOAllocClass(interp, + AllocObject(interp, "object", (Namespace *)fPtr->ooNs, NULL)); + /* Corresponding TclOODecrRefCount in KillFoudation */ AddRef(fPtr->objectCls->thisPtr); /* @@ -423,14 +474,13 @@ InitFoundation( fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT; fPtr->objectCls->flags |= ROOT_OBJECT; + TclNewLiteralStringObj(defNsName, "::oo::objdefine"); + fPtr->objectCls->objDefinitionNs = defNsName; + Tcl_IncrRefCount(defNsName); fPtr->classCls = TclOOAllocClass(interp, AllocObject(interp, "class", (Namespace *)fPtr->ooNs, NULL)); - - /* - * Corresponding TclOODecrRefCount in KillFoudation. - */ - + /* Corresponding TclOODecrRefCount in KillFoudation */ AddRef(fPtr->classCls->thisPtr); /* @@ -455,77 +505,17 @@ InitFoundation( fPtr->classCls->thisPtr->flags |= ROOT_CLASS; fPtr->classCls->flags |= ROOT_CLASS; + TclNewLiteralStringObj(defNsName, "::oo::define"); + fPtr->classCls->clsDefinitionNs = defNsName; + Tcl_IncrRefCount(defNsName); - /* - * Standard initialization for new Objects. - */ - + /* Standard initialization for new Objects */ TclOOAddToSubclasses(fPtr->classCls, fPtr->objectCls); /* - * Basic method declarations for the core classes. - */ - - for (i = 0 ; objMethods[i].name ; i++) { - TclOONewBasicMethod(interp, fPtr->objectCls, &objMethods[i]); - } - for (i = 0 ; clsMethods[i].name ; i++) { - TclOONewBasicMethod(interp, fPtr->classCls, &clsMethods[i]); - } - - /* - * Create the default <cloned> method implementation, used when 'oo::copy' - * is called to finish the copying of one object to another. + * THIS IS THE ONLY FUNCTION THAT DOES NON-STANDARD CLASS SPLICING. + * Everything else is careful to prohibit looping. */ - - TclNewLiteralStringObj(argsPtr, "originObject"); - Tcl_IncrRefCount(argsPtr); - bodyPtr = Tcl_NewStringObj(clonedBody, -1); - TclOONewProcMethod(interp, fPtr->objectCls, 0, fPtr->clonedName, argsPtr, - bodyPtr, NULL); - TclDecrRefCount(argsPtr); - - /* - * Finish setting up the class of classes by marking the 'new' method as - * private; classes, unlike general objects, must have explicit names. We - * also need to create the constructor for classes. - */ - - TclNewLiteralStringObj(namePtr, "new"); - Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr, - namePtr /* keeps ref */, 0 /* private */, NULL, NULL); - fPtr->classCls->constructorPtr = (Method *) Tcl_NewMethod(interp, - (Tcl_Class) fPtr->classCls, NULL, 0, &classConstructor, NULL); - - /* - * Create non-object commands and plug ourselves into the Tcl [info] - * ensemble. - */ - - cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::next", - NULL, TclOONextObjCmd, NULL, NULL); - cmdPtr->compileProc = TclCompileObjectNextCmd; - cmdPtr = (Command *) Tcl_NRCreateCommand(interp, "::oo::Helpers::nextto", - NULL, TclOONextToObjCmd, NULL, NULL); - cmdPtr->compileProc = TclCompileObjectNextToCmd; - cmdPtr = (Command *) Tcl_CreateObjCommand(interp, "::oo::Helpers::self", - TclOOSelfObjCmd, NULL, NULL); - cmdPtr->compileProc = TclCompileObjectSelfCmd; - Tcl_CreateObjCommand(interp, "::oo::define", TclOODefineObjCmd, NULL, - NULL); - Tcl_CreateObjCommand(interp, "::oo::objdefine", TclOOObjDefObjCmd, NULL, - NULL); - Tcl_CreateObjCommand(interp, "::oo::copy", TclOOCopyObjectCmd, NULL,NULL); - TclOOInitInfo(interp); - - /* - * Now make the class of slots. - */ - - if (TclOODefineSlots(fPtr) != TCL_OK) { - return TCL_ERROR; - } - return Tcl_Eval(interp, slotScript); } /* @@ -620,8 +610,8 @@ AllocObject( * if the OO system should pick the object * name itself (equal to the namespace * name). */ - Namespace *nsPtr, /* The namespace to create the object in, - or NULL if *nameStr is NULL */ + Namespace *nsPtr, /* The namespace to create the object in, or + * NULL if *nameStr is NULL */ const char *nsNameStr) /* The name of the namespace to create, or * NULL if the OO system should pick a unique * name itself. If this is non-NULL but names @@ -718,8 +708,8 @@ AllocObject( * destruction it occur: A call to ObjectRenamedTrace(), and a call to * ObjectNamespaceDeleted(). */ - oPtr->refCount = 2; + oPtr->refCount = 2; oPtr->flags = USE_CLASS_CACHE; /* @@ -734,10 +724,9 @@ AllocObject( if (nsPtr->parentPtr != NULL) { nsPtr = nsPtr->parentPtr; } - } oPtr->command = TclCreateObjCommandInNs(interp, nameStr, - (Tcl_Namespace *)nsPtr, PublicObjectCmd, oPtr, NULL); + (Tcl_Namespace *)nsPtr, TclOOPublicObjectCmd, oPtr, NULL); /* * Add the NRE command and trace directly. While this breaks a number of @@ -754,7 +743,10 @@ AllocObject( tracePtr->refCount = 1; oPtr->myCommand = TclNRCreateCommandInNs(interp, "my", oPtr->namespacePtr, - PrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted); + TclOOPrivateObjectCmd, PrivateNRObjectCmd, oPtr, MyDeleted); + oPtr->myclassCommand = TclNRCreateCommandInNs(interp, "myclass", + oPtr->namespacePtr, TclOOMyClassObjCmd, MyClassNRObjCmd, oPtr, + MyClassDeleted); return oPtr; } @@ -782,12 +774,12 @@ SquelchCachedName( /* * ---------------------------------------------------------------------- * - * MyDeleted -- + * MyDeleted, MyClassDeleted -- * - * This callback is triggered when the object's [my] command is deleted - * by any mechanism. It just marks the object as not having a [my] - * command, and so prevents cleanup of that when the object itself is - * deleted. + * These callbacks are triggered when the object's [my] or [myclass] + * commands are deleted by any mechanism. They just mark the object as + * not having a [my] command or [myclass] command, and so prevent cleanup + * of those commands when the object itself is deleted. * * ---------------------------------------------------------------------- */ @@ -801,6 +793,14 @@ MyDeleted( oPtr->myCommand = NULL; } + +static void +MyClassDeleted( + ClientData clientData) +{ + Object *oPtr = clientData; + oPtr->myclassCommand = NULL; +} /* * ---------------------------------------------------------------------- @@ -824,6 +824,7 @@ ObjectRenamedTrace( int flags) /* Why was the object deleted? */ { Object *oPtr = clientData; + /* * If this is a rename and not a delete of the object, we just flush the * cache of the object name. @@ -891,6 +892,7 @@ TclOODeleteDescendants( ckfree(clsPtr->mixinSubs.list); clsPtr->mixinSubs.size = 0; } + /* * Squelch subclasses of this class. */ @@ -960,6 +962,7 @@ TclOOReleaseClassContents( Method *mPtr; Foundation *fPtr = oPtr->fPtr; Tcl_Obj *variableObj; + PrivateVariableMapping *privateVariable; /* * Sanity check! @@ -976,6 +979,19 @@ TclOOReleaseClassContents( } /* + * Stop using the class for definition information. + */ + + if (clsPtr->clsDefinitionNs) { + Tcl_DecrRefCount(clsPtr->clsDefinitionNs); + clsPtr->clsDefinitionNs = NULL; + } + if (clsPtr->objDefinitionNs) { + Tcl_DecrRefCount(clsPtr->objDefinitionNs); + clsPtr->objDefinitionNs = NULL; + } + + /* * Squelch method implementation chain caches. */ @@ -1063,6 +1079,14 @@ TclOOReleaseClassContents( ckfree(clsPtr->variables.list); } + FOREACH_STRUCT(privateVariable, clsPtr->privateVariables) { + TclDecrRefCount(privateVariable->variableObj); + TclDecrRefCount(privateVariable->fullNameObj); + } + if (i) { + ckfree(clsPtr->privateVariables.list); + } + if (IsRootClass(oPtr) && !Deleted(fPtr->objectCls->thisPtr)) { Tcl_DeleteCommandFromToken(interp, fPtr->objectCls->thisPtr->command); } @@ -1092,6 +1116,7 @@ ObjectNamespaceDeleted( Class *mixinPtr; Method *mPtr; Tcl_Obj *filterObj, *variableObj; + PrivateVariableMapping *privateVariable; Tcl_Interp *interp = oPtr->fPtr->interp; int i; @@ -1100,6 +1125,7 @@ ObjectNamespaceDeleted( * TODO: Can ObjectNamespaceDeleted ever be called twice? If not, * this guard could be removed. */ + return; } @@ -1108,6 +1134,7 @@ ObjectNamespaceDeleted( * process of being deleted, nothing else may modify its bookeeping * records. This is the flag that */ + oPtr->flags |= OBJECT_DELETED; /* @@ -1127,7 +1154,7 @@ ObjectNamespaceDeleted( if (!Tcl_InterpDeleted(interp) && !(oPtr->flags & DESTRUCTOR_CALLED)) { CallContext *contextPtr = - TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL); + TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL, NULL); int result; Tcl_InterpState state; @@ -1168,6 +1195,9 @@ ObjectNamespaceDeleted( Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command); } + if (oPtr->myclassCommand) { + Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myclassCommand); + } if (oPtr->myCommand) { Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myCommand); } @@ -1212,6 +1242,14 @@ ObjectNamespaceDeleted( ckfree(oPtr->variables.list); } + FOREACH_STRUCT(privateVariable, oPtr->privateVariables) { + TclDecrRefCount(privateVariable->variableObj); + TclDecrRefCount(privateVariable->fullNameObj); + } + if (i) { + ckfree(oPtr->privateVariables.list); + } + if (oPtr->chainCache) { TclOODeleteChainCache(oPtr->chainCache); } @@ -1244,7 +1282,6 @@ ObjectNamespaceDeleted( if (IsRootObject(oPtr) && !Deleted(fPtr->classCls->thisPtr) && !Tcl_InterpDeleted(interp)) { - Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command); } @@ -1267,7 +1304,7 @@ ObjectNamespaceDeleted( /* * ---------------------------------------------------------------------- * - * TclOODecrRef -- + * TclOODecrRefCount -- * * Decrement the refcount of an object and deallocate storage then object * is no longer referenced. Returns 1 if storage was deallocated, and 0 @@ -1275,8 +1312,13 @@ ObjectNamespaceDeleted( * * ---------------------------------------------------------------------- */ -int TclOODecrRefCount(Object *oPtr) { + +int +TclOODecrRefCount( + Object *oPtr) +{ if (oPtr->refCount-- <= 1) { + if (oPtr->classPtr != NULL) { ckfree(oPtr->classPtr); } @@ -1287,21 +1329,6 @@ int TclOODecrRefCount(Object *oPtr) { } /* - * Setting the "empty" location to NULL makes debugging a little easier. - */ - -#define REMOVEBODY { \ - for (; idx < num - 1; idx++) { \ - list[idx] = list[idx + 1]; \ - } \ - list[idx] = NULL; \ - return; \ -} -void RemoveClass(Class **list, int num, int idx) REMOVEBODY - -void RemoveObject(Object **list, int num, int idx) REMOVEBODY - -/* * ---------------------------------------------------------------------- * * TclOORemoveFromInstances -- @@ -1538,6 +1565,25 @@ TclOOAddToMixinSubs( * ---------------------------------------------------------------------- */ +static inline void +InitClassPath( + Tcl_Interp *interp, + Class *clsPtr) +{ + Foundation *fPtr = GetFoundation(interp); + + if (fPtr->helpersNs != NULL) { + Tcl_Namespace *path[2]; + + path[0] = fPtr->helpersNs; + path[1] = fPtr->ooNs; + TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 2, path); + } else { + TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 1, + &fPtr->ooNs); + } +} + Class * TclOOAllocClass( Tcl_Interp *interp, /* Interpreter within which to allocate the @@ -1554,7 +1600,8 @@ TclOOAllocClass( /* * Configure the namespace path for the class's object. */ - initClassPath(interp, clsPtr); + + InitClassPath(interp, clsPtr); /* * Classes are subclasses of oo::object, i.e. the objects they create are @@ -1580,19 +1627,6 @@ TclOOAllocClass( Tcl_InitObjHashTable(&clsPtr->classMethods); return clsPtr; } -static void -initClassPath(Tcl_Interp *interp, Class *clsPtr) { - Foundation *fPtr = GetFoundation(interp); - if (fPtr->helpersNs != NULL) { - Tcl_Namespace *path[2]; - path[0] = fPtr->helpersNs; - path[1] = fPtr->ooNs; - TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 2, path); - } else { - TclSetNsPath((Namespace *) clsPtr->thisPtr->namespacePtr, 1, - &fPtr->ooNs); - } -} /* * ---------------------------------------------------------------------- @@ -1623,7 +1657,9 @@ Tcl_NewObjectInstance( ClientData clientData[4]; oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr); - if (oPtr == NULL) {return NULL;} + if (oPtr == NULL) { + return NULL; + } /* * Run constructors, except when objc < 0, which is a special flag case @@ -1632,7 +1668,7 @@ Tcl_NewObjectInstance( if (objc >= 0) { CallContext *contextPtr = - TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL); + TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL, NULL, NULL); if (contextPtr != NULL) { int isRoot, result; @@ -1692,7 +1728,9 @@ TclNRNewObjectInstance( Object *oPtr; oPtr = TclNewObjectInstanceCommon(interp, classPtr, nameStr, nsNameStr); - if (oPtr == NULL) {return TCL_ERROR;} + if (oPtr == NULL) { + return TCL_ERROR; + } /* * Run constructors, except when objc < 0 (a special flag case used for @@ -1703,7 +1741,7 @@ TclNRNewObjectInstance( *objectPtr = (Tcl_Object) oPtr; return TCL_OK; } - contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL); + contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL, NULL, NULL); if (contextPtr == NULL) { *objectPtr = (Tcl_Object) oPtr; return TCL_OK; @@ -1742,8 +1780,8 @@ TclNewObjectInstanceCommon( Foundation *fPtr = GetFoundation(interp); Object *oPtr; const char *simpleName = NULL; - Namespace *nsPtr = NULL, *dummy, - *inNsPtr = (Namespace *)TclGetCurrentNamespace(interp); + Namespace *nsPtr = NULL, *dummy; + Namespace *inNsPtr = (Namespace *) TclGetCurrentNamespace(interp); if (nameStr) { TclGetNamespaceForQualName(interp, nameStr, inNsPtr, @@ -1805,8 +1843,8 @@ FinalizeAlloc( Tcl_Object *objectPtr = data[3]; /* - * Ensure an error if the object was deleted in the constructor. - * Don't want to lose errors by accident. [Bug 2903011] + * Ensure an error if the object was deleted in the constructor. Don't + * want to lose errors by accident. [Bug 2903011] */ if (result != TCL_ERROR && Deleted(oPtr)) { @@ -1872,6 +1910,7 @@ Tcl_CopyObjectInstance( Class *mixinPtr; CallContext *contextPtr; Tcl_Obj *keyPtr, *filterObj, *variableObj, *args[3]; + PrivateVariableMapping *privateVariable; int i, result; /* @@ -1945,7 +1984,7 @@ Tcl_CopyObjectInstance( } /* - * Copy the object's variable resolution list to the new object. + * Copy the object's variable resolution lists to the new object. */ DUPLICATE(o2Ptr->variables, oPtr->variables, Tcl_Obj *); @@ -1953,6 +1992,13 @@ Tcl_CopyObjectInstance( Tcl_IncrRefCount(variableObj); } + DUPLICATE(o2Ptr->privateVariables, oPtr->privateVariables, + PrivateVariableMapping); + FOREACH_STRUCT(privateVariable, o2Ptr->privateVariables) { + Tcl_IncrRefCount(privateVariable->variableObj); + Tcl_IncrRefCount(privateVariable->fullNameObj); + } + /* * Copy the object's flags to the new object, clearing those that must be * kept object-local. The duplicate is never deleted at this point, nor is @@ -2044,7 +2090,7 @@ Tcl_CopyObjectInstance( } /* - * Copy the source class's variable resolution list. + * Copy the source class's variable resolution lists. */ DUPLICATE(cls2Ptr->variables, clsPtr->variables, Tcl_Obj *); @@ -2052,6 +2098,13 @@ Tcl_CopyObjectInstance( Tcl_IncrRefCount(variableObj); } + DUPLICATE(cls2Ptr->privateVariables, clsPtr->privateVariables, + PrivateVariableMapping); + FOREACH_STRUCT(privateVariable, cls2Ptr->privateVariables) { + Tcl_IncrRefCount(privateVariable->variableObj); + Tcl_IncrRefCount(privateVariable->fullNameObj); + } + /* * Duplicate the source class's mixins (which cannot be circular * references to the duplicate). @@ -2128,7 +2181,8 @@ Tcl_CopyObjectInstance( } TclResetRewriteEnsemble(interp, 1); - contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0, NULL); + contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0, NULL, + NULL, NULL); if (contextPtr) { args[0] = TclOOObjectName(interp, o2Ptr); args[1] = oPtr->fPtr->clonedName; @@ -2416,7 +2470,7 @@ Tcl_ObjectSetMetadata( /* * ---------------------------------------------------------------------- * - * PublicObjectCmd, PrivateObjectCmd, TclOOInvokeObject -- + * TclOOPublicObjectCmd, TclOOPrivateObjectCmd, TclOOInvokeObject -- * * Main entry point for object invocations. The Public* and Private* * wrapper functions (implementations of both object instance commands @@ -2426,8 +2480,8 @@ Tcl_ObjectSetMetadata( * ---------------------------------------------------------------------- */ -static int -PublicObjectCmd( +int +TclOOPublicObjectCmd( ClientData clientData, Tcl_Interp *interp, int objc, @@ -2447,8 +2501,8 @@ PublicNRObjectCmd( NULL); } -static int -PrivateObjectCmd( +int +TclOOPrivateObjectCmd( ClientData clientData, Tcl_Interp *interp, int objc, @@ -2501,6 +2555,43 @@ TclOOInvokeObject( /* * ---------------------------------------------------------------------- * + * TclOOMyClassObjCmd, MyClassNRObjCmd -- + * + * Special trap door to allow an object to delegate simply to its class. + * + * ---------------------------------------------------------------------- + */ + +int +TclOOMyClassObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + return Tcl_NRCallObjProc(interp, MyClassNRObjCmd, clientData, objc, objv); +} + +static int +MyClassNRObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = clientData; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "methodName ?arg ...?"); + return TCL_ERROR; + } + return TclOOObjectCmdCore(oPtr->selfCls->thisPtr, interp, objc, objv, 0, + NULL); +} + +/* + * ---------------------------------------------------------------------- + * * TclOOObjectCmdCore, FinalizeObjectCall -- * * Main function for object invocations. Does call chain creation, @@ -2525,6 +2616,9 @@ TclOOObjectCmdCore( { CallContext *contextPtr; Tcl_Obj *methodNamePtr; + CallFrame *framePtr = ((Interp *) interp)->varFramePtr; + Object *callerObjPtr = NULL; + Class *callerClsPtr = NULL; int result; /* @@ -2539,6 +2633,24 @@ TclOOObjectCmdCore( } /* + * Determine if we're in a context that can see the extra, private methods + * in this class. + */ + + if (framePtr->isProcCallFrame & FRAME_IS_METHOD) { + CallContext *callerContextPtr = framePtr->clientData; + Method *callerMethodPtr = + callerContextPtr->callPtr->chain[callerContextPtr->index].mPtr; + + if (callerMethodPtr->declaringObjectPtr) { + callerObjPtr = callerMethodPtr->declaringObjectPtr; + } + if (callerMethodPtr->declaringClassPtr) { + callerClsPtr = callerMethodPtr->declaringClassPtr; + } + } + + /* * Give plugged in code a chance to remap the method name. */ @@ -2565,7 +2677,8 @@ TclOOObjectCmdCore( Tcl_IncrRefCount(mappedMethodName); contextPtr = TclOOGetCallContext(oPtr, mappedMethodName, - flags | (oPtr->flags & FILTER_HANDLING), methodNamePtr); + flags | (oPtr->flags & FILTER_HANDLING), callerObjPtr, + callerClsPtr, methodNamePtr); TclDecrRefCount(mappedMethodName); if (contextPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -2582,7 +2695,8 @@ TclOOObjectCmdCore( noMapping: contextPtr = TclOOGetCallContext(oPtr, methodNamePtr, - flags | (oPtr->flags & FILTER_HANDLING), NULL); + flags | (oPtr->flags & FILTER_HANDLING), callerObjPtr, + callerClsPtr, NULL); if (contextPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "impossible to invoke method \"%s\": no defined method or" @@ -2832,9 +2946,9 @@ Tcl_GetObjectFromObj( if (cmdPtr == NULL) { goto notAnObject; } - if (cmdPtr->objProc != PublicObjectCmd) { + if (cmdPtr->objProc != TclOOPublicObjectCmd) { cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr); - if (cmdPtr == NULL || cmdPtr->objProc != PublicObjectCmd) { + if (cmdPtr == NULL || cmdPtr->objProc != TclOOPublicObjectCmd) { goto notAnObject; } } diff --git a/generic/tclOO.decls b/generic/tclOO.decls index 265ba88..f1bb320 100644 --- a/generic/tclOO.decls +++ b/generic/tclOO.decls @@ -58,12 +58,12 @@ declare 10 { } declare 11 { Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, Tcl_Object object, - Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, + Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, ClientData clientData) } declare 12 { Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, - Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, + Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, ClientData clientData) } declare 13 { @@ -126,6 +126,9 @@ declare 27 { declare 28 { Tcl_Obj *Tcl_GetObjectName(Tcl_Interp *interp, Tcl_Object object) } +declare 29 { + int Tcl_MethodIsPrivate(Tcl_Method method) +} ###################################################################### # Private API, exposed to support advanced OO systems that plug in on top of diff --git a/generic/tclOO.h b/generic/tclOO.h index 32afbf1..9c1dd1e 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -24,7 +24,7 @@ * win/tclooConfig.sh */ -#define TCLOO_VERSION "1.1.0" +#define TCLOO_VERSION "1.2.0" #define TCLOO_PATCHLEVEL TCLOO_VERSION #include "tcl.h" @@ -99,6 +99,15 @@ typedef struct { */ #define TCL_OO_METHOD_VERSION_CURRENT 1 + +/* + * Visibility constants for the flags parameter to Tcl_NewMethod and + * Tcl_NewInstanceMethod. + */ + +#define TCL_OO_METHOD_PUBLIC 1 +#define TCL_OO_METHOD_UNEXPORTED 0 +#define TCL_OO_METHOD_PRIVATE 0x20 /* * The type of some object (or class) metadata. This describes how to delete diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index d874cba..13c98f4 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -83,7 +83,7 @@ TclOO_Class_Constructor( Tcl_Obj *const *objv) { Object *oPtr = (Object *) Tcl_ObjectContextObject(context); - Tcl_Obj **invoke; + Tcl_Obj **invoke, *nameObj; if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, @@ -94,6 +94,17 @@ TclOO_Class_Constructor( } /* + * Make the class definition delegate. This is special; it doesn't reenter + * here (and the class definition delegate doesn't run any constructors). + */ + + nameObj = Tcl_NewStringObj(oPtr->namespacePtr->fullName, -1); + Tcl_AppendToObj(nameObj, ":: oo ::delegate", -1); + Tcl_NewObjectInstance(interp, (Tcl_Class) oPtr->fPtr->classCls, + TclGetString(nameObj), NULL, -1, NULL, -1); + Tcl_DecrRefCount(nameObj); + + /* * Delegate to [oo::define] to do the work. */ @@ -111,7 +122,7 @@ TclOO_Class_Constructor( Tcl_IncrRefCount(invoke[1]); Tcl_IncrRefCount(invoke[2]); TclNRAddCallback(interp, DecrRefsPostClassConstructor, - invoke, NULL, NULL, NULL); + invoke, oPtr, NULL, NULL); /* * Tricky point: do not want the extra reported level in the Tcl stack @@ -128,12 +139,27 @@ DecrRefsPostClassConstructor( int result) { Tcl_Obj **invoke = data[0]; + Object *oPtr = data[1]; + Tcl_InterpState saved; + int code; TclDecrRefCount(invoke[0]); TclDecrRefCount(invoke[1]); TclDecrRefCount(invoke[2]); + invoke[0] = Tcl_NewStringObj("::oo::MixinClassDelegates", -1); + invoke[1] = TclOOObjectName(interp, oPtr); + Tcl_IncrRefCount(invoke[0]); + Tcl_IncrRefCount(invoke[1]); + saved = Tcl_SaveInterpState(interp, result); + code = Tcl_EvalObjv(interp, 2, invoke, 0); + TclDecrRefCount(invoke[0]); + TclDecrRefCount(invoke[1]); ckfree(invoke); - return result; + if (code != TCL_OK) { + Tcl_DiscardInterpState(saved); + return code; + } + return Tcl_RestoreInterpState(interp, saved); } /* @@ -347,7 +373,8 @@ TclOO_Object_Destroy( } if (!(oPtr->flags & DESTRUCTOR_CALLED)) { oPtr->flags |= DESTRUCTOR_CALLED; - contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL); + contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL, NULL, + NULL); if (contextPtr != NULL) { contextPtr->callPtr->flags |= DESTRUCTOR; contextPtr->skip = 0; @@ -499,9 +526,12 @@ TclOO_Object_Unknown( Tcl_Obj *const *objv) /* The actual arguments. */ { CallContext *contextPtr = (CallContext *) context; + Object *callerObj = NULL; + Class *callerCls = NULL; Object *oPtr = contextPtr->oPtr; const char **methodNames; int numMethodNames, i, skip = Tcl_ObjectContextSkippedArgs(context); + CallFrame *framePtr = ((Interp *) interp)->varFramePtr; Tcl_Obj *errorMsg; /* @@ -516,10 +546,31 @@ TclOO_Object_Unknown( } /* + * Determine if the calling context should know about extra private + * methods, and if so, which. + */ + + if (framePtr->isProcCallFrame & FRAME_IS_METHOD) { + CallContext *callerContext = framePtr->clientData; + Method *mPtr = callerContext->callPtr->chain[ + callerContext->index].mPtr; + + if (mPtr->declaringObjectPtr) { + if (oPtr == mPtr->declaringObjectPtr) { + callerObj = mPtr->declaringObjectPtr; + } + } else { + if (TclOOIsReachable(mPtr->declaringClassPtr, oPtr->selfCls)) { + callerCls = mPtr->declaringClassPtr; + } + } + } + + /* * Get the list of methods that we want to know about. */ - numMethodNames = TclOOGetSortedMethodList(oPtr, + numMethodNames = TclOOGetSortedMethodList(oPtr, callerObj, callerCls, contextPtr->callPtr->flags & PUBLIC_METHOD, &methodNames); /* @@ -684,6 +735,7 @@ TclOO_Object_VarName( { Var *varPtr, *aryVar; Tcl_Obj *varNamePtr, *argPtr; + CallFrame *framePtr = ((Interp *) interp)->varFramePtr; const char *arg; if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { @@ -709,6 +761,58 @@ TclOO_Object_VarName( Tcl_Namespace *namespacePtr = Tcl_GetObjectNamespace(Tcl_ObjectContextObject(context)); + /* + * Private method handling. [TIP 500] + * + * If we're in a context that can see some private methods of an + * object, we may need to precede a variable name with its prefix. + * This is a little tricky as we need to check through the inheritance + * hierarchy when the method was declared by a class to see if the + * current object is an instance of that class. + */ + + if (framePtr->isProcCallFrame & FRAME_IS_METHOD) { + Object *oPtr = (Object *) Tcl_ObjectContextObject(context); + CallContext *callerContext = framePtr->clientData; + Method *mPtr = callerContext->callPtr->chain[ + callerContext->index].mPtr; + PrivateVariableMapping *pvPtr; + int i; + + if (mPtr->declaringObjectPtr == oPtr) { + FOREACH_STRUCT(pvPtr, oPtr->privateVariables) { + if (!strcmp(Tcl_GetString(pvPtr->variableObj), + Tcl_GetString(argPtr))) { + argPtr = pvPtr->fullNameObj; + break; + } + } + } else if (mPtr->declaringClassPtr && + mPtr->declaringClassPtr->privateVariables.num) { + Class *clsPtr = mPtr->declaringClassPtr; + int isInstance = TclOOIsReachable(clsPtr, oPtr->selfCls); + Class *mixinCls; + + if (!isInstance) { + FOREACH(mixinCls, oPtr->mixins) { + if (TclOOIsReachable(clsPtr, mixinCls)) { + isInstance = 1; + break; + } + } + } + if (isInstance) { + FOREACH_STRUCT(pvPtr, clsPtr->privateVariables) { + if (!strcmp(Tcl_GetString(pvPtr->variableObj), + Tcl_GetString(argPtr))) { + argPtr = pvPtr->fullNameObj; + break; + } + } + } + } + } + varNamePtr = Tcl_NewStringObj(namespacePtr->fullName, -1); Tcl_AppendToObj(varNamePtr, "::", 2); Tcl_AppendObjToObj(varNamePtr, argPtr); @@ -729,26 +833,16 @@ TclOO_Object_VarName( varNamePtr = Tcl_NewObj(); if (aryVar != NULL) { - Tcl_HashEntry *hPtr; - Tcl_HashSearch search; - Tcl_GetVariableFullName(interp, (Tcl_Var) aryVar, varNamePtr); /* * WARNING! This code pokes inside the implementation of hash tables! */ - hPtr = Tcl_FirstHashEntry((Tcl_HashTable *) aryVar->value.tablePtr, - &search); - while (hPtr != NULL) { - if (varPtr == Tcl_GetHashValue(hPtr)) { - Tcl_AppendToObj(varNamePtr, "(", -1); - Tcl_AppendObjToObj(varNamePtr, hPtr->key.objPtr); - Tcl_AppendToObj(varNamePtr, ")", -1); - break; - } - hPtr = Tcl_NextHashEntry(&search); - } + Tcl_AppendToObj(varNamePtr, "(", -1); + Tcl_AppendObjToObj(varNamePtr, ((VarInHash *) + varPtr)->entry.key.objPtr); + Tcl_AppendToObj(varNamePtr, ")", -1); } else { Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, varNamePtr); } diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index cc02c68..c0d2e64 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -15,6 +15,7 @@ #endif #include "tclInt.h" #include "tclOOInt.h" +#include <assert.h> /* * Structure containing a CallContext and any other values needed only during @@ -31,6 +32,22 @@ struct ChainBuilder { }; /* + * Structures used for traversing the class hierarchy to find out where + * definitions are supposed to be done. + */ + +typedef struct { + Class *definerCls; + Tcl_Obj *namespaceName; +} DefineEntry; + +typedef struct { + DefineEntry *list; + int num; + int size; +} DefineChain; + +/* * Extra flags used for call chain management. */ @@ -46,6 +63,28 @@ struct ChainBuilder { !((flags) & BUILDING_MIXINS) == !((flags) & TRAVERSED_MIXIN)) /* + * Note that the flag bit PRIVATE_METHOD has a confusing name; it's just for + * Itcl's special type of private. + */ + +#define IS_PUBLIC(mPtr) \ + (((mPtr)->flags & PUBLIC_METHOD) != 0) +#define IS_UNEXPORTED(mPtr) \ + (((mPtr)->flags & SCOPE_FLAGS) == 0) +#define IS_ITCLPRIVATE(mPtr) \ + (((mPtr)->flags & PRIVATE_METHOD) != 0) +#define IS_PRIVATE(mPtr) \ + (((mPtr)->flags & TRUE_PRIVATE_METHOD) != 0) +#define WANT_PUBLIC(flags) \ + (((flags) & PUBLIC_METHOD) != 0) +#define WANT_UNEXPORTED(flags) \ + (((flags) & (PRIVATE_METHOD | TRUE_PRIVATE_METHOD)) == 0) +#define WANT_ITCLPRIVATE(flags) \ + (((flags) & PRIVATE_METHOD) != 0) +#define WANT_PRIVATE(flags) \ + (((flags) & TRUE_PRIVATE_METHOD) != 0) + +/* * Function declarations for things defined in this file. */ @@ -55,20 +94,41 @@ static void AddClassFiltersToCallContext(Object *const oPtr, static void AddClassMethodNames(Class *clsPtr, const int flags, Tcl_HashTable *const namesPtr, Tcl_HashTable *const examinedClassesPtr); +static inline void AddDefinitionNamespaceToChain(Class *const definerCls, + Tcl_Obj *const namespaceName, + DefineChain *const definePtr, int flags); static inline void AddMethodToCallChain(Method *const mPtr, struct ChainBuilder *const cbPtr, Tcl_HashTable *const doneFilters, Class *const filterDecl, int flags); -static inline void AddSimpleChainToCallContext(Object *const oPtr, +static inline int AddInstancePrivateToCallContext(Object *const oPtr, + Tcl_Obj *const methodNameObj, + struct ChainBuilder *const cbPtr, int flags); +static inline void AddStandardMethodName(int flags, Tcl_Obj *namePtr, + Method *mPtr, Tcl_HashTable *namesPtr); +static inline void AddPrivateMethodNames(Tcl_HashTable *methodsTablePtr, + Tcl_HashTable *namesPtr); +static inline int AddSimpleChainToCallContext(Object *const oPtr, + Class *const contextCls, Tcl_Obj *const methodNameObj, struct ChainBuilder *const cbPtr, Tcl_HashTable *const doneFilters, int flags, Class *const filterDecl); -static void AddSimpleClassChainToCallContext(Class *classPtr, +static int AddPrivatesFromClassChainToCallContext(Class *classPtr, + Class *const contextCls, Tcl_Obj *const methodNameObj, struct ChainBuilder *const cbPtr, Tcl_HashTable *const doneFilters, int flags, Class *const filterDecl); +static int AddSimpleClassChainToCallContext(Class *classPtr, + Tcl_Obj *const methodNameObj, + struct ChainBuilder *const cbPtr, + Tcl_HashTable *const doneFilters, int flags, + Class *const filterDecl); +static void AddSimpleClassDefineNamespaces(Class *classPtr, + DefineChain *const definePtr, int flags); +static inline void AddSimpleDefineNamespaces(Object *const oPtr, + DefineChain *const definePtr, int flags); static int CmpStr(const void *ptr1, const void *ptr2); static void DupMethodNameRep(Tcl_Obj *srcPtr, Tcl_Obj *dstPtr); static Tcl_NRPostProc FinalizeMethodRefs; @@ -77,6 +137,8 @@ static inline int IsStillValid(CallChain *callPtr, Object *oPtr, int flags, int reuseMask); static Tcl_NRPostProc ResetFilterFlags; static Tcl_NRPostProc SetFilterFlags; +static int SortMethodNames(Tcl_HashTable *namesPtr, int flags, + const char ***stringsPtr); static inline void StashCallChain(Tcl_Obj *objPtr, CallChain *callPtr); /* @@ -90,6 +152,7 @@ static const Tcl_ObjType methodNameType = { NULL, NULL }; + /* * ---------------------------------------------------------------------- @@ -184,11 +247,12 @@ StashCallChain( Tcl_Obj *objPtr, CallChain *callPtr) { + Tcl_ObjIntRep ir; + callPtr->refCount++; TclGetString(objPtr); - TclFreeIntRep(objPtr); - objPtr->typePtr = &methodNameType; - objPtr->internalRep.twoPtrValue.ptr1 = callPtr; + ir.twoPtrValue.ptr1 = callPtr; + Tcl_StoreIntRep(objPtr, &methodNameType, &ir); } void @@ -215,21 +279,16 @@ DupMethodNameRep( Tcl_Obj *srcPtr, Tcl_Obj *dstPtr) { - register CallChain *callPtr = srcPtr->internalRep.twoPtrValue.ptr1; - - dstPtr->typePtr = &methodNameType; - dstPtr->internalRep.twoPtrValue.ptr1 = callPtr; - callPtr->refCount++; + StashCallChain(dstPtr, + TclFetchIntRep(srcPtr, &methodNameType)->twoPtrValue.ptr1); } static void FreeMethodNameRep( Tcl_Obj *objPtr) { - register CallChain *callPtr = objPtr->internalRep.twoPtrValue.ptr1; - - TclOODeleteChain(callPtr); - objPtr->typePtr = NULL; + TclOODeleteChain( + TclFetchIntRep(objPtr, &methodNameType)->twoPtrValue.ptr1); } /* @@ -366,6 +425,14 @@ FinalizeMethodRefs( int TclOOGetSortedMethodList( Object *oPtr, /* The object to get the method names for. */ + Object *contextObj, /* From what context object we are inquiring. + * NULL when the context shouldn't see + * object-level private methods. Note that + * flags can override this. */ + Class *contextCls, /* From what context class we are inquiring. + * NULL when the context shouldn't see + * class-level private methods. Note that + * flags can override this. */ int flags, /* Whether we just want the public method * names. */ const char ***stringsPtr) /* Where to write a pointer to the array of @@ -378,12 +445,10 @@ TclOOGetSortedMethodList( * at. Is set-like in nature and keyed by * pointer to class. */ FOREACH_HASH_DECLS; - int i; + int i, numStrings; Class *mixinPtr; Tcl_Obj *namePtr; Method *mPtr; - int isWantedIn; - void *isWanted; Tcl_InitObjHashTable(&names); Tcl_InitHashTable(&examinedClasses, TCL_ONE_WORD_KEYS); @@ -400,18 +465,13 @@ TclOOGetSortedMethodList( if (oPtr->methodsPtr) { FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) { - int isNew; - - if ((mPtr->flags & PRIVATE_METHOD) && !(flags & PRIVATE_METHOD)) { + if (IS_PRIVATE(mPtr)) { continue; } - hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew); - if (isNew) { - isWantedIn = ((!(flags & PUBLIC_METHOD) - || mPtr->flags & PUBLIC_METHOD) ? IN_LIST : 0); - isWantedIn |= (mPtr->typePtr == NULL ? NO_IMPLEMENTATION : 0); - Tcl_SetHashValue(hPtr, INT2PTR(isWantedIn)); + if (IS_UNEXPORTED(mPtr) && !WANT_UNEXPORTED(flags)) { + continue; } + AddStandardMethodName(flags, namePtr, mPtr, &names); } } @@ -419,84 +479,46 @@ TclOOGetSortedMethodList( * Process method names due to private methods on the object's class. */ - if (flags & PRIVATE_METHOD) { + if (WANT_UNEXPORTED(flags)) { FOREACH_HASH(namePtr, mPtr, &oPtr->selfCls->classMethods) { - if (mPtr->flags & PRIVATE_METHOD) { - int isNew; - - hPtr = Tcl_CreateHashEntry(&names, (char *) namePtr, &isNew); - if (isNew) { - isWantedIn = IN_LIST; - if (mPtr->typePtr == NULL) { - isWantedIn |= NO_IMPLEMENTATION; - } - Tcl_SetHashValue(hPtr, INT2PTR(isWantedIn)); - } else if (mPtr->typePtr != NULL) { - isWantedIn = PTR2INT(Tcl_GetHashValue(hPtr)); - if (isWantedIn & NO_IMPLEMENTATION) { - isWantedIn &= ~NO_IMPLEMENTATION; - Tcl_SetHashValue(hPtr, INT2PTR(isWantedIn)); - } - } + if (IS_UNEXPORTED(mPtr)) { + AddStandardMethodName(flags, namePtr, mPtr, &names); } } } /* + * Process method names due to private methods on the context's object or + * class. Which must be correct if either are not NULL. + */ + + if (contextObj && contextObj->methodsPtr) { + AddPrivateMethodNames(contextObj->methodsPtr, &names); + } + if (contextCls) { + AddPrivateMethodNames(&contextCls->classMethods, &names); + } + + /* * Process (normal) method names from the class hierarchy and the mixin * hierarchy. */ AddClassMethodNames(oPtr->selfCls, flags, &names, &examinedClasses); FOREACH(mixinPtr, oPtr->mixins) { - AddClassMethodNames(mixinPtr, flags|TRAVERSED_MIXIN, &names, + AddClassMethodNames(mixinPtr, flags | TRAVERSED_MIXIN, &names, &examinedClasses); } - Tcl_DeleteHashTable(&examinedClasses); - /* - * See how many (visible) method names there are. If none, we do not (and - * should not) try to sort the list of them. + * Tidy up, sort the names and resolve finally whether we really want + * them (processing export layering). */ - i = 0; - if (names.numEntries != 0) { - const char **strings; - - /* - * We need to build the list of methods to sort. We will be using - * qsort() for this, because it is very unlikely that the list will be - * heavily sorted when it is long enough to matter. - */ - - strings = ckalloc(sizeof(char *) * names.numEntries); - FOREACH_HASH(namePtr, isWanted, &names) { - if (!(flags & PUBLIC_METHOD) || (PTR2INT(isWanted) & IN_LIST)) { - if (PTR2INT(isWanted) & NO_IMPLEMENTATION) { - continue; - } - strings[i++] = TclGetString(namePtr); - } - } - - /* - * Note that 'i' may well be less than names.numEntries when we are - * dealing with public method names. - */ - - if (i > 0) { - if (i > 1) { - qsort((void *) strings, (unsigned) i, sizeof(char *), CmpStr); - } - *stringsPtr = strings; - } else { - ckfree(strings); - } - } - + Tcl_DeleteHashTable(&examinedClasses); + numStrings = SortMethodNames(&names, flags, stringsPtr); Tcl_DeleteHashTable(&names); - return i; + return numStrings; } int @@ -513,10 +535,7 @@ TclOOGetSortedClassMethodList( /* Used to track what classes have been looked * at. Is set-like in nature and keyed by * pointer to class. */ - FOREACH_HASH_DECLS; - int i; - Tcl_Obj *namePtr; - void *isWanted; + int numStrings; Tcl_InitObjHashTable(&names); Tcl_InitHashTable(&examinedClasses, TCL_ONE_WORD_KEYS); @@ -529,51 +548,101 @@ TclOOGetSortedClassMethodList( Tcl_DeleteHashTable(&examinedClasses); /* + * Process private method names if we should. [TIP 500] + */ + + if (WANT_PRIVATE(flags)) { + AddPrivateMethodNames(&clsPtr->classMethods, &names); + flags &= ~TRUE_PRIVATE_METHOD; + } + + /* + * Tidy up, sort the names and resolve finally whether we really want + * them (processing export layering). + */ + + numStrings = SortMethodNames(&names, flags, stringsPtr); + Tcl_DeleteHashTable(&names); + return numStrings; +} + +/* + * ---------------------------------------------------------------------- + * + * SortMethodNames -- + * + * Shared helper for TclOOGetSortedMethodList etc. that knows the method + * sorting rules. + * + * Returns: + * The length of the sorted list. + * + * ---------------------------------------------------------------------- + */ + +static int +SortMethodNames( + Tcl_HashTable *namesPtr, /* The table of names; unsorted, but contains + * whether the names are wanted and under what + * circumstances. */ + int flags, /* Whether we are looking for unexported + * methods. Full private methods are handled + * on insertion to the table. */ + const char ***stringsPtr) /* Where to store the sorted list of strings + * that we produce. ckalloced() */ +{ + const char **strings; + FOREACH_HASH_DECLS; + Tcl_Obj *namePtr; + void *isWanted; + int i = 0; + + /* * See how many (visible) method names there are. If none, we do not (and * should not) try to sort the list of them. */ - i = 0; - if (names.numEntries != 0) { - const char **strings; + if (namesPtr->numEntries == 0) { + *stringsPtr = NULL; + return 0; + } - /* - * We need to build the list of methods to sort. We will be using - * qsort() for this, because it is very unlikely that the list will be - * heavily sorted when it is long enough to matter. - */ + /* + * We need to build the list of methods to sort. We will be using qsort() + * for this, because it is very unlikely that the list will be heavily + * sorted when it is long enough to matter. + */ - strings = ckalloc(sizeof(char *) * names.numEntries); - FOREACH_HASH(namePtr, isWanted, &names) { - if (!(flags & PUBLIC_METHOD) || (PTR2INT(isWanted) & IN_LIST)) { - if (PTR2INT(isWanted) & NO_IMPLEMENTATION) { - continue; - } - strings[i++] = TclGetString(namePtr); + strings = ckalloc(sizeof(char *) * namesPtr->numEntries); + FOREACH_HASH(namePtr, isWanted, namesPtr) { + if (!WANT_PUBLIC(flags) || (PTR2INT(isWanted) & IN_LIST)) { + if (PTR2INT(isWanted) & NO_IMPLEMENTATION) { + continue; } + strings[i++] = TclGetString(namePtr); } + } - /* - * Note that 'i' may well be less than names.numEntries when we are - * dealing with public method names. - */ + /* + * Note that 'i' may well be less than names.numEntries when we are + * dealing with public method names. We don't sort unless there's at least + * two method names. + */ - if (i > 0) { - if (i > 1) { - qsort((void *) strings, (unsigned) i, sizeof(char *), CmpStr); - } - *stringsPtr = strings; - } else { - ckfree(strings); + if (i > 0) { + if (i > 1) { + qsort((void *) strings, i, sizeof(char *), CmpStr); } + *stringsPtr = strings; + } else { + ckfree(strings); + *stringsPtr = NULL; } - - Tcl_DeleteHashTable(&names); return i; } /* - * Comparator for GetSortedMethodList + * Comparator for SortMethodNames */ static int @@ -617,6 +686,8 @@ AddClassMethodNames( * pointers to the classes, and the values are * immaterial. */ { + int i; + /* * If we've already started looking at this class, stop working on it now * to prevent repeated work. @@ -647,7 +718,6 @@ AddClassMethodNames( if (clsPtr->mixins.num != 0) { Class *mixinPtr; - int i; FOREACH(mixinPtr, clsPtr->mixins) { if (mixinPtr != clsPtr) { @@ -658,20 +728,7 @@ AddClassMethodNames( } FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) { - hPtr = Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew); - if (isNew) { - 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) { - int isWanted = PTR2INT(Tcl_GetHashValue(hPtr)); - - isWanted &= ~NO_IMPLEMENTATION; - Tcl_SetHashValue(hPtr, INT2PTR(isWanted)); - } + AddStandardMethodName(flags, namePtr, mPtr, namesPtr); } if (clsPtr->superclasses.num != 1) { @@ -681,7 +738,6 @@ AddClassMethodNames( } if (clsPtr->superclasses.num != 0) { Class *superPtr; - int i; FOREACH(superPtr, clsPtr->superclasses) { AddClassMethodNames(superPtr, flags, namesPtr, @@ -693,19 +749,121 @@ AddClassMethodNames( /* * ---------------------------------------------------------------------- * + * AddPrivateMethodNames, AddStandardMethodName -- + * + * Factored-out helpers for the sorted name list production functions. + * + * ---------------------------------------------------------------------- + */ + +static inline void +AddPrivateMethodNames( + Tcl_HashTable *methodsTablePtr, + Tcl_HashTable *namesPtr) +{ + FOREACH_HASH_DECLS; + Method *mPtr; + Tcl_Obj *namePtr; + + FOREACH_HASH(namePtr, mPtr, methodsTablePtr) { + if (IS_PRIVATE(mPtr)) { + int isNew; + + hPtr = Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew); + Tcl_SetHashValue(hPtr, INT2PTR(IN_LIST)); + } + } +} + +static inline void +AddStandardMethodName( + int flags, + Tcl_Obj *namePtr, + Method *mPtr, + Tcl_HashTable *namesPtr) +{ + if (!IS_PRIVATE(mPtr)) { + int isNew; + Tcl_HashEntry *hPtr = + Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew); + + if (isNew) { + int isWanted = (!WANT_PUBLIC(flags) || IS_PUBLIC(mPtr)) + ? 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) { + int isWanted = PTR2INT(Tcl_GetHashValue(hPtr)); + + isWanted &= ~NO_IMPLEMENTATION; + Tcl_SetHashValue(hPtr, INT2PTR(isWanted)); + } + } +} + +#undef IN_LIST +#undef NO_IMPLEMENTATION + +/* + * ---------------------------------------------------------------------- + * + * AddInstancePrivateToCallContext -- + * + * Add private methods from the instance. Called when the calling Tcl + * context is a TclOO method declared by an object that is the same as + * the current object. Returns true iff a private method was actually + * found and added to the call chain (as this suppresses caching). + * + * ---------------------------------------------------------------------- + */ + +static inline int +AddInstancePrivateToCallContext( + Object *const oPtr, /* Object to add call chain entries for. */ + Tcl_Obj *const methodName, /* Name of method to add the call chain + * entries for. */ + struct ChainBuilder *const cbPtr, + /* Where to add the call chain entries. */ + int flags) /* What sort of call chain are we building. */ +{ + Tcl_HashEntry *hPtr; + Method *mPtr; + int donePrivate = 0; + + if (oPtr->methodsPtr) { + hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodName); + if (hPtr != NULL) { + mPtr = Tcl_GetHashValue(hPtr); + if (IS_PRIVATE(mPtr)) { + AddMethodToCallChain(mPtr, cbPtr, NULL, NULL, flags); + donePrivate = 1; + } + } + } + return donePrivate; +} + +/* + * ---------------------------------------------------------------------- + * * AddSimpleChainToCallContext -- * * The core of the call-chain construction engine, this handles calling a * particular method on a particular object. Note that filters and * unknown handling are already handled by the logic that uses this - * function. + * function. Returns true if a private method was one of those found. * * ---------------------------------------------------------------------- */ -static inline void +static inline int AddSimpleChainToCallContext( Object *const oPtr, /* Object to add call chain entries for. */ + Class *const contextCls, /* Context class; the currently considered + * class is equal to this, private methods may + * also be added. [TIP 500] */ Tcl_Obj *const methodNameObj, /* Name of method to add the call chain * entries for. */ @@ -719,44 +877,62 @@ AddSimpleChainToCallContext( * NULL, either the filter was declared by the * object or this isn't a filter. */ { - int i; + int i, foundPrivate = 0, blockedUnexported = 0; + Tcl_HashEntry *hPtr; + Method *mPtr; if (!(flags & (KNOWN_STATE | SPECIAL)) && oPtr->methodsPtr) { - Tcl_HashEntry *hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, - (char *) methodNameObj); + hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodNameObj); if (hPtr != NULL) { - Method *mPtr = Tcl_GetHashValue(hPtr); - - if (flags & PUBLIC_METHOD) { - if (!(mPtr->flags & PUBLIC_METHOD)) { - return; + mPtr = Tcl_GetHashValue(hPtr); + if (!IS_PRIVATE(mPtr)) { + if (WANT_PUBLIC(flags)) { + if (!IS_PUBLIC(mPtr)) { + blockedUnexported = 1; + } else { + flags |= DEFINITE_PUBLIC; + } } else { - flags |= DEFINITE_PUBLIC; + flags |= DEFINITE_PROTECTED; } - } else { - flags |= DEFINITE_PROTECTED; } } } if (!(flags & SPECIAL)) { - Tcl_HashEntry *hPtr; Class *mixinPtr; FOREACH(mixinPtr, oPtr->mixins) { - AddSimpleClassChainToCallContext(mixinPtr, methodNameObj, cbPtr, - doneFilters, flags|TRAVERSED_MIXIN, filterDecl); + if (contextCls) { + foundPrivate |= AddPrivatesFromClassChainToCallContext( + mixinPtr, contextCls, methodNameObj, cbPtr, + doneFilters, flags|TRAVERSED_MIXIN, filterDecl); + } + foundPrivate |= AddSimpleClassChainToCallContext(mixinPtr, + methodNameObj, cbPtr, doneFilters, + flags | TRAVERSED_MIXIN, filterDecl); } - if (oPtr->methodsPtr) { + if (oPtr->methodsPtr && !blockedUnexported) { hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char*) methodNameObj); if (hPtr != NULL) { - AddMethodToCallChain(Tcl_GetHashValue(hPtr), cbPtr, - doneFilters, filterDecl, flags); + mPtr = Tcl_GetHashValue(hPtr); + if (!IS_PRIVATE(mPtr)) { + AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl, + flags); + } } } } - AddSimpleClassChainToCallContext(oPtr->selfCls, methodNameObj, cbPtr, - doneFilters, flags, filterDecl); + if (contextCls) { + foundPrivate |= AddPrivatesFromClassChainToCallContext(oPtr->selfCls, + contextCls, methodNameObj, cbPtr, doneFilters, flags, + filterDecl); + } + if (!blockedUnexported) { + foundPrivate |= AddSimpleClassChainToCallContext(oPtr->selfCls, + methodNameObj, cbPtr, doneFilters, flags, filterDecl); + } + return foundPrivate; } /* @@ -819,8 +995,8 @@ AddMethodToCallChain( * should be sufficient for [incr Tcl] support though. */ - if (!(callPtr->flags & PRIVATE_METHOD) - && (mPtr->flags & PRIVATE_METHOD) + if (!WANT_UNEXPORTED(callPtr->flags) + && IS_UNEXPORTED(mPtr) && (mPtr->declaringClassPtr != NULL) && (mPtr->declaringClassPtr != cbPtr->oPtr->selfCls)) { return; @@ -908,6 +1084,7 @@ InitCallChain( * ---------------------------------------------------------------------- * * IsStillValid -- + * * Calculates whether the given call chain can be used for executing a * method for the given object. The condition on a chain from a cached * location being reusable is: @@ -959,6 +1136,12 @@ TclOOGetCallContext( * Only the bits PUBLIC_METHOD, CONSTRUCTOR, * PRIVATE_METHOD, DESTRUCTOR and * FILTER_HANDLING are useful. */ + Object *contextObj, /* Context object; when equal to oPtr, it + * means that private methods may also be + * added. [TIP 500] */ + Class *contextCls, /* Context class; the currently considered + * class is equal to this, private methods may + * also be added. [TIP 500] */ Tcl_Obj *cacheInThisObj) /* What object to cache in, or NULL if it is * to be in the same object as the * methodNameObj. */ @@ -966,7 +1149,7 @@ TclOOGetCallContext( CallContext *contextPtr; CallChain *callPtr; struct ChainBuilder cb; - int i, count, doFilters; + int i, count, doFilters, donePrivate = 0; Tcl_HashEntry *hPtr; Tcl_HashTable doneFilters; @@ -1006,15 +1189,16 @@ TclOOGetCallContext( * the object, and in the class). */ - const int reuseMask = ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD); + const Tcl_ObjIntRep *irPtr; + const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD); - if (cacheInThisObj->typePtr == &methodNameType) { - callPtr = cacheInThisObj->internalRep.twoPtrValue.ptr1; + if ((irPtr = TclFetchIntRep(cacheInThisObj, &methodNameType))) { + callPtr = irPtr->twoPtrValue.ptr1; if (IsStillValid(callPtr, oPtr, flags, reuseMask)) { callPtr->refCount++; goto returnContext; } - FreeMethodNameRep(cacheInThisObj); + Tcl_StoreIntRep(cacheInThisObj, &methodNameType, NULL); } if (oPtr->flags & USE_CLASS_CACHE) { @@ -1058,10 +1242,11 @@ TclOOGetCallContext( */ if (flags & FORCE_UNKNOWN) { - AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj, - &cb, NULL, BUILDING_MIXINS, NULL); - AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj, - &cb, NULL, 0, NULL); + AddSimpleChainToCallContext(oPtr, NULL, + oPtr->fPtr->unknownMethodNameObj, &cb, NULL, BUILDING_MIXINS, + NULL); + AddSimpleChainToCallContext(oPtr, NULL, + oPtr->fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL); callPtr->flags |= OO_UNKNOWN_METHOD; callPtr->epoch = -1; if (callPtr->numChain == 0) { @@ -1090,10 +1275,10 @@ TclOOGetCallContext( OBJECT_MIXIN); } FOREACH(filterObj, oPtr->filters) { - AddSimpleChainToCallContext(oPtr, filterObj, &cb, &doneFilters, - BUILDING_MIXINS, NULL); - AddSimpleChainToCallContext(oPtr, filterObj, &cb, &doneFilters, 0, - NULL); + donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls, + filterObj, &cb, &doneFilters, BUILDING_MIXINS, NULL); + donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls, + filterObj, &cb, &doneFilters, 0, NULL); } AddClassFiltersToCallContext(oPtr, oPtr->selfCls, &cb, &doneFilters, BUILDING_MIXINS); @@ -1108,9 +1293,15 @@ TclOOGetCallContext( * handle class mixins right. */ - AddSimpleChainToCallContext(oPtr, methodNameObj, &cb, NULL, - flags|BUILDING_MIXINS, NULL); - AddSimpleChainToCallContext(oPtr, methodNameObj, &cb, NULL, flags, NULL); + if (oPtr == contextObj) { + donePrivate |= AddInstancePrivateToCallContext(oPtr, methodNameObj, + &cb, flags); + donePrivate |= (contextObj->flags & HAS_PRIVATE_METHODS); + } + donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls, + methodNameObj, &cb, NULL, flags|BUILDING_MIXINS, NULL); + donePrivate |= AddSimpleChainToCallContext(oPtr, contextCls, + methodNameObj, &cb, NULL, flags, NULL); /* * Check to see if the method has no implementation. If so, we probably @@ -1128,17 +1319,18 @@ TclOOGetCallContext( TclOODeleteChain(callPtr); return NULL; } - AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj, - &cb, NULL, BUILDING_MIXINS, NULL); - AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj, - &cb, NULL, 0, NULL); + AddSimpleChainToCallContext(oPtr, NULL, + oPtr->fPtr->unknownMethodNameObj, &cb, NULL, BUILDING_MIXINS, + NULL); + AddSimpleChainToCallContext(oPtr, NULL, + oPtr->fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL); callPtr->flags |= OO_UNKNOWN_METHOD; callPtr->epoch = -1; if (count == callPtr->numChain) { TclOODeleteChain(callPtr); return NULL; } - } else if (doFilters) { + } else if (doFilters && !donePrivate) { if (hPtr == NULL) { if (oPtr->flags & USE_CLASS_CACHE) { if (oPtr->selfCls->classChainCache == NULL) { @@ -1244,8 +1436,7 @@ TclOOGetStereotypeCallChain( hPtr = Tcl_FindHashEntry(clsPtr->classChainCache, (char *) methodNameObj); if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) { - const int reuseMask = - ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD); + const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD); callPtr = Tcl_GetHashValue(hPtr); if (IsStillValid(callPtr, &obj, flags, reuseMask)) { @@ -1289,9 +1480,10 @@ TclOOGetStereotypeCallChain( * Add the actual method implementations. */ - AddSimpleChainToCallContext(&obj, methodNameObj, &cb, NULL, + AddSimpleChainToCallContext(&obj, NULL, methodNameObj, &cb, NULL, flags|BUILDING_MIXINS, NULL); - AddSimpleChainToCallContext(&obj, methodNameObj, &cb, NULL, flags, NULL); + AddSimpleChainToCallContext(&obj, NULL, methodNameObj, &cb, NULL, flags, + NULL); /* * Check to see if the method has no implementation. If so, we probably @@ -1300,10 +1492,10 @@ TclOOGetStereotypeCallChain( */ if (count == callPtr->numChain) { - AddSimpleChainToCallContext(&obj, fPtr->unknownMethodNameObj, &cb, - NULL, BUILDING_MIXINS, NULL); - AddSimpleChainToCallContext(&obj, fPtr->unknownMethodNameObj, &cb, - NULL, 0, NULL); + AddSimpleChainToCallContext(&obj, NULL, fPtr->unknownMethodNameObj, + &cb, NULL, BUILDING_MIXINS, NULL); + AddSimpleChainToCallContext(&obj, NULL, fPtr->unknownMethodNameObj, + &cb, NULL, 0, NULL); callPtr->flags |= OO_UNKNOWN_METHOD; callPtr->epoch = -1; if (count == callPtr->numChain) { @@ -1383,9 +1575,9 @@ AddClassFiltersToCallContext( (void) Tcl_CreateHashEntry(doneFilters, (char *) filterObj, &isNew); if (isNew) { - AddSimpleChainToCallContext(oPtr, filterObj, cbPtr, + AddSimpleChainToCallContext(oPtr, NULL, filterObj, cbPtr, doneFilters, clearedFlags|BUILDING_MIXINS, clsPtr); - AddSimpleChainToCallContext(oPtr, filterObj, cbPtr, + AddSimpleChainToCallContext(oPtr, NULL, filterObj, cbPtr, doneFilters, clearedFlags, clsPtr); } } @@ -1412,6 +1604,87 @@ AddClassFiltersToCallContext( /* * ---------------------------------------------------------------------- * + * AddPrivatesFromClassChainToCallContext -- + * + * Helper for AddSimpleChainToCallContext that is used to find private + * methds and add them to the call chain. Returns true when a private + * method is found and added. [TIP 500] + * + * ---------------------------------------------------------------------- + */ + +static int +AddPrivatesFromClassChainToCallContext( + Class *classPtr, /* Class to add the call chain entries for. */ + Class *const contextCls, /* Context class; the currently considered + * class is equal to this, private methods may + * also be added. */ + Tcl_Obj *const methodName, /* Name of method to add the call chain + * entries for. */ + struct ChainBuilder *const cbPtr, + /* Where to add the call chain entries. */ + Tcl_HashTable *const doneFilters, + /* Where to record what call chain entries + * have been processed. */ + int flags, /* What sort of call chain are we building. */ + Class *const filterDecl) /* The class that declared the filter. If + * NULL, either the filter was declared by the + * object or this isn't a filter. */ +{ + int i; + Class *superPtr; + + /* + * We hard-code the tail-recursive form. It's by far the most common case + * *and* it is much more gentle on the stack. + * + * Note that mixins must be processed before the main class hierarchy. + * [Bug 1998221] + */ + + tailRecurse: + FOREACH(superPtr, classPtr->mixins) { + if (AddPrivatesFromClassChainToCallContext(superPtr, contextCls, + methodName, cbPtr, doneFilters, flags|TRAVERSED_MIXIN, + filterDecl)) { + return 1; + } + } + + if (classPtr == contextCls) { + Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods, + (char *) methodName); + + if (hPtr != NULL) { + register Method *mPtr = Tcl_GetHashValue(hPtr); + + if (IS_PRIVATE(mPtr)) { + AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl, + flags); + return 1; + } + } + } + + switch (classPtr->superclasses.num) { + case 1: + classPtr = classPtr->superclasses.list[0]; + goto tailRecurse; + default: + FOREACH(superPtr, classPtr->superclasses) { + if (AddPrivatesFromClassChainToCallContext(superPtr, contextCls, + methodName, cbPtr, doneFilters, flags, filterDecl)) { + return 1; + } + } + case 0: + return 0; + } +} + +/* + * ---------------------------------------------------------------------- + * * AddSimpleClassChainToCallContext -- * * Construct a call-chain from a class hierarchy. @@ -1419,7 +1692,7 @@ AddClassFiltersToCallContext( * ---------------------------------------------------------------------- */ -static void +static int AddSimpleClassChainToCallContext( Class *classPtr, /* Class to add the call chain entries for. */ Tcl_Obj *const methodNameObj, @@ -1435,7 +1708,7 @@ AddSimpleClassChainToCallContext( * NULL, either the filter was declared by the * object or this isn't a filter. */ { - int i; + int i, privateDanger = 0; Class *superPtr; /* @@ -1448,8 +1721,9 @@ AddSimpleClassChainToCallContext( tailRecurse: FOREACH(superPtr, classPtr->mixins) { - AddSimpleClassChainToCallContext(superPtr, methodNameObj, cbPtr, - doneFilters, flags|TRAVERSED_MIXIN, filterDecl); + privateDanger |= AddSimpleClassChainToCallContext(superPtr, + methodNameObj, cbPtr, doneFilters, flags | TRAVERSED_MIXIN, + filterDecl); } if (flags & CONSTRUCTOR) { @@ -1462,21 +1736,26 @@ AddSimpleClassChainToCallContext( Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods, (char *) methodNameObj); + if (classPtr->flags & HAS_PRIVATE_METHODS) { + privateDanger |= 1; + } if (hPtr != NULL) { register Method *mPtr = Tcl_GetHashValue(hPtr); - if (!(flags & KNOWN_STATE)) { - if (flags & PUBLIC_METHOD) { - if (mPtr->flags & PUBLIC_METHOD) { + if (!IS_PRIVATE(mPtr)) { + if (!(flags & KNOWN_STATE)) { + if (flags & PUBLIC_METHOD) { + if (!IS_PUBLIC(mPtr)) { + return privateDanger; + } flags |= DEFINITE_PUBLIC; } else { - return; + flags |= DEFINITE_PROTECTED; } - } else { - flags |= DEFINITE_PROTECTED; } + AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl, + flags); } - AddMethodToCallChain(mPtr, cbPtr, doneFilters, filterDecl, flags); } } @@ -1486,11 +1765,11 @@ AddSimpleClassChainToCallContext( goto tailRecurse; default: FOREACH(superPtr, classPtr->superclasses) { - AddSimpleClassChainToCallContext(superPtr, methodNameObj, cbPtr, - doneFilters, flags, filterDecl); + privateDanger |= AddSimpleClassChainToCallContext(superPtr, + methodNameObj, cbPtr, doneFilters, flags, filterDecl); } case 0: - return; + return privateDanger; } } @@ -1510,7 +1789,7 @@ TclOORenderCallChain( Tcl_Interp *interp, CallChain *callPtr) { - Tcl_Obj *filterLiteral, *methodLiteral, *objectLiteral; + Tcl_Obj *filterLiteral, *methodLiteral, *objectLiteral, *privateLiteral; Tcl_Obj *resultObj, *descObjs[4], **objv; Foundation *fPtr = TclOOGetFoundation(interp); int i; @@ -1519,12 +1798,14 @@ TclOORenderCallChain( * Allocate the literals (potentially) used in our description. */ - filterLiteral = Tcl_NewStringObj("filter", -1); + TclNewLiteralStringObj(filterLiteral, "filter"); Tcl_IncrRefCount(filterLiteral); - methodLiteral = Tcl_NewStringObj("method", -1); + TclNewLiteralStringObj(methodLiteral, "method"); Tcl_IncrRefCount(methodLiteral); - objectLiteral = Tcl_NewStringObj("object", -1); + TclNewLiteralStringObj(objectLiteral, "object"); Tcl_IncrRefCount(objectLiteral); + TclNewLiteralStringObj(privateLiteral, "private"); + Tcl_IncrRefCount(privateLiteral); /* * Do the actual construction of the descriptions. They consist of a list @@ -1542,16 +1823,15 @@ TclOORenderCallChain( for (i = 0 ; i < callPtr->numChain ; i++) { struct MInvoke *miPtr = &callPtr->chain[i]; - descObjs[0] = miPtr->isFilter - ? filterLiteral - : callPtr->flags & OO_UNKNOWN_METHOD - ? fPtr->unknownMethodNameObj - : methodLiteral; - descObjs[1] = callPtr->flags & CONSTRUCTOR - ? fPtr->constructorName - : callPtr->flags & DESTRUCTOR - ? fPtr->destructorName - : miPtr->mPtr->namePtr; + descObjs[0] = + miPtr->isFilter ? filterLiteral : + callPtr->flags & OO_UNKNOWN_METHOD ? fPtr->unknownMethodNameObj : + IS_PRIVATE(miPtr->mPtr) ? privateLiteral : + methodLiteral; + descObjs[1] = + callPtr->flags & CONSTRUCTOR ? fPtr->constructorName : + callPtr->flags & DESTRUCTOR ? fPtr->destructorName : + miPtr->mPtr->namePtr; descObjs[2] = miPtr->mPtr->declaringClassPtr ? Tcl_GetObjectName(interp, (Tcl_Object) miPtr->mPtr->declaringClassPtr->thisPtr) @@ -1569,6 +1849,7 @@ TclOORenderCallChain( Tcl_DecrRefCount(filterLiteral); Tcl_DecrRefCount(methodLiteral); Tcl_DecrRefCount(objectLiteral); + Tcl_DecrRefCount(privateLiteral); /* * Finish building the description and return it. @@ -1580,6 +1861,246 @@ TclOORenderCallChain( } /* + * ---------------------------------------------------------------------- + * + * TclOOGetDefineContextNamespace -- + * + * Responsible for determining which namespace to use for definitions. + * This is done by building a define chain, which models (strongly!) the + * way that a call chain works but with a different internal model. + * + * Then it walks the chain to find the first namespace name that actually + * resolves to an existing namespace. + * + * Returns: + * Name of namespace, or NULL if none can be found. Note that this + * function does *not* set an error message in the interpreter on failure. + * + * ---------------------------------------------------------------------- + */ + +#define DEFINE_CHAIN_STATIC_SIZE 4 /* Enough space to store most cases. */ + +Tcl_Namespace * +TclOOGetDefineContextNamespace( + Tcl_Interp *interp, /* In what interpreter should namespace names + * actually be resolved. */ + Object *oPtr, /* The object to get the context for. */ + int forClass) /* What sort of context are we looking for. + * If true, we are going to use this for + * [oo::define], otherwise, we are going to + * use this for [oo::objdefine]. */ +{ + DefineChain define; + DefineEntry staticSpace[DEFINE_CHAIN_STATIC_SIZE]; + DefineEntry *entryPtr; + Tcl_Namespace *nsPtr = NULL; + int i; + + define.list = staticSpace; + define.num = 0; + define.size = DEFINE_CHAIN_STATIC_SIZE; + + /* + * Add the actual define locations. We have to do this twice to handle + * class mixins right. + */ + + AddSimpleDefineNamespaces(oPtr, &define, forClass | BUILDING_MIXINS); + AddSimpleDefineNamespaces(oPtr, &define, forClass); + + /* + * Go through the list until we find a namespace whose name we can + * resolve. + */ + + FOREACH_STRUCT(entryPtr, define) { + if (TclGetNamespaceFromObj(interp, entryPtr->namespaceName, + &nsPtr) == TCL_OK) { + break; + } + Tcl_ResetResult(interp); + } + if (define.list != staticSpace) { + ckfree(define.list); + } + return nsPtr; +} + +/* + * ---------------------------------------------------------------------- + * + * AddSimpleDefineNamespaces -- + * + * Adds to the definition chain all the definitions provided by an + * object's class and its mixins, taking into account everything they + * inherit from. + * + * ---------------------------------------------------------------------- + */ + +static inline void +AddSimpleDefineNamespaces( + Object *const oPtr, /* Object to add define chain entries for. */ + DefineChain *const definePtr, + /* Where to add the define chain entries. */ + int flags) /* What sort of define chain are we + * building. */ +{ + Class *mixinPtr; + int i; + + FOREACH(mixinPtr, oPtr->mixins) { + AddSimpleClassDefineNamespaces(mixinPtr, definePtr, + flags | TRAVERSED_MIXIN); + } + + AddSimpleClassDefineNamespaces(oPtr->selfCls, definePtr, flags); +} + +/* + * ---------------------------------------------------------------------- + * + * AddSimpleClassDefineNamespaces -- + * + * Adds to the definition chain all the definitions provided by a class + * and its superclasses and its class mixins. + * + * ---------------------------------------------------------------------- + */ + +static void +AddSimpleClassDefineNamespaces( + Class *classPtr, /* Class to add the define chain entries for. */ + DefineChain *const definePtr, + /* Where to add the define chain entries. */ + int flags) /* What sort of define chain are we + * building. */ +{ + int i; + Class *superPtr; + + /* + * We hard-code the tail-recursive form. It's by far the most common case + * *and* it is much more gentle on the stack. + */ + + tailRecurse: + FOREACH(superPtr, classPtr->mixins) { + AddSimpleClassDefineNamespaces(superPtr, definePtr, + flags | TRAVERSED_MIXIN); + } + + if (flags & ~(TRAVERSED_MIXIN | BUILDING_MIXINS)) { + AddDefinitionNamespaceToChain(classPtr, classPtr->clsDefinitionNs, + definePtr, flags); + } else { + AddDefinitionNamespaceToChain(classPtr, classPtr->objDefinitionNs, + definePtr, flags); + } + + switch (classPtr->superclasses.num) { + case 1: + classPtr = classPtr->superclasses.list[0]; + goto tailRecurse; + default: + FOREACH(superPtr, classPtr->superclasses) { + AddSimpleClassDefineNamespaces(superPtr, definePtr, flags); + } + case 0: + return; + } +} + +/* + * ---------------------------------------------------------------------- + * + * AddDefinitionNamespaceToChain -- + * + * Adds a single item to the definition chain (if it is meaningful), + * reallocating the space for the chain if necessary. + * + * ---------------------------------------------------------------------- + */ + +static inline void +AddDefinitionNamespaceToChain( + Class *const definerCls, /* What class defines this entry. */ + Tcl_Obj *const namespaceName, /* The name for this entry (or NULL, a + * no-op). */ + DefineChain *const definePtr, + /* The define chain to add the method + * implementation to. */ + int flags) /* Used to check if we're mixin-consistent + * only. Mixin-consistent means that either + * we're looking to add things from a mixin + * and we have passed a mixin, or we're not + * looking to add things from a mixin and have + * not passed a mixin. */ +{ + int i; + + /* + * Return if this entry is blank. This is also where we enforce + * mixin-consistency. + */ + + if (namespaceName == NULL || !MIXIN_CONSISTENT(flags)) { + return; + } + + /* + * First test whether the method is already in the call chain. + */ + + for (i=0 ; i<definePtr->num ; i++) { + if (definePtr->list[i].definerCls == definerCls) { + /* + * Call chain semantics states that methods come as *late* in the + * call chain as possible. This is done by copying down the + * following methods. Note that this does not change the number of + * method invocations in the call chain; it just rearranges them. + * + * We skip changing anything if the place we found was already at + * the end of the list. + */ + + if (i < definePtr->num - 1) { + memmove(&definePtr->list[i], &definePtr->list[i + 1], + sizeof(DefineEntry) * (definePtr->num - i - 1)); + definePtr->list[i].definerCls = definerCls; + definePtr->list[i].namespaceName = namespaceName; + } + return; + } + } + + /* + * Need to really add the define. This is made a bit more complex by the + * fact that we are using some "static" space initially, and only start + * realloc-ing if the chain gets long. + */ + + if (definePtr->num == definePtr->size) { + definePtr->size *= 2; + if (definePtr->num == DEFINE_CHAIN_STATIC_SIZE) { + DefineEntry *staticList = definePtr->list; + + definePtr->list = + ckalloc(sizeof(DefineEntry) * definePtr->size); + memcpy(definePtr->list, staticList, + sizeof(DefineEntry) * definePtr->num); + } else { + definePtr->list = ckrealloc(definePtr->list, + sizeof(DefineEntry) * definePtr->size); + } + } + definePtr->list[i].definerCls = definerCls; + definePtr->list[i].namespaceName = namespaceName; + definePtr->num++; +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h index 9fd62ec..928d07e 100644 --- a/generic/tclOODecls.h +++ b/generic/tclOODecls.h @@ -59,11 +59,11 @@ TCLAPI Tcl_Obj * Tcl_MethodName(Tcl_Method method); /* 11 */ TCLAPI Tcl_Method Tcl_NewInstanceMethod(Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, - int isPublic, const Tcl_MethodType *typePtr, + int flags, const Tcl_MethodType *typePtr, ClientData clientData); /* 12 */ TCLAPI Tcl_Method Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls, - Tcl_Obj *nameObj, int isPublic, + Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, ClientData clientData); /* 13 */ @@ -116,6 +116,8 @@ TCLAPI void Tcl_ClassSetDestructor(Tcl_Interp *interp, /* 28 */ TCLAPI Tcl_Obj * Tcl_GetObjectName(Tcl_Interp *interp, Tcl_Object object); +/* 29 */ +TCLAPI int Tcl_MethodIsPrivate(Tcl_Method method); typedef struct { const struct TclOOIntStubs *tclOOIntStubs; @@ -136,8 +138,8 @@ typedef struct TclOOStubs { int (*tcl_MethodIsPublic) (Tcl_Method method); /* 8 */ int (*tcl_MethodIsType) (Tcl_Method method, const Tcl_MethodType *typePtr, ClientData *clientDataPtr); /* 9 */ Tcl_Obj * (*tcl_MethodName) (Tcl_Method method); /* 10 */ - Tcl_Method (*tcl_NewInstanceMethod) (Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 11 */ - Tcl_Method (*tcl_NewMethod) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int isPublic, const Tcl_MethodType *typePtr, ClientData clientData); /* 12 */ + Tcl_Method (*tcl_NewInstanceMethod) (Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, ClientData clientData); /* 11 */ + Tcl_Method (*tcl_NewMethod) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int flags, const Tcl_MethodType *typePtr, ClientData clientData); /* 12 */ Tcl_Object (*tcl_NewObjectInstance) (Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, int objc, Tcl_Obj *const *objv, int skip); /* 13 */ int (*tcl_ObjectDeleted) (Tcl_Object object); /* 14 */ int (*tcl_ObjectContextIsFiltering) (Tcl_ObjectContext context); /* 15 */ @@ -154,6 +156,7 @@ typedef struct TclOOStubs { void (*tcl_ClassSetConstructor) (Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 26 */ void (*tcl_ClassSetDestructor) (Tcl_Interp *interp, Tcl_Class clazz, Tcl_Method method); /* 27 */ Tcl_Obj * (*tcl_GetObjectName) (Tcl_Interp *interp, Tcl_Object object); /* 28 */ + int (*tcl_MethodIsPrivate) (Tcl_Method method); /* 29 */ } TclOOStubs; extern const TclOOStubs *tclOOStubsPtr; @@ -226,6 +229,8 @@ extern const TclOOStubs *tclOOStubsPtr; (tclOOStubsPtr->tcl_ClassSetDestructor) /* 27 */ #define Tcl_GetObjectName \ (tclOOStubsPtr->tcl_GetObjectName) /* 28 */ +#define Tcl_MethodIsPrivate \ + (tclOOStubsPtr->tcl_MethodIsPrivate) /* 29 */ #endif /* defined(USE_TCLOO_STUBS) */ diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index f02e1d3..fb16007 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -17,6 +17,12 @@ #include "tclOOInt.h" /* + * The actual value used to mark private declaration frames. + */ + +#define PRIVATE_FRAME (FRAME_IS_OO_DEFINE | FRAME_IS_PRIVATE_DEFINE) + +/* * The maximum length of fully-qualified object name to use in an errorinfo * message. Longer than this will be curtailed. */ @@ -31,14 +37,17 @@ struct DeclaredSlot { const char *name; const Tcl_MethodType getterType; const Tcl_MethodType setterType; + const Tcl_MethodType resolverType; }; -#define SLOT(name,getter,setter) \ +#define SLOT(name,getter,setter,resolver) \ {"::oo::" name, \ {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Getter", \ getter, NULL, NULL}, \ {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Setter", \ - setter, NULL, NULL}} + setter, NULL, NULL}, \ + {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Resolver", \ + resolver, NULL, NULL}} /* * A [string match] pattern used to determine if a method should be exported. @@ -60,6 +69,8 @@ static inline int MagicDefinitionInvoke(Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); static inline Class * GetClassInOuterContext(Tcl_Interp *interp, Tcl_Obj *className, const char *errMsg); +static inline Tcl_Namespace *GetNamespaceInOuterContext(Tcl_Interp *interp, + Tcl_Obj *namespaceName); static inline int InitDefineContext(Tcl_Interp *interp, Tcl_Namespace *namespacePtr, Object *oPtr, int objc, Tcl_Obj *const objv[]); @@ -109,26 +120,59 @@ static int ObjVarsGet(ClientData clientData, static int ObjVarsSet(ClientData clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); +static int ResolveClass(ClientData clientData, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); /* * Now define the slots used in declarations. */ static const struct DeclaredSlot slots[] = { - SLOT("define::filter", ClassFilterGet, ClassFilterSet), - SLOT("define::mixin", ClassMixinGet, ClassMixinSet), - SLOT("define::superclass", ClassSuperGet, ClassSuperSet), - SLOT("define::variable", ClassVarsGet, ClassVarsSet), - SLOT("objdefine::filter", ObjFilterGet, ObjFilterSet), - SLOT("objdefine::mixin", ObjMixinGet, ObjMixinSet), - SLOT("objdefine::variable", ObjVarsGet, ObjVarsSet), - {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}} + SLOT("define::filter", ClassFilterGet, ClassFilterSet, NULL), + SLOT("define::mixin", ClassMixinGet, ClassMixinSet, ResolveClass), + SLOT("define::superclass", ClassSuperGet, ClassSuperSet, ResolveClass), + SLOT("define::variable", ClassVarsGet, ClassVarsSet, NULL), + SLOT("objdefine::filter", ObjFilterGet, ObjFilterSet, NULL), + SLOT("objdefine::mixin", ObjMixinGet, ObjMixinSet, ResolveClass), + SLOT("objdefine::variable", ObjVarsGet, ObjVarsSet, NULL), + {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}} }; + +/* + * How to build the in-namespace name of a private variable. This is a pattern + * used with Tcl_ObjPrintf(). + */ + +#define PRIVATE_VARIABLE_PATTERN "%d : %s" + +/* + * ---------------------------------------------------------------------- + * + * IsPrivateDefine -- + * + * Extracts whether the current context is handling private definitions. + * + * ---------------------------------------------------------------------- + */ + +static inline int +IsPrivateDefine( + Tcl_Interp *interp) +{ + Interp *iPtr = (Interp *) interp; + + if (!iPtr->varFramePtr) { + return 0; + } + return iPtr->varFramePtr->isProcCallFrame == PRIVATE_FRAME; +} /* * ---------------------------------------------------------------------- * * BumpGlobalEpoch -- + * * Utility that ensures that call chains that are invalid will get thrown * away at an appropriate time. Note that exactly which epoch gets * advanced will depend on exactly what the class is tangled up in; in @@ -173,6 +217,7 @@ BumpGlobalEpoch( * ---------------------------------------------------------------------- * * RecomputeClassCacheFlag -- + * * Determine whether the object is prototypical of its class, and hence * able to use the class's method chain cache. * @@ -195,6 +240,7 @@ RecomputeClassCacheFlag( * ---------------------------------------------------------------------- * * TclOOObjectSetFilters -- + * * Install a list of filter method names into an object. * * ---------------------------------------------------------------------- @@ -253,6 +299,7 @@ TclOOObjectSetFilters( * ---------------------------------------------------------------------- * * TclOOClassSetFilters -- + * * Install a list of filter method names into a class. * * ---------------------------------------------------------------------- @@ -315,6 +362,7 @@ TclOOClassSetFilters( * ---------------------------------------------------------------------- * * TclOOObjectSetMixins -- + * * Install a list of mixin classes into an object. * * ---------------------------------------------------------------------- @@ -374,6 +422,7 @@ TclOOObjectSetMixins( * ---------------------------------------------------------------------- * * TclOOClassSetMixins -- + * * Install a list of mixin classes into a class. * * ---------------------------------------------------------------------- @@ -427,7 +476,125 @@ TclOOClassSetMixins( /* * ---------------------------------------------------------------------- * + * InstallStandardVariableMapping, InstallPrivateVariableMapping -- + * + * Helpers for installing standard and private variable maps. + * + * ---------------------------------------------------------------------- + */ +static inline void +InstallStandardVariableMapping( + VariableNameList *vnlPtr, + int varc, + Tcl_Obj *const *varv) +{ + Tcl_Obj *variableObj; + int i, n, created; + Tcl_HashTable uniqueTable; + + for (i=0 ; i<varc ; i++) { + Tcl_IncrRefCount(varv[i]); + } + FOREACH(variableObj, *vnlPtr) { + Tcl_DecrRefCount(variableObj); + } + if (i != varc) { + if (varc == 0) { + ckfree(vnlPtr->list); + } else if (i) { + vnlPtr->list = ckrealloc(vnlPtr->list, sizeof(Tcl_Obj *) * varc); + } else { + vnlPtr->list = ckalloc(sizeof(Tcl_Obj *) * varc); + } + } + vnlPtr->num = 0; + if (varc > 0) { + Tcl_InitObjHashTable(&uniqueTable); + for (i=n=0 ; i<varc ; i++) { + Tcl_CreateHashEntry(&uniqueTable, varv[i], &created); + if (created) { + vnlPtr->list[n++] = varv[i]; + } else { + Tcl_DecrRefCount(varv[i]); + } + } + vnlPtr->num = n; + + /* + * Shouldn't be necessary, but maintain num/list invariant. + */ + + if (n != varc) { + vnlPtr->list = ckrealloc(vnlPtr->list, sizeof(Tcl_Obj *) * n); + } + Tcl_DeleteHashTable(&uniqueTable); + } +} + +static inline void +InstallPrivateVariableMapping( + PrivateVariableList *pvlPtr, + int varc, + Tcl_Obj *const *varv, + int creationEpoch) +{ + PrivateVariableMapping *privatePtr; + int i, n, created; + Tcl_HashTable uniqueTable; + + for (i=0 ; i<varc ; i++) { + Tcl_IncrRefCount(varv[i]); + } + FOREACH_STRUCT(privatePtr, *pvlPtr) { + Tcl_DecrRefCount(privatePtr->variableObj); + Tcl_DecrRefCount(privatePtr->fullNameObj); + } + if (i != varc) { + if (varc == 0) { + ckfree(pvlPtr->list); + } else if (i) { + pvlPtr->list = ckrealloc(pvlPtr->list, + sizeof(PrivateVariableMapping) * varc); + } else { + pvlPtr->list = ckalloc(sizeof(PrivateVariableMapping) * varc); + } + } + + pvlPtr->num = 0; + if (varc > 0) { + Tcl_InitObjHashTable(&uniqueTable); + for (i=n=0 ; i<varc ; i++) { + Tcl_CreateHashEntry(&uniqueTable, varv[i], &created); + if (created) { + privatePtr = &(pvlPtr->list[n++]); + privatePtr->variableObj = varv[i]; + privatePtr->fullNameObj = Tcl_ObjPrintf( + PRIVATE_VARIABLE_PATTERN, + creationEpoch, Tcl_GetString(varv[i])); + Tcl_IncrRefCount(privatePtr->fullNameObj); + } else { + Tcl_DecrRefCount(varv[i]); + } + } + pvlPtr->num = n; + + /* + * Shouldn't be necessary, but maintain num/list invariant. + */ + + if (n != varc) { + pvlPtr->list = ckrealloc(pvlPtr->list, + sizeof(PrivateVariableMapping) * n); + } + Tcl_DeleteHashTable(&uniqueTable); + } +} + +/* + * ---------------------------------------------------------------------- + * * RenameDeleteMethod -- + * * Core of the code to rename and delete methods. * * ---------------------------------------------------------------------- @@ -517,6 +684,7 @@ RenameDeleteMethod( * ---------------------------------------------------------------------- * * TclOOUnknownDefinition -- + * * Handles what happens when an unknown command is encountered during the * processing of a definition script. Works by finding a command in the * operating definition namespace that the requested command is a unique @@ -548,7 +716,7 @@ TclOOUnknownDefinition( return TCL_ERROR; } - soughtStr = Tcl_GetStringFromObj(objv[1], &soughtLen); + soughtStr = TclGetStringFromObj(objv[1], &soughtLen); if (soughtLen == 0) { goto noMatch; } @@ -596,6 +764,7 @@ TclOOUnknownDefinition( * ---------------------------------------------------------------------- * * FindCommand -- + * * Specialized version of Tcl_FindCommand that handles command prefixes * and disallows namespace magic. * @@ -609,7 +778,7 @@ FindCommand( Tcl_Namespace *const namespacePtr) { int length; - const char *nameStr, *string = Tcl_GetStringFromObj(stringObj, &length); + const char *nameStr, *string = TclGetStringFromObj(stringObj, &length); register Namespace *const nsPtr = (Namespace *) namespacePtr; FOREACH_HASH_DECLS; Tcl_Command cmd, cmd2; @@ -656,6 +825,7 @@ FindCommand( * ---------------------------------------------------------------------- * * InitDefineContext -- + * * Does the magic incantations necessary to push the special stack frame * used when processing object definitions. It is up to the caller to * dispose of the frame (with TclPopStackFrame) when finished. @@ -675,8 +845,7 @@ InitDefineContext( if (namespacePtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "cannot process definitions; support namespace deleted", - -1)); + "no definition namespace available", -1)); Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } @@ -698,6 +867,7 @@ InitDefineContext( * ---------------------------------------------------------------------- * * TclOOGetDefineCmdContext -- + * * Extracts the magic token from the current stack frame, or returns NULL * (and leaves an error message) otherwise. * @@ -712,7 +882,8 @@ TclOOGetDefineCmdContext( Tcl_Object object; if ((iPtr->varFramePtr == NULL) - || (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE)) { + || (iPtr->varFramePtr->isProcCallFrame != FRAME_IS_OO_DEFINE + && iPtr->varFramePtr->isProcCallFrame != PRIVATE_FRAME)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "this command may only be called from within the context of" " an ::oo::define or ::oo::objdefine command", -1)); @@ -733,11 +904,12 @@ TclOOGetDefineCmdContext( /* * ---------------------------------------------------------------------- * - * GetClassInOuterContext -- - * Wrapper round Tcl_GetObjectFromObj to perform the lookup in the - * context that called oo::define (or equivalent). Note that this may - * have to go up multiple levels to get the level that we started doing - * definitions at. + * GetClassInOuterContext, GetNamespaceInOuterContext -- + * + * Wrappers round Tcl_GetObjectFromObj and TclGetNamespaceFromObj to + * perform the lookup in the context that called oo::define (or + * equivalent). Note that this may have to go up multiple levels to get + * the level that we started doing definitions at. * * ---------------------------------------------------------------------- */ @@ -752,7 +924,8 @@ GetClassInOuterContext( Object *oPtr; CallFrame *savedFramePtr = iPtr->varFramePtr; - while (iPtr->varFramePtr->isProcCallFrame == FRAME_IS_OO_DEFINE) { + while (iPtr->varFramePtr->isProcCallFrame == FRAME_IS_OO_DEFINE + || iPtr->varFramePtr->isProcCallFrame == PRIVATE_FRAME) { if (iPtr->varFramePtr->callerVarPtr == NULL) { Tcl_Panic("getting outer context when already in global context"); } @@ -771,11 +944,37 @@ GetClassInOuterContext( } return oPtr->classPtr; } + +static inline Tcl_Namespace * +GetNamespaceInOuterContext( + Tcl_Interp *interp, + Tcl_Obj *namespaceName) +{ + Interp *iPtr = (Interp *) interp; + Tcl_Namespace *nsPtr; + int result; + CallFrame *savedFramePtr = iPtr->varFramePtr; + + while (iPtr->varFramePtr->isProcCallFrame == FRAME_IS_OO_DEFINE + || iPtr->varFramePtr->isProcCallFrame == PRIVATE_FRAME) { + if (iPtr->varFramePtr->callerVarPtr == NULL) { + Tcl_Panic("getting outer context when already in global context"); + } + iPtr->varFramePtr = iPtr->varFramePtr->callerVarPtr; + } + result = TclGetNamespaceFromObj(interp, namespaceName, &nsPtr); + iPtr->varFramePtr = savedFramePtr; + if (result != TCL_OK) { + return NULL; + } + return nsPtr; +} /* * ---------------------------------------------------------------------- * * GenerateErrorInfo -- + * * Factored out code to generate part of the error trace messages. * * ---------------------------------------------------------------------- @@ -800,7 +999,7 @@ GenerateErrorInfo( int length; Tcl_Obj *realNameObj = Tcl_ObjectDeleted((Tcl_Object) oPtr) ? savedNameObj : TclOOObjectName(interp, oPtr); - const char *objName = Tcl_GetStringFromObj(realNameObj, &length); + const char *objName = TclGetStringFromObj(realNameObj, &length); int limit = OBJNAME_LENGTH_IN_ERRORINFO_LIMIT; int overflow = (length > limit); @@ -814,6 +1013,7 @@ GenerateErrorInfo( * ---------------------------------------------------------------------- * * MagicDefinitionInvoke -- + * * Part of the implementation of the "oo::define" and "oo::objdefine" * commands that is used to implement the more-than-one-argument case, * applying ensemble-like tricks with dispatch so that error messages are @@ -880,6 +1080,7 @@ MagicDefinitionInvoke( * ---------------------------------------------------------------------- * * TclOODefineObjCmd -- + * * Implementation of the "oo::define" command. Works by effectively doing * the same as 'namespace eval', but with extra magic applied so that the * object to be modified is known to the commands in the target @@ -896,7 +1097,7 @@ TclOODefineObjCmd( int objc, Tcl_Obj *const *objv) { - Foundation *fPtr = TclOOGetFoundation(interp); + Tcl_Namespace *nsPtr; Object *oPtr; int result; @@ -911,7 +1112,7 @@ TclOODefineObjCmd( } if (oPtr->classPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%s does not refer to a class",TclGetString(objv[1]))); + "%s does not refer to a class", TclGetString(objv[1]))); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS", TclGetString(objv[1]), NULL); return TCL_ERROR; @@ -922,7 +1123,8 @@ TclOODefineObjCmd( * command(s). */ - if (InitDefineContext(interp, fPtr->defineNs, oPtr, objc,objv) != TCL_OK){ + nsPtr = TclOOGetDefineContextNamespace(interp, oPtr, 1); + if (InitDefineContext(interp, nsPtr, oPtr, objc, objv) != TCL_OK) { return TCL_ERROR; } @@ -938,7 +1140,7 @@ TclOODefineObjCmd( } TclDecrRefCount(objNameObj); } else { - result = MagicDefinitionInvoke(interp, fPtr->defineNs, 2, objc, objv); + result = MagicDefinitionInvoke(interp, nsPtr, 2, objc, objv); } TclOODecrRefCount(oPtr); @@ -954,6 +1156,7 @@ TclOODefineObjCmd( * ---------------------------------------------------------------------- * * TclOOObjDefObjCmd -- + * * Implementation of the "oo::objdefine" command. Works by effectively * doing the same as 'namespace eval', but with extra magic applied so * that the object to be modified is known to the commands in the target @@ -970,7 +1173,7 @@ TclOOObjDefObjCmd( int objc, Tcl_Obj *const *objv) { - Foundation *fPtr = TclOOGetFoundation(interp); + Tcl_Namespace *nsPtr; Object *oPtr; int result; @@ -989,7 +1192,8 @@ TclOOObjDefObjCmd( * command(s). */ - if (InitDefineContext(interp, fPtr->objdefNs, oPtr, objc,objv) != TCL_OK){ + nsPtr = TclOOGetDefineContextNamespace(interp, oPtr, 0); + if (InitDefineContext(interp, nsPtr, oPtr, objc, objv) != TCL_OK) { return TCL_ERROR; } @@ -1005,7 +1209,7 @@ TclOOObjDefObjCmd( } TclDecrRefCount(objNameObj); } else { - result = MagicDefinitionInvoke(interp, fPtr->objdefNs, 2, objc, objv); + result = MagicDefinitionInvoke(interp, nsPtr, 2, objc, objv); } TclOODecrRefCount(oPtr); @@ -1021,6 +1225,7 @@ TclOOObjDefObjCmd( * ---------------------------------------------------------------------- * * TclOODefineSelfObjCmd -- + * * Implementation of the "self" subcommand of the "oo::define" command. * Works by effectively doing the same as 'namespace eval', but with * extra magic applied so that the object to be modified is known to the @@ -1037,28 +1242,34 @@ TclOODefineSelfObjCmd( int objc, Tcl_Obj *const *objv) { - Foundation *fPtr = TclOOGetFoundation(interp); + Tcl_Namespace *nsPtr; Object *oPtr; - int result; - - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "arg ?arg ...?"); - return TCL_ERROR; - } + int result, isPrivate; oPtr = (Object *) TclOOGetDefineCmdContext(interp); if (oPtr == NULL) { return TCL_ERROR; } + if (objc < 2) { + Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr)); + return TCL_OK; + } + + isPrivate = IsPrivateDefine(interp); + /* * Make the oo::objdefine namespace the current namespace and evaluate the * command(s). */ - if (InitDefineContext(interp, fPtr->objdefNs, oPtr, objc,objv) != TCL_OK){ + nsPtr = TclOOGetDefineContextNamespace(interp, oPtr, 0); + if (InitDefineContext(interp, nsPtr, oPtr, objc, objv) != TCL_OK) { return TCL_ERROR; } + if (isPrivate) { + ((Interp *) interp)->varFramePtr->isProcCallFrame = PRIVATE_FRAME; + } AddRef(oPtr); if (objc == 2) { @@ -1066,13 +1277,13 @@ TclOODefineSelfObjCmd( Tcl_IncrRefCount(objNameObj); result = TclEvalObjEx(interp, objv[1], 0, - ((Interp *)interp)->cmdFramePtr, 2); + ((Interp *)interp)->cmdFramePtr, 1); if (result == TCL_ERROR) { GenerateErrorInfo(interp, oPtr, objNameObj, "class object"); } TclDecrRefCount(objNameObj); } else { - result = MagicDefinitionInvoke(interp, fPtr->objdefNs, 1, objc, objv); + result = MagicDefinitionInvoke(interp, nsPtr, 1, objc, objv); } TclOODecrRefCount(oPtr); @@ -1087,7 +1298,115 @@ TclOODefineSelfObjCmd( /* * ---------------------------------------------------------------------- * + * TclOODefineObjSelfObjCmd -- + * + * Implementation of the "self" subcommand of the "oo::objdefine" + * command. + * + * ---------------------------------------------------------------------- + */ + +int +TclOODefineObjSelfObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr; + + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return TCL_ERROR; + } + + oPtr = (Object *) TclOOGetDefineCmdContext(interp); + if (oPtr == NULL) { + return TCL_ERROR; + } + + Tcl_SetObjResult(interp, TclOOObjectName(interp, oPtr)); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * TclOODefinePrivateObjCmd -- + * + * Implementation of the "private" subcommand of the "oo::define" + * and "oo::objdefine" commands. + * + * ---------------------------------------------------------------------- + */ + +int +TclOODefinePrivateObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + int isInstancePrivate = (clientData != NULL); + /* Just so that we can generate the correct + * error message depending on the context of + * usage of this function. */ + Interp *iPtr = (Interp *) interp; + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + int saved; /* The saved flag. We restore it on exit so + * that [private private ...] doesn't make + * things go weird. */ + int result; + + if (oPtr == NULL) { + return TCL_ERROR; + } + if (objc == 1) { + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(IsPrivateDefine(interp))); + return TCL_OK; + } + + /* + * Change the frame type flag while evaluating the body. + */ + + saved = iPtr->varFramePtr->isProcCallFrame; + iPtr->varFramePtr->isProcCallFrame = PRIVATE_FRAME; + + /* + * Evaluate the body; standard pattern. + */ + + AddRef(oPtr); + if (objc == 2) { + Tcl_Obj *objNameObj = TclOOObjectName(interp, oPtr); + + Tcl_IncrRefCount(objNameObj); + result = TclEvalObjEx(interp, objv[1], 0, iPtr->cmdFramePtr, 1); + if (result == TCL_ERROR) { + GenerateErrorInfo(interp, oPtr, objNameObj, + isInstancePrivate ? "object" : "class"); + } + TclDecrRefCount(objNameObj); + } else { + result = MagicDefinitionInvoke(interp, TclGetCurrentNamespace(interp), + 1, objc, objv); + } + TclOODecrRefCount(oPtr); + + /* + * Restore the frame type flag to what it was previously. + */ + + iPtr->varFramePtr->isProcCallFrame = saved; + return result; +} + +/* + * ---------------------------------------------------------------------- + * * TclOODefineClassObjCmd -- + * * Implementation of the "class" subcommand of the "oo::objdefine" * command. * @@ -1196,6 +1515,7 @@ TclOODefineClassObjCmd( * ---------------------------------------------------------------------- * * TclOODefineConstructorObjCmd -- + * * Implementation of the "constructor" subcommand of the "oo::define" * command. * @@ -1230,7 +1550,7 @@ TclOODefineConstructorObjCmd( } clsPtr = oPtr->classPtr; - Tcl_GetStringFromObj(objv[2], &bodyLength); + TclGetStringFromObj(objv[2], &bodyLength); if (bodyLength > 0) { /* * Create the method structure. @@ -1263,7 +1583,93 @@ TclOODefineConstructorObjCmd( /* * ---------------------------------------------------------------------- * + * TclOODefineDefnNsObjCmd -- + * + * Implementation of the "definitionnamespace" subcommand of the + * "oo::define" command. + * + * ---------------------------------------------------------------------- + */ + +int +TclOODefineDefnNsObjCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + static const char *kindList[] = { + "-class", + "-instance", + NULL + }; + int kind = 0; + Object *oPtr; + Tcl_Namespace *nsPtr; + Tcl_Obj *nsNamePtr, **storagePtr; + + oPtr = (Object *) TclOOGetDefineCmdContext(interp); + if (oPtr == NULL) { + return TCL_ERROR; + } + if (!oPtr->classPtr) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "attempt to misuse API", -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + return TCL_ERROR; + } + if (oPtr->flags & (ROOT_OBJECT | ROOT_CLASS)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "may not modify the definition namespace of the root classes", + -1)); + Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); + return TCL_ERROR; + } + + /* + * Parse the arguments and work out what the user wants to do. + */ + + if (objc != 2 && objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "?kind? namespace"); + return TCL_ERROR; + } + if (objc == 3 && Tcl_GetIndexFromObj(interp, objv[1], kindList, "kind", 0, + &kind) != TCL_OK) { + return TCL_ERROR; + } + if (!Tcl_GetString(objv[objc - 1])[0]) { + nsNamePtr = NULL; + } else { + nsPtr = GetNamespaceInOuterContext(interp, objv[objc - 1]); + if (nsPtr == NULL) { + return TCL_ERROR; + } + nsNamePtr = Tcl_NewStringObj(nsPtr->fullName, -1); + Tcl_IncrRefCount(nsNamePtr); + } + + /* + * Update the correct field of the class definition. + */ + + if (kind) { + storagePtr = &oPtr->classPtr->objDefinitionNs; + } else { + storagePtr = &oPtr->classPtr->clsDefinitionNs; + } + if (*storagePtr != NULL) { + Tcl_DecrRefCount(*storagePtr); + } + *storagePtr = nsNamePtr; + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * * TclOODefineDeleteMethodObjCmd -- + * * Implementation of the "deletemethod" subcommand of the "oo::define" * and "oo::objdefine" commands. * @@ -1320,6 +1726,7 @@ TclOODefineDeleteMethodObjCmd( * ---------------------------------------------------------------------- * * TclOODefineDestructorObjCmd -- + * * Implementation of the "destructor" subcommand of the "oo::define" * command. * @@ -1349,7 +1756,7 @@ TclOODefineDestructorObjCmd( } clsPtr = oPtr->classPtr; - Tcl_GetStringFromObj(objv[1], &bodyLength); + TclGetStringFromObj(objv[1], &bodyLength); if (bodyLength > 0) { /* * Create the method structure. @@ -1384,6 +1791,7 @@ TclOODefineDestructorObjCmd( * ---------------------------------------------------------------------- * * TclOODefineExportObjCmd -- + * * Implementation of the "export" subcommand of the "oo::define" and * "oo::objdefine" commands. * @@ -1454,8 +1862,9 @@ TclOODefineExportObjCmd( } else { mPtr = Tcl_GetHashValue(hPtr); } - if (isNew || !(mPtr->flags & PUBLIC_METHOD)) { + if (isNew || !(mPtr->flags & (PUBLIC_METHOD | PRIVATE_METHOD))) { mPtr->flags |= PUBLIC_METHOD; + mPtr->flags &= ~TRUE_PRIVATE_METHOD; changed = 1; } } @@ -1478,6 +1887,7 @@ TclOODefineExportObjCmd( * ---------------------------------------------------------------------- * * TclOODefineForwardObjCmd -- + * * Implementation of the "forward" subcommand of the "oo::define" and * "oo::objdefine" commands. * @@ -1514,6 +1924,9 @@ TclOODefineForwardObjCmd( } isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN) ? PUBLIC_METHOD : 0; + if (IsPrivateDefine(interp)) { + isPublic = TRUE_PRIVATE_METHOD; + } /* * Create the method structure. @@ -1538,6 +1951,7 @@ TclOODefineForwardObjCmd( * ---------------------------------------------------------------------- * * TclOODefineMethodObjCmd -- + * * Implementation of the "method" subcommand of the "oo::define" and * "oo::objdefine" commands. * @@ -1551,12 +1965,28 @@ TclOODefineMethodObjCmd( int objc, Tcl_Obj *const *objv) { + /* + * Table of export modes for methods and their corresponding enum. + */ + + static const char *const exportModes[] = { + "-export", + "-private", + "-unexport", + NULL + }; + enum ExportMode { + MODE_EXPORT, + MODE_PRIVATE, + MODE_UNEXPORT + } exportMode; + int isInstanceMethod = (clientData != NULL); Object *oPtr; - int isPublic; + int isPublic = 0; - if (objc != 4) { - Tcl_WrongNumArgs(interp, 1, objv, "name args body"); + if (objc < 4 || objc > 5) { + Tcl_WrongNumArgs(interp, 1, objv, "name ?option? args body"); return TCL_ERROR; } @@ -1570,8 +2000,30 @@ TclOODefineMethodObjCmd( Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL); return TCL_ERROR; } - isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN) - ? PUBLIC_METHOD : 0; + if (objc == 5) { + if (Tcl_GetIndexFromObj(interp, objv[2], exportModes, "export flag", + 0, (int *) &exportMode) != TCL_OK) { + return TCL_ERROR; + } + switch (exportMode) { + case MODE_EXPORT: + isPublic = PUBLIC_METHOD; + break; + case MODE_PRIVATE: + isPublic = TRUE_PRIVATE_METHOD; + break; + case MODE_UNEXPORT: + isPublic = 0; + break; + } + } else { + if (IsPrivateDefine(interp)) { + isPublic = TRUE_PRIVATE_METHOD; + } else { + isPublic = Tcl_StringMatch(TclGetString(objv[1]), PUBLIC_PATTERN) + ? PUBLIC_METHOD : 0; + } + } /* * Create the method by using the right back-end API. @@ -1579,12 +2031,12 @@ TclOODefineMethodObjCmd( if (isInstanceMethod) { if (TclOONewProcInstanceMethod(interp, oPtr, isPublic, objv[1], - objv[2], objv[3], NULL) == NULL) { + objv[objc - 2], objv[objc - 1], NULL) == NULL) { return TCL_ERROR; } } else { if (TclOONewProcMethod(interp, oPtr->classPtr, isPublic, objv[1], - objv[2], objv[3], NULL) == NULL) { + objv[objc - 2], objv[objc - 1], NULL) == NULL) { return TCL_ERROR; } } @@ -1595,6 +2047,7 @@ TclOODefineMethodObjCmd( * ---------------------------------------------------------------------- * * TclOODefineRenameMethodObjCmd -- + * * Implementation of the "renamemethod" subcommand of the "oo::define" * and "oo::objdefine" commands. * @@ -1651,6 +2104,7 @@ TclOODefineRenameMethodObjCmd( * ---------------------------------------------------------------------- * * TclOODefineUnexportObjCmd -- + * * Implementation of the "unexport" subcommand of the "oo::define" and * "oo::objdefine" commands. * @@ -1721,8 +2175,8 @@ TclOODefineUnexportObjCmd( } else { mPtr = Tcl_GetHashValue(hPtr); } - if (isNew || mPtr->flags & PUBLIC_METHOD) { - mPtr->flags &= ~PUBLIC_METHOD; + if (isNew || mPtr->flags & (PUBLIC_METHOD | TRUE_PRIVATE_METHOD)) { + mPtr->flags &= ~(PUBLIC_METHOD | TRUE_PRIVATE_METHOD); changed = 1; } } @@ -1745,6 +2199,7 @@ TclOODefineUnexportObjCmd( * ---------------------------------------------------------------------- * * Tcl_ClassSetConstructor, Tcl_ClassSetDestructor -- + * * How to install a constructor or destructor into a class; API to call * from C. * @@ -1799,6 +2254,7 @@ Tcl_ClassSetDestructor( * ---------------------------------------------------------------------- * * TclOODefineSlots -- + * * Create the "::oo::Slot" class and its standard instances. Class * definition is empty at the stage (added by scripting). * @@ -1812,6 +2268,7 @@ TclOODefineSlots( const struct DeclaredSlot *slotInfoPtr; Tcl_Obj *getName = Tcl_NewStringObj("Get", -1); Tcl_Obj *setName = Tcl_NewStringObj("Set", -1); + Tcl_Obj *resolveName = Tcl_NewStringObj("Resolve", -1); Class *slotCls; slotCls = ((Object *) Tcl_NewObjectInstance(fPtr->interp, (Tcl_Class) @@ -1821,6 +2278,7 @@ TclOODefineSlots( } Tcl_IncrRefCount(getName); Tcl_IncrRefCount(setName); + Tcl_IncrRefCount(resolveName); for (slotInfoPtr = slots ; slotInfoPtr->name ; slotInfoPtr++) { Tcl_Object slotObject = Tcl_NewObjectInstance(fPtr->interp, (Tcl_Class) slotCls, slotInfoPtr->name, NULL, -1, NULL, 0); @@ -1832,9 +2290,14 @@ TclOODefineSlots( &slotInfoPtr->getterType, NULL); Tcl_NewInstanceMethod(fPtr->interp, slotObject, setName, 0, &slotInfoPtr->setterType, NULL); + if (slotInfoPtr->resolverType.callProc) { + Tcl_NewInstanceMethod(fPtr->interp, slotObject, resolveName, 0, + &slotInfoPtr->resolverType, NULL); + } } Tcl_DecrRefCount(getName); Tcl_DecrRefCount(setName); + Tcl_DecrRefCount(resolveName); return TCL_OK; } @@ -1842,6 +2305,7 @@ TclOODefineSlots( * ---------------------------------------------------------------------- * * ClassFilterGet, ClassFilterSet -- + * * Implementation of the "filter" slot accessors of the "oo::define" * command. * @@ -1921,6 +2385,7 @@ ClassFilterSet( * ---------------------------------------------------------------------- * * ClassMixinGet, ClassMixinSet -- + * * Implementation of the "mixin" slot accessors of the "oo::define" * command. * @@ -2026,6 +2491,7 @@ ClassMixinSet( * ---------------------------------------------------------------------- * * ClassSuperGet, ClassSuperSet -- + * * Implementation of the "superclass" slot accessors of the "oo::define" * command. * @@ -2177,7 +2643,7 @@ ClassSuperSet( TclOORemoveFromSubclasses(oPtr->classPtr, superPtr); TclOODecrRefCount(superPtr->thisPtr); } - ckfree((char *) oPtr->classPtr->superclasses.list); + ckfree(oPtr->classPtr->superclasses.list); } oPtr->classPtr->superclasses.list = superclasses; oPtr->classPtr->superclasses.num = superc; @@ -2193,6 +2659,7 @@ ClassSuperSet( * ---------------------------------------------------------------------- * * ClassVarsGet, ClassVarsSet -- + * * Implementation of the "variable" slot accessors of the "oo::define" * command. * @@ -2208,7 +2675,7 @@ ClassVarsGet( Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Obj *resultObj, *variableObj; + Tcl_Obj *resultObj; int i; if (Tcl_ObjectContextSkippedArgs(context) != objc) { @@ -2226,8 +2693,18 @@ ClassVarsGet( } resultObj = Tcl_NewObj(); - FOREACH(variableObj, oPtr->classPtr->variables) { - Tcl_ListObjAppendElement(NULL, resultObj, variableObj); + if (IsPrivateDefine(interp)) { + PrivateVariableMapping *privatePtr; + + FOREACH_STRUCT(privatePtr, oPtr->classPtr->privateVariables) { + Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj); + } + } else { + Tcl_Obj *variableObj; + + FOREACH(variableObj, oPtr->classPtr->variables) { + Tcl_ListObjAppendElement(NULL, resultObj, variableObj); + } } Tcl_SetObjResult(interp, resultObj); return TCL_OK; @@ -2243,7 +2720,7 @@ ClassVarsSet( { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); int varc; - Tcl_Obj **varv, *variableObj; + Tcl_Obj **varv; int i; if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { @@ -2266,7 +2743,7 @@ ClassVarsSet( } for (i = 0; i < varc; i++) { - const char *varName = Tcl_GetString(varv[i]); + const char *varName = TclGetString(varv[i]); if (strstr(varName, "::") != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -2284,49 +2761,11 @@ ClassVarsSet( } } - for (i = 0; i < varc; i++) { - Tcl_IncrRefCount(varv[i]); - } - FOREACH(variableObj, oPtr->classPtr->variables) { - Tcl_DecrRefCount(variableObj); - } - if (i != varc) { - if (varc == 0) { - ckfree((char *) oPtr->classPtr->variables.list); - } else if (i) { - oPtr->classPtr->variables.list = (Tcl_Obj **) - ckrealloc((char *) oPtr->classPtr->variables.list, - sizeof(Tcl_Obj *) * varc); - } else { - oPtr->classPtr->variables.list = (Tcl_Obj **) - ckalloc(sizeof(Tcl_Obj *) * varc); - } - } - - oPtr->classPtr->variables.num = 0; - if (varc > 0) { - int created, n; - Tcl_HashTable uniqueTable; - - Tcl_InitObjHashTable(&uniqueTable); - for (i = n = 0; i < varc; i++) { - Tcl_CreateHashEntry(&uniqueTable, varv[i], &created); - if (created) { - oPtr->classPtr->variables.list[n++] = varv[i]; - } else { - Tcl_DecrRefCount(varv[i]); - } - } - oPtr->classPtr->variables.num = n; - - /* - * Shouldn't be necessary, but maintain num/list invariant. - */ - - oPtr->classPtr->variables.list = (Tcl_Obj **) - ckrealloc((char *) oPtr->classPtr->variables.list, - sizeof(Tcl_Obj *) * n); - Tcl_DeleteHashTable(&uniqueTable); + if (IsPrivateDefine(interp)) { + InstallPrivateVariableMapping(&oPtr->classPtr->privateVariables, + varc, varv, oPtr->classPtr->thisPtr->creationEpoch); + } else { + InstallStandardVariableMapping(&oPtr->classPtr->variables, varc, varv); } return TCL_OK; } @@ -2335,6 +2774,7 @@ ClassVarsSet( * ---------------------------------------------------------------------- * * ObjectFilterGet, ObjectFilterSet -- + * * Implementation of the "filter" slot accessors of the "oo::objdefine" * command. * @@ -2402,6 +2842,7 @@ ObjFilterSet( * ---------------------------------------------------------------------- * * ObjectMixinGet, ObjectMixinSet -- + * * Implementation of the "mixin" slot accessors of the "oo::objdefine" * command. * @@ -2487,6 +2928,7 @@ ObjMixinSet( * ---------------------------------------------------------------------- * * ObjectVarsGet, ObjectVarsSet -- + * * Implementation of the "variable" slot accessors of the "oo::objdefine" * command. * @@ -2502,7 +2944,7 @@ ObjVarsGet( Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Obj *resultObj, *variableObj; + Tcl_Obj *resultObj; int i; if (Tcl_ObjectContextSkippedArgs(context) != objc) { @@ -2514,8 +2956,18 @@ ObjVarsGet( } resultObj = Tcl_NewObj(); - FOREACH(variableObj, oPtr->variables) { - Tcl_ListObjAppendElement(NULL, resultObj, variableObj); + if (IsPrivateDefine(interp)) { + PrivateVariableMapping *privatePtr; + + FOREACH_STRUCT(privatePtr, oPtr->privateVariables) { + Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj); + } + } else { + Tcl_Obj *variableObj; + + FOREACH(variableObj, oPtr->variables) { + Tcl_ListObjAppendElement(NULL, resultObj, variableObj); + } } Tcl_SetObjResult(interp, resultObj); return TCL_OK; @@ -2531,7 +2983,7 @@ ObjVarsSet( { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); int varc, i; - Tcl_Obj **varv, *variableObj; + Tcl_Obj **varv; if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, @@ -2547,7 +2999,7 @@ ObjVarsSet( } for (i = 0; i < varc; i++) { - const char *varName = Tcl_GetString(varv[i]); + const char *varName = TclGetString(varv[i]); if (strstr(varName, "::") != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -2564,50 +3016,66 @@ ObjVarsSet( return TCL_ERROR; } } - for (i = 0; i < varc; i++) { - Tcl_IncrRefCount(varv[i]); - } - FOREACH(variableObj, oPtr->variables) { - Tcl_DecrRefCount(variableObj); - } - if (i != varc) { - if (varc == 0) { - ckfree((char *) oPtr->variables.list); - } else if (i) { - oPtr->variables.list = (Tcl_Obj **) - ckrealloc((char *) oPtr->variables.list, - sizeof(Tcl_Obj *) * varc); - } else { - oPtr->variables.list = (Tcl_Obj **) - ckalloc(sizeof(Tcl_Obj *) * varc); - } + if (IsPrivateDefine(interp)) { + InstallPrivateVariableMapping(&oPtr->privateVariables, varc, varv, + oPtr->creationEpoch); + } else { + InstallStandardVariableMapping(&oPtr->variables, varc, varv); } - oPtr->variables.num = 0; - if (varc > 0) { - int created, n; - Tcl_HashTable uniqueTable; + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * ResolveClass -- + * + * Implementation of the "Resolve" support method for some slots (those + * that are slots around a list of classes). This resolves possible class + * names to their fully-qualified names if possible. + * + * ---------------------------------------------------------------------- + */ - Tcl_InitObjHashTable(&uniqueTable); - for (i = n = 0; i < varc; i++) { - Tcl_CreateHashEntry(&uniqueTable, varv[i], &created); - if (created) { - oPtr->variables.list[n++] = varv[i]; - } else { - Tcl_DecrRefCount(varv[i]); - } - } - oPtr->variables.num = n; +static int +ResolveClass( + ClientData clientData, + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + int idx = Tcl_ObjectContextSkippedArgs(context); + Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); + Class *clsPtr; - /* - * Shouldn't be necessary, but maintain num/list invariant. - */ + /* + * Check if were called wrongly. The definition context isn't used... + * except that GetClassInOuterContext() assumes that it is there. + */ - oPtr->variables.list = (Tcl_Obj **) - ckrealloc((char *) oPtr->variables.list, - sizeof(Tcl_Obj *) * n); - Tcl_DeleteHashTable(&uniqueTable); + if (oPtr == NULL) { + return TCL_ERROR; + } else if (objc != idx + 1) { + Tcl_WrongNumArgs(interp, idx, objv, "slotElement"); + return TCL_ERROR; + } + + /* + * Resolve the class if possible. If not, remove any resolution error and + * return what we've got anyway as the failure might not be fatal overall. + */ + + clsPtr = GetClassInOuterContext(interp, objv[idx], + "USER SHOULD NOT SEE THIS MESSAGE"); + if (clsPtr == NULL) { + Tcl_ResetResult(interp); + Tcl_SetObjResult(interp, objv[idx]); + } else { + Tcl_SetObjResult(interp, TclOOObjectName(interp, clsPtr->thisPtr)); } + return TCL_OK; } diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index c9263b5..99918ae 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -22,6 +22,7 @@ static Tcl_ObjCmdProc InfoObjectClassCmd; static Tcl_ObjCmdProc InfoObjectDefnCmd; static Tcl_ObjCmdProc InfoObjectFiltersCmd; static Tcl_ObjCmdProc InfoObjectForwardCmd; +static Tcl_ObjCmdProc InfoObjectIdCmd; static Tcl_ObjCmdProc InfoObjectIsACmd; static Tcl_ObjCmdProc InfoObjectMethodsCmd; static Tcl_ObjCmdProc InfoObjectMethodTypeCmd; @@ -32,6 +33,7 @@ static Tcl_ObjCmdProc InfoObjectVariablesCmd; static Tcl_ObjCmdProc InfoClassCallCmd; static Tcl_ObjCmdProc InfoClassConstrCmd; static Tcl_ObjCmdProc InfoClassDefnCmd; +static Tcl_ObjCmdProc InfoClassDefnNsCmd; static Tcl_ObjCmdProc InfoClassDestrCmd; static Tcl_ObjCmdProc InfoClassFiltersCmd; static Tcl_ObjCmdProc InfoClassForwardCmd; @@ -50,6 +52,7 @@ static Tcl_ObjCmdProc InfoClassVariablesCmd; static const EnsembleImplMap infoObjectCmds[] = { {"call", InfoObjectCallCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"class", InfoObjectClassCmd, TclCompileInfoObjectClassCmd, NULL, NULL, 0}, + {"creationid", InfoObjectIdCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"definition", InfoObjectDefnCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"filters", InfoObjectFiltersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"forward", InfoObjectForwardCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, @@ -58,7 +61,7 @@ static const EnsembleImplMap infoObjectCmds[] = { {"methodtype", InfoObjectMethodTypeCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"mixins", InfoObjectMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"namespace", InfoObjectNsCmd, TclCompileInfoObjectNamespaceCmd, NULL, NULL, 0}, - {"variables", InfoObjectVariablesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"variables", InfoObjectVariablesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {"vars", InfoObjectVarsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {NULL, NULL, NULL, NULL, NULL, 0} }; @@ -71,6 +74,7 @@ static const EnsembleImplMap infoClassCmds[] = { {"call", InfoClassCallCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"constructor", InfoClassConstrCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"definition", InfoClassDefnCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, + {"definitionnamespace", InfoClassDefnNsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {"destructor", InfoClassDestrCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"filters", InfoClassFiltersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"forward", InfoClassForwardCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, @@ -80,7 +84,7 @@ static const EnsembleImplMap infoClassCmds[] = { {"mixins", InfoClassMixinsCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, {"subclasses", InfoClassSubsCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {"superclasses", InfoClassSupersCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"variables", InfoClassVariablesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, + {"variables", InfoClassVariablesCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {NULL, NULL, NULL, NULL, NULL, 0} }; @@ -519,15 +523,22 @@ InfoObjectMethodsCmd( Tcl_Obj *const objv[]) { Object *oPtr; - int flag = PUBLIC_METHOD, recurse = 0; + int flag = PUBLIC_METHOD, recurse = 0, scope = -1; FOREACH_HASH_DECLS; Tcl_Obj *namePtr, *resultObj; Method *mPtr; static const char *const options[] = { - "-all", "-localprivate", "-private", NULL + "-all", "-localprivate", "-private", "-scope", NULL }; enum Options { - OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE + OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE, OPT_SCOPE + }; + static const char *const scopes[] = { + "private", "public", "unexported" + }; + enum Scopes { + SCOPE_PRIVATE, SCOPE_PUBLIC, SCOPE_UNEXPORTED, + SCOPE_LOCALPRIVATE }; if (objc < 2) { @@ -556,14 +567,45 @@ InfoObjectMethodsCmd( case OPT_PRIVATE: flag = 0; break; + case OPT_SCOPE: + if (++i >= objc) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "missing option for -scope")); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", + NULL); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[i], scopes, "scope", 0, + &scope) != TCL_OK) { + return TCL_ERROR; + } + break; } } } + if (scope != -1) { + recurse = 0; + switch (scope) { + case SCOPE_PRIVATE: + flag = TRUE_PRIVATE_METHOD; + break; + case SCOPE_PUBLIC: + flag = PUBLIC_METHOD; + break; + case SCOPE_LOCALPRIVATE: + flag = PRIVATE_METHOD; + break; + case SCOPE_UNEXPORTED: + flag = 0; + break; + } + } resultObj = Tcl_NewObj(); if (recurse) { const char **names; - int i, numNames = TclOOGetSortedMethodList(oPtr, flag, &names); + int i, numNames = TclOOGetSortedMethodList(oPtr, NULL, NULL, flag, + &names); for (i=0 ; i<numNames ; i++) { Tcl_ListObjAppendElement(NULL, resultObj, @@ -574,7 +616,7 @@ InfoObjectMethodsCmd( } } else if (oPtr->methodsPtr) { FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) { - if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) { + if (mPtr->typePtr && (mPtr->flags & SCOPE_FLAGS) == flag) { Tcl_ListObjAppendElement(NULL, resultObj, namePtr); } } @@ -686,6 +728,38 @@ InfoObjectMixinsCmd( /* * ---------------------------------------------------------------------- * + * InfoObjectIdCmd -- + * + * Implements [info object creationid $objName] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoObjectIdCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Object *oPtr; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "objName"); + return TCL_ERROR; + } + oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); + if (oPtr == NULL) { + return TCL_ERROR; + } + + Tcl_SetObjResult(interp, Tcl_NewIntObj(oPtr->creationEpoch)); + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * * InfoObjectNsCmd -- * * Implements [info object namespace $objName] @@ -721,7 +795,7 @@ InfoObjectNsCmd( * * InfoObjectVariablesCmd -- * - * Implements [info object variables $objName] + * Implements [info object variables $objName ?-private?] * * ---------------------------------------------------------------------- */ @@ -734,21 +808,37 @@ InfoObjectVariablesCmd( Tcl_Obj *const objv[]) { Object *oPtr; - Tcl_Obj *variableObj, *resultObj; - int i; + Tcl_Obj *resultObj; + int i, isPrivate = 0; - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "objName"); + if (objc != 2 && objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "objName ?-private?"); return TCL_ERROR; } + if (objc == 3) { + if (strcmp("-private", Tcl_GetString(objv[2])) != 0) { + return TCL_ERROR; + } + isPrivate = 1; + } oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]); if (oPtr == NULL) { return TCL_ERROR; } resultObj = Tcl_NewObj(); - FOREACH(variableObj, oPtr->variables) { - Tcl_ListObjAppendElement(NULL, resultObj, variableObj); + if (isPrivate) { + PrivateVariableMapping *privatePtr; + + FOREACH_STRUCT(privatePtr, oPtr->privateVariables) { + Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj); + } + } else { + Tcl_Obj *variableObj; + + FOREACH(variableObj, oPtr->variables) { + Tcl_ListObjAppendElement(NULL, resultObj, variableObj); + } } Tcl_SetObjResult(interp, resultObj); return TCL_OK; @@ -947,6 +1037,56 @@ InfoClassDefnCmd( /* * ---------------------------------------------------------------------- * + * InfoClassDefnNsCmd -- + * + * Implements [info class definitionnamespace $clsName ?$kind?] + * + * ---------------------------------------------------------------------- + */ + +static int +InfoClassDefnNsCmd( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + static const char *kindList[] = { + "-class", + "-instance", + NULL + }; + int kind = 0; + Tcl_Obj *nsNamePtr; + Class *clsPtr; + + if (objc != 2 && objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "className ?kind?"); + return TCL_ERROR; + } + clsPtr = GetClassFromObj(interp, objv[1]); + if (clsPtr == NULL) { + return TCL_ERROR; + } + if (objc == 3 && Tcl_GetIndexFromObj(interp, objv[2], kindList, "kind", 0, + &kind) != TCL_OK) { + return TCL_ERROR; + } + + if (kind) { + nsNamePtr = clsPtr->objDefinitionNs; + } else { + nsNamePtr = clsPtr->clsDefinitionNs; + } + if (nsNamePtr) { + Tcl_SetObjResult(interp, nsNamePtr); + } + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * * InfoClassDestrCmd -- * * Implements [info class destructor $clsName] @@ -1130,7 +1270,7 @@ InfoClassInstancesCmd( * * InfoClassMethodsCmd -- * - * Implements [info class methods $clsName ?-private?] + * Implements [info class methods $clsName ?options...?] * * ---------------------------------------------------------------------- */ @@ -1142,15 +1282,21 @@ InfoClassMethodsCmd( int objc, Tcl_Obj *const objv[]) { - int flag = PUBLIC_METHOD, recurse = 0; + int flag = PUBLIC_METHOD, recurse = 0, scope = -1; Tcl_Obj *namePtr, *resultObj; Method *mPtr; Class *clsPtr; static const char *const options[] = { - "-all", "-localprivate", "-private", NULL + "-all", "-localprivate", "-private", "-scope", NULL }; enum Options { - OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE + OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE, OPT_SCOPE + }; + static const char *const scopes[] = { + "private", "public", "unexported" + }; + enum Scopes { + SCOPE_PRIVATE, SCOPE_PUBLIC, SCOPE_UNEXPORTED }; if (objc < 2) { @@ -1179,9 +1325,36 @@ InfoClassMethodsCmd( case OPT_PRIVATE: flag = 0; break; + case OPT_SCOPE: + if (++i >= objc) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "missing option for -scope")); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", + NULL); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[i], scopes, "scope", 0, + &scope) != TCL_OK) { + return TCL_ERROR; + } + break; } } } + if (scope != -1) { + recurse = 0; + switch (scope) { + case SCOPE_PRIVATE: + flag = TRUE_PRIVATE_METHOD; + break; + case SCOPE_PUBLIC: + flag = PUBLIC_METHOD; + break; + case SCOPE_UNEXPORTED: + flag = 0; + break; + } + } resultObj = Tcl_NewObj(); if (recurse) { @@ -1199,7 +1372,7 @@ InfoClassMethodsCmd( FOREACH_HASH_DECLS; FOREACH_HASH(namePtr, mPtr, &clsPtr->classMethods) { - if (mPtr->typePtr != NULL && (mPtr->flags & flag) == flag) { + if (mPtr->typePtr && (mPtr->flags & SCOPE_FLAGS) == flag) { Tcl_ListObjAppendElement(NULL, resultObj, namePtr); } } @@ -1401,7 +1574,7 @@ InfoClassSupersCmd( * * InfoClassVariablesCmd -- * - * Implements [info class variables $clsName] + * Implements [info class variables $clsName ?-private?] * * ---------------------------------------------------------------------- */ @@ -1414,21 +1587,37 @@ InfoClassVariablesCmd( Tcl_Obj *const objv[]) { Class *clsPtr; - Tcl_Obj *variableObj, *resultObj; - int i; + Tcl_Obj *resultObj; + int i, isPrivate = 0; - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "className"); + if (objc != 2 && objc != 3) { + Tcl_WrongNumArgs(interp, 1, objv, "className ?-private?"); return TCL_ERROR; } + if (objc == 3) { + if (strcmp("-private", Tcl_GetString(objv[2])) != 0) { + return TCL_ERROR; + } + isPrivate = 1; + } clsPtr = GetClassFromObj(interp, objv[1]); if (clsPtr == NULL) { return TCL_ERROR; } resultObj = Tcl_NewObj(); - FOREACH(variableObj, clsPtr->variables) { - Tcl_ListObjAppendElement(NULL, resultObj, variableObj); + if (isPrivate) { + PrivateVariableMapping *privatePtr; + + FOREACH_STRUCT(privatePtr, clsPtr->privateVariables) { + Tcl_ListObjAppendElement(NULL, resultObj, privatePtr->variableObj); + } + } else { + Tcl_Obj *variableObj; + + FOREACH(variableObj, clsPtr->variables) { + Tcl_ListObjAppendElement(NULL, resultObj, variableObj); + } } Tcl_SetObjResult(interp, resultObj); return TCL_OK; @@ -1467,7 +1656,8 @@ InfoObjectCallCmd( * Get the call context and render its call chain. */ - contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL); + contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL, NULL, + NULL); if (contextPtr == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot construct any call chain", -1)); diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index d90b407..1f44ef8 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -47,7 +47,7 @@ typedef struct Method { * special flag record which is just used for * the setting of the flags field. */ int refCount; - ClientData clientData; /* Type-specific data. */ + void *clientData; /* Type-specific data. */ Tcl_Obj *namePtr; /* Name of the method. */ struct Object *declaringObjectPtr; /* The object that declares this method, or @@ -84,7 +84,7 @@ typedef struct ProcedureMethod { * body bytecodes. */ int flags; /* Flags to control features. */ int refCount; - ClientData clientData; + void *clientData; TclOO_PmCDDeleteProc *deleteClientdataProc; TclOO_PmCDCloneProc *cloneClientdataProc; ProcErrorProc *errProc; /* Replacement error handler. */ @@ -125,6 +125,18 @@ typedef struct ForwardMethod { } ForwardMethod; /* + * Structure used in private variable mappings. Describes the mapping of a + * single variable from the user's local name to the system's storage name. + * [TIP #500] + */ + +typedef struct { + Tcl_Obj *variableObj; /* Name used within methods. This is the part + * that is properly under user control. */ + Tcl_Obj *fullNameObj; /* Name used at the instance namespace level. */ +} PrivateVariableMapping; + +/* * Helper definitions that declare a "list" array. The two varieties are * either optimized for simplicity (in the case that the whole array is * typically assigned at once) or efficiency (in the case that the array is @@ -142,6 +154,13 @@ typedef struct ForwardMethod { struct { int num, size; listType_t *list; } /* + * These types are needed in function arguments. + */ + +typedef LIST_STATIC(Tcl_Obj *) VariableNameList; +typedef LIST_STATIC(PrivateVariableMapping) PrivateVariableList; + +/* * Now, the definition of what an object actually is. */ @@ -186,7 +205,12 @@ typedef struct Object { Tcl_ObjectMapMethodNameProc *mapMethodNameProc; /* Function to allow remapping of method * names. For itcl-ng. */ - LIST_STATIC(Tcl_Obj *) variables; + VariableNameList variables; + PrivateVariableList privateVariables; + /* Configurations for the variable resolver + * used inside methods. */ + Tcl_Command myclassCommand; /* Reference to this object's class dispatcher + * command. */ } Object; #define OBJECT_DELETED 1 /* Flag to say that an object has been @@ -214,7 +238,14 @@ typedef struct Object { * other spots). */ #define FORCE_UNKNOWN 0x10000 /* States that we are *really* looking up the * unknown method handler at that point. */ -#define DONT_DELETE 0x20000 /* Inhibit deletion of this object. */ +#define HAS_PRIVATE_METHODS 0x20000 + /* Object/class has (or had) private methods, + * and so shouldn't be cached so + * aggressively. */ +#define DONT_DELETE 0x40000 /* Inhibit deletion of this object. Used + * during fundamental object type mutation to + * make sure that the object actually survives + * to the end of the operation. */ /* * And the definition of a class. Note that every class also has an associated @@ -269,7 +300,28 @@ typedef struct Class { * object doesn't override with its own mixins * (and filters and method implementations for * when getting method chains). */ - LIST_STATIC(Tcl_Obj *) variables; + VariableNameList variables; + PrivateVariableList privateVariables; + /* Configurations for the variable resolver + * used inside methods. */ + Tcl_Obj *clsDefinitionNs; /* Name of the namespace to use for + * definitions commands of instances of this + * class in when those instances are defined + * as classes. If NULL, use the value from the + * class hierarchy. It's an error at + * [oo::define] call time if this namespace is + * defined but doesn't exist; we also check at + * setting time but don't check between + * times. */ + Tcl_Obj *objDefinitionNs; /* Name of the namespace to use for + * definitions commands of instances of this + * class in when those instances are defined + * as instances. If NULL, use the value from + * the class hierarchy. It's an error at + * [oo::objdefine]/[self] call time if this + * namespace is defined but doesn't exist; we + * also check at setting time but don't check + * between times. */ } Class; /* @@ -371,10 +423,15 @@ typedef struct CallContext { #define PUBLIC_METHOD 0x01 /* This is a public (exported) method. */ #define PRIVATE_METHOD 0x02 /* This is a private (class's direct instances - * only) method. */ + * only) method. Supports itcl. */ #define OO_UNKNOWN_METHOD 0x04 /* This is an unknown method. */ #define CONSTRUCTOR 0x08 /* This is a constructor. */ #define DESTRUCTOR 0x10 /* This is a destructor. */ +#define TRUE_PRIVATE_METHOD 0x20 + /* This is a private method only accessible + * from other methods defined on this class + * or instance. [TIP #500] */ +#define SCOPE_FLAGS (PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD) /* * Structure containing definition information about basic class methods. @@ -402,6 +459,9 @@ MODULE_SCOPE int TclOOObjDefObjCmd(ClientData clientData, MODULE_SCOPE int TclOODefineConstructorObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); +MODULE_SCOPE int TclOODefineDefnNsObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); MODULE_SCOPE int TclOODefineDeleteMethodObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); @@ -429,6 +489,12 @@ MODULE_SCOPE int TclOODefineClassObjCmd(ClientData clientData, MODULE_SCOPE int TclOODefineSelfObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); +MODULE_SCOPE int TclOODefineObjSelfObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); +MODULE_SCOPE int TclOODefinePrivateObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const *objv); MODULE_SCOPE int TclOOUnknownDefinition(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv); @@ -506,7 +572,10 @@ MODULE_SCOPE void TclOODeleteDescendants(Tcl_Interp *interp, MODULE_SCOPE void TclOODelMethodRef(Method *method); MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr, Tcl_Obj *methodNameObj, int flags, + Object *contextObjPtr, Class *contextClsPtr, Tcl_Obj *cacheInThisObj); +MODULE_SCOPE Tcl_Namespace *TclOOGetDefineContextNamespace( + Tcl_Interp *interp, Object *oPtr, int forClass); MODULE_SCOPE CallChain *TclOOGetStereotypeCallChain(Class *clsPtr, Tcl_Obj *methodNameObj, int flags); MODULE_SCOPE Foundation *TclOOGetFoundation(Tcl_Interp *interp); @@ -515,7 +584,8 @@ MODULE_SCOPE Proc * TclOOGetProcFromMethod(Method *mPtr); MODULE_SCOPE Tcl_Obj * TclOOGetMethodBody(Method *mPtr); MODULE_SCOPE int TclOOGetSortedClassMethodList(Class *clsPtr, int flags, const char ***stringsPtr); -MODULE_SCOPE int TclOOGetSortedMethodList(Object *oPtr, int flags, +MODULE_SCOPE int TclOOGetSortedMethodList(Object *oPtr, + Object *contextObj, Class *contextCls, int flags, const char ***stringsPtr); MODULE_SCOPE int TclOOInit(Tcl_Interp *interp); MODULE_SCOPE void TclOOInitInfo(Tcl_Interp *interp); @@ -566,10 +636,21 @@ MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr); } else if (var = (ary).list[i], 1) /* + * A variation where the array is an array of structs. There's no issue with + * possible NULLs; every element of the array will be iterated over and the + * varable set to a pointer to each of those elements in turn. + * REQUIRES DECLARATION: int i; + */ + +#define FOREACH_STRUCT(var,ary) \ + for(i=0 ; var=&((ary).list[i]), i<(ary).num; i++) + +/* * Convenience macros for iterating through hash tables. FOREACH_HASH_DECLS * sets up the declarations needed for the main macro, FOREACH_HASH, which * does the actual iteration. FOREACH_HASH_VALUE is a restricted version that * only iterates over values. + * REQUIRES DECLARATION: FOREACH_HASH_DECLS; */ #define FOREACH_HASH_DECLS \ @@ -590,7 +671,7 @@ MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr); #undef DUPLICATE /* prevent possible conflict with definition in WINAPI nb30.h */ #define DUPLICATE(target,source,type) \ do { \ - register unsigned len = sizeof(type) * ((target).num=(source).num);\ + unsigned len = sizeof(type) * ((target).num=(source).num);\ if (len != 0) { \ memcpy(((target).list=(type*)ckalloc(len)), (source).list, len); \ } else { \ diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 3e64ba2..32dd3c7 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -67,7 +67,7 @@ static Tcl_Obj ** InitEnsembleRewrite(Tcl_Interp *interp, int objc, Tcl_Obj *const *objv, int toRewrite, int rewriteLength, Tcl_Obj *const *rewriteObjs, int *lengthPtr); -static int InvokeProcedureMethod(ClientData clientData, +static int InvokeProcedureMethod(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); static Tcl_NRPostProc FinalizeForwardCall; @@ -77,22 +77,22 @@ static int PushMethodCallFrame(Tcl_Interp *interp, int objc, Tcl_Obj *const *objv, PMFrameData *fdPtr); static void DeleteProcedureMethodRecord(ProcedureMethod *pmPtr); -static void DeleteProcedureMethod(ClientData clientData); +static void DeleteProcedureMethod(void *clientData); static int CloneProcedureMethod(Tcl_Interp *interp, - ClientData clientData, ClientData *newClientData); + void *clientData, void **newClientData); static void MethodErrorHandler(Tcl_Interp *interp, Tcl_Obj *procNameObj); static void ConstructorErrorHandler(Tcl_Interp *interp, Tcl_Obj *procNameObj); static void DestructorErrorHandler(Tcl_Interp *interp, Tcl_Obj *procNameObj); -static Tcl_Obj * RenderDeclarerName(ClientData clientData); -static int InvokeForwardMethod(ClientData clientData, +static Tcl_Obj * RenderDeclarerName(void *clientData); +static int InvokeForwardMethod(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); -static void DeleteForwardMethod(ClientData clientData); +static void DeleteForwardMethod(void *clientData); static int CloneForwardMethod(Tcl_Interp *interp, - ClientData clientData, ClientData *newClientData); + void *clientData, void **newClientData); static int ProcedureMethodVarResolver(Tcl_Interp *interp, const char *varName, Tcl_Namespace *contextNs, int flags, Tcl_Var *varPtr); @@ -121,7 +121,7 @@ static const Tcl_MethodType fwdMethodType = { #define TclVarTable(contextNs) \ ((Tcl_HashTable *) (&((Namespace *) (contextNs))->varTable)) #define TclVarHashGetValue(hPtr) \ - ((Tcl_Var) ((char *)hPtr - TclOffset(VarInHash, entry))) + ((Tcl_Var) ((char *)hPtr - offsetof(VarInHash, entry))) /* * ---------------------------------------------------------------------- @@ -146,7 +146,7 @@ Tcl_NewInstanceMethod( /* The type of method this is, which defines * how to invoke, delete and clone the * method. */ - ClientData clientData) /* Some data associated with the particular + void *clientData) /* Some data associated with the particular * method to be created. */ { register Object *oPtr = (Object *) object; @@ -186,7 +186,11 @@ Tcl_NewInstanceMethod( mPtr->declaringObjectPtr = oPtr; mPtr->declaringClassPtr = NULL; if (flags) { - mPtr->flags |= flags & (PUBLIC_METHOD | PRIVATE_METHOD); + mPtr->flags |= flags & + (PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD); + if (flags & TRUE_PRIVATE_METHOD) { + oPtr->flags |= HAS_PRIVATE_METHODS; + } } oPtr->epoch++; return (Tcl_Method) mPtr; @@ -214,7 +218,7 @@ Tcl_NewMethod( /* The type of method this is, which defines * how to invoke, delete and clone the * method. */ - ClientData clientData) /* Some data associated with the particular + void *clientData) /* Some data associated with the particular * method to be created. */ { register Class *clsPtr = (Class *) cls; @@ -250,7 +254,11 @@ Tcl_NewMethod( mPtr->declaringObjectPtr = NULL; mPtr->declaringClassPtr = clsPtr; if (flags) { - mPtr->flags |= flags & (PUBLIC_METHOD | PRIVATE_METHOD); + mPtr->flags |= flags & + (PUBLIC_METHOD | PRIVATE_METHOD | TRUE_PRIVATE_METHOD); + if (flags & TRUE_PRIVATE_METHOD) { + clsPtr->flags |= HAS_PRIVATE_METHODS; + } } return (Tcl_Method) mPtr; @@ -450,7 +458,7 @@ TclOOMakeProcInstanceMethod( * NULL. */ const Tcl_MethodType *typePtr, /* The type of the method to create. */ - ClientData clientData, /* The per-method type-specific data. */ + void *clientData, /* The per-method type-specific data. */ Proc **procPtrPtr) /* A pointer to the variable in which to write * the procedure record reference. Presumably * inside the structure indicated by the @@ -563,7 +571,7 @@ TclOOMakeProcMethod( * NULL. */ const Tcl_MethodType *typePtr, /* The type of the method to create. */ - ClientData clientData, /* The per-method type-specific data. */ + void *clientData, /* The per-method type-specific data. */ Proc **procPtrPtr) /* A pointer to the variable in which to write * the procedure record reference. Presumably * inside the structure indicated by the @@ -658,7 +666,7 @@ TclOOMakeProcMethod( static int InvokeProcedureMethod( - ClientData clientData, /* Pointer to some per-method context. */ + void *clientData, /* Pointer to some per-method context. */ Tcl_Interp *interp, Tcl_ObjectContext context, /* The method calling context. */ int objc, /* Number of arguments. */ @@ -737,7 +745,7 @@ InvokeProcedureMethod( static int FinalizePMCall( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { @@ -791,6 +799,7 @@ PushMethodCallFrame( register int result; const char *namePtr; CallFrame **framePtrPtr = &fdPtr->framePtr; + ByteCode *codePtr; /* * Compute basic information on the basis of the type of method it is. @@ -856,10 +865,8 @@ PushMethodCallFrame( * alternative is *so* slow... */ - if (pmPtr->procPtr->bodyPtr->typePtr == &tclByteCodeType) { - ByteCode *codePtr = - pmPtr->procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; - + ByteCodeGetIntRep(pmPtr->procPtr->bodyPtr, &tclByteCodeType, codePtr); + if (codePtr) { codePtr->nsPtr = nsPtr; } result = TclProcCompileProc(interp, pmPtr->procPtr, @@ -928,7 +935,7 @@ PushMethodCallFrame( * variables used in methods. The compiled variable resolver is more * important, but both are needed as it is possible to have a variable * that is only referred to in ways that aren't compilable and we can't - * force LVT presence. [TIP #320] + * force LVT presence. [TIP #320, #500] * * ---------------------------------------------------------------------- */ @@ -984,6 +991,7 @@ ProcedureMethodCompiledVarConnect( CallFrame *framePtr = iPtr->varFramePtr; CallContext *contextPtr; Tcl_Obj *variableObj; + PrivateVariableMapping *privateVar; Tcl_HashEntry *hPtr; int i, isNew, cacheIt, varLen, len; const char *match, *varName; @@ -1017,6 +1025,15 @@ ProcedureMethodCompiledVarConnect( varName = TclGetStringFromObj(infoPtr->variableObj, &varLen); if (contextPtr->callPtr->chain[contextPtr->index] .mPtr->declaringClassPtr != NULL) { + FOREACH_STRUCT(privateVar, contextPtr->callPtr->chain[contextPtr->index] + .mPtr->declaringClassPtr->privateVariables) { + match = TclGetStringFromObj(privateVar->variableObj, &len); + if ((len == varLen) && !memcmp(match, varName, len)) { + variableObj = privateVar->fullNameObj; + cacheIt = 0; + goto gotMatch; + } + } FOREACH(variableObj, contextPtr->callPtr->chain[contextPtr->index] .mPtr->declaringClassPtr->variables) { match = TclGetStringFromObj(variableObj, &len); @@ -1026,6 +1043,14 @@ ProcedureMethodCompiledVarConnect( } } } else { + FOREACH_STRUCT(privateVar, contextPtr->oPtr->privateVariables) { + match = TclGetStringFromObj(privateVar->variableObj, &len); + if ((len == varLen) && !memcmp(match, varName, len)) { + variableObj = privateVar->fullNameObj; + cacheIt = 1; + goto gotMatch; + } + } FOREACH(variableObj, contextPtr->oPtr->variables) { match = TclGetStringFromObj(variableObj, &len); if ((len == varLen) && !memcmp(match, varName, len)) { @@ -1125,7 +1150,7 @@ ProcedureMethodCompiledVarResolver( static Tcl_Obj * RenderDeclarerName( - ClientData clientData) + void *clientData) { struct PNI *pni = clientData; Tcl_Object object = Tcl_MethodDeclarerObject(pni->method); @@ -1164,7 +1189,7 @@ MethodErrorHandler( CallContext *contextPtr = ((Interp *) interp)->varFramePtr->clientData; Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr; const char *objectName, *kindName, *methodName = - Tcl_GetStringFromObj(mPtr->namePtr, &nameLen); + TclGetStringFromObj(mPtr->namePtr, &nameLen); Object *declarerPtr; if (mPtr->declaringObjectPtr != NULL) { @@ -1267,7 +1292,7 @@ DeleteProcedureMethodRecord( static void DeleteProcedureMethod( - ClientData clientData) + void *clientData) { register ProcedureMethod *pmPtr = clientData; @@ -1279,8 +1304,8 @@ DeleteProcedureMethod( static int CloneProcedureMethod( Tcl_Interp *interp, - ClientData clientData, - ClientData *newClientData) + void *clientData, + void **newClientData) { ProcedureMethod *pmPtr = clientData; ProcedureMethod *pm2Ptr; @@ -1313,7 +1338,7 @@ CloneProcedureMethod( bodyObj = Tcl_DuplicateObj(pmPtr->procPtr->bodyPtr); Tcl_GetString(bodyObj); - TclFreeIntRep(bodyObj); + Tcl_StoreIntRep(pmPtr->procPtr->bodyPtr, &tclByteCodeType, NULL); /* * Create the actual copy of the method record, manufacturing a new proc @@ -1433,7 +1458,7 @@ TclOONewForwardMethod( static int InvokeForwardMethod( - ClientData clientData, /* Pointer to some per-method context. */ + void *clientData, /* Pointer to some per-method context. */ Tcl_Interp *interp, Tcl_ObjectContext context, /* The method calling context. */ int objc, /* Number of arguments. */ @@ -1467,7 +1492,7 @@ InvokeForwardMethod( static int FinalizeForwardCall( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { @@ -1489,7 +1514,7 @@ FinalizeForwardCall( static void DeleteForwardMethod( - ClientData clientData) + void *clientData) { ForwardMethod *fmPtr = clientData; @@ -1500,8 +1525,8 @@ DeleteForwardMethod( static int CloneForwardMethod( Tcl_Interp *interp, - ClientData clientData, - ClientData *newClientData) + void *clientData, + void **newClientData) { ForwardMethod *fmPtr = clientData; ForwardMethod *fm2Ptr = ckalloc(sizeof(ForwardMethod)); @@ -1542,9 +1567,7 @@ TclOOGetMethodBody( if (mPtr->typePtr == &procMethodType) { ProcedureMethod *pmPtr = mPtr->clientData; - if (pmPtr->procPtr->bodyPtr->bytes == NULL) { - (void) Tcl_GetString(pmPtr->procPtr->bodyPtr); - } + (void) TclGetString(pmPtr->procPtr->bodyPtr); return pmPtr->procPtr->bodyPtr; } return NULL; @@ -1652,7 +1675,7 @@ int Tcl_MethodIsType( Tcl_Method method, const Tcl_MethodType *typePtr, - ClientData *clientDataPtr) + void **clientDataPtr) { Method *mPtr = (Method *) method; @@ -1671,6 +1694,13 @@ Tcl_MethodIsPublic( { return (((Method *)method)->flags & PUBLIC_METHOD) ? 1 : 0; } + +int +Tcl_MethodIsPrivate( + Tcl_Method method) +{ + return (((Method *)method)->flags & TRUE_PRIVATE_METHOD) ? 1 : 0; +} /* * Extended method construction for itcl-ng. @@ -1683,7 +1713,7 @@ TclOONewProcInstanceMethodEx( TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc, - ClientData clientData, + void *clientData, Tcl_Obj *nameObj, /* The name of the method, which must not be * NULL. */ Tcl_Obj *argsObj, /* The formal argument list for the method, @@ -1720,7 +1750,7 @@ TclOONewProcMethodEx( TclOO_PreCallProc *preCallPtr, TclOO_PostCallProc *postCallPtr, ProcErrorProc *errProc, - ClientData clientData, + void *clientData, Tcl_Obj *nameObj, /* The name of the method, which may be NULL; * if so, up to caller to manage storage * (e.g., because it is a constructor or diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h new file mode 100644 index 0000000..ab637dd --- /dev/null +++ b/generic/tclOOScript.h @@ -0,0 +1,263 @@ +/* + * tclOOScript.h -- + * + * This file contains support scripts for TclOO. They are defined here so + * that the code can be definitely run even in safe interpreters; TclOO's + * core setup is safe. + * + * Copyright (c) 2012-2018 Donal K. Fellows + * Copyright (c) 2013 Andreas Kupries + * Copyright (c) 2017 Gerald Lester + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#ifndef TCL_OO_SCRIPT_H +#define TCL_OO_SCRIPT_H + +/* + * The scripted part of the definitions of TclOO. + * + * Compiled from generic/tclOOScript.tcl by tools/makeHeader.tcl, which + * contains the commented version of everything; *this* file is automatically + * generated. + */ + +static const char *tclOOSetupScript = +/* !BEGIN!: Do not edit below this line. */ +"::namespace eval ::oo {\n" +"\t::namespace path {}\n" +"\tnamespace eval Helpers {\n" +"\t\t::namespace path {}\n" +"\t\tproc callback {method args} {\n" +"\t\t\tlist [uplevel 1 {::namespace which my}] $method {*}$args\n" +"\t\t}\n" +"\t\tnamespace export callback\n" +"\t\tnamespace eval tmp {namespace import ::oo::Helpers::callback}\n" +"\t\tnamespace export -clear\n" +"\t\trename tmp::callback mymethod\n" +"\t\tnamespace delete tmp\n" +"\t\tproc classvariable {name args} {\n" +"\t\t\tset ns [info object namespace [uplevel 1 {self class}]]\n" +"\t\t\tforeach v [list $name {*}$args] {\n" +"\t\t\t\tif {[string match *(*) $v]} {\n" +"\t\t\t\t\tset reason \"can\'t create a scalar variable that looks like an array element\"\n" +"\t\t\t\t\treturn -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \\\n" +"\t\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n" +"\t\t\t\t}\n" +"\t\t\t\tif {[string match *::* $v]} {\n" +"\t\t\t\t\tset reason \"can\'t create a local variable with a namespace separator in it\"\n" +"\t\t\t\t\treturn -code error -errorcode {TCL UPVAR INVERTED} \\\n" +"\t\t\t\t\t\t[format {bad variable name \"%s\": %s} $v $reason]\n" +"\t\t\t\t}\n" +"\t\t\t\tlappend vs $v $v\n" +"\t\t\t}\n" +"\t\t\ttailcall namespace upvar $ns {*}$vs\n" +"\t\t}\n" +"\t\tproc link {args} {\n" +"\t\t\tset ns [uplevel 1 {::namespace current}]\n" +"\t\t\tforeach link $args {\n" +"\t\t\t\tif {[llength $link] == 2} {\n" +"\t\t\t\t\tlassign $link src dst\n" +"\t\t\t\t} elseif {[llength $link] == 1} {\n" +"\t\t\t\t\tlassign $link src\n" +"\t\t\t\t\tset dst $src\n" +"\t\t\t\t} else {\n" +"\t\t\t\t\treturn -code error -errorcode {TCLOO CMDLINK FORMAT} \\\n" +"\t\t\t\t\t\t\"bad link description; must only have one or two elements\"\n" +"\t\t\t\t}\n" +"\t\t\t\tif {![string match ::* $src]} {\n" +"\t\t\t\t\tset src [string cat $ns :: $src]\n" +"\t\t\t\t}\n" +"\t\t\t\tinterp alias {} $src {} ${ns}::my $dst\n" +"\t\t\t\ttrace add command ${ns}::my delete [list \\\n" +"\t\t\t\t\t::oo::UnlinkLinkedCommand $src]\n" +"\t\t\t}\n" +"\t\t\treturn\n" +"\t\t}\n" +"\t}\n" +"\tproc UnlinkLinkedCommand {cmd args} {\n" +"\t\tif {[namespace which $cmd] ne {}} {\n" +"\t\t\trename $cmd {}\n" +"\t\t}\n" +"\t}\n" +"\tproc DelegateName {class} {\n" +"\t\tstring cat [info object namespace $class] {:: oo ::delegate}\n" +"\t}\n" +"\tproc MixinClassDelegates {class} {\n" +"\t\tif {![info object isa class $class]} {\n" +"\t\t\treturn\n" +"\t\t}\n" +"\t\tset delegate [DelegateName $class]\n" +"\t\tif {![info object isa class $delegate]} {\n" +"\t\t\treturn\n" +"\t\t}\n" +"\t\tforeach c [info class superclass $class] {\n" +"\t\t\tset d [DelegateName $c]\n" +"\t\t\tif {![info object isa class $d]} {\n" +"\t\t\t\tcontinue\n" +"\t\t\t}\n" +"\t\t\tdefine $delegate ::oo::define::superclass -append $d\n" +"\t\t}\n" +"\t\tobjdefine $class ::oo::objdefine::mixin -append $delegate\n" +"\t}\n" +"\tproc UpdateClassDelegatesAfterClone {originObject targetObject} {\n" +"\t\tset originDelegate [DelegateName $originObject]\n" +"\t\tset targetDelegate [DelegateName $targetObject]\n" +"\t\tif {\n" +"\t\t\t[info object isa class $originDelegate]\n" +"\t\t\t&& ![info object isa class $targetDelegate]\n" +"\t\t} then {\n" +"\t\t\tcopy $originDelegate $targetDelegate\n" +"\t\t\tobjdefine $targetObject mixin -set \\\n" +"\t\t\t\t{*}[lmap c [info object mixin $targetObject] {\n" +"\t\t\t\t\tif {$c eq $originDelegate} {set targetDelegate} {set c}\n" +"\t\t\t\t}]\n" +"\t\t}\n" +"\t}\n" +"\tproc define::classmethod {name {args {}} {body {}}} {\n" +"\t\t::set argc [::llength [::info level 0]]\n" +"\t\t::if {$argc == 3} {\n" +"\t\t\t::return -code error -errorcode {TCL WRONGARGS} [::format \\\n" +"\t\t\t\t{wrong # args: should be \"%s name \?args body\?\"} \\\n" +"\t\t\t\t[::lindex [::info level 0] 0]]\n" +"\t\t}\n" +"\t\t::set cls [::uplevel 1 self]\n" +"\t\t::if {$argc == 4} {\n" +"\t\t\t::oo::define [::oo::DelegateName $cls] method $name $args $body\n" +"\t\t}\n" +"\t\t::tailcall forward $name myclass $name\n" +"\t}\n" +"\tproc define::initialise {body} {\n" +"\t\t::set clsns [::info object namespace [::uplevel 1 self]]\n" +"\t\t::tailcall apply [::list {} $body $clsns]\n" +"\t}\n" +"\tnamespace eval define {\n" +"\t\t::namespace export initialise\n" +"\t\t::namespace eval tmp {::namespace import ::oo::define::initialise}\n" +"\t\t::namespace export -clear\n" +"\t\t::rename tmp::initialise initialize\n" +"\t\t::namespace delete tmp\n" +"\t}\n" +"\tdefine Slot {\n" +"\t\tmethod Get {} {\n" +"\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n" +"\t\t}\n" +"\t\tmethod Set list {\n" +"\t\t\treturn -code error -errorcode {TCLOO ABSTRACT_SLOT} \"unimplemented\"\n" +"\t\t}\n" +"\t\tmethod Resolve list {\n" +"\t\t\treturn $list\n" +"\t\t}\n" +"\t\tmethod -set args {\n" +"\t\t\tset my [namespace which my]\n" +"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" +"\t\t\ttailcall my Set $args\n" +"\t\t}\n" +"\t\tmethod -append args {\n" +"\t\t\tset my [namespace which my]\n" +"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" +"\t\t\tset current [uplevel 1 [list $my Get]]\n" +"\t\t\ttailcall my Set [list {*}$current {*}$args]\n" +"\t\t}\n" +"\t\tmethod -clear {} {tailcall my Set {}}\n" +"\t\tmethod -prepend args {\n" +"\t\t\tset my [namespace which my]\n" +"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" +"\t\t\tset current [uplevel 1 [list $my Get]]\n" +"\t\t\ttailcall my Set [list {*}$args {*}$current]\n" +"\t\t}\n" +"\t\tmethod -remove args {\n" +"\t\t\tset my [namespace which my]\n" +"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" +"\t\t\tset current [uplevel 1 [list $my Get]]\n" +"\t\t\ttailcall my Set [lmap val $current {\n" +"\t\t\t\tif {$val in $args} continue else {set val}\n" +"\t\t\t}]\n" +"\t\t}\n" +"\t\tforward --default-operation my -append\n" +"\t\tmethod unknown {args} {\n" +"\t\t\tset def --default-operation\n" +"\t\t\tif {[llength $args] == 0} {\n" +"\t\t\t\ttailcall my $def\n" +"\t\t\t} elseif {![string match -* [lindex $args 0]]} {\n" +"\t\t\t\ttailcall my $def {*}$args\n" +"\t\t\t}\n" +"\t\t\tnext {*}$args\n" +"\t\t}\n" +"\t\texport -set -append -clear -prepend -remove\n" +"\t\tunexport unknown destroy\n" +"\t}\n" +"\tobjdefine define::superclass forward --default-operation my -set\n" +"\tobjdefine define::mixin forward --default-operation my -set\n" +"\tobjdefine objdefine::mixin forward --default-operation my -set\n" +"\tdefine object method <cloned> {originObject} {\n" +"\t\tforeach p [info procs [info object namespace $originObject]::*] {\n" +"\t\t\tset args [info args $p]\n" +"\t\t\tset idx -1\n" +"\t\t\tforeach a $args {\n" +"\t\t\t\tif {[info default $p $a d]} {\n" +"\t\t\t\t\tlset args [incr idx] [list $a $d]\n" +"\t\t\t\t} else {\n" +"\t\t\t\t\tlset args [incr idx] [list $a]\n" +"\t\t\t\t}\n" +"\t\t\t}\n" +"\t\t\tset b [info body $p]\n" +"\t\t\tset p [namespace tail $p]\n" +"\t\t\tproc $p $args $b\n" +"\t\t}\n" +"\t\tforeach v [info vars [info object namespace $originObject]::*] {\n" +"\t\t\tupvar 0 $v vOrigin\n" +"\t\t\tnamespace upvar [namespace current] [namespace tail $v] vNew\n" +"\t\t\tif {[info exists vOrigin]} {\n" +"\t\t\t\tif {[array exists vOrigin]} {\n" +"\t\t\t\t\tarray set vNew [array get vOrigin]\n" +"\t\t\t\t} else {\n" +"\t\t\t\t\tset vNew $vOrigin\n" +"\t\t\t\t}\n" +"\t\t\t}\n" +"\t\t}\n" +"\t}\n" +"\tdefine class method <cloned> {originObject} {\n" +"\t\tnext $originObject\n" +"\t\t::oo::UpdateClassDelegatesAfterClone $originObject [self]\n" +"\t}\n" +"\tclass create singleton {\n" +"\t\tsuperclass class\n" +"\t\tvariable object\n" +"\t\tunexport create createWithNamespace\n" +"\t\tmethod new args {\n" +"\t\t\tif {![info exists object] || ![info object isa object $object]} {\n" +"\t\t\t\tset object [next {*}$args]\n" +"\t\t\t\t::oo::objdefine $object {\n" +"\t\t\t\t\tmethod destroy {} {\n" +"\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n" +"\t\t\t\t\t\t\t\"may not destroy a singleton object\"\n" +"\t\t\t\t\t}\n" +"\t\t\t\t\tmethod <cloned> {originObject} {\n" +"\t\t\t\t\t\t::return -code error -errorcode {TCLOO SINGLETON} \\\n" +"\t\t\t\t\t\t\t\"may not clone a singleton object\"\n" +"\t\t\t\t\t}\n" +"\t\t\t\t}\n" +"\t\t\t}\n" +"\t\t\treturn $object\n" +"\t\t}\n" +"\t}\n" +"\tclass create abstract {\n" +"\t\tsuperclass class\n" +"\t\tunexport create createWithNamespace new\n" +"\t}\n" +"}\n" +/* !END!: Do not edit above this line. */ +; + +#endif /* TCL_OO_SCRIPT_H */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclOOScript.tcl b/generic/tclOOScript.tcl new file mode 100644 index 0000000..5e0145f --- /dev/null +++ b/generic/tclOOScript.tcl @@ -0,0 +1,456 @@ +# tclOOScript.h -- +# +# This file contains support scripts for TclOO. They are defined here so +# that the code can be definitely run even in safe interpreters; TclOO's +# core setup is safe. +# +# Copyright (c) 2012-2018 Donal K. Fellows +# Copyright (c) 2013 Andreas Kupries +# Copyright (c) 2017 Gerald Lester +# +# See the file "license.terms" for information on usage and redistribution of +# this file, and for a DISCLAIMER OF ALL WARRANTIES. + +::namespace eval ::oo { + ::namespace path {} + + # + # Commands that are made available to objects by default. + # + namespace eval Helpers { + ::namespace path {} + + # ------------------------------------------------------------------ + # + # callback, mymethod -- + # + # Create a script prefix that calls a method on the current + # object. Same operation, two names. + # + # ------------------------------------------------------------------ + + proc callback {method args} { + list [uplevel 1 {::namespace which my}] $method {*}$args + } + + # Make the [callback] command appear as [mymethod] too. + namespace export callback + namespace eval tmp {namespace import ::oo::Helpers::callback} + namespace export -clear + rename tmp::callback mymethod + namespace delete tmp + + # ------------------------------------------------------------------ + # + # classvariable -- + # + # Link to a variable in the class of the current object. + # + # ------------------------------------------------------------------ + + proc classvariable {name args} { + # Get a reference to the class's namespace + set ns [info object namespace [uplevel 1 {self class}]] + # Double up the list of variable names + foreach v [list $name {*}$args] { + if {[string match *(*) $v]} { + set reason "can't create a scalar variable that looks like an array element" + return -code error -errorcode {TCL UPVAR LOCAL_ELEMENT} \ + [format {bad variable name "%s": %s} $v $reason] + } + if {[string match *::* $v]} { + set reason "can't create a local variable with a namespace separator in it" + return -code error -errorcode {TCL UPVAR INVERTED} \ + [format {bad variable name "%s": %s} $v $reason] + } + lappend vs $v $v + } + # Lastly, link the caller's local variables to the class's variables + tailcall namespace upvar $ns {*}$vs + } + + # ------------------------------------------------------------------ + # + # link -- + # + # Make a command that invokes a method on the current object. + # The name of the command and the name of the method match by + # default. + # + # ------------------------------------------------------------------ + + proc link {args} { + set ns [uplevel 1 {::namespace current}] + foreach link $args { + if {[llength $link] == 2} { + lassign $link src dst + } elseif {[llength $link] == 1} { + lassign $link src + set dst $src + } else { + return -code error -errorcode {TCLOO CMDLINK FORMAT} \ + "bad link description; must only have one or two elements" + } + if {![string match ::* $src]} { + set src [string cat $ns :: $src] + } + interp alias {} $src {} ${ns}::my $dst + trace add command ${ns}::my delete [list \ + ::oo::UnlinkLinkedCommand $src] + } + return + } + } + + # ---------------------------------------------------------------------- + # + # UnlinkLinkedCommand -- + # + # Callback used to remove linked command when the underlying mechanism + # that supports it is deleted. + # + # ---------------------------------------------------------------------- + + proc UnlinkLinkedCommand {cmd args} { + if {[namespace which $cmd] ne {}} { + rename $cmd {} + } + } + + # ---------------------------------------------------------------------- + # + # DelegateName -- + # + # Utility that gets the name of the class delegate for a class. It's + # trivial, but makes working with them much easier as delegate names are + # intentionally hard to create by accident. + # + # ---------------------------------------------------------------------- + + proc DelegateName {class} { + string cat [info object namespace $class] {:: oo ::delegate} + } + + # ---------------------------------------------------------------------- + # + # MixinClassDelegates -- + # + # Support code called *after* [oo::define] inside the constructor of a + # class that patches in the appropriate class delegates. + # + # ---------------------------------------------------------------------- + + proc MixinClassDelegates {class} { + if {![info object isa class $class]} { + return + } + set delegate [DelegateName $class] + if {![info object isa class $delegate]} { + return + } + foreach c [info class superclass $class] { + set d [DelegateName $c] + if {![info object isa class $d]} { + continue + } + define $delegate ::oo::define::superclass -append $d + } + objdefine $class ::oo::objdefine::mixin -append $delegate + } + + # ---------------------------------------------------------------------- + # + # UpdateClassDelegatesAfterClone -- + # + # Support code that is like [MixinClassDelegates] except for when a + # class is cloned. + # + # ---------------------------------------------------------------------- + + proc UpdateClassDelegatesAfterClone {originObject targetObject} { + # Rebuild the class inheritance delegation class + set originDelegate [DelegateName $originObject] + set targetDelegate [DelegateName $targetObject] + if { + [info object isa class $originDelegate] + && ![info object isa class $targetDelegate] + } then { + copy $originDelegate $targetDelegate + objdefine $targetObject ::oo::objdefine::mixin -set \ + {*}[lmap c [info object mixin $targetObject] { + if {$c eq $originDelegate} {set targetDelegate} {set c} + }] + } + } + + # ---------------------------------------------------------------------- + # + # oo::define::classmethod -- + # + # Defines a class method. See define(n) for details. + # + # Note that the ::oo::define namespace is semi-public and a bit weird + # anyway, so we don't regard the namespace path as being under control: + # fully qualified names are used for everything. + # + # ---------------------------------------------------------------------- + + proc define::classmethod {name {args {}} {body {}}} { + # Create the method on the class if the caller gave arguments and body + ::set argc [::llength [::info level 0]] + ::if {$argc == 3} { + ::return -code error -errorcode {TCL WRONGARGS} [::format \ + {wrong # args: should be "%s name ?args body?"} \ + [::lindex [::info level 0] 0]] + } + ::set cls [::uplevel 1 self] + ::if {$argc == 4} { + ::oo::define [::oo::DelegateName $cls] method $name $args $body + } + # Make the connection by forwarding + ::tailcall forward $name myclass $name + } + + # ---------------------------------------------------------------------- + # + # oo::define::initialise, oo::define::initialize -- + # + # Do specific initialisation for a class. See define(n) for details. + # + # Note that the ::oo::define namespace is semi-public and a bit weird + # anyway, so we don't regard the namespace path as being under control: + # fully qualified names are used for everything. + # + # ---------------------------------------------------------------------- + + proc define::initialise {body} { + ::set clsns [::info object namespace [::uplevel 1 self]] + ::tailcall apply [::list {} $body $clsns] + } + + # Make the [initialise] definition appear as [initialize] too + namespace eval define { + ::namespace export initialise + ::namespace eval tmp {::namespace import ::oo::define::initialise} + ::namespace export -clear + ::rename tmp::initialise initialize + ::namespace delete tmp + } + + # ---------------------------------------------------------------------- + # + # Slot -- + # + # The class of slot operations, which are basically lists at the low + # level of TclOO; this provides a more consistent interface to them. + # + # ---------------------------------------------------------------------- + + define Slot { + # ------------------------------------------------------------------ + # + # Slot Get -- + # + # Basic slot getter. Retrieves the contents of the slot. + # Particular slots must provide concrete non-erroring + # implementation. + # + # ------------------------------------------------------------------ + + method Get {} { + return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented" + } + + # ------------------------------------------------------------------ + # + # Slot Set -- + # + # Basic slot setter. Sets the contents of the slot. Particular + # slots must provide concrete non-erroring implementation. + # + # ------------------------------------------------------------------ + + method Set list { + return -code error -errorcode {TCLOO ABSTRACT_SLOT} "unimplemented" + } + + # ------------------------------------------------------------------ + # + # Slot Resolve -- + # + # Helper that lets a slot convert a list of arguments of a + # particular type to their canonical forms. Defaults to doing + # nothing (suitable for simple strings). + # + # ------------------------------------------------------------------ + + method Resolve list { + return $list + } + + # ------------------------------------------------------------------ + # + # Slot -set, -append, -clear, --default-operation -- + # + # Standard public slot operations. If a slot can't figure out + # what method to call directly, it uses --default-operation. + # + # ------------------------------------------------------------------ + + method -set args { + set my [namespace which my] + set args [lmap a $args {uplevel 1 [list $my Resolve $a]}] + tailcall my Set $args + } + method -append args { + set my [namespace which my] + set args [lmap a $args {uplevel 1 [list $my Resolve $a]}] + set current [uplevel 1 [list $my Get]] + tailcall my Set [list {*}$current {*}$args] + } + method -clear {} {tailcall my Set {}} + method -prepend args { + set my [namespace which my] + set args [lmap a $args {uplevel 1 [list $my Resolve $a]}] + set current [uplevel 1 [list $my Get]] + tailcall my Set [list {*}$args {*}$current] + } + method -remove args { + set my [namespace which my] + set args [lmap a $args {uplevel 1 [list $my Resolve $a]}] + set current [uplevel 1 [list $my Get]] + tailcall my Set [lmap val $current { + if {$val in $args} continue else {set val} + }] + } + + # Default handling + forward --default-operation my -append + method unknown {args} { + set def --default-operation + if {[llength $args] == 0} { + tailcall my $def + } elseif {![string match -* [lindex $args 0]]} { + tailcall my $def {*}$args + } + next {*}$args + } + + # Set up what is exported and what isn't + export -set -append -clear -prepend -remove + unexport unknown destroy + } + + # Set the default operation differently for these slots + objdefine define::superclass forward --default-operation my -set + objdefine define::mixin forward --default-operation my -set + objdefine objdefine::mixin forward --default-operation my -set + + # ---------------------------------------------------------------------- + # + # oo::object <cloned> -- + # + # Handler for cloning objects that clones basic bits (only!) of the + # object's namespace. Non-procedures, traces, sub-namespaces, etc. need + # more complex (and class-specific) handling. + # + # ---------------------------------------------------------------------- + + define object method <cloned> {originObject} { + # Copy over the procedures from the original namespace + foreach p [info procs [info object namespace $originObject]::*] { + set args [info args $p] + set idx -1 + foreach a $args { + if {[info default $p $a d]} { + lset args [incr idx] [list $a $d] + } else { + lset args [incr idx] [list $a] + } + } + set b [info body $p] + set p [namespace tail $p] + proc $p $args $b + } + # Copy over the variables from the original namespace + foreach v [info vars [info object namespace $originObject]::*] { + upvar 0 $v vOrigin + namespace upvar [namespace current] [namespace tail $v] vNew + if {[info exists vOrigin]} { + if {[array exists vOrigin]} { + array set vNew [array get vOrigin] + } else { + set vNew $vOrigin + } + } + } + # General commands, sub-namespaces and advancd variable config (traces, + # etc) are *not* copied over. Classes that want that should do it + # themselves. + } + + # ---------------------------------------------------------------------- + # + # oo::class <cloned> -- + # + # Handler for cloning classes, which fixes up the delegates. + # + # ---------------------------------------------------------------------- + + define class method <cloned> {originObject} { + next $originObject + # Rebuild the class inheritance delegation class + ::oo::UpdateClassDelegatesAfterClone $originObject [self] + } + + # ---------------------------------------------------------------------- + # + # oo::singleton -- + # + # A metaclass that is used to make classes that only permit one instance + # of them to exist. See singleton(n). + # + # ---------------------------------------------------------------------- + + class create singleton { + superclass class + variable object + unexport create createWithNamespace + method new args { + if {![info exists object] || ![info object isa object $object]} { + set object [next {*}$args] + ::oo::objdefine $object { + method destroy {} { + ::return -code error -errorcode {TCLOO SINGLETON} \ + "may not destroy a singleton object" + } + method <cloned> {originObject} { + ::return -code error -errorcode {TCLOO SINGLETON} \ + "may not clone a singleton object" + } + } + } + return $object + } + } + + # ---------------------------------------------------------------------- + # + # oo::abstract -- + # + # A metaclass that is used to make classes that can't be directly + # instantiated. See abstract(n). + # + # ---------------------------------------------------------------------- + + class create abstract { + superclass class + unexport create createWithNamespace new + } +} + +# Local Variables: +# mode: tcl +# c-basic-offset: 4 +# fill-column: 78 +# End: diff --git a/generic/tclOOStubInit.c b/generic/tclOOStubInit.c index 900ab22..5e235f4 100644 --- a/generic/tclOOStubInit.c +++ b/generic/tclOOStubInit.c @@ -73,6 +73,7 @@ const TclOOStubs tclOOStubs = { Tcl_ClassSetConstructor, /* 26 */ Tcl_ClassSetDestructor, /* 27 */ Tcl_GetObjectName, /* 28 */ + Tcl_MethodIsPrivate, /* 29 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclObj.c b/generic/tclObj.c index 255614a..d329aba 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -17,6 +17,7 @@ #include "tclInt.h" #include "tommath.h" #include <math.h> +#include <assert.h> /* * Table of all object types. @@ -37,7 +38,7 @@ Tcl_Obj *tclFreeObjList = NULL; * TclNewObj macro, however, so must be visible. */ -#ifdef TCL_THREADS +#if TCL_THREADS MODULE_SCOPE Tcl_Mutex tclObjMutex; Tcl_Mutex tclObjMutex; #endif @@ -49,9 +50,8 @@ Tcl_Mutex tclObjMutex; */ char tclEmptyString = '\0'; -char *tclEmptyStringRep = &tclEmptyString; -#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) +#if TCL_THREADS && defined(TCL_MEM_DEBUG) /* * Structure for tracking the source file and line number where a given * Tcl_Obj was allocated. We also track the pointer to the Tcl_Obj itself, @@ -76,7 +76,7 @@ typedef struct ObjData { * The structure defined below is used in this file only. */ -typedef struct ThreadSpecificData { +typedef struct { Tcl_HashTable *lineCLPtr; /* This table remembers for each Tcl_Obj * generated by a call to the function * TclSubstTokens() from a literal text @@ -88,7 +88,7 @@ typedef struct ThreadSpecificData { * tclCompile.h for the definition of this * structure, and for references to all * related places in the core. */ -#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) +#if TCL_THREADS && defined(TCL_MEM_DEBUG) Tcl_HashTable *objThreadMap;/* Thread local table that is used to check * that a Tcl_Obj was not allocated by some * other thread. */ @@ -157,7 +157,7 @@ typedef struct PendingObjData { /* * Macro to set up the local reference to the deletion context. */ -#ifndef TCL_THREADS +#if !TCL_THREADS static PendingObjData pendingObjData; #define ObjInitDeletionContext(contextPtr) \ PendingObjData *const contextPtr = &pendingObjData @@ -178,7 +178,7 @@ static Tcl_ThreadDataKey pendingObjDataKey; #define PACK_BIGNUM(bignum, objPtr) \ if ((bignum).used > 0x7fff) { \ - mp_int *temp = (void *) ckalloc((unsigned) sizeof(mp_int)); \ + mp_int *temp = (void *) ckalloc(sizeof(mp_int)); \ *temp = bignum; \ (objPtr)->internalRep.twoPtrValue.ptr1 = temp; \ (objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR(-1); \ @@ -191,17 +191,6 @@ static Tcl_ThreadDataKey pendingObjDataKey; | ((bignum).alloc << 15) | ((bignum).used)); \ } -#define UNPACK_BIGNUM(objPtr, bignum) \ - if ((objPtr)->internalRep.twoPtrValue.ptr2 == INT2PTR(-1)) { \ - (bignum) = *((mp_int *) ((objPtr)->internalRep.twoPtrValue.ptr1)); \ - } else { \ - (bignum).dp = (objPtr)->internalRep.twoPtrValue.ptr1; \ - (bignum).sign = PTR2INT((objPtr)->internalRep.twoPtrValue.ptr2) >> 30; \ - (bignum).alloc = \ - (PTR2INT((objPtr)->internalRep.twoPtrValue.ptr2) >> 15) & 0x7fff; \ - (bignum).used = PTR2INT((objPtr)->internalRep.twoPtrValue.ptr2) & 0x7fff; \ - } - /* * Prototypes for functions defined later in this file: */ @@ -211,9 +200,8 @@ static int SetDoubleFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static int SetIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void UpdateStringOfDouble(Tcl_Obj *objPtr); static void UpdateStringOfInt(Tcl_Obj *objPtr); -#ifndef TCL_WIDE_INT_IS_LONG -static void UpdateStringOfWideInt(Tcl_Obj *objPtr); -static int SetWideIntFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 && !defined(TCL_WIDE_INT_IS_LONG) +static void UpdateStringOfOldInt(Tcl_Obj *objPtr); #endif static void FreeBignum(Tcl_Obj *objPtr); static void DupBignum(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); @@ -243,6 +231,7 @@ static int SetCmdNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); * implementations. */ +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 static const Tcl_ObjType oldBooleanType = { "boolean", /* name */ NULL, /* freeIntRepProc */ @@ -250,6 +239,7 @@ static const Tcl_ObjType oldBooleanType = { NULL, /* updateStringProc */ TclSetBooleanFromAny /* setFromAnyProc */ }; +#endif const Tcl_ObjType tclBooleanType = { "booleanString", /* name */ NULL, /* freeIntRepProc */ @@ -265,19 +255,23 @@ const Tcl_ObjType tclDoubleType = { SetDoubleFromAny /* setFromAnyProc */ }; const Tcl_ObjType tclIntType = { +#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 || defined(TCL_WIDE_INT_IS_LONG) "int", /* name */ +#else + "wideInt", /* name, keeping maximum compatibility with Tcl 8.6 on 32-bit platforms*/ +#endif NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ UpdateStringOfInt, /* updateStringProc */ SetIntFromAny /* setFromAnyProc */ }; -#ifndef TCL_WIDE_INT_IS_LONG -const Tcl_ObjType tclWideIntType = { - "wideInt", /* name */ +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 && !defined(TCL_WIDE_INT_IS_LONG) +static const Tcl_ObjType oldIntType = { + "int", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ - UpdateStringOfWideInt, /* updateStringProc */ - SetWideIntFromAny /* setFromAnyProc */ + UpdateStringOfOldInt, /* updateStringProc */ + SetIntFromAny /* setFromAnyProc */ }; #endif const Tcl_ObjType tclBignumType = { @@ -345,23 +339,23 @@ typedef struct ResolvedCmdName { * reference (not the namespace that contains * the referenced command). NULL if the name * is fully qualified.*/ - long refNsId; /* refNsPtr's unique namespace id. Used to + unsigned 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). */ - int refNsCmdEpoch; /* Value of the referencing namespace's + unsigned 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. */ - int cmdEpoch; /* Value of the command's cmdEpoch when this + unsigned 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. */ - int refCount; /* Reference count: 1 for each cmdName object + size_t refCount; /* Reference count: 1 for each cmdName object * that has a pointer to this ResolvedCmdName * structure as its internal rep. This * structure can be freed when refCount @@ -396,21 +390,21 @@ TclInitObjSubsystem(void) Tcl_RegisterObjType(&tclByteArrayType); Tcl_RegisterObjType(&tclDoubleType); - Tcl_RegisterObjType(&tclEndOffsetType); - Tcl_RegisterObjType(&tclIntType); Tcl_RegisterObjType(&tclStringType); Tcl_RegisterObjType(&tclListType); Tcl_RegisterObjType(&tclDictType); Tcl_RegisterObjType(&tclByteCodeType); - Tcl_RegisterObjType(&tclArraySearchType); Tcl_RegisterObjType(&tclCmdNameType); Tcl_RegisterObjType(&tclRegexpType); Tcl_RegisterObjType(&tclProcBodyType); /* For backward compatibility only ... */ +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 + Tcl_RegisterObjType(&tclIntType); +#if !defined(TCL_WIDE_INT_IS_LONG) + Tcl_RegisterObjType(&oldIntType); +#endif Tcl_RegisterObjType(&oldBooleanType); -#ifndef TCL_WIDE_INT_IS_LONG - Tcl_RegisterObjType(&tclWideIntType); #endif #ifdef TCL_COMPILE_STATS @@ -448,7 +442,7 @@ TclInitObjSubsystem(void) void TclFinalizeThreadObjects(void) { -#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) +#if TCL_THREADS && defined(TCL_MEM_DEBUG) Tcl_HashEntry *hPtr; Tcl_HashSearch hSearch; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -1005,7 +999,7 @@ void TclDbDumpActiveObjects( FILE *outFile) { -#if defined(TCL_MEM_DEBUG) && defined(TCL_THREADS) +#if TCL_THREADS && defined(TCL_MEM_DEBUG) Tcl_HashSearch hSearch; Tcl_HashEntry *hPtr; Tcl_HashTable *tablePtr; @@ -1061,11 +1055,10 @@ TclDbInitNewObj( * debugging. */ { objPtr->refCount = 0; - objPtr->bytes = tclEmptyStringRep; - objPtr->length = 0; objPtr->typePtr = NULL; + TclInitStringRep(objPtr, NULL, 0); -#ifdef TCL_THREADS +#if TCL_THREADS /* * Add entry to a thread local map used to check if a Tcl_Obj was * allocated by the currently executing thread. @@ -1301,7 +1294,7 @@ TclFreeObj( ObjInitDeletionContext(context); -# ifdef TCL_THREADS +#if TCL_THREADS /* * Check to make sure that the Tcl_Obj was allocated by the current * thread. Don't do this check when shutting down since thread local @@ -1628,32 +1621,30 @@ Tcl_GetString( register Tcl_Obj *objPtr) /* Object whose string rep byte pointer should * be returned. */ { - if (objPtr->bytes != NULL) { - return objPtr->bytes; - } - - /* - * Note we do not check for objPtr->typePtr == NULL. An invariant of - * a properly maintained Tcl_Obj is that at least one of objPtr->bytes - * and objPtr->typePtr must not be NULL. If broken extensions fail to - * maintain that invariant, we can crash here. - */ - - if (objPtr->typePtr->updateStringProc == NULL) { + if (objPtr->bytes == NULL) { /* - * Those Tcl_ObjTypes which choose not to define an updateStringProc - * must be written in such a way that (objPtr->bytes) never becomes - * NULL. This panic was added in Tcl 8.1. + * Note we do not check for objPtr->typePtr == NULL. An invariant + * of a properly maintained Tcl_Obj is that at least one of + * objPtr->bytes and objPtr->typePtr must not be NULL. If broken + * extensions fail to maintain that invariant, we can crash here. */ - Tcl_Panic("UpdateStringProc should not be invoked for type %s", - objPtr->typePtr->name); - } - objPtr->typePtr->updateStringProc(objPtr); - if (objPtr->bytes == NULL || objPtr->length < 0 - || objPtr->bytes[objPtr->length] != '\0') { - Tcl_Panic("UpdateStringProc for type '%s' " - "failed to create a valid string rep", objPtr->typePtr->name); + if (objPtr->typePtr->updateStringProc == NULL) { + /* + * Those Tcl_ObjTypes which choose not to define an + * updateStringProc must be written in such a way that + * (objPtr->bytes) never becomes NULL. + */ + Tcl_Panic("UpdateStringProc should not be invoked for type %s", + objPtr->typePtr->name); + } + objPtr->typePtr->updateStringProc(objPtr); + if (objPtr->bytes == NULL || objPtr->length < 0 + || objPtr->bytes[objPtr->length] != '\0') { + Tcl_Panic("UpdateStringProc for type '%s' " + "failed to create a valid string rep", + objPtr->typePtr->name); + } } return objPtr->bytes; } @@ -1689,8 +1680,31 @@ Tcl_GetStringFromObj( * rep's byte array length should * be stored. * If NULL, no length is stored. */ { - (void) TclGetString(objPtr); + if (objPtr->bytes == NULL) { + /* + * Note we do not check for objPtr->typePtr == NULL. An invariant + * of a properly maintained Tcl_Obj is that at least one of + * objPtr->bytes and objPtr->typePtr must not be NULL. If broken + * extensions fail to maintain that invariant, we can crash here. + */ + if (objPtr->typePtr->updateStringProc == NULL) { + /* + * Those Tcl_ObjTypes which choose not to define an + * updateStringProc must be written in such a way that + * (objPtr->bytes) never becomes NULL. + */ + Tcl_Panic("UpdateStringProc should not be invoked for type %s", + objPtr->typePtr->name); + } + objPtr->typePtr->updateStringProc(objPtr); + if (objPtr->bytes == NULL || objPtr->length < 0 + || objPtr->bytes[objPtr->length] != '\0') { + Tcl_Panic("UpdateStringProc for type '%s' " + "failed to create a valid string rep", + objPtr->typePtr->name); + } + } if (lengthPtr != NULL) { *lengthPtr = objPtr->length; } @@ -1700,6 +1714,91 @@ Tcl_GetStringFromObj( /* *---------------------------------------------------------------------- * + * Tcl_InitStringRep -- + * + * This function is called in several configurations to provide all + * the tools needed to set an object's string representation. The + * function is determined by the arguments. + * + * (objPtr->bytes != NULL && bytes != NULL) || (numBytes < 0) + * Invalid call -- panic! + * + * objPtr->bytes == NULL && bytes == NULL && numBytes >= 0 + * Allocation only - allocate space for (numBytes+1) chars. + * store in objPtr->bytes and return. Also sets + * objPtr->length to 0 and objPtr->bytes[0] to NUL. + * + * objPtr->bytes == NULL && bytes != NULL && numBytes >= 0 + * Allocate and copy. bytes is assumed to point to chars to + * copy into the string rep. objPtr->length = numBytes. Allocate + * array of (numBytes + 1) chars. store in objPtr->bytes. Copy + * numBytes chars from bytes to objPtr->bytes; Set + * objPtr->bytes[numBytes] to NUL and return objPtr->bytes. + * Caller must guarantee there are numBytes chars at bytes to + * be copied. + * + * objPtr->bytes != NULL && bytes == NULL && numBytes >= 0 + * Truncate. Set objPtr->length to numBytes and + * objPr->bytes[numBytes] to NUL. Caller has to guarantee + * that a prior allocating call allocated enough bytes for + * this to be valid. Return objPtr->bytes. + * + * Caller is expected to ascertain that the bytes copied into + * the string rep make up complete valid UTF-8 characters. + * + * Results: + * A pointer to the string rep of objPtr. + * + * Side effects: + * As described above. + * + *---------------------------------------------------------------------- + */ + +char * +Tcl_InitStringRep( + Tcl_Obj *objPtr, /* Object whose string rep is to be set */ + const char *bytes, + unsigned int numBytes) +{ + assert(objPtr->bytes == NULL || bytes == NULL); + + if (numBytes > INT_MAX) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } + + /* Allocate */ + if (objPtr->bytes == NULL) { + /* Allocate only as empty - extend later if bytes copied */ + objPtr->length = 0; + if (numBytes) { + objPtr->bytes = attemptckalloc(numBytes + 1); + if (objPtr->bytes == NULL) { + return NULL; + } + if (bytes) { + /* Copy */ + memcpy(objPtr->bytes, bytes, numBytes); + objPtr->length = (int) numBytes; + } + } else { + TclInitStringRep(objPtr, NULL, 0); + } + } else { + /* objPtr->bytes != NULL bytes == NULL - Truncate */ + objPtr->bytes = ckrealloc(objPtr->bytes, numBytes + 1); + objPtr->length = (int)numBytes; + } + + /* Terminate */ + objPtr->bytes[objPtr->length] = '\0'; + + return objPtr->bytes; +} + +/* + *---------------------------------------------------------------------- + * * Tcl_InvalidateStringRep -- * * This function is called to invalidate an object's string @@ -1726,6 +1825,117 @@ Tcl_InvalidateStringRep( /* *---------------------------------------------------------------------- * + * Tcl_HasStringRep -- + * + * This function reports whether object has a string representation. + * + * Results: + * Boolean. + *---------------------------------------------------------------------- + */ + +int +Tcl_HasStringRep( + Tcl_Obj *objPtr) /* Object to test */ +{ + return TclHasStringRep(objPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_StoreIntRep -- + * + * This function is called to set the object's internal + * representation to match a particular type. + * + * It is the caller's responsibility to guarantee that + * the value of the submitted IntRep is in agreement with + * the value of any existing string rep. + * + * Results: + * None. + * + * Side effects: + * Calls the freeIntRepProc of the current Tcl_ObjType, if any. + * Sets the internalRep and typePtr fields to the submitted values. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_StoreIntRep( + Tcl_Obj *objPtr, /* Object whose internal rep should be set. */ + const Tcl_ObjType *typePtr, /* New type for the object */ + const Tcl_ObjIntRep *irPtr) /* New IntRep for the object */ +{ + /* Clear out any existing IntRep ( "shimmer" ) */ + TclFreeIntRep(objPtr); + + /* When irPtr == NULL, just leave objPtr with no IntRep for typePtr */ + if (irPtr) { + /* Copy the new IntRep into place */ + objPtr->internalRep = *irPtr; + + /* Set the type to match */ + objPtr->typePtr = typePtr; + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FetchIntRep -- + * + * This function is called to retrieve the object's internal + * representation matching a requested type, if any. + * + * Results: + * A read-only pointer to the associated Tcl_ObjIntRep, or + * NULL if no such internal representation exists. + * + * Side effects: + * Calls the freeIntRepProc of the current Tcl_ObjType, if any. + * Sets the internalRep and typePtr fields to the submitted values. + * + *---------------------------------------------------------------------- + */ + +Tcl_ObjIntRep * +Tcl_FetchIntRep( + Tcl_Obj *objPtr, /* Object to fetch from. */ + const Tcl_ObjType *typePtr) /* Requested type */ +{ + return TclFetchIntRep(objPtr, typePtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_FreeIntRep -- + * + * This function is called to free an object's internal representation. + * + * Results: + * None. + * + * Side effects: + * Calls the freeIntRepProc of the current Tcl_ObjType, if any. + * Sets typePtr field to NULL. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_FreeIntRep( + Tcl_Obj *objPtr) /* Object whose internal rep should be freed. */ +{ + TclFreeIntRep(objPtr); +} + +/* + *---------------------------------------------------------------------- + * * Tcl_NewBooleanObj -- * * This function is normally called when not debugging: i.e., when @@ -1734,7 +1944,7 @@ Tcl_InvalidateStringRep( * is coerced to 1. * * When TCL_MEM_DEBUG is defined, this function just returns the result - * of calling the debugging version Tcl_DbNewBooleanObj. + * of calling the debugging version Tcl_DbNewLongObj. * * Results: * The newly created object is returned. This object will have an invalid @@ -1753,7 +1963,7 @@ Tcl_Obj * Tcl_NewBooleanObj( register int boolValue) /* Boolean used to initialize new object. */ { - return Tcl_DbNewBooleanObj(boolValue, "unknown", 0); + return Tcl_DbNewWideIntObj(boolValue!=0, "unknown", 0); } #else /* if not TCL_MEM_DEBUG */ @@ -1764,7 +1974,7 @@ Tcl_NewBooleanObj( { register Tcl_Obj *objPtr; - TclNewBooleanObj(objPtr, boolValue); + TclNewIntObj(objPtr, boolValue!=0); return objPtr; } #endif /* TCL_MEM_DEBUG */ @@ -1795,6 +2005,7 @@ Tcl_NewBooleanObj( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_DbNewBooleanObj #ifdef TCL_MEM_DEBUG @@ -1809,9 +2020,10 @@ Tcl_DbNewBooleanObj( register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); + /* Optimized TclInvalidateStringRep() */ objPtr->bytes = NULL; - objPtr->internalRep.longValue = (boolValue? 1 : 0); + objPtr->internalRep.wideValue = (boolValue != 0); objPtr->typePtr = &tclIntType; return objPtr; } @@ -1858,8 +2070,9 @@ Tcl_SetBooleanObj( Tcl_Panic("%s called with shared object", "Tcl_SetBooleanObj"); } - TclSetBooleanObj(objPtr, boolValue); + TclSetIntObj(objPtr, boolValue!=0); } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -1888,11 +2101,11 @@ Tcl_GetBooleanFromObj( { do { if (objPtr->typePtr == &tclIntType) { - *boolPtr = (objPtr->internalRep.longValue != 0); + *boolPtr = (objPtr->internalRep.wideValue != 0); return TCL_OK; } if (objPtr->typePtr == &tclBooleanType) { - *boolPtr = (int) objPtr->internalRep.longValue; + *boolPtr = objPtr->internalRep.longValue != 0; return TCL_OK; } if (objPtr->typePtr == &tclDoubleType) { @@ -1916,12 +2129,6 @@ Tcl_GetBooleanFromObj( *boolPtr = 1; return TCL_OK; } -#ifndef TCL_WIDE_INT_IS_LONG - if (objPtr->typePtr == &tclWideIntType) { - *boolPtr = (objPtr->internalRep.wideValue != 0); - return TCL_OK; - } -#endif } while ((ParseBoolean(objPtr) == TCL_OK) || (TCL_OK == TclParseNumber(interp, objPtr, "boolean value", NULL,-1,NULL,0))); return TCL_ERROR; @@ -1942,7 +2149,12 @@ Tcl_GetBooleanFromObj( * * Side effects: * If no error occurs, an integer 1 or 0 is stored as "objPtr"s internal - * representation and the type of "objPtr" is set to boolean. + * representation and the type of "objPtr" is set to boolean or int/wideInt. + * + * Warning: If the returned type is "wideInt" (32-bit platforms) and your + * platform is bigendian, you cannot use internalRep.longValue to distinguish + * between false and true. On Windows and most other platforms this still will + * work fine, but basically it is non-portable. * *---------------------------------------------------------------------- */ @@ -1960,8 +2172,7 @@ TclSetBooleanFromAny( if (objPtr->bytes == NULL) { if (objPtr->typePtr == &tclIntType) { - switch (objPtr->internalRep.longValue) { - case 0L: case 1L: + if ((Tcl_WideUInt)objPtr->internalRep.wideValue < 2) { return TCL_OK; } goto badBoolean; @@ -1971,12 +2182,6 @@ TclSetBooleanFromAny( goto badBoolean; } -#ifndef TCL_WIDE_INT_IS_LONG - if (objPtr->typePtr == &tclWideIntType) { - goto badBoolean; - } -#endif - if (objPtr->typePtr == &tclDoubleType) { goto badBoolean; } @@ -2005,9 +2210,10 @@ static int ParseBoolean( register Tcl_Obj *objPtr) /* The object to parse/convert. */ { - int i, length, newBool; + int newBool; char lowerCase[6]; - const char *str = TclGetStringFromObj(objPtr, &length); + const char *str = TclGetString(objPtr); + size_t i, length = objPtr->length; if ((length == 0) || (length > 5)) { /* @@ -2059,25 +2265,25 @@ ParseBoolean( /* * Checking the 'y' is redundant, but makes the code clearer. */ - if (strncmp(lowerCase, "yes", (size_t) length) == 0) { + if (strncmp(lowerCase, "yes", length) == 0) { newBool = 1; goto goodBoolean; } return TCL_ERROR; case 'n': - if (strncmp(lowerCase, "no", (size_t) length) == 0) { + if (strncmp(lowerCase, "no", length) == 0) { newBool = 0; goto goodBoolean; } return TCL_ERROR; case 't': - if (strncmp(lowerCase, "true", (size_t) length) == 0) { + if (strncmp(lowerCase, "true", length) == 0) { newBool = 1; goto goodBoolean; } return TCL_ERROR; case 'f': - if (strncmp(lowerCase, "false", (size_t) length) == 0) { + if (strncmp(lowerCase, "false", length) == 0) { newBool = 0; goto goodBoolean; } @@ -2086,10 +2292,10 @@ ParseBoolean( if (length < 2) { return TCL_ERROR; } - if (strncmp(lowerCase, "on", (size_t) length) == 0) { + if (strncmp(lowerCase, "on", length) == 0) { newBool = 1; goto goodBoolean; - } else if (strncmp(lowerCase, "off", (size_t) length) == 0) { + } else if (strncmp(lowerCase, "off", length) == 0) { newBool = 0; goto goodBoolean; } @@ -2112,7 +2318,7 @@ ParseBoolean( numericBoolean: TclFreeIntRep(objPtr); - objPtr->internalRep.longValue = newBool; + objPtr->internalRep.wideValue = newBool; objPtr->typePtr = &tclIntType; return TCL_OK; } @@ -2201,6 +2407,7 @@ Tcl_DbNewDoubleObj( register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); + /* Optimized TclInvalidateStringRep() */ objPtr->bytes = NULL; objPtr->internalRep.doubleValue = dblValue; @@ -2293,22 +2500,16 @@ Tcl_GetDoubleFromObj( return TCL_OK; } if (objPtr->typePtr == &tclIntType) { - *dblPtr = objPtr->internalRep.longValue; + *dblPtr = (double) objPtr->internalRep.wideValue; return TCL_OK; } if (objPtr->typePtr == &tclBignumType) { mp_int big; - UNPACK_BIGNUM(objPtr, big); + TclUnpackBignum(objPtr, big); *dblPtr = TclBignumToDouble(&big); return TCL_OK; } -#ifndef TCL_WIDE_INT_IS_LONG - if (objPtr->typePtr == &tclWideIntType) { - *dblPtr = (double) objPtr->internalRep.wideValue; - return TCL_OK; - } -#endif } while (SetDoubleFromAny(interp, objPtr) == TCL_OK); return TCL_ERROR; } @@ -2367,15 +2568,12 @@ static void UpdateStringOfDouble( register Tcl_Obj *objPtr) /* Double obj with string rep to update. */ { - char buffer[TCL_DOUBLE_SPACE]; - register int len; + char *dst = Tcl_InitStringRep(objPtr, NULL, TCL_DOUBLE_SPACE); - Tcl_PrintDouble(NULL, objPtr->internalRep.doubleValue, buffer); - len = strlen(buffer); + TclOOM(dst, TCL_DOUBLE_SPACE + 1); - objPtr->bytes = ckalloc(len + 1); - memcpy(objPtr->bytes, buffer, (unsigned) len + 1); - objPtr->length = len; + Tcl_PrintDouble(NULL, objPtr->internalRep.doubleValue, dst); + (void) Tcl_InitStringRep(objPtr, NULL, strlen(dst)); } /* @@ -2408,6 +2606,7 @@ UpdateStringOfDouble( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_NewIntObj #ifdef TCL_MEM_DEBUG @@ -2415,7 +2614,7 @@ Tcl_Obj * Tcl_NewIntObj( register int intValue) /* Int used to initialize the new object. */ { - return Tcl_DbNewLongObj((long)intValue, "unknown", 0); + return Tcl_DbNewWideIntObj((long)intValue, "unknown", 0); } #else /* if not TCL_MEM_DEBUG */ @@ -2430,6 +2629,7 @@ Tcl_NewIntObj( return objPtr; } #endif /* if TCL_MEM_DEBUG */ +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -2448,7 +2648,7 @@ Tcl_NewIntObj( * *---------------------------------------------------------------------- */ - +#ifndef TCL_NO_DEPRECATED #undef Tcl_SetIntObj void Tcl_SetIntObj( @@ -2461,32 +2661,30 @@ Tcl_SetIntObj( TclSetIntObj(objPtr, intValue); } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- * * Tcl_GetIntFromObj -- * - * Retrieve the integer value of 'objPtr'. - * - * Value - * - * TCL_OK - * - * Success. - * - * TCL_ERROR + * Attempt to return an int from the Tcl object "objPtr". If the object + * is not already an int, an attempt will be made to convert it to one. * - * An error occurred during conversion or the integral value can not - * be represented as an integer (it might be too large). An error - * message is left in the interpreter's result if 'interp' is not - * NULL. + * Integer and long integer objects share the same "integer" type + * implementation. We store all integers as longs and Tcl_GetIntFromObj + * checks whether the current value of the long can be represented by an + * int. * - * Effect + * Results: + * The return value is a standard Tcl object result. If an error occurs + * during conversion or if the long integer held by the object can not be + * represented by an int, an error message is left in the interpreter's + * result unless "interp" is NULL. * - * 'objPtr' is converted to an integer if necessary if it is not one - * already. The conversion frees any previously-existing internal - * representation. + * Side effects: + * If the object is not already an int, the conversion will free any old + * internal representation. * *---------------------------------------------------------------------- */ @@ -2505,7 +2703,7 @@ Tcl_GetIntFromObj( if (TclGetLongFromObj(interp, objPtr, &l) != TCL_OK) { return TCL_ERROR; } - if ((ULONG_MAX > UINT_MAX) && ((l > UINT_MAX) || (l < -(long)UINT_MAX))) { + if ((ULONG_MAX > UINT_MAX) && ((l > UINT_MAX) || (l < INT_MIN))) { if (interp != NULL) { const char *s = "integer value too large to represent as non-long integer"; @@ -2540,9 +2738,8 @@ SetIntFromAny( Tcl_Interp *interp, /* Tcl interpreter */ Tcl_Obj *objPtr) /* Pointer to the object to convert */ { - long l; - - return TclGetLongFromObj(interp, objPtr, &l); + Tcl_WideInt w; + return Tcl_GetWideIntFromObj(interp, objPtr, &w); } /* @@ -2568,15 +2765,25 @@ static void UpdateStringOfInt( register Tcl_Obj *objPtr) /* Int object whose string rep to update. */ { - char buffer[TCL_INTEGER_SPACE]; - register int len; + char *dst = Tcl_InitStringRep( objPtr, NULL, TCL_INTEGER_SPACE); - len = TclFormatInt(buffer, objPtr->internalRep.longValue); + TclOOM(dst, TCL_INTEGER_SPACE + 1); + (void) Tcl_InitStringRep(objPtr, NULL, + TclFormatInt(dst, objPtr->internalRep.wideValue)); +} - objPtr->bytes = ckalloc(len + 1); - memcpy(objPtr->bytes, buffer, (unsigned) len + 1); - objPtr->length = len; +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 && !defined(TCL_WIDE_INT_IS_LONG) +static void +UpdateStringOfOldInt( + register Tcl_Obj *objPtr) /* Int object whose string rep to update. */ +{ + char *dst = Tcl_InitStringRep( objPtr, NULL, TCL_INTEGER_SPACE); + + TclOOM(dst, TCL_INTEGER_SPACE + 1); + (void) Tcl_InitStringRep(objPtr, NULL, + TclFormatInt(dst, objPtr->internalRep.longValue)); } +#endif /* *---------------------------------------------------------------------- @@ -2608,15 +2815,16 @@ UpdateStringOfInt( *---------------------------------------------------------------------- */ -#ifdef TCL_MEM_DEBUG +#ifndef TCL_NO_DEPRECATED #undef Tcl_NewLongObj +#ifdef TCL_MEM_DEBUG Tcl_Obj * Tcl_NewLongObj( register long longValue) /* Long integer used to initialize the * new object. */ { - return Tcl_DbNewLongObj(longValue, "unknown", 0); + return Tcl_DbNewWideIntObj(longValue, "unknown", 0); } #else /* if not TCL_MEM_DEBUG */ @@ -2628,10 +2836,11 @@ Tcl_NewLongObj( { register Tcl_Obj *objPtr; - TclNewLongObj(objPtr, longValue); + TclNewIntObj(objPtr, longValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -2665,6 +2874,8 @@ Tcl_NewLongObj( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED +#undef Tcl_DbNewLongObj #ifdef TCL_MEM_DEBUG Tcl_Obj * @@ -2679,9 +2890,10 @@ Tcl_DbNewLongObj( register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); + /* Optimized TclInvalidateStringRep */ objPtr->bytes = NULL; - objPtr->internalRep.longValue = longValue; + objPtr->internalRep.wideValue = longValue; objPtr->typePtr = &tclIntType; return objPtr; } @@ -2697,9 +2909,10 @@ Tcl_DbNewLongObj( int line) /* Line number in the source file; used for * debugging. */ { - return Tcl_NewLongObj(longValue); + return Tcl_NewWideIntObj(longValue); } #endif /* TCL_MEM_DEBUG */ +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -2719,6 +2932,8 @@ Tcl_DbNewLongObj( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED +#undef Tcl_SetLongObj void Tcl_SetLongObj( register Tcl_Obj *objPtr, /* Object whose internal rep to init. */ @@ -2729,8 +2944,9 @@ Tcl_SetLongObj( Tcl_Panic("%s called with shared object", "Tcl_SetLongObj"); } - TclSetLongObj(objPtr, longValue); + TclSetIntObj(objPtr, longValue); } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -2760,14 +2976,15 @@ Tcl_GetLongFromObj( register long *longPtr) /* Place to store resulting long. */ { do { +#ifdef TCL_WIDE_INT_IS_LONG if (objPtr->typePtr == &tclIntType) { - *longPtr = objPtr->internalRep.longValue; + *longPtr = objPtr->internalRep.wideValue; return TCL_OK; } -#ifndef TCL_WIDE_INT_IS_LONG - if (objPtr->typePtr == &tclWideIntType) { +#else + if (objPtr->typePtr == &tclIntType) { /* - * We return any integer in the range -ULONG_MAX to ULONG_MAX + * We return any integer in the range LONG_MIN to ULONG_MAX * converted to a long, ignoring overflow. The rule preserves * existing semantics for conversion of integers on input, but * avoids inadvertent demotion of wide integers to 32-bit ones in @@ -2776,9 +2993,9 @@ Tcl_GetLongFromObj( Tcl_WideInt w = objPtr->internalRep.wideValue; - if (w >= -(Tcl_WideInt)(ULONG_MAX) + if (w >= (Tcl_WideInt)(LONG_MIN) && w <= (Tcl_WideInt)(ULONG_MAX)) { - *longPtr = Tcl_WideAsLong(w); + *longPtr = (long) w; return TCL_OK; } goto tooLarge; @@ -2802,24 +3019,24 @@ Tcl_GetLongFromObj( */ mp_int big; + unsigned long scratch, value = 0, numBytes = sizeof(unsigned long); + unsigned char *bytes = (unsigned char *) &scratch; - UNPACK_BIGNUM(objPtr, big); - if ((size_t) big.used <= (CHAR_BIT * sizeof(long) + MP_DIGIT_BIT - 1) - / MP_DIGIT_BIT) { - unsigned long value = 0, numBytes = sizeof(long); - long scratch; - unsigned char *bytes = (unsigned char *) &scratch; - - if (mp_to_unsigned_bin_n(&big, bytes, &numBytes) == MP_OKAY) { - while (numBytes-- > 0) { + TclUnpackBignum(objPtr, big); + if (mp_to_unsigned_bin_n(&big, bytes, &numBytes) == MP_OKAY) { + while (numBytes-- > 0) { value = (value << CHAR_BIT) | *bytes++; - } - if (big.sign) { + } + if (big.sign) { + if (value <= 1 + (unsigned long)LONG_MAX) { *longPtr = - (long) value; - } else { + return TCL_OK; + } + } else { + if (value <= (unsigned long)ULONG_MAX) { *longPtr = (long) value; + return TCL_OK; } - return TCL_OK; } } #ifndef TCL_WIDE_INT_IS_LONG @@ -2838,49 +3055,6 @@ Tcl_GetLongFromObj( TCL_PARSE_INTEGER_ONLY)==TCL_OK); return TCL_ERROR; } -#ifndef TCL_WIDE_INT_IS_LONG - -/* - *---------------------------------------------------------------------- - * - * UpdateStringOfWideInt -- - * - * Update the string representation for a wide integer object. Note: this - * function does not free an existing old string rep so storage will be - * lost if this has not already been done. - * - * Results: - * None. - * - * Side effects: - * The object's string is set to a valid string that results from the - * wideInt-to-string conversion. - * - *---------------------------------------------------------------------- - */ - -static void -UpdateStringOfWideInt( - register Tcl_Obj *objPtr) /* Int object whose string rep to update. */ -{ - char buffer[TCL_INTEGER_SPACE+2]; - register unsigned len; - register Tcl_WideInt wideVal = objPtr->internalRep.wideValue; - - /* - * Note that sprintf will generate a compiler warning under Mingw claiming - * %I64 is an unknown format specifier. Just ignore this warning. We can't - * use %L as the format specifier since that gets printed as a 32 bit - * value. - */ - - sprintf(buffer, "%" TCL_LL_MODIFIER "d", wideVal); - len = strlen(buffer); - objPtr->bytes = ckalloc(len + 1); - memcpy(objPtr->bytes, buffer, len + 1); - objPtr->length = len; -} -#endif /* !TCL_WIDE_INT_IS_LONG */ /* *---------------------------------------------------------------------- @@ -2930,7 +3104,7 @@ Tcl_NewWideIntObj( register Tcl_Obj *objPtr; TclNewObj(objPtr); - Tcl_SetWideIntObj(objPtr, wideValue); + TclSetIntObj(objPtr, wideValue); return objPtr; } #endif /* if TCL_MEM_DEBUG */ @@ -2982,7 +3156,7 @@ Tcl_DbNewWideIntObj( register Tcl_Obj *objPtr; TclDbNewObj(objPtr, file, line); - Tcl_SetWideIntObj(objPtr, wideValue); + TclSetIntObj(objPtr, wideValue); return objPtr; } @@ -3031,19 +3205,7 @@ Tcl_SetWideIntObj( Tcl_Panic("%s called with shared object", "Tcl_SetWideIntObj"); } - if ((wideValue >= (Tcl_WideInt) LONG_MIN) - && (wideValue <= (Tcl_WideInt) LONG_MAX)) { - TclSetLongObj(objPtr, (long) wideValue); - } else { -#ifndef TCL_WIDE_INT_IS_LONG - TclSetWideIntObj(objPtr, wideValue); -#else - mp_int big; - - TclBNInitBignumFromWideInt(&big, wideValue); - Tcl_SetBignumObj(objPtr, &big); -#endif - } + TclSetIntObj(objPtr, wideValue); } /* @@ -3075,14 +3237,8 @@ Tcl_GetWideIntFromObj( /* Place to store resulting long. */ { do { -#ifndef TCL_WIDE_INT_IS_LONG - if (objPtr->typePtr == &tclWideIntType) { - *wideIntPtr = objPtr->internalRep.wideValue; - return TCL_OK; - } -#endif if (objPtr->typePtr == &tclIntType) { - *wideIntPtr = (Tcl_WideInt) objPtr->internalRep.longValue; + *wideIntPtr = objPtr->internalRep.wideValue; return TCL_OK; } if (objPtr->typePtr == &tclDoubleType) { @@ -3101,25 +3257,26 @@ Tcl_GetWideIntFromObj( */ mp_int big; - - UNPACK_BIGNUM(objPtr, big); - if ((size_t) big.used <= (CHAR_BIT * sizeof(Tcl_WideInt) - + MP_DIGIT_BIT - 1) / MP_DIGIT_BIT) { - Tcl_WideUInt value = 0; - unsigned long numBytes = sizeof(Tcl_WideInt); - Tcl_WideInt scratch; - unsigned char *bytes = (unsigned char *) &scratch; - - if (mp_to_unsigned_bin_n(&big, bytes, &numBytes) == MP_OKAY) { - while (numBytes-- > 0) { - value = (value << CHAR_BIT) | *bytes++; - } - if (big.sign) { + Tcl_WideUInt value = 0; + unsigned long numBytes = sizeof(Tcl_WideInt); + Tcl_WideInt scratch; + unsigned char *bytes = (unsigned char *) &scratch; + + TclUnpackBignum(objPtr, big); + if (mp_to_unsigned_bin_n(&big, bytes, &numBytes) == MP_OKAY) { + while (numBytes-- > 0) { + value = (value << CHAR_BIT) | *bytes++; + } + if (big.sign) { + if (value <= 1 + ~(Tcl_WideUInt)WIDE_MIN) { *wideIntPtr = - (Tcl_WideInt) value; - } else { + return TCL_OK; + } + } else { + if (value <= (Tcl_WideUInt)WIDE_MAX) { *wideIntPtr = (Tcl_WideInt) value; + return TCL_OK; } - return TCL_OK; } } if (interp != NULL) { @@ -3135,33 +3292,70 @@ Tcl_GetWideIntFromObj( TCL_PARSE_INTEGER_ONLY)==TCL_OK); return TCL_ERROR; } -#ifndef TCL_WIDE_INT_IS_LONG /* *---------------------------------------------------------------------- * - * SetWideIntFromAny -- + * TclGetWideBitsFromObj -- * - * Attempts to force the internal representation for a Tcl object to - * tclWideIntType, specifically. + * Attempt to return a wide integer from the Tcl object "objPtr". If the + * object is not already a int, double or bignum, an attempt will be made + * to convert it to one of these. Out-of-range values don't result in an + * error, but only the least significant 64 bits will be returned. * * Results: - * The return value is a standard object Tcl result. If an error occurs + * The return value is a standard Tcl object result. If an error occurs * during conversion, an error message is left in the interpreter's * result unless "interp" is NULL. * + * Side effects: + * If the object is not already an int, double or bignum object, the + * conversion will free any old internal representation. + * *---------------------------------------------------------------------- */ -static int -SetWideIntFromAny( - Tcl_Interp *interp, /* Tcl interpreter */ - Tcl_Obj *objPtr) /* Pointer to the object to convert */ +int +TclGetWideBitsFromObj( + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr, /* Object from which to get a wide int. */ + Tcl_WideInt *wideIntPtr) /* Place to store resulting wide integer. */ { - Tcl_WideInt w; - return Tcl_GetWideIntFromObj(interp, objPtr, &w); + do { + if (objPtr->typePtr == &tclIntType) { + *wideIntPtr = objPtr->internalRep.wideValue; + return TCL_OK; + } + if (objPtr->typePtr == &tclDoubleType) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected integer but got \"%s\"", + TclGetString(objPtr))); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL); + } + return TCL_ERROR; + } + if (objPtr->typePtr == &tclBignumType) { + mp_int big; + + Tcl_WideUInt value = 0, scratch; + unsigned long numBytes = sizeof(Tcl_WideInt); + unsigned char *bytes = (unsigned char *) &scratch; + + Tcl_GetBignumFromObj(NULL, objPtr, &big); + mp_mod_2d(&big, (int) (CHAR_BIT * sizeof(Tcl_WideInt)), &big); + mp_to_unsigned_bin_n(&big, bytes, &numBytes); + while (numBytes-- > 0) { + value = (value << CHAR_BIT) | *bytes++; + } + *wideIntPtr = !big.sign ? (Tcl_WideInt)value : -(Tcl_WideInt)value; + mp_clear(&big); + return TCL_OK; + } + } while (TclParseNumber(interp, objPtr, "integer", NULL, -1, NULL, + TCL_PARSE_INTEGER_ONLY)==TCL_OK); + return TCL_ERROR; } -#endif /* !TCL_WIDE_INT_IS_LONG */ /* *---------------------------------------------------------------------- @@ -3182,7 +3376,7 @@ FreeBignum( { mp_int toFree; /* Bignum to free */ - UNPACK_BIGNUM(objPtr, toFree); + TclUnpackBignum(objPtr, toFree); mp_clear(&toFree); if (PTR2INT(objPtr->internalRep.twoPtrValue.ptr2) < 0) { ckfree(objPtr->internalRep.twoPtrValue.ptr1); @@ -3215,7 +3409,7 @@ DupBignum( mp_int bignumCopy; copyPtr->typePtr = &tclBignumType; - UNPACK_BIGNUM(srcPtr, bignumVal); + TclUnpackBignum(srcPtr, bignumVal); if (mp_init_copy(&bignumCopy, &bignumVal) != MP_OKAY) { Tcl_Panic("initialization failure in DupBignum"); } @@ -3248,12 +3442,10 @@ UpdateStringOfBignum( { mp_int bignumVal; int size; - int status; char *stringVal; - UNPACK_BIGNUM(objPtr, bignumVal); - status = mp_radix_size(&bignumVal, 10, &size); - if (status != MP_OKAY) { + TclUnpackBignum(objPtr, bignumVal); + if (MP_OKAY != mp_radix_size(&bignumVal, 10, &size)) { Tcl_Panic("radix size failure in UpdateStringOfBignum"); } if (size < 2) { @@ -3268,13 +3460,14 @@ UpdateStringOfBignum( Tcl_Panic("UpdateStringOfBignum: string length limit exceeded"); } - stringVal = ckalloc(size); - status = mp_toradix_n(&bignumVal, stringVal, 10, size); - if (status != MP_OKAY) { + + stringVal = Tcl_InitStringRep(objPtr, NULL, size - 1); + + TclOOM(stringVal, size); + if (MP_OKAY != mp_toradix_n(&bignumVal, stringVal, 10, size)) { Tcl_Panic("conversion failure in UpdateStringOfBignum"); } - objPtr->bytes = stringVal; - objPtr->length = size - 1; /* size includes a trailing NUL byte. */ + (void) Tcl_InitStringRep(objPtr, NULL, size - 1); } /* @@ -3390,30 +3583,30 @@ GetBignumFromObj( if (copy || Tcl_IsShared(objPtr)) { mp_int temp; - UNPACK_BIGNUM(objPtr, temp); + TclUnpackBignum(objPtr, temp); mp_init_copy(bignumValue, &temp); } else { - UNPACK_BIGNUM(objPtr, *bignumValue); + TclUnpackBignum(objPtr, *bignumValue); + /* Optimized TclFreeIntRep */ objPtr->internalRep.twoPtrValue.ptr1 = NULL; objPtr->internalRep.twoPtrValue.ptr2 = NULL; objPtr->typePtr = NULL; + /* + * TODO: If objPtr has a string rep, this leaves + * it undisturbed. Not clear that's proper. Pure + * bignum values are converted to empty string. + */ if (objPtr->bytes == NULL) { - TclInitStringRep(objPtr, tclEmptyStringRep, 0); + TclInitStringRep(objPtr, NULL, 0); } } return TCL_OK; } if (objPtr->typePtr == &tclIntType) { - TclBNInitBignumFromLong(bignumValue, objPtr->internalRep.longValue); - return TCL_OK; - } -#ifndef TCL_WIDE_INT_IS_LONG - if (objPtr->typePtr == &tclWideIntType) { - TclBNInitBignumFromWideInt(bignumValue, + TclInitBignumFromWideInt(bignumValue, objPtr->internalRep.wideValue); return TCL_OK; } -#endif if (objPtr->typePtr == &tclDoubleType) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -3519,60 +3712,31 @@ Tcl_SetBignumObj( Tcl_Obj *objPtr, /* Object to set */ mp_int *bignumValue) /* Value to store */ { + Tcl_WideUInt value = 0; + unsigned long numBytes = sizeof(Tcl_WideUInt); + Tcl_WideUInt scratch; + unsigned char *bytes = (unsigned char *) &scratch; + if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetBignumObj"); } - if ((size_t) bignumValue->used - <= (CHAR_BIT * sizeof(long) + MP_DIGIT_BIT - 1) / MP_DIGIT_BIT) { - unsigned long value = 0, numBytes = sizeof(long); - long scratch; - unsigned char *bytes = (unsigned char *) &scratch; - - if (mp_to_unsigned_bin_n(bignumValue, bytes, &numBytes) != MP_OKAY) { - goto tooLargeForLong; - } - while (numBytes-- > 0) { - value = (value << CHAR_BIT) | *bytes++; - } - if (value > (((~(unsigned long)0) >> 1) + bignumValue->sign)) { - goto tooLargeForLong; - } - if (bignumValue->sign) { - TclSetLongObj(objPtr, -(long)value); - } else { - TclSetLongObj(objPtr, (long)value); - } - mp_clear(bignumValue); - return; + if (mp_to_unsigned_bin_n(bignumValue, bytes, &numBytes) != MP_OKAY) { + goto tooLargeForWide; } - tooLargeForLong: -#ifndef TCL_WIDE_INT_IS_LONG - if ((size_t) bignumValue->used - <= (CHAR_BIT * sizeof(Tcl_WideInt) + MP_DIGIT_BIT - 1) / MP_DIGIT_BIT) { - Tcl_WideUInt value = 0; - unsigned long numBytes = sizeof(Tcl_WideInt); - Tcl_WideInt scratch; - unsigned char *bytes = (unsigned char *)&scratch; - - if (mp_to_unsigned_bin_n(bignumValue, bytes, &numBytes) != MP_OKAY) { - goto tooLargeForWide; - } - while (numBytes-- > 0) { - value = (value << CHAR_BIT) | *bytes++; - } - if (value > (((~(Tcl_WideUInt)0) >> 1) + bignumValue->sign)) { - goto tooLargeForWide; - } - if (bignumValue->sign) { - TclSetWideIntObj(objPtr, -(Tcl_WideInt)value); - } else { - TclSetWideIntObj(objPtr, (Tcl_WideInt)value); - } - mp_clear(bignumValue); - return; + while (numBytes-- > 0) { + value = (value << CHAR_BIT) | *bytes++; + } + if (value > ((Tcl_WideUInt)WIDE_MAX + bignumValue->sign)) { + goto tooLargeForWide; + } + if (bignumValue->sign) { + TclSetIntObj(objPtr, -(Tcl_WideInt)value); + } else { + TclSetIntObj(objPtr, (Tcl_WideInt)value); } + mp_clear(bignumValue); + return; tooLargeForWide: -#endif TclInvalidateStringRep(objPtr); TclFreeIntRep(objPtr); TclSetBignumIntRep(objPtr, bignumValue); @@ -3654,23 +3818,16 @@ TclGetNumberFromObj( return TCL_OK; } if (objPtr->typePtr == &tclIntType) { - *typePtr = TCL_NUMBER_LONG; - *clientDataPtr = &objPtr->internalRep.longValue; - return TCL_OK; - } -#ifndef TCL_WIDE_INT_IS_LONG - if (objPtr->typePtr == &tclWideIntType) { - *typePtr = TCL_NUMBER_WIDE; + *typePtr = TCL_NUMBER_INT; *clientDataPtr = &objPtr->internalRep.wideValue; return TCL_OK; } -#endif if (objPtr->typePtr == &tclBignumType) { static Tcl_ThreadDataKey bignumKey; mp_int *bigPtr = Tcl_GetThreadData(&bignumKey, (int) sizeof(mp_int)); - UNPACK_BIGNUM(objPtr, *bigPtr); + TclUnpackBignum(objPtr, *bigPtr); *typePtr = TCL_NUMBER_BIG; *clientDataPtr = bigPtr; return TCL_OK; @@ -3683,6 +3840,71 @@ TclGetNumberFromObj( /* *---------------------------------------------------------------------- * + * Tcl_IncrRefCount -- + * + * Increments the reference count of the object. + * + * Results: + * None. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_IncrRefCount +void +Tcl_IncrRefCount( + Tcl_Obj *objPtr) /* The object we are registering a reference to. */ +{ + ++(objPtr)->refCount; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DecrRefCount -- + * + * Decrements the reference count of the object. + * + * Results: + * None. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_DecrRefCount +void +Tcl_DecrRefCount( + Tcl_Obj *objPtr) /* The object we are releasing a reference to. */ +{ + if (objPtr->refCount-- <= 1) { + TclFreeObj(objPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_IsShared -- + * + * Tests if the object has a ref count greater than one. + * + * Results: + * Boolean value that is the result of the test. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_IsShared +int +Tcl_IsShared( + Tcl_Obj *objPtr) /* The object to test for being shared. */ +{ + return ((objPtr)->refCount > 1); +} + +/* + *---------------------------------------------------------------------- + * * Tcl_DbIncrRefCount -- * * This function is normally called when debugging: i.e., when @@ -3717,7 +3939,7 @@ Tcl_DbIncrRefCount( Tcl_Panic("incrementing refCount of previously disposed object"); } -# ifdef TCL_THREADS +#if TCL_THREADS /* * Check to make sure that the Tcl_Obj was allocated by the current * thread. Don't do this check when shutting down since thread local @@ -3780,7 +4002,7 @@ Tcl_DbDecrRefCount( Tcl_Panic("decrementing refCount of previously disposed object"); } -# ifdef TCL_THREADS +#if TCL_THREADS /* * Check to make sure that the Tcl_Obj was allocated by the current * thread. Don't do this check when shutting down since thread local @@ -3845,7 +4067,7 @@ Tcl_DbIsShared( Tcl_Panic("checking whether previously disposed object is shared"); } -# ifdef TCL_THREADS +#if TCL_THREADS /* * Check to make sure that the Tcl_Obj was allocated by the current * thread. Don't do this check when shutting down since thread local @@ -4049,7 +4271,7 @@ TclFreeObjEntry( *---------------------------------------------------------------------- */ -unsigned int +TCL_HASH_TYPE TclHashObjKey( Tcl_HashTable *tablePtr, /* Hash table. */ void *keyPtr) /* Key from which to compute hash value. */ @@ -4099,7 +4321,7 @@ TclHashObjKey( result += (result << 3) + UCHAR(*++string); } } - return result; + return (TCL_HASH_TYPE) result; } /* @@ -4153,11 +4375,10 @@ Tcl_GetCommandFromObj( */ resPtr = objPtr->internalRep.twoPtrValue.ptr1; - if ((objPtr->typePtr == &tclCmdNameType) && (resPtr != NULL)) { + if (objPtr->typePtr == &tclCmdNameType) { 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 *) @@ -4177,7 +4398,7 @@ Tcl_GetCommandFromObj( * had is invalid one way or another. */ - /* See [] why we cannot call SetCmdNameFromAny() directly here. */ + /* See [07d13d99b0a9] why we cannot call SetCmdNameFromAny() directly here. */ if (tclCmdNameType.setFromAnyProc(interp, objPtr) != TCL_OK) { return NULL; } @@ -4205,6 +4426,59 @@ 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 @@ -4214,10 +4488,7 @@ 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; @@ -4226,36 +4497,7 @@ TclSetCmdNameObj( } } - 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; + SetCmdNameObj(interp, objPtr, cmdPtr, NULL); } /* @@ -4286,13 +4528,12 @@ 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 @@ -4304,7 +4545,6 @@ FreeCmdNameInternalRep( TclCleanupCommandMacro(cmdPtr); ckfree(resPtr); } - } objPtr->typePtr = NULL; } @@ -4337,9 +4577,7 @@ DupCmdNameInternalRep( copyPtr->internalRep.twoPtrValue.ptr1 = resPtr; copyPtr->internalRep.twoPtrValue.ptr2 = NULL; - if (resPtr != NULL) { resPtr->refCount++; - } copyPtr->typePtr = &tclCmdNameType; } @@ -4369,10 +4607,8 @@ 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) { @@ -4392,59 +4628,31 @@ SetCmdNameFromAny( Tcl_FindCommand(interp, name, /*ns*/ NULL, /*flags*/ 0); /* - * 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. + * Stop shimmering and caching nothing when we found nothing. Just + * report the failure to find the command as an 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 - */ - - 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 (cmdPtr == NULL) { + return TCL_ERROR; + } - resPtr->refNsPtr = NULL; - } else { - /* - * Get the current namespace. - */ + 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. + */ - currNsPtr = iPtr->varFramePtr->nsPtr; + Command *oldCmdPtr = resPtr->cmdPtr; - resPtr->refNsPtr = currNsPtr; - resPtr->refNsId = currNsPtr->nsId; - resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; + if (oldCmdPtr->refCount-- <= 1) { + TclCleanupCommandMacro(oldCmdPtr); } } else { - TclFreeIntRep(objPtr); - objPtr->internalRep.twoPtrValue.ptr1 = NULL; - objPtr->internalRep.twoPtrValue.ptr2 = NULL; - objPtr->typePtr = &tclCmdNameType; + resPtr = NULL; } + + SetCmdNameObj(interp, objPtr, cmdPtr, resPtr); return TCL_OK; } @@ -4471,7 +4679,6 @@ Tcl_RepresentationCmd( int objc, Tcl_Obj *const objv[]) { - char ptrBuffer[2*TCL_INTEGER_SPACE+6]; Tcl_Obj *descObj; if (objc != 2) { @@ -4485,36 +4692,20 @@ Tcl_RepresentationCmd( * "1872361827361287" */ - sprintf(ptrBuffer, "%p", (void *) objv[1]); descObj = Tcl_ObjPrintf("value is a %s with a refcount of %d," - " object pointer at %s", - objv[1]->typePtr ? objv[1]->typePtr->name : "pure string", - objv[1]->refCount, ptrBuffer); + " object pointer at %p", + objv[1]->typePtr ? objv[1]->typePtr->name : "pure string", + objv[1]->refCount, objv[1]); - /* - * This is a workaround to silence reports from `make valgrind` - * on 64-bit systems. The problem is that the test suite - * includes calling the [represenation] command on values of - * &tclDoubleType. When these values are created, the "doubleValue" - * is set, but when the "twoPtrValue" is examined, its "ptr2" - * field has never been initialized. Since [representation] - * presents the value of the ptr2 value in its output, valgrind - * alerts about the read of uninitialized memory. - * - * The general problem with [representation], that it can read - * and report uninitialized fields, is still present. This is - * just the minimal workaround to silence one particular test. - */ - - if ((sizeof(void *) > 4) && objv[1]->typePtr == &tclDoubleType) { - objv[1]->internalRep.twoPtrValue.ptr2 = NULL; - } if (objv[1]->typePtr) { - sprintf(ptrBuffer, "%p:%p", - (void *) objv[1]->internalRep.twoPtrValue.ptr1, - (void *) objv[1]->internalRep.twoPtrValue.ptr2); - Tcl_AppendPrintfToObj(descObj, ", internal representation %s", - ptrBuffer); + if (objv[1]->typePtr == &tclDoubleType) { + Tcl_AppendPrintfToObj(descObj, ", internal representation %g", + objv[1]->internalRep.doubleValue); + } else { + Tcl_AppendPrintfToObj(descObj, ", internal representation %p:%p", + (void *) objv[1]->internalRep.twoPtrValue.ptr1, + (void *) objv[1]->internalRep.twoPtrValue.ptr2); + } } if (objv[1]->bytes) { diff --git a/generic/tclOptimize.c b/generic/tclOptimize.c index 827d89d..8267a7d 100644 --- a/generic/tclOptimize.c +++ b/generic/tclOptimize.c @@ -233,7 +233,7 @@ ConvertZeroEffectToNOP( TclGetUInt1AtPtr(currentInstPtr + 1)); int numBytes; - (void) Tcl_GetStringFromObj(litPtr, &numBytes); + (void) TclGetStringFromObj(litPtr, &numBytes); if (numBytes == 0) { blank = size + InstLength(nextInst); } @@ -248,7 +248,7 @@ ConvertZeroEffectToNOP( TclGetUInt4AtPtr(currentInstPtr + 1)); int numBytes; - (void) Tcl_GetStringFromObj(litPtr, &numBytes); + (void) TclGetStringFromObj(litPtr, &numBytes); if (numBytes == 0) { blank = size + InstLength(nextInst); } diff --git a/generic/tclPanic.c b/generic/tclPanic.c index b03ad41..e8c1e7f 100644 --- a/generic/tclPanic.c +++ b/generic/tclPanic.c @@ -23,8 +23,8 @@ * procedure. */ -#if defined(__CYGWIN__) -static TCL_NORETURN Tcl_PanicProc *panicProc = tclWinDebugPanic; +#if defined(__CYGWIN__) || (defined(_WIN32) && (defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8)) +static TCL_NORETURN1 Tcl_PanicProc *panicProc = tclWinDebugPanic; #else static TCL_NORETURN1 Tcl_PanicProc *panicProc = NULL; #endif @@ -58,6 +58,7 @@ Tcl_SetPanicProc( else #endif panicProc = proc; + TclInitSubsystems(); } /* diff --git a/generic/tclParse.c b/generic/tclParse.c index 1532c05..448ce5e 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -19,12 +19,7 @@ /* * The following table provides parsing information about each possible 8-bit - * character. The table is designed to be referenced with either signed or - * unsigned characters, so it has 384 entries. The first 128 entries - * correspond to negative character values, the next 256 correspond to - * positive character values. The last 128 entries are identical to the first - * 128. The table is always indexed with a 128-byte offset (the 128th entry - * corresponds to a character value of 0). + * character. The table is designed to be referenced with unsigned characters. * * The macro CHAR_TYPE is used to index into the table and return information * about its character argument. The following return values are defined. @@ -44,42 +39,6 @@ */ const char tclCharTypeTable[] = { - /* - * Negative character values, from -128 to -1: - */ - - TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, - TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, - TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, - TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, - TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, - TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, - TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, - TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, - TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, - TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, - TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, - TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, - TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, - TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, - TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, - TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, - TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, - TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, - TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, - TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, - TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, - TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, - TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, - TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, - TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, - TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, - TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, - TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, - TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, - TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, - TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, - TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, /* * Positive character values, from 0-127: @@ -167,6 +126,8 @@ 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); /* *---------------------------------------------------------------------- @@ -298,9 +259,43 @@ 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. */ @@ -310,23 +305,6 @@ 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++; @@ -546,52 +524,12 @@ Tcl_ParseCommand( tokenPtr->type = TCL_TOKEN_SIMPLE_WORD; } - /* - * 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. - */ + /* Parse the whitespace between words. */ scanned = ParseWhiteSpace(src,numBytes, &parsePtr->incomplete, &type); - 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; + src += scanned; + numBytes -= scanned; } - - parsePtr->commandSize = src - parsePtr->commandStart; - return TCL_OK; - - error: - Tcl_FreeParse(parsePtr); - parsePtr->commandSize = parsePtr->end - parsePtr->commandStart; - return TCL_ERROR; } /* @@ -733,23 +671,32 @@ ParseWhiteSpace( *---------------------------------------------------------------------- */ -int -TclParseAllWhiteSpace( +static int +ParseAllWhiteSpace( const char *src, /* First character to parse. */ - int numBytes) /* Max number of byes to scan */ + int numBytes, /* Max number of byes to scan */ + int *incompletePtr) /* Set true if parse is incomplete. */ { - int dummy; char type; const char *p = src; do { - int scanned = ParseWhiteSpace(p, numBytes, &dummy, &type); + int scanned = ParseWhiteSpace(p, numBytes, incompletePtr, &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); +} /* *---------------------------------------------------------------------- @@ -837,14 +784,13 @@ TclParseBackslash( * of bytes scanned should be written. */ char *dst) /* NULL, or points to buffer where the UTF-8 * encoding of the backslash sequence is to be - * written. At most TCL_UTF_MAX bytes will be - * written there. */ + * written. At most 4 bytes will be written there. */ { register const char *p = src+1; Tcl_UniChar unichar = 0; int result; int count; - char buf[TCL_UTF_MAX] = ""; + char buf[4] = ""; if (numBytes == 0) { if (readPtr != NULL) { @@ -902,7 +848,7 @@ TclParseBackslash( count += TclParseHex(p+1, (numBytes > 3) ? 2 : numBytes-2, &result); if (count == 2) { /* - * No hexadigits -> This is just "x". + * No hexdigits -> This is just "x". */ result = 'x'; @@ -917,7 +863,7 @@ TclParseBackslash( count += TclParseHex(p+1, (numBytes > 5) ? 4 : numBytes-2, &result); if (count == 2) { /* - * No hexadigits -> This is just "u". + * No hexdigits -> This is just "u". */ result = 'u'; } @@ -926,7 +872,7 @@ TclParseBackslash( count += TclParseHex(p+1, (numBytes > 9) ? 8 : numBytes-2, &result); if (count == 2) { /* - * No hexadigits -> This is just "U". + * No hexdigits -> This is just "U". */ result = 'U'; } @@ -979,7 +925,7 @@ TclParseBackslash( } else { char utfBytes[TCL_UTF_MAX]; - memcpy(utfBytes, p, (size_t) (numBytes - 1)); + memcpy(utfBytes, p, numBytes - 1); utfBytes[numBytes - 1] = '\0'; count = TclUtfToUniChar(utfBytes, &unichar) + 1; } @@ -992,11 +938,10 @@ TclParseBackslash( *readPtr = count; } count = Tcl_UniCharToUtf(result, dst); -#if TCL_UTF_MAX > 3 - if ((result >= 0xD800) && (count < 3)) { + if ((result >= 0xD800) && (count < 3)) { + /* Special case for handling high surrogates. */ count += Tcl_UniCharToUtf(-1, dst + count); } -#endif return count; } @@ -1027,17 +972,12 @@ ParseComment( * command. */ { register const char *p = src; + int incomplete = parsePtr->incomplete; while (numBytes) { - char type; - int scanned; - - do { - scanned = ParseWhiteSpace(p, numBytes, - &parsePtr->incomplete, &type); - p += scanned; - numBytes -= scanned; - } while (numBytes && (*p == '\n') && (p++,numBytes--)); + int scanned = ParseAllWhiteSpace(p, numBytes, &incomplete); + p += scanned; + numBytes -= scanned; if ((numBytes == 0) || (*p != '#')) { break; @@ -1046,35 +986,28 @@ 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 (p[-1] == '\n') { + if (numBytes == 0) { break; } } + incomplete = (*p == '\n'); + p++; + numBytes--; } parsePtr->commentSize = p - parsePtr->commentStart; } + parsePtr->incomplete = incomplete; return (p - src); } @@ -2217,7 +2150,7 @@ TclSubstTokens( Tcl_Obj *appendObj = NULL; const char *append = NULL; int appendByteLength = 0; - char utfCharBytes[TCL_UTF_MAX] = ""; + char utfCharBytes[4] = ""; switch (tokenPtr->type) { case TCL_TOKEN_TEXT: @@ -2253,7 +2186,7 @@ TclSubstTokens( if (result == 0) { clPos = 0; } else { - Tcl_GetStringFromObj(result, &clPos); + TclGetStringFromObj(result, &clPos); } if (numCL >= maxNumCL) { @@ -2529,7 +2462,7 @@ TclObjCommandComplete( * check. */ { int length; - const char *script = Tcl_GetStringFromObj(objPtr, &length); + const char *script = TclGetStringFromObj(objPtr, &length); return CommandComplete(script, length); } diff --git a/generic/tclParse.h b/generic/tclParse.h index 9247602..5f75c9a 100644 --- a/generic/tclParse.h +++ b/generic/tclParse.h @@ -12,6 +12,6 @@ #define TYPE_CLOSE_BRACK 0x20 #define TYPE_BRACE 0x40 -#define CHAR_TYPE(c) (tclCharTypeTable+128)[(unsigned char)(c)] +#define CHAR_TYPE(c) tclCharTypeTable[(unsigned char)(c)] MODULE_SCOPE const char tclCharTypeTable[]; diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index a2a41e4..78d87b9 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -36,7 +36,7 @@ static int MakePathFromNormalized(Tcl_Interp *interp, * internally. */ -static const Tcl_ObjType tclFsPathType = { +static const Tcl_ObjType fsPathType = { "path", /* name */ FreeFsPathInternalRep, /* freeIntRepProc */ DupFsPathInternalRep, /* dupIntRepProc */ @@ -51,19 +51,14 @@ static const Tcl_ObjType tclFsPathType = { * represent relative or absolute paths, and has certain optimisations when * used to represent paths which are already normalized and absolute. * - * Note that both 'translatedPathPtr' and 'normPathPtr' can be a circular - * reference to the container Tcl_Obj of this FsPath. - * * There are two cases, with the first being the most common: * * (i) flags == 0, => Ordinary path. * - * translatedPathPtr contains the translated path (which may be a circular - * reference to the object itself). If it is NULL then the path is pure - * normalized (and the normPathPtr will be a circular reference). cwdPtr is - * null for an absolute path, and non-null for a relative path (unless the cwd - * has never been set, in which case the cwdPtr may also be null for a - * relative path). + * translatedPathPtr contains the translated path. If it is NULL then the path + * is pure normalized. cwdPtr is null for an absolute path, and non-null for a + * relative path (unless the cwd has never been set, in which case the cwdPtr + * may also be null for a relative path). * * (ii) flags != 0, => Special path, see TclNewFSPathObj * @@ -79,11 +74,7 @@ typedef struct FsPath { * Tcl_Obj's string rep is already both * translated and normalized. */ Tcl_Obj *normPathPtr; /* Normalized absolute path, without ., .. or - * ~user sequences. If the Tcl_Obj containing - * this FsPath is already normalized, this may - * be a circular reference back to the - * container. If that is NOT the case, we have - * a refCount on the object. */ + * ~user sequences. */ Tcl_Obj *cwdPtr; /* If null, path is absolute, else this points * to the cwd object used for this path. We * have a refCount on the object. */ @@ -110,9 +101,14 @@ typedef struct FsPath { * fields. */ -#define PATHOBJ(pathPtr) ((FsPath *) (pathPtr)->internalRep.twoPtrValue.ptr1) +#define PATHOBJ(pathPtr) ((FsPath *) (TclFetchIntRep((pathPtr), &fsPathType)->twoPtrValue.ptr1)) #define SETPATHOBJ(pathPtr,fsPathPtr) \ - ((pathPtr)->internalRep.twoPtrValue.ptr1 = (void *) (fsPathPtr)) + do { \ + Tcl_ObjIntRep ir; \ + ir.twoPtrValue.ptr1 = (void *) (fsPathPtr); \ + ir.twoPtrValue.ptr2 = NULL; \ + Tcl_StoreIntRep((pathPtr), &fsPathType, &ir); \ + } while (0) #define PATHFLAGS(pathPtr) (PATHOBJ(pathPtr)->flags) /* @@ -232,7 +228,7 @@ TclFSNormalizeAbsolutePath( retVal = Tcl_NewStringObj(path, dirSep - path); Tcl_IncrRefCount(retVal); } - Tcl_GetStringFromObj(retVal, &curLen); + TclGetStringFromObj(retVal, &curLen); if (curLen == 0) { Tcl_AppendToObj(retVal, dirSep, 1); } @@ -258,7 +254,7 @@ TclFSNormalizeAbsolutePath( retVal = Tcl_NewStringObj(path, dirSep - path); Tcl_IncrRefCount(retVal); } - Tcl_GetStringFromObj(retVal, &curLen); + TclGetStringFromObj(retVal, &curLen); if (curLen == 0) { Tcl_AppendToObj(retVal, dirSep, 1); } @@ -289,7 +285,7 @@ TclFSNormalizeAbsolutePath( */ const char *path = - Tcl_GetStringFromObj(retVal, &curLen); + TclGetStringFromObj(retVal, &curLen); while (--curLen >= 0) { if (IsSeparatorOrNull(path[curLen])) { @@ -304,7 +300,7 @@ TclFSNormalizeAbsolutePath( Tcl_SetObjLength(retVal, curLen+1); Tcl_AppendObjToObj(retVal, linkObj); TclDecrRefCount(linkObj); - linkStr = Tcl_GetStringFromObj(retVal, &curLen); + linkStr = TclGetStringFromObj(retVal, &curLen); } else { /* * Absolute link. @@ -317,7 +313,7 @@ TclFSNormalizeAbsolutePath( } else { retVal = linkObj; } - linkStr = Tcl_GetStringFromObj(retVal, &curLen); + linkStr = TclGetStringFromObj(retVal, &curLen); /* * Convert to forward-slashes on windows. @@ -334,7 +330,7 @@ TclFSNormalizeAbsolutePath( } } } else { - linkStr = Tcl_GetStringFromObj(retVal, &curLen); + linkStr = TclGetStringFromObj(retVal, &curLen); } /* @@ -405,7 +401,7 @@ TclFSNormalizeAbsolutePath( if (tclPlatform == TCL_PLATFORM_WINDOWS) { int len; - const char *path = Tcl_GetStringFromObj(retVal, &len); + const char *path = TclGetStringFromObj(retVal, &len); if (len == 2 && path[0] != 0 && path[1] == ':') { if (Tcl_IsShared(retVal)) { @@ -564,7 +560,7 @@ TclPathPart( Tcl_Obj *pathPtr, /* Path to take dirname of */ Tcl_PathPart portion) /* Requested portion of name */ { - if (pathPtr->typePtr == &tclFsPathType) { + if (TclHasIntRep(pathPtr, &fsPathType)) { FsPath *fsPathPtr = PATHOBJ(pathPtr); if (PATHFLAGS(pathPtr) != 0) { @@ -580,7 +576,7 @@ TclPathPart( int numBytes; const char *rest = - Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &numBytes); + TclGetStringFromObj(fsPathPtr->normPathPtr, &numBytes); if (strchr(rest, '/') != NULL) { goto standardPath; @@ -618,7 +614,7 @@ TclPathPart( int numBytes; const char *rest = - Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &numBytes); + TclGetStringFromObj(fsPathPtr->normPathPtr, &numBytes); if (strchr(rest, '/') != NULL) { goto standardPath; @@ -647,7 +643,7 @@ TclPathPart( const char *fileName, *extension; int length; - fileName = Tcl_GetStringFromObj(fsPathPtr->normPathPtr, + fileName = TclGetStringFromObj(fsPathPtr->normPathPtr, &length); extension = TclGetExtension(fileName); if (extension == NULL) { @@ -699,7 +695,7 @@ TclPathPart( int length; const char *fileName, *extension; - fileName = Tcl_GetStringFromObj(pathPtr, &length); + fileName = TclGetStringFromObj(pathPtr, &length); extension = TclGetExtension(fileName); if (extension == NULL) { Tcl_IncrRefCount(pathPtr); @@ -864,6 +860,7 @@ TclJoinPath( if (elements == 2) { Tcl_Obj *elt = objv[0]; + Tcl_ObjIntRep *eltIr = TclFetchIntRep(elt, &fsPathType); /* * This is a special case where we can be much more efficient, where @@ -877,7 +874,7 @@ TclJoinPath( * to be an absolute path. Added a check for that elt is absolute. */ - if ((elt->typePtr == &tclFsPathType) + if ((eltIr) && !((elt->bytes != NULL) && (elt->bytes[0] == '\0')) && TclGetPathType(elt, NULL, NULL, NULL) == TCL_PATH_ABSOLUTE) { Tcl_Obj *tailObj = objv[1]; @@ -890,7 +887,7 @@ TclJoinPath( const char *str; int len; - str = Tcl_GetStringFromObj(tailObj, &len); + str = TclGetStringFromObj(tailObj, &len); if (len == 0) { /* * This happens if we try to handle the root volume '/'. @@ -961,7 +958,7 @@ TclJoinPath( Tcl_Obj *driveName = NULL; Tcl_Obj *elt = objv[i]; - strElt = Tcl_GetStringFromObj(elt, &strEltLen); + strElt = TclGetStringFromObj(elt, &strEltLen); driveNameLength = 0; /* if forceRelative - all paths excepting first one are relative */ type = (forceRelative && (i > 0)) ? TCL_PATH_RELATIVE : @@ -1057,10 +1054,8 @@ TclJoinPath( noQuickReturn: if (res == NULL) { res = Tcl_NewObj(); - ptr = Tcl_GetStringFromObj(res, &length); - } else { - ptr = Tcl_GetStringFromObj(res, &length); } + ptr = TclGetStringFromObj(res, &length); /* * Strip off any './' before a tilde, unless this is the beginning of @@ -1093,7 +1088,7 @@ TclJoinPath( if (sep != NULL) { separator = TclGetString(sep)[0]; - Tcl_DecrRefCount(sep); + TclDecrRefCount(sep); } /* Safety check in case the VFS driver caused sharing */ if (Tcl_IsShared(res)) { @@ -1105,7 +1100,7 @@ TclJoinPath( if (length > 0 && ptr[length -1] != '/') { Tcl_AppendToObj(res, &separator, 1); - Tcl_GetStringFromObj(res, &length); + TclGetStringFromObj(res, &length); } Tcl_SetObjLength(res, length + (int) strlen(strElt)); @@ -1171,39 +1166,16 @@ Tcl_FSConvertToPathType( * path. */ - if (pathPtr->typePtr == &tclFsPathType) { + if (TclHasIntRep(pathPtr, &fsPathType)) { if (TclFSEpochOk(PATHOBJ(pathPtr)->filesystemEpoch)) { return TCL_OK; } - if (pathPtr->bytes == NULL) { - UpdateStringOfFsPath(pathPtr); - } - FreeFsPathInternalRep(pathPtr); + TclGetString(pathPtr); + Tcl_StoreIntRep(pathPtr, &fsPathType, NULL); } return SetFsPathFromAny(interp, pathPtr); - - /* - * We used to have more complex code here: - * - * FsPath *fsPathPtr = PATHOBJ(pathPtr); - * if (fsPathPtr->cwdPtr == NULL || PATHFLAGS(pathPtr) != 0) { - * return TCL_OK; - * } else { - * if (TclFSCwdPointerEquals(&fsPathPtr->cwdPtr)) { - * return TCL_OK; - * } else { - * if (pathPtr->bytes == NULL) { - * UpdateStringOfFsPath(pathPtr); - * } - * FreeFsPathInternalRep(pathPtr); - * return Tcl_ConvertToType(interp, pathPtr, &tclFsPathType); - * } - * } - * - * But we no longer believe this is necessary. - */ } /* @@ -1335,9 +1307,7 @@ TclNewFSPathObj( SETPATHOBJ(pathPtr, fsPathPtr); PATHFLAGS(pathPtr) = TCLPATH_APPENDED; - pathPtr->typePtr = &tclFsPathType; - pathPtr->bytes = NULL; - pathPtr->length = 0; + TclInvalidateStringRep(pathPtr); /* * Look for path components made up of only "." @@ -1399,7 +1369,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 = Tcl_GetStringFromObj(tail, &numBytes); + bytes = TclGetStringFromObj(tail, &numBytes); if (numBytes == 0) { Tcl_AppendToObj(copy, "/", 1); } else { @@ -1438,8 +1408,9 @@ TclFSMakePathRelative( { int cwdLen, len; const char *tempStr; + Tcl_ObjIntRep *irPtr = TclFetchIntRep(pathPtr, &fsPathType); - if (pathPtr->typePtr == &tclFsPathType) { + if (irPtr) { FsPath *fsPathPtr = PATHOBJ(pathPtr); if (PATHFLAGS(pathPtr) != 0 && fsPathPtr->cwdPtr == cwdPtr) { @@ -1458,7 +1429,7 @@ TclFSMakePathRelative( * too little below, leading to wrong answers returned by glob. */ - tempStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen); + tempStr = TclGetStringFromObj(cwdPtr, &cwdLen); /* * Should we perhaps use 'Tcl_FSPathSeparator'? But then what about the @@ -1478,7 +1449,7 @@ TclFSMakePathRelative( } break; } - tempStr = Tcl_GetStringFromObj(pathPtr, &len); + tempStr = TclGetStringFromObj(pathPtr, &len); return Tcl_NewStringObj(tempStr + cwdLen, len - cwdLen); } @@ -1507,30 +1478,10 @@ MakePathFromNormalized( { FsPath *fsPathPtr; - if (pathPtr->typePtr == &tclFsPathType) { + if (TclHasIntRep(pathPtr, &fsPathType)) { return TCL_OK; } - /* - * Free old representation - */ - - if (pathPtr->typePtr != NULL) { - if (pathPtr->bytes == NULL) { - if (pathPtr->typePtr->updateStringProc == NULL) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can't find object string representation", -1)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "WTF", - NULL); - } - return TCL_ERROR; - } - pathPtr->typePtr->updateStringProc(pathPtr); - } - TclFreeIntRep(pathPtr); - } - fsPathPtr = ckalloc(sizeof(FsPath)); /* @@ -1539,11 +1490,7 @@ MakePathFromNormalized( fsPathPtr->translatedPathPtr = NULL; - /* - * Circular reference by design. - */ - - fsPathPtr->normPathPtr = pathPtr; + Tcl_IncrRefCount(fsPathPtr->normPathPtr = Tcl_DuplicateObj(pathPtr)); fsPathPtr->cwdPtr = NULL; fsPathPtr->nativePathPtr = NULL; fsPathPtr->fsPtr = NULL; @@ -1552,7 +1499,6 @@ MakePathFromNormalized( SETPATHOBJ(pathPtr, fsPathPtr); PATHFLAGS(pathPtr) = 0; - pathPtr->typePtr = &tclFsPathType; return TCL_OK; } @@ -1603,25 +1549,12 @@ Tcl_FSNewNativePath( * safe. */ - if (pathPtr->typePtr != NULL) { - if (pathPtr->bytes == NULL) { - if (pathPtr->typePtr->updateStringProc == NULL) { - return NULL; - } - pathPtr->typePtr->updateStringProc(pathPtr); - } - TclFreeIntRep(pathPtr); - } - + Tcl_StoreIntRep(pathPtr, &fsPathType, NULL); fsPathPtr = ckalloc(sizeof(FsPath)); fsPathPtr->translatedPathPtr = NULL; - /* - * Circular reference, by design. - */ - - fsPathPtr->normPathPtr = pathPtr; + Tcl_IncrRefCount(fsPathPtr->normPathPtr = Tcl_DuplicateObj(pathPtr)); fsPathPtr->cwdPtr = NULL; fsPathPtr->nativePathPtr = clientData; fsPathPtr->fsPtr = fromFilesystem; @@ -1629,7 +1562,6 @@ Tcl_FSNewNativePath( SETPATHOBJ(pathPtr, fsPathPtr); PATHFLAGS(pathPtr) = 0; - pathPtr->typePtr = &tclFsPathType; return pathPtr; } @@ -1676,20 +1608,22 @@ Tcl_FSGetTranslatedPath( Tcl_Obj *translatedCwdPtr = Tcl_FSGetTranslatedPath(interp, srcFsPathPtr->cwdPtr); + Tcl_ObjIntRep *translatedCwdIrPtr; + if (translatedCwdPtr == NULL) { return NULL; } retObj = Tcl_FSJoinToPath(translatedCwdPtr, 1, &srcFsPathPtr->normPathPtr); - srcFsPathPtr->translatedPathPtr = retObj; - if (translatedCwdPtr->typePtr == &tclFsPathType) { + Tcl_IncrRefCount(srcFsPathPtr->translatedPathPtr = retObj); + translatedCwdIrPtr = TclFetchIntRep(translatedCwdPtr, &fsPathType); + if (translatedCwdIrPtr) { srcFsPathPtr->filesystemEpoch = PATHOBJ(translatedCwdPtr)->filesystemEpoch; } else { srcFsPathPtr->filesystemEpoch = 0; } - Tcl_IncrRefCount(retObj); Tcl_DecrRefCount(translatedCwdPtr); } else { /* @@ -1742,10 +1676,10 @@ Tcl_FSGetTranslatedStringPath( if (transPtr != NULL) { int len; - const char *orig = Tcl_GetStringFromObj(transPtr, &len); + const char *orig = TclGetStringFromObj(transPtr, &len); char *result = ckalloc(len+1); - memcpy(result, orig, (size_t) len+1); + memcpy(result, orig, len+1); TclDecrRefCount(transPtr); return result; } @@ -1799,11 +1733,9 @@ Tcl_FSGetNormalizedPath( return NULL; } /* TODO: Figure out why this is needed. */ - if (pathPtr->bytes == NULL) { - UpdateStringOfFsPath(pathPtr); - } + TclGetString(pathPtr); - Tcl_GetStringFromObj(fsPathPtr->normPathPtr, &tailLen); + TclGetStringFromObj(fsPathPtr->normPathPtr, &tailLen); if (tailLen) { copy = AppendPath(dir, fsPathPtr->normPathPtr); } else { @@ -1816,7 +1748,7 @@ Tcl_FSGetNormalizedPath( * We now own a reference on both 'dir' and 'copy' */ - (void) Tcl_GetStringFromObj(dir, &cwdLen); + (void) TclGetStringFromObj(dir, &cwdLen); /* Normalize the combined string. */ @@ -1853,7 +1785,7 @@ Tcl_FSGetNormalizedPath( /* * NOTE: here we are (dangerously?) assuming that origDir points - * to a Tcl_Obj with Tcl_ObjType == &tclFsPathType. The + * to a Tcl_Obj with Tcl_ObjType == &fsPathType. The * pathType = Tcl_FSGetPathType(fsPathPtr->cwdPtr); * above that set the pathType value should have established that, * but it's far less clear on what basis we know there's been no @@ -1871,6 +1803,7 @@ Tcl_FSGetNormalizedPath( /* * That's our reference to copy used. */ + copy = NULL; TclDecrRefCount(dir); TclDecrRefCount(origDir); @@ -1883,7 +1816,7 @@ Tcl_FSGetNormalizedPath( /* * That's our reference to copy used. */ - + copy = NULL; TclDecrRefCount(dir); } PATHFLAGS(pathPtr) = 0; @@ -1895,10 +1828,8 @@ Tcl_FSGetNormalizedPath( if (fsPathPtr->cwdPtr != NULL) { if (!TclFSCwdPointerEquals(&fsPathPtr->cwdPtr)) { - if (pathPtr->bytes == NULL) { - UpdateStringOfFsPath(pathPtr); - } - FreeFsPathInternalRep(pathPtr); + TclGetString(pathPtr); + Tcl_StoreIntRep(pathPtr, &fsPathType, NULL); if (SetFsPathFromAny(interp, pathPtr) != TCL_OK) { return NULL; } @@ -1909,7 +1840,7 @@ Tcl_FSGetNormalizedPath( copy = AppendPath(fsPathPtr->cwdPtr, pathPtr); - (void) Tcl_GetStringFromObj(fsPathPtr->cwdPtr, &cwdLen); + (void) TclGetStringFromObj(fsPathPtr->cwdPtr, &cwdLen); cwdLen += (Tcl_GetString(copy)[cwdLen] == '/'); /* @@ -1924,7 +1855,6 @@ Tcl_FSGetNormalizedPath( } if (fsPathPtr->normPathPtr == NULL) { Tcl_Obj *useThisCwd = NULL; - int pureNormalized = 1; /* * Since normPathPtr is NULL, but this is a valid path object, we know @@ -1974,7 +1904,6 @@ Tcl_FSGetNormalizedPath( return NULL; } - pureNormalized = 0; Tcl_DecrRefCount(absolutePath); absolutePath = Tcl_FSJoinToPath(useThisCwd, 1, &absolutePath); Tcl_IncrRefCount(absolutePath); @@ -1994,7 +1923,6 @@ Tcl_FSGetNormalizedPath( if (absolutePath == NULL) { return NULL; } - pureNormalized = 0; #endif /* _WIN32 */ } } @@ -2003,35 +1931,12 @@ Tcl_FSGetNormalizedPath( * Already has refCount incremented. */ + if (fsPathPtr->normPathPtr) { + Tcl_DecrRefCount(fsPathPtr->normPathPtr); + } fsPathPtr->normPathPtr = TclFSNormalizeAbsolutePath(interp, absolutePath); - /* - * Check if path is pure normalized (this can only be the case if it - * is an absolute path). - */ - - if (pureNormalized) { - int normPathLen, pathLen; - const char *normPath; - - path = TclGetStringFromObj(pathPtr, &pathLen); - normPath = TclGetStringFromObj(fsPathPtr->normPathPtr, &normPathLen); - if ((pathLen == normPathLen) && !memcmp(path, normPath, pathLen)) { - /* - * The path was already normalized. Get rid of the duplicate. - */ - - TclDecrRefCount(fsPathPtr->normPathPtr); - - /* - * We do *not* increment the refCount for this circular - * reference. - */ - - fsPathPtr->normPathPtr = pathPtr; - } - } if (useThisCwd != NULL) { /* * We just need to free an object we allocated above for relative @@ -2178,7 +2083,7 @@ TclFSEnsureEpochOk( { FsPath *srcFsPathPtr; - if (pathPtr->typePtr != &tclFsPathType) { + if (!TclHasIntRep(pathPtr, &fsPathType)) { return TCL_OK; } @@ -2194,10 +2099,8 @@ TclFSEnsureEpochOk( * We have to discard the stale representation and recalculate it. */ - if (pathPtr->bytes == NULL) { - UpdateStringOfFsPath(pathPtr); - } - FreeFsPathInternalRep(pathPtr); + TclGetString(pathPtr); + Tcl_StoreIntRep(pathPtr, &fsPathType, NULL); if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) { return TCL_ERROR; } @@ -2242,7 +2145,7 @@ TclFSSetPathDetails( * Make sure pathPtr is of the correct type. */ - if (pathPtr->typePtr != &tclFsPathType) { + if (!TclHasIntRep(pathPtr, &fsPathType)) { if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) { return; } @@ -2339,9 +2242,9 @@ SetFsPathFromAny( int len; FsPath *fsPathPtr; Tcl_Obj *transPtr; - char *name; + const char *name; - if (pathPtr->typePtr == &tclFsPathType) { + if (TclHasIntRep(pathPtr, &fsPathType)) { return TCL_OK; } @@ -2359,7 +2262,7 @@ SetFsPathFromAny( * cmdAH.test exercise most of the code). */ - name = Tcl_GetStringFromObj(pathPtr, &len); + name = TclGetStringFromObj(pathPtr, &len); /* * Handle tilde substitutions, if needed. @@ -2483,27 +2386,21 @@ SetFsPathFromAny( fsPathPtr = ckalloc(sizeof(FsPath)); - fsPathPtr->translatedPathPtr = transPtr; - if (transPtr != pathPtr) { - Tcl_IncrRefCount(fsPathPtr->translatedPathPtr); - /* Redo translation when $env(HOME) changes */ - fsPathPtr->filesystemEpoch = TclFSEpoch(); + if (transPtr == pathPtr) { + transPtr = Tcl_DuplicateObj(pathPtr); + fsPathPtr->filesystemEpoch = 0; } else { - fsPathPtr->filesystemEpoch = 0; + fsPathPtr->filesystemEpoch = TclFSEpoch(); } + Tcl_IncrRefCount(transPtr); + fsPathPtr->translatedPathPtr = transPtr; fsPathPtr->normPathPtr = NULL; fsPathPtr->cwdPtr = NULL; fsPathPtr->nativePathPtr = NULL; fsPathPtr->fsPtr = NULL; - /* - * Free old representation before installing our new one. - */ - - TclFreeIntRep(pathPtr); SETPATHOBJ(pathPtr, fsPathPtr); PATHFLAGS(pathPtr) = 0; - pathPtr->typePtr = &tclFsPathType; return TCL_OK; } @@ -2526,6 +2423,7 @@ FreeFsPathInternalRep( } if (fsPathPtr->cwdPtr != NULL) { TclDecrRefCount(fsPathPtr->cwdPtr); + fsPathPtr->cwdPtr = NULL; } if (fsPathPtr->nativePathPtr != NULL && fsPathPtr->fsPtr != NULL) { Tcl_FSFreeInternalRepProc *freeProc = @@ -2538,7 +2436,6 @@ FreeFsPathInternalRep( } ckfree(fsPathPtr); - pathPtr->typePtr = NULL; } static void @@ -2551,24 +2448,14 @@ DupFsPathInternalRep( SETPATHOBJ(copyPtr, copyFsPathPtr); - if (srcFsPathPtr->translatedPathPtr == srcPtr) { - /* Cycle in src -> make cycle in copy. */ - copyFsPathPtr->translatedPathPtr = copyPtr; - } else { - copyFsPathPtr->translatedPathPtr = srcFsPathPtr->translatedPathPtr; - if (copyFsPathPtr->translatedPathPtr != NULL) { - Tcl_IncrRefCount(copyFsPathPtr->translatedPathPtr); - } + copyFsPathPtr->translatedPathPtr = srcFsPathPtr->translatedPathPtr; + if (copyFsPathPtr->translatedPathPtr != NULL) { + Tcl_IncrRefCount(copyFsPathPtr->translatedPathPtr); } - if (srcFsPathPtr->normPathPtr == srcPtr) { - /* Cycle in src -> make cycle in copy. */ - copyFsPathPtr->normPathPtr = copyPtr; - } else { - copyFsPathPtr->normPathPtr = srcFsPathPtr->normPathPtr; - if (copyFsPathPtr->normPathPtr != NULL) { - Tcl_IncrRefCount(copyFsPathPtr->normPathPtr); - } + copyFsPathPtr->normPathPtr = srcFsPathPtr->normPathPtr; + if (copyFsPathPtr->normPathPtr != NULL) { + Tcl_IncrRefCount(copyFsPathPtr->normPathPtr); } copyFsPathPtr->cwdPtr = srcFsPathPtr->cwdPtr; @@ -2594,8 +2481,6 @@ DupFsPathInternalRep( } copyFsPathPtr->fsPtr = srcFsPathPtr->fsPtr; copyFsPathPtr->filesystemEpoch = srcFsPathPtr->filesystemEpoch; - - copyPtr->typePtr = &tclFsPathType; } /* @@ -2627,11 +2512,15 @@ UpdateStringOfFsPath( } copy = AppendPath(fsPathPtr->cwdPtr, fsPathPtr->normPathPtr); + if (Tcl_IsShared(copy)) { + copy = Tcl_DuplicateObj(copy); + } - pathPtr->bytes = Tcl_GetStringFromObj(copy, &cwdLen); + Tcl_IncrRefCount(copy); + /* Steal copy's string rep */ + pathPtr->bytes = TclGetStringFromObj(copy, &cwdLen); pathPtr->length = cwdLen; - copy->bytes = tclEmptyStringRep; - copy->length = 0; + TclInitStringRep(copy, NULL, 0); TclDecrRefCount(copy); } @@ -2668,7 +2557,7 @@ TclNativePathInFilesystem( * semantics of Tcl (at present anyway), so we have to abide by them here. */ - if (pathPtr->typePtr == &tclFsPathType) { + if (TclHasIntRep(pathPtr, &fsPathType)) { if (pathPtr->bytes != NULL && pathPtr->bytes[0] == '\0') { /* * We reject the empty path "". @@ -2683,13 +2572,13 @@ TclNativePathInFilesystem( } else { /* * It is somewhat unusual to reach this code path without the object - * being of tclFsPathType. However, we do our best to deal with the + * being of fsPathType. However, we do our best to deal with the * situation. */ int len; - (void) Tcl_GetStringFromObj(pathPtr, &len); + (void) TclGetStringFromObj(pathPtr, &len); if (len == 0) { /* * We reject the empty path "". diff --git a/generic/tclPipe.c b/generic/tclPipe.c index 2ecc5a6..63fd2fa 100644 --- a/generic/tclPipe.c +++ b/generic/tclPipe.c @@ -60,7 +60,7 @@ static TclFile FileForRedirect(Tcl_Interp *interp, const char *spec, static TclFile FileForRedirect( - Tcl_Interp *interp, /* Intepreter to use for error reporting. */ + Tcl_Interp *interp, /* Interpreter to use for error reporting. */ const char *spec, /* Points to character just after redirection * character. */ int atOK, /* Non-zero means that '@' notation can be @@ -221,13 +221,13 @@ Tcl_ReapDetachedProcs(void) { register Detached *detPtr; Detached *nextPtr, *prevPtr; - int status; - Tcl_Pid pid; + int status, code; Tcl_MutexLock(&pipeMutex); for (detPtr = detList, prevPtr = NULL; detPtr != NULL; ) { - pid = Tcl_WaitPid(detPtr->pid, &status, WNOHANG); - if ((pid == 0) || ((pid == (Tcl_Pid) -1) && (errno != ECHILD))) { + status = TclProcessWait(detPtr->pid, WNOHANG, &code, NULL, NULL); + if (status == TCL_PROCESS_UNCHANGED || (status == TCL_PROCESS_ERROR + && code != ECHILD)) { prevPtr = detPtr; detPtr = detPtr->nextPtr; continue; @@ -277,38 +277,21 @@ TclCleanupChildren( { int result = TCL_OK; int i, abnormalExit, anyErrorInfo; - Tcl_Pid pid; - int waitStatus; - const char *msg; - unsigned long resolvedPid; + TclProcessWaitStatus waitStatus; + int code; + Tcl_Obj *msg, *error; abnormalExit = 0; for (i = 0; i < numPids; i++) { - /* - * We need to get the resolved pid before we wait on it as the windows - * implementation of Tcl_WaitPid deletes the information such that any - * following calls to TclpGetPid fail. - */ - - resolvedPid = TclpGetPid(pidPtr[i]); - pid = Tcl_WaitPid(pidPtr[i], &waitStatus, 0); - if (pid == (Tcl_Pid) -1) { + waitStatus = TclProcessWait(pidPtr[i], 0, &code, &msg, &error); + if (waitStatus == TCL_PROCESS_ERROR) { result = TCL_ERROR; if (interp != NULL) { - msg = Tcl_PosixError(interp); - if (errno == ECHILD) { - /* - * This changeup in message suggested by Mark Diekhans to - * remind people that ECHILD errors can occur on some - * systems if SIGCHLD isn't in its default state. - */ - - msg = - "child process lost (is SIGCHLD ignored or trapped?)"; - } - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "error waiting for process to exit: %s", msg)); + Tcl_SetObjErrorCode(interp, error); + Tcl_SetObjResult(interp, msg); } + Tcl_DecrRefCount(error); + Tcl_DecrRefCount(msg); continue; } @@ -319,39 +302,19 @@ TclCleanupChildren( * removed). */ - if (!WIFEXITED(waitStatus) || (WEXITSTATUS(waitStatus) != 0)) { - char msg1[TCL_INTEGER_SPACE], msg2[TCL_INTEGER_SPACE]; - + if (waitStatus != TCL_PROCESS_EXITED || code != 0) { result = TCL_ERROR; - sprintf(msg1, "%lu", resolvedPid); - if (WIFEXITED(waitStatus)) { + if (waitStatus == TCL_PROCESS_EXITED) { if (interp != NULL) { - sprintf(msg2, "%u", WEXITSTATUS(waitStatus)); - Tcl_SetErrorCode(interp, "CHILDSTATUS", msg1, msg2, NULL); + Tcl_SetObjErrorCode(interp, error); } abnormalExit = 1; } else if (interp != NULL) { - const char *p; - - if (WIFSIGNALED(waitStatus)) { - p = Tcl_SignalMsg(WTERMSIG(waitStatus)); - Tcl_SetErrorCode(interp, "CHILDKILLED", msg1, - Tcl_SignalId(WTERMSIG(waitStatus)), p, NULL); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "child killed: %s\n", p)); - } else if (WIFSTOPPED(waitStatus)) { - p = Tcl_SignalMsg(WSTOPSIG(waitStatus)); - Tcl_SetErrorCode(interp, "CHILDSUSP", msg1, - Tcl_SignalId(WSTOPSIG(waitStatus)), p, NULL); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "child suspended: %s\n", p)); - } else { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "child wait status didn't make sense\n", -1)); - Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", - "ODDWAITRESULT", msg1, NULL); - } + Tcl_SetObjErrorCode(interp, error); + Tcl_SetObjResult(interp, msg); } + Tcl_DecrRefCount(error); + Tcl_DecrRefCount(msg); } } @@ -370,7 +333,7 @@ TclCleanupChildren( int count; Tcl_Obj *objPtr; - Tcl_Seek(errorChan, (Tcl_WideInt)0, SEEK_SET); + Tcl_Seek(errorChan, 0, SEEK_SET); objPtr = Tcl_NewObj(); count = Tcl_ReadChars(errorChan, objPtr, -1, 0); if (count < 0) { @@ -936,6 +899,7 @@ TclCreatePipeline( pidPtr[numPids] = pid; numPids++; + TclProcessCreated(pid); /* * Close off our copies of file descriptors that were set up for this diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 06d6ade..6727715 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -17,6 +17,10 @@ #include "tclInt.h" +MODULE_SCOPE char *tclEmptyStringRep; + +char *tclEmptyStringRep = &tclEmptyString; + /* * Each invocation of the "package ifneeded" command creates a structure of * the following type, which is used to load the package into the interpreter @@ -28,10 +32,24 @@ 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 @@ -47,7 +65,7 @@ typedef struct Package { } Package; typedef struct Require { - void * clientDataPtr; + void *clientDataPtr; const char *name; Package *pkgPtr; char *versionToProvide; @@ -96,7 +114,7 @@ static int TclNRPackageObjCmdCleanup(ClientData data[], Tcl_Interp *interp, int ((v) = ckalloc(len), memcpy((v),(s),(len))) #define DupString(v,s) \ do { \ - unsigned local__len = (unsigned) (strlen(s) + 1); \ + size_t local__len = strlen(s) + 1; \ DupBlock((v),(s),local__len); \ } while (0) @@ -205,6 +223,78 @@ 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); + ckfree(pkgFiles); + 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 isNew; + Tcl_HashEntry *entry = Tcl_CreateHashEntry(table, name, &isNew); + Tcl_Obj *list; + + if (isNew) { + 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( @@ -274,12 +364,12 @@ Tcl_PkgRequireEx( * * Second, how does this work? If we reach this point, then the global * variable tclEmptyStringRep has the value NULL. Compare that with - * the definition of tclEmptyStringRep near the top of the file - * generic/tclObj.c. It clearly should not have the value NULL; it - * should point to the char tclEmptyString. If we see it having the - * value NULL, then somehow we are seeing a Tcl library that isn't - * completely initialized, and that's an indicator for the error - * condition described above. (Further explanation is welcome.) + * the definition of tclEmptyStringRep near the top of this file. It + * clearly should not have the value NULL; it should point to the char + * tclEmptyString. If we see it having the value NULL, then somehow we + * are seeing a Tcl library that isn't completely initialized, and + * that's an indicator for the error condition described above. + * (Further explanation is welcome.) * * Third, so what do we do about it? This situation indicates the * package we just loaded wasn't properly compiled to be stub-enabled, @@ -291,18 +381,11 @@ Tcl_PkgRequireEx( * After all, two Tcl libraries can't be a good thing!) * * Trouble is that's going to be tricky. We're now using a Tcl library - * that's not fully initialized. In particular, it doesn't have a - * proper value for tclEmptyStringRep. The Tcl_Obj system heavily - * depends on the value of tclEmptyStringRep and all of Tcl depends - * (increasingly) on the Tcl_Obj system, we need to correct that flaw - * before making the calls to set the interpreter result to the error - * message. That's the only flaw corrected; other problems with - * initialization of the Tcl library are not remedied, so be very - * careful about adding any other calls here without checking how they - * behave when initialization is incomplete. + * that's not fully initialized. Functions in it may not work + * reliably, so be very careful about adding any other calls here + * without checking how they behave when initialization is incomplete. */ - tclEmptyStringRep = &tclEmptyString; Tcl_SetObjResult(interp, Tcl_ObjPrintf( "Cannot load package \"%s\" in standalone executable:" " This package is not compiled with stub support", name)); @@ -350,9 +433,11 @@ Tcl_PkgRequireProc( void *clientDataPtr) { RequireProcArgs args; + args.name = name; args.clientDataPtr = clientDataPtr; - return Tcl_NRCallObjProc(interp, TclNRPkgRequireProc, (void *)&args, reqc, reqv); + return Tcl_NRCallObjProc(interp, + TclNRPkgRequireProc, (void *) &args, reqc, reqv); } static int @@ -360,20 +445,28 @@ TclNRPkgRequireProc( ClientData clientData, Tcl_Interp *interp, int reqc, - Tcl_Obj *const reqv[]) { + Tcl_Obj *const reqv[]) +{ RequireProcArgs *args = clientData; - Tcl_NRAddCallback(interp, PkgRequireCore, (void *)args->name, INT2PTR(reqc), (void *)reqv, args->clientDataPtr); + + Tcl_NRAddCallback(interp, + PkgRequireCore, (void *) args->name, INT2PTR(reqc), (void *) reqv, + args->clientDataPtr); return TCL_OK; } static int -PkgRequireCore(ClientData data[], Tcl_Interp *interp, int result) +PkgRequireCore( + ClientData data[], + Tcl_Interp *interp, + int result) { const char *name = data[0]; int reqc = PTR2INT(data[1]); Tcl_Obj *const *reqv = data[2]; int code = CheckAllRequirements(interp, reqc, reqv); Require *reqPtr; + if (code != TCL_OK) { return code; } @@ -383,56 +476,86 @@ PkgRequireCore(ClientData data[], Tcl_Interp *interp, int result) reqPtr->name = name; reqPtr->pkgPtr = FindPackage(interp, name); if (reqPtr->pkgPtr->version == NULL) { - Tcl_NRAddCallback(interp, SelectPackage, reqPtr, INT2PTR(reqc), (void *)reqv, PkgRequireCoreStep1); + Tcl_NRAddCallback(interp, + SelectPackage, reqPtr, INT2PTR(reqc), (void *) reqv, + PkgRequireCoreStep1); } else { - Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + Tcl_NRAddCallback(interp, + PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *) reqv,NULL); } return TCL_OK; } static int -PkgRequireCoreStep1(ClientData data[], Tcl_Interp *interp, int result) { +PkgRequireCoreStep1( + ClientData data[], + Tcl_Interp *interp, + int result) +{ Tcl_DString command; char *script; Require *reqPtr = data[0]; int reqc = PTR2INT(data[1]); Tcl_Obj **const reqv = data[2]; const char *name = reqPtr->name /* Name of desired package. */; - if (reqPtr->pkgPtr->version == NULL) { - /* - * The package is not in the database. If there is a "package unknown" - * command, invoke it. - */ - script = ((Interp *) interp)->packageUnknown; - if (script == NULL) { - Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); - } else { - Tcl_DStringInit(&command); - Tcl_DStringAppend(&command, script, -1); - Tcl_DStringAppendElement(&command, name); - AddRequirementsToDString(&command, reqc, reqv); - - Tcl_NRAddCallback(interp, PkgRequireCoreStep2, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); - Tcl_NREvalObj(interp, - Tcl_NewStringObj(Tcl_DStringValue(&command), Tcl_DStringLength(&command)), - TCL_EVAL_GLOBAL - ); - Tcl_DStringFree(&command); - } - return TCL_OK; - } else { - Tcl_NRAddCallback(interp, PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + /* + * If we've got the package in the DB already, go on to actually loading + * it. + */ + + if (reqPtr->pkgPtr->version != NULL) { + Tcl_NRAddCallback(interp, + PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + return TCL_OK; } + + /* + * The package is not in the database. If there is a "package unknown" + * command, invoke it. + */ + + script = ((Interp *) interp)->packageUnknown; + if (script == NULL) { + /* + * No package unknown script. Move on to finalizing. + */ + + Tcl_NRAddCallback(interp, + PkgRequireCoreFinal, reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + return TCL_OK; + } + + /* + * Invoke the "package unknown" script synchronously. + */ + + Tcl_DStringInit(&command); + Tcl_DStringAppend(&command, script, -1); + Tcl_DStringAppendElement(&command, name); + AddRequirementsToDString(&command, reqc, reqv); + + Tcl_NRAddCallback(interp, + PkgRequireCoreStep2, reqPtr, INT2PTR(reqc), (void *) reqv, NULL); + Tcl_NREvalObj(interp, + Tcl_NewStringObj(Tcl_DStringValue(&command), + Tcl_DStringLength(&command)), + TCL_EVAL_GLOBAL); + Tcl_DStringFree(&command); return TCL_OK; } static int -PkgRequireCoreStep2(ClientData data[], Tcl_Interp *interp, int result) { +PkgRequireCoreStep2( + ClientData data[], + Tcl_Interp *interp, + int result) +{ Require *reqPtr = data[0]; int reqc = PTR2INT(data[1]); Tcl_Obj **const reqv = data[2]; - const char *name = reqPtr->name /* Name of desired package. */; + const char *name = reqPtr->name; /* Name of desired package. */ + if ((result != TCL_OK) && (result != TCL_ERROR)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad return code: %d", result)); @@ -445,20 +568,31 @@ PkgRequireCoreStep2(ClientData data[], Tcl_Interp *interp, int result) { return result; } Tcl_ResetResult(interp); - /* pkgPtr may now be invalid, so refresh it. */ + + /* + * pkgPtr may now be invalid, so refresh it. + */ + reqPtr->pkgPtr = FindPackage(interp, name); - Tcl_NRAddCallback(interp, SelectPackage, reqPtr, INT2PTR(reqc), (void *)reqv, PkgRequireCoreFinal); + Tcl_NRAddCallback(interp, + SelectPackage, reqPtr, INT2PTR(reqc), (void *) reqv, + PkgRequireCoreFinal); return TCL_OK; } static int -PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result) { +PkgRequireCoreFinal( + ClientData data[], + Tcl_Interp *interp, + int result) +{ Require *reqPtr = data[0]; int reqc = PTR2INT(data[1]), satisfies; Tcl_Obj **const reqv = data[2]; char *pkgVersionI; void *clientDataPtr = reqPtr->clientDataPtr; - const char *name = reqPtr->name /* Name of desired package. */; + const char *name = reqPtr->name; /* Name of desired package. */ + if (reqPtr->pkgPtr->version == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't find package %s", name)); @@ -499,14 +633,21 @@ PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result) { } static int -PkgRequireCoreCleanup(ClientData data[], Tcl_Interp *interp, int result) { +PkgRequireCoreCleanup( + ClientData data[], + Tcl_Interp *interp, + int result) +{ ckfree(data[0]); return result; } - static int -SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { +SelectPackage( + ClientData data[], + Tcl_Interp *interp, + int result) +{ PkgAvail *availPtr, *bestPtr, *bestStablePtr; char *availVersion, *bestVersion, *bestStableVersion; /* Internal rep. of versions */ @@ -534,10 +675,10 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { } /* - * The package isn't yet present. Search the list of available - * versions and invoke the script for the best available version. We - * are actually locating the best, and the best stable version. One of - * them is then chosen based on the selection mode. + * The package isn't yet present. Search the list of available versions + * and invoke the script for the best available version. We are actually + * locating the best, and the best stable version. One of them is then + * chosen based on the selection mode. */ bestPtr = NULL; @@ -550,15 +691,19 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { if (CheckVersionAndConvert(interp, availPtr->version, &availVersion, &availStable) != TCL_OK) { /* - * The provided version number has invalid syntax. This - * should not happen. This should have been caught by the - * 'package ifneeded' registering the package. + * The provided version number has invalid syntax. This should not + * happen. This should have been caught by the 'package ifneeded' + * registering the package. */ continue; } - /* Check satisfaction of requirements before considering the current version further. */ + /* + * Check satisfaction of requirements before considering the current + * version further. + */ + if (reqc > 0) { satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv); if (!satisfies) { @@ -580,13 +725,16 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { * The version of the package sought is better than the * currently selected version. */ + ckfree(bestVersion); bestVersion = NULL; goto newbest; } } else { newbest: - /* We have found a version which is better than our max. */ + /* + * We have found a version which is better than our max. + */ bestPtr = availPtr; CheckVersionAndConvert(interp, bestPtr->version, &bestVersion, NULL); @@ -607,18 +755,24 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { if (res > 0) { /* - * This stable version of the package sought is better - * than the currently selected stable version. + * This stable version of the package sought is better than + * the currently selected stable version. */ + ckfree(bestStableVersion); bestStableVersion = NULL; goto newstable; } } else { newstable: - /* We have found a stable version which is better than our max stable. */ + /* + * We have found a stable version which is better than our max + * stable. + */ + bestStablePtr = availPtr; - CheckVersionAndConvert(interp, bestStablePtr->version, &bestStableVersion, NULL); + CheckVersionAndConvert(interp, bestStablePtr->version, + &bestStableVersion, NULL); } ckfree(availVersion); @@ -640,9 +794,9 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { } /* - * Now choose a version among the two best. For 'latest' we simply - * take (actually keep) the best. For 'stable' we take the best - * stable, if there is any, or the best if there is nothing stable. + * Now choose a version among the two best. For 'latest' we simply take + * (actually keep) the best. For 'stable' we take the best stable, if + * there is any, or the best if there is nothing stable. */ if ((iPtr->packagePrefer == PKG_PREFER_STABLE) @@ -651,34 +805,67 @@ SelectPackage(ClientData data[], Tcl_Interp *interp, int result) { } if (bestPtr == NULL) { - Tcl_NRAddCallback(interp, data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + Tcl_NRAddCallback(interp, + data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL); } else { /* * We found an ifneeded script for the package. Be careful while * executing it: this could cause reentrancy, so (a) protect the - * script itself from deletion and (b) don't assume that bestPtr - * will still exist when the script completes. + * script itself from deletion and (b) don't assume that bestPtr will + * still exist when the script completes. */ char *versionToProvide = bestPtr->version; + PkgFiles *pkgFiles; + PkgName *pkgName; - pkgPtr->clientData = versionToProvide; Tcl_Preserve(versionToProvide); + pkgPtr->clientData = versionToProvide; + + 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); + } reqPtr->versionToProvide = versionToProvide; - Tcl_NRAddCallback(interp, SelectPackageFinal, reqPtr, INT2PTR(reqc), (void *)reqv, data[3]); - Tcl_NREvalObj(interp, Tcl_NewStringObj(bestPtr->script, -1), TCL_EVAL_GLOBAL); + Tcl_NRAddCallback(interp, + SelectPackageFinal, reqPtr, INT2PTR(reqc), (void *)reqv, + data[3]); + Tcl_NREvalObj(interp, Tcl_NewStringObj(bestPtr->script, -1), + TCL_EVAL_GLOBAL); } return TCL_OK; } static int -SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) { +SelectPackageFinal( + ClientData data[], + Tcl_Interp *interp, + int result) +{ Require *reqPtr = data[0]; int reqc = PTR2INT(data[1]); Tcl_Obj **const reqv = data[2]; const char *name = reqPtr->name; char *versionToProvide = reqPtr->versionToProvide; + /* + * Pop the "ifneeded" package name from "tclPkgFiles" assocdata + */ + + PkgFiles *pkgFiles = Tcl_GetAssocData(interp, "tclPkgFiles", NULL); + PkgName *pkgName = pkgFiles->names; + pkgFiles->names = pkgName->nextPtr; + ckfree(pkgName); + reqPtr->pkgPtr = FindPackage(interp, name); if (result == TCL_OK) { Tcl_ResetResult(interp); @@ -738,14 +925,13 @@ SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) { if (result != TCL_OK) { /* - * Take a non-TCL_OK code from the script as an indication the - * package wasn't loaded properly, so the package system - * should not remember an improper load. + * Take a non-TCL_OK code from the script as an indication the package + * wasn't loaded properly, so the package system should not remember + * an improper load. * - * This is consistent with our returning NULL. If we're not - * willing to tell our caller we got a particular version, we - * shouldn't store that version for telling future callers - * either. + * This is consistent with our returning NULL. If we're not willing to + * tell our caller we got a particular version, we shouldn't store + * that version for telling future callers either. */ if (reqPtr->pkgPtr->version != NULL) { @@ -756,7 +942,8 @@ SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result) { return result; } - Tcl_NRAddCallback(interp, data[3], reqPtr, INT2PTR(reqc), (void *)reqv, NULL); + Tcl_NRAddCallback(interp, + data[3], reqPtr, INT2PTR(reqc), (void *) reqv, NULL); return TCL_OK; } @@ -882,14 +1069,14 @@ TclNRPackageObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { static const char *const pkgOptions[] = { - "forget", "ifneeded", "names", "prefer", "present", - "provide", "require", "unknown", "vcompare", "versions", - "vsatisfies", NULL + "files", "forget", "ifneeded", "names", "prefer", + "present", "provide", "require", "unknown", "vcompare", + "versions", "vsatisfies", NULL }; enum pkgOptions { - PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, PKG_PREFER, PKG_PRESENT, - PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE, PKG_VERSIONS, - PKG_VSATISFIES + PKG_FILES, PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, PKG_PREFER, + PKG_PRESENT, PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE, + PKG_VERSIONS, PKG_VSATISFIES }; Interp *iPtr = (Interp *) interp; int optionIndex, exact, i, newobjc, satisfies; @@ -913,11 +1100,39 @@ TclNRPackageObjCmd( 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; @@ -932,6 +1147,10 @@ TclNRPackageObjCmd( 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); + availPtr->pkgIndex = NULL; + } ckfree(availPtr); } ckfree(pkgPtr); @@ -961,7 +1180,7 @@ TclNRPackageObjCmd( } else { pkgPtr = FindPackage(interp, argv2); } - argv3 = Tcl_GetStringFromObj(objv[3], &length); + argv3 = TclGetStringFromObj(objv[3], &length); for (availPtr = pkgPtr->availPtr, prevPtr = NULL; availPtr != NULL; prevPtr = availPtr, availPtr = availPtr->nextPtr) { @@ -974,7 +1193,7 @@ TclNRPackageObjCmd( res = CompareVersions(avi, argv3i, NULL); ckfree(avi); - if (res == 0){ + if (res == 0) { if (objc == 4) { ckfree(argv3i); Tcl_SetObjResult(interp, @@ -982,6 +1201,10 @@ TclNRPackageObjCmd( return TCL_OK; } Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC); + if (availPtr->pkgIndex) { + Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC); + availPtr->pkgIndex = NULL; + } break; } } @@ -992,7 +1215,8 @@ TclNRPackageObjCmd( } if (availPtr == NULL) { availPtr = ckalloc(sizeof(PkgAvail)); - DupBlock(availPtr->version, argv3, (unsigned) length + 1); + availPtr->pkgIndex = NULL; + DupBlock(availPtr->version, argv3, length + 1); if (prevPtr == NULL) { availPtr->nextPtr = pkgPtr->availPtr; @@ -1002,8 +1226,12 @@ TclNRPackageObjCmd( prevPtr->nextPtr = availPtr; } } - argv4 = Tcl_GetStringFromObj(objv[4], &length); - DupBlock(availPtr->script, argv4, (unsigned) length + 1); + if (iPtr->scriptFile) { + argv4 = TclGetStringFromObj(iPtr->scriptFile, &length); + DupBlock(availPtr->pkgIndex, argv4, length + 1); + } + argv4 = TclGetStringFromObj(objv[4], &length); + DupBlock(availPtr->script, argv4, length + 1); break; } case PKG_NAMES: @@ -1133,12 +1361,16 @@ TclNRPackageObjCmd( Tcl_ListObjAppendElement(interp, objvListPtr, ov); Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); - Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[3], objvListPtr, NULL, NULL); - Tcl_NRAddCallback(interp, PkgRequireCore, (void *)argv3, INT2PTR(newobjc), newObjvPtr, NULL); + Tcl_NRAddCallback(interp, + TclNRPackageObjCmdCleanup, objv[3], objvListPtr, NULL,NULL); + Tcl_NRAddCallback(interp, + PkgRequireCore, (void *) argv3, INT2PTR(newobjc), + newObjvPtr, NULL); return TCL_OK; } else { int i, newobjc = objc-3; Tcl_Obj *const *newobjv = objv + 3; + if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) { return TCL_ERROR; } @@ -1146,17 +1378,20 @@ TclNRPackageObjCmd( Tcl_IncrRefCount(objvListPtr); Tcl_IncrRefCount(objv[2]); for (i = 0; i < newobjc; i++) { - /* * Tcl_Obj structures may have come from another interpreter, * so duplicate them. */ - Tcl_ListObjAppendElement(interp, objvListPtr, Tcl_DuplicateObj(newobjv[i])); + Tcl_ListObjAppendElement(interp, objvListPtr, + Tcl_DuplicateObj(newobjv[i])); } Tcl_ListObjGetElements(interp, objvListPtr, &newobjc, &newObjvPtr); - Tcl_NRAddCallback(interp, TclNRPackageObjCmdCleanup, objv[2], objvListPtr, NULL, NULL); - Tcl_NRAddCallback(interp, PkgRequireCore, (void *)argv2, INT2PTR(newobjc), newObjvPtr, NULL); + Tcl_NRAddCallback(interp, + TclNRPackageObjCmdCleanup, objv[2], objvListPtr, NULL,NULL); + Tcl_NRAddCallback(interp, + PkgRequireCore, (void *) argv2, INT2PTR(newobjc), + newObjvPtr, NULL); return TCL_OK; } break; @@ -1172,11 +1407,11 @@ TclNRPackageObjCmd( if (iPtr->packageUnknown != NULL) { ckfree(iPtr->packageUnknown); } - argv2 = Tcl_GetStringFromObj(objv[2], &length); + argv2 = TclGetStringFromObj(objv[2], &length); if (argv2[0] == 0) { iPtr->packageUnknown = NULL; } else { - DupBlock(iPtr->packageUnknown, argv2, (unsigned) length+1); + DupBlock(iPtr->packageUnknown, argv2, length+1); } } else { Tcl_WrongNumArgs(interp, 2, objv, "?command?"); @@ -1299,9 +1534,13 @@ TclNRPackageObjCmd( } static int -TclNRPackageObjCmdCleanup(ClientData data[], Tcl_Interp *interp, int result) { - TclDecrRefCount((Tcl_Obj *)data[0]); - TclDecrRefCount((Tcl_Obj *)data[1]); +TclNRPackageObjCmdCleanup( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + TclDecrRefCount((Tcl_Obj *) data[0]); + TclDecrRefCount((Tcl_Obj *) data[1]); return result; } @@ -1365,7 +1604,7 @@ FindPackage( void TclFreePackageInfo( - Interp *iPtr) /* Interpereter that is being deleted. */ + Interp *iPtr) /* Interpreter that is being deleted. */ { Package *pkgPtr; Tcl_HashSearch search; @@ -1383,6 +1622,10 @@ 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); + availPtr->pkgIndex = NULL; + } ckfree(availPtr); } ckfree(pkgPtr); @@ -1827,7 +2070,7 @@ AddRequirementsToResult( int i, length; for (i = 0; i < reqc; i++) { - const char *v = Tcl_GetStringFromObj(reqv[i], &length); + const char *v = TclGetStringFromObj(reqv[i], &length); if ((length & 0x1) && (v[length/2] == '-') && (strncmp(v, v+((length+1)/2), length/2) == 0)) { @@ -2040,7 +2283,7 @@ Tcl_PkgInitStubsCheck( { const char *actualVersion = Tcl_PkgPresent(interp, "Tcl", version, 0); - if (exact && actualVersion) { + if ((exact&1) && actualVersion) { const char *p = version; int count = 0; diff --git a/generic/tclPkgConfig.c b/generic/tclPkgConfig.c index 466d535..96b6962 100644 --- a/generic/tclPkgConfig.c +++ b/generic/tclPkgConfig.c @@ -40,7 +40,7 @@ * configuration information. */ -#ifdef TCL_THREADS +#if TCL_THREADS # define CFG_THREADED "1" #else # define CFG_THREADED "0" @@ -105,6 +105,8 @@ static Tcl_Config const cfg[] = { {"scriptdir,runtime", CFG_RUNTIME_SCRDIR}, {"includedir,runtime", CFG_RUNTIME_INCDIR}, {"docdir,runtime", CFG_RUNTIME_DOCDIR}, + {"dllfile,runtime", CFG_RUNTIME_DLLFILE}, + {"zipfile,runtime", CFG_RUNTIME_ZIPFILE}, /* Installation paths to various stuff */ diff --git a/generic/tclPort.h b/generic/tclPort.h index 9485567..d3f6233 100644 --- a/generic/tclPort.h +++ b/generic/tclPort.h @@ -24,21 +24,6 @@ #endif #include "tcl.h" -#if !defined(LLONG_MIN) -# ifdef TCL_WIDE_INT_IS_LONG -# define LLONG_MIN LONG_MIN -# else -# ifdef LLONG_BIT -# define LLONG_MIN ((Tcl_WideInt)(Tcl_LongAsWide(1)<<(LLONG_BIT-1))) -# else -/* Assume we're on a system with a 64-bit 'long long' type */ -# define LLONG_MIN ((Tcl_WideInt)(Tcl_LongAsWide(1)<<63)) -# endif -# endif -/* Assume that if LLONG_MIN is undefined, then so is LLONG_MAX */ -# define LLONG_MAX (~LLONG_MIN) -#endif - #define UWIDE_MAX ((Tcl_WideUInt)-1) #define WIDE_MAX ((Tcl_WideInt)(UWIDE_MAX >> 1)) #define WIDE_MIN ((Tcl_WideInt)((Tcl_WideUInt)WIDE_MAX+1)) diff --git a/generic/tclPreserve.c b/generic/tclPreserve.c index cca13e8..5c6097f 100644 --- a/generic/tclPreserve.c +++ b/generic/tclPreserve.c @@ -22,7 +22,7 @@ typedef struct { ClientData clientData; /* Address of preserved block. */ - int refCount; /* Number of Tcl_Preserve calls in effect for + size_t refCount; /* Number of Tcl_Preserve calls in effect for * block. */ int mustFree; /* Non-zero means Tcl_EventuallyFree was * called while a Tcl_Preserve call was in @@ -63,7 +63,7 @@ typedef struct HandleStruct { * ensure that the contents of the handle are * not changed by anyone else. */ #endif - int refCount; /* Number of TclHandlePreserve() calls in + size_t refCount; /* Number of TclHandlePreserve() calls in * effect on this handle. */ } HandleStruct; @@ -155,7 +155,7 @@ Tcl_Preserve( refPtr->clientData = clientData; refPtr->refCount = 1; refPtr->mustFree = 0; - refPtr->freeProc = TCL_STATIC; + refPtr->freeProc = 0; inUse += 1; Tcl_MutexUnlock(&preserveMutex); } @@ -195,7 +195,7 @@ Tcl_Release( continue; } - if (--refPtr->refCount != 0) { + if (refPtr->refCount-- > 1) { Tcl_MutexUnlock(&preserveMutex); return; } @@ -459,7 +459,7 @@ TclHandleRelease( handlePtr, handlePtr->ptr2, handlePtr->ptr); } #endif - if ((--handlePtr->refCount == 0) && (handlePtr->ptr == NULL)) { + if ((handlePtr->refCount-- <= 1) && (handlePtr->ptr == NULL)) { ckfree(handlePtr); } } diff --git a/generic/tclProc.c b/generic/tclProc.c index 03cb0f0..1ed48ac 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -15,6 +15,7 @@ #include "tclInt.h" #include "tclCompile.h" +#include <assert.h> /* * Variables that are part of the [apply] command implementation and which @@ -67,6 +68,22 @@ const Tcl_ObjType tclProcBodyType = { * should panic instead. */ }; +#define ProcSetIntRep(objPtr, procPtr) \ + do { \ + Tcl_ObjIntRep ir; \ + (procPtr)->refCount++; \ + ir.twoPtrValue.ptr1 = (procPtr); \ + ir.twoPtrValue.ptr2 = NULL; \ + Tcl_StoreIntRep((objPtr), &tclProcBodyType, &ir); \ + } while (0) + +#define ProcGetIntRep(objPtr, procPtr) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = TclFetchIntRep((objPtr), &tclProcBodyType); \ + (procPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + } while (0) + /* * The [upvar]/[uplevel] level reference type. Uses the longValue field * to remember the integer value of a parsed #<integer> format. @@ -89,13 +106,31 @@ static const Tcl_ObjType levelReferenceType = { * will execute within. IF YOU CHANGE THIS, CHECK IN tclDisassemble.c TOO. */ -const Tcl_ObjType tclLambdaType = { +static const Tcl_ObjType lambdaType = { "lambdaExpr", /* name */ FreeLambdaInternalRep, /* freeIntRepProc */ DupLambdaInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ SetLambdaFromAny /* setFromAnyProc */ }; + +#define LambdaSetIntRep(objPtr, procPtr, nsObjPtr) \ + do { \ + Tcl_ObjIntRep ir; \ + ir.twoPtrValue.ptr1 = (procPtr); \ + ir.twoPtrValue.ptr2 = (nsObjPtr); \ + Tcl_IncrRefCount((nsObjPtr)); \ + Tcl_StoreIntRep((objPtr), &lambdaType, &ir); \ + } while (0) + +#define LambdaGetIntRep(objPtr, procPtr, nsObjPtr) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = TclFetchIntRep((objPtr), &lambdaType); \ + (procPtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + (nsObjPtr) = irPtr ? irPtr->twoPtrValue.ptr2 : NULL; \ + } while (0) + /* *---------------------------------------------------------------------- @@ -122,7 +157,7 @@ Tcl_ProcObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - register Interp *iPtr = (Interp *) interp; + Interp *iPtr = (Interp *) interp; Proc *procPtr; const char *procName; const char *simpleName, *procArgs, *procBody; @@ -294,7 +329,7 @@ Tcl_ProcObjCmd( * of all procs whose argument list is just _args_ */ - if (objv[3]->typePtr == &tclProcBodyType) { + if (TclHasIntRep(objv[3], &tclProcBodyType)) { goto done; } @@ -319,7 +354,7 @@ Tcl_ProcObjCmd( * The argument list is just "args"; check the body */ - procBody = Tcl_GetStringFromObj(objv[3], &numBytes); + procBody = TclGetStringFromObj(objv[3], &numBytes); if (TclParseAllWhiteSpace(procBody, numBytes) < numBytes) { goto done; } @@ -370,13 +405,14 @@ TclCreateProc( { Interp *iPtr = (Interp *) interp; - register Proc *procPtr; + Proc *procPtr = NULL; int i, result, numArgs; - register CompiledLocal *localPtr = NULL; + CompiledLocal *localPtr = NULL; Tcl_Obj **argArray; int precompiled = 0; - if (bodyPtr->typePtr == &tclProcBodyType) { + ProcGetIntRep(bodyPtr, procPtr); + if (procPtr != NULL) { /* * Because the body is a TclProProcBody, the actual body is already * compiled, and it is not shared with anyone else, so it's OK not to @@ -389,7 +425,6 @@ TclCreateProc( * will be holding a reference to it. */ - procPtr = bodyPtr->internalRep.twoPtrValue.ptr1; procPtr->iPtr = iPtr; procPtr->refCount++; precompiled = 1; @@ -566,11 +601,10 @@ TclCreateProc( */ if (localPtr->defValuePtr != NULL) { - int tmpLength, valueLength; - const char *tmpPtr = TclGetStringFromObj(localPtr->defValuePtr, - &tmpLength); - const char *value = TclGetStringFromObj(fieldValues[1], - &valueLength); + const char *tmpPtr = TclGetString(localPtr->defValuePtr); + size_t tmpLength = localPtr->defValuePtr->length; + const char *value = TclGetString(fieldValues[1]); + size_t valueLength = fieldValues[1]->length; if ((valueLength != tmpLength) || memcmp(value, tmpPtr, tmpLength) != 0 @@ -600,7 +634,7 @@ TclCreateProc( * local variables for the argument. */ - localPtr = ckalloc(TclOffset(CompiledLocal, name) + fieldValues[0]->length +1); + localPtr = ckalloc(offsetof(CompiledLocal, name) + fieldValues[0]->length +1); if (procPtr->firstLocalPtr == NULL) { procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; } else { @@ -684,51 +718,15 @@ TclGetFrame( CallFrame **framePtrPtr) /* Store pointer to frame here (or NULL if * global frame indicated). */ { - register Interp *iPtr = (Interp *) interp; - int curLevel, level, result; - CallFrame *framePtr; - - /* - * Parse string to figure out which level number to go to. - */ - - result = 1; - curLevel = iPtr->varFramePtr->level; - if (*name== '#') { - if (Tcl_GetInt(interp, name+1, &level) != TCL_OK || level < 0) { - goto levelError; - } - } else if (isdigit(UCHAR(*name))) { /* INTL: digit */ - if (Tcl_GetInt(interp, name, &level) != TCL_OK) { - goto levelError; - } - level = curLevel - level; - } else { - level = curLevel - 1; - result = 0; - } - - /* - * Figure out which frame to use, and return it to the caller. - */ - - for (framePtr = iPtr->varFramePtr; framePtr != NULL; - framePtr = framePtr->callerVarPtr) { - if (framePtr->level == level) { - break; - } - } - if (framePtr == NULL) { - goto levelError; - } - - *framePtrPtr = framePtr; - return result; - - levelError: - Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL); - return -1; + int result; + Tcl_Obj obj; + + obj.bytes = (char *) name; + obj.length = strlen(name); + obj.typePtr = NULL; + result = TclObjGetFrame(interp, &obj, framePtrPtr); + TclFreeIntRep(&obj); + return result; } /* @@ -763,9 +761,11 @@ TclObjGetFrame( CallFrame **framePtrPtr) /* Store pointer to frame here (or NULL if * global frame indicated). */ { - register Interp *iPtr = (Interp *) interp; + Interp *iPtr = (Interp *) interp; int curLevel, level, result; + const Tcl_ObjIntRep *irPtr; const char *name = NULL; + Tcl_WideInt w; /* * Parse object to figure out which level number to go to. @@ -781,25 +781,34 @@ TclObjGetFrame( if (objPtr == NULL) { /* Do nothing */ - } else if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &level) - && (level >= 0)) { - level = curLevel - level; - result = 1; - } else if (objPtr->typePtr == &levelReferenceType) { - level = (int) objPtr->internalRep.longValue; + } else if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &level)) { + Tcl_GetWideIntFromObj(NULL, objPtr, &w); + if (w < 0 || w > INT_MAX || curLevel > w + INT_MAX) { + result = -1; + } else { + level = curLevel - level; + result = 1; + } + } else if ((irPtr = TclFetchIntRep(objPtr, &levelReferenceType))) { + level = irPtr->wideValue; result = 1; } else { name = TclGetString(objPtr); if (name[0] == '#') { - if (TCL_OK == Tcl_GetInt(NULL, name+1, &level) && level >= 0) { - TclFreeIntRep(objPtr); - objPtr->typePtr = &levelReferenceType; - objPtr->internalRep.longValue = level; - result = 1; + if (TCL_OK == Tcl_GetInt(NULL, name+1, &level)) { + if (level < 0 || (level > 0 && name[1] == '-')) { + result = -1; + } else { + Tcl_ObjIntRep ir; + + ir.wideValue = level; + Tcl_StoreIntRep(objPtr, &levelReferenceType, &ir); + result = 1; + } } else { result = -1; } - } else if (isdigit(UCHAR(name[0]))) { /* INTL: digit */ + } else if (TclGetWideBitsFromObj(interp, objPtr, &w) == TCL_OK) { /* * If this were an integer, we'd have succeeded already. * Docs say we have to treat this as a 'bad level' error. @@ -810,7 +819,6 @@ TclObjGetFrame( if (result == 0) { level = curLevel - 1; - name = "1"; } if (result != -1) { if (level >= 0) { @@ -823,11 +831,11 @@ TclObjGetFrame( } } } - if (name == NULL) { - name = TclGetString(objPtr); - } } + if (name == NULL) { + name = TclGetString(objPtr); + } Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", name, NULL); return -1; @@ -890,7 +898,7 @@ TclNRUplevelObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { - register Interp *iPtr = (Interp *) interp; + Interp *iPtr = (Interp *) interp; CmdFrame *invoker = NULL; int word = 0; int result; @@ -1030,7 +1038,7 @@ ProcWrongNumArgs( int skip) { CallFrame *framePtr = ((Interp *)interp)->varFramePtr; - register Proc *procPtr = framePtr->procPtr; + Proc *procPtr = framePtr->procPtr; int localCt = procPtr->numCompiledLocals, numArgs, i; Tcl_Obj **desiredObjs; const char *final = NULL; @@ -1055,7 +1063,7 @@ ProcWrongNumArgs( Tcl_IncrRefCount(desiredObjs[0]); if (localCt > 0) { - register Var *defPtr = (Var *) (&framePtr->localCachePtr->varName0 + localCt); + Var *defPtr = (Var *) (&framePtr->localCachePtr->varName0 + localCt); for (i=1 ; i<=numArgs ; i++, defPtr++) { Tcl_Obj *argObj; @@ -1118,10 +1126,10 @@ TclInitCompiledLocals( ByteCode *codePtr; bodyPtr = framePtr->procPtr->bodyPtr; - if (bodyPtr->typePtr != &tclByteCodeType) { + ByteCodeGetIntRep(bodyPtr, &tclByteCodeType, codePtr); + if (codePtr == NULL) { Tcl_Panic("body object for proc attached to frame is not a byte code type"); } - codePtr = bodyPtr->internalRep.twoPtrValue.ptr1; if (framePtr->numCompiledLocals) { if (!codePtr->localCachePtr) { @@ -1246,7 +1254,7 @@ InitResolvedLocals( resVarInfo = localPtr->resolveInfo; if (resVarInfo && resVarInfo->fetchProc) { - register Var *resolvedVarPtr = (Var *) + Var *resolvedVarPtr = (Var *) resVarInfo->fetchProc(interp, resVarInfo); if (resolvedVarPtr) { @@ -1269,7 +1277,7 @@ TclFreeLocalCache( Tcl_Obj **namePtrPtr = &localCachePtr->varName0; for (i = 0; i < localCachePtr->numVars; i++, namePtrPtr++) { - register Tcl_Obj *objPtr = *namePtrPtr; + Tcl_Obj *objPtr = *namePtrPtr; if (objPtr) { /* TclReleaseLiteral calls Tcl_DecrRefCount for us */ @@ -1284,7 +1292,7 @@ InitLocalCache( Proc *procPtr) { Interp *iPtr = procPtr->iPtr; - ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; + ByteCode *codePtr; int localCt = procPtr->numCompiledLocals; int numArgs = procPtr->numArgs, i = 0; @@ -1292,7 +1300,9 @@ InitLocalCache( Var *varPtr; LocalCache *localCachePtr; CompiledLocal *localPtr; - int new; + int isNew; + + ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr); /* * Cache the names and initial values of local variables; store the @@ -1313,7 +1323,7 @@ InitLocalCache( } else { *namePtr = TclCreateLiteral(iPtr, localPtr->name, localPtr->nameLength, /* hash */ (unsigned int) -1, - &new, /* nsPtr */ NULL, 0, NULL); + &isNew, /* nsPtr */ NULL, 0, NULL); Tcl_IncrRefCount(*namePtr); } @@ -1353,19 +1363,21 @@ InitLocalCache( static int InitArgsAndLocals( - register Tcl_Interp *interp,/* Interpreter in which procedure was + Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ Tcl_Obj *procNameObj, /* Procedure name for error reporting. */ int skip) /* Number of initial arguments to be skipped, * i.e., words in the "command name". */ { CallFrame *framePtr = ((Interp *)interp)->varFramePtr; - register Proc *procPtr = framePtr->procPtr; - ByteCode *codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; - register Var *varPtr, *defPtr; + Proc *procPtr = framePtr->procPtr; + ByteCode *codePtr; + Var *varPtr, *defPtr; int localCt = procPtr->numCompiledLocals, numArgs, argCt, i, imax; Tcl_Obj *const *argObjs; + ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr); + /* * Make sure that the local cache of variable names and initial values has * been initialised properly . @@ -1518,7 +1530,7 @@ int TclPushProcCallFrame( ClientData clientData, /* Record describing procedure to be * interpreted. */ - register Tcl_Interp *interp,/* Interpreter in which procedure was + Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ int objc, /* Count of number of arguments to this * procedure. */ @@ -1540,7 +1552,8 @@ TclPushProcCallFrame( * local variables are found while compiling. */ - if (procPtr->bodyPtr->typePtr == &tclByteCodeType) { + ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr); + if (codePtr != NULL) { Interp *iPtr = (Interp *) interp; /* @@ -1552,7 +1565,6 @@ TclPushProcCallFrame( * commands and/or resolver changes are considered). */ - codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; if (((Interp *) *codePtr->interpHandle != iPtr) || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != nsPtr) @@ -1610,7 +1622,7 @@ int TclObjInterpProc( ClientData clientData, /* Record describing procedure to be * interpreted. */ - register Tcl_Interp *interp,/* Interpreter in which procedure was + Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ int objc, /* Count of number of arguments to this * procedure. */ @@ -1627,7 +1639,7 @@ int TclNRInterpProc( ClientData clientData, /* Record describing procedure to be * interpreted. */ - register Tcl_Interp *interp,/* Interpreter in which procedure was + Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ int objc, /* Count of number of arguments to this * procedure. */ @@ -1662,7 +1674,7 @@ TclNRInterpProc( int TclNRInterpProcCore( - register Tcl_Interp *interp,/* Interpreter in which procedure was + Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ Tcl_Obj *procNameObj, /* Procedure name for error reporting. */ int skip, /* Number of initial arguments to be skipped, @@ -1671,7 +1683,7 @@ TclNRInterpProcCore( * results of the overall procedure. */ { Interp *iPtr = (Interp *) interp; - register Proc *procPtr = iPtr->varFramePtr->procPtr; + Proc *procPtr = iPtr->varFramePtr->procPtr; int result; CallFrame *freePtr; ByteCode *codePtr; @@ -1688,8 +1700,8 @@ TclNRInterpProcCore( #if defined(TCL_COMPILE_DEBUG) if (tclTraceExec >= 1) { - register CallFrame *framePtr = iPtr->varFramePtr; - register int i; + CallFrame *framePtr = iPtr->varFramePtr; + int i; if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) { fprintf(stdout, "Calling lambda "); @@ -1750,7 +1762,7 @@ TclNRInterpProcCore( */ procPtr->refCount++; - codePtr = procPtr->bodyPtr->internalRep.twoPtrValue.ptr1; + ByteCodeGetIntRep(procPtr->bodyPtr, &tclByteCodeType, codePtr); TclNRAddCallback(interp, InterpProcNR2, procNameObj, errorProc, NULL, NULL); @@ -1884,7 +1896,9 @@ TclProcCompileProc( { Interp *iPtr = (Interp *) interp; Tcl_CallFrame *framePtr; - ByteCode *codePtr = bodyPtr->internalRep.twoPtrValue.ptr1; + ByteCode *codePtr; + + ByteCodeGetIntRep(bodyPtr, &tclByteCodeType, codePtr); /* * If necessary, compile the procedure's body. The compiler will allocate @@ -1900,7 +1914,7 @@ TclProcCompileProc( * are not recompiled, even if things have changed. */ - if (bodyPtr->typePtr == &tclByteCodeType) { + if (codePtr != NULL) { if (((Interp *) *codePtr->interpHandle == iPtr) && (codePtr->compileEpoch == iPtr->compileEpoch) && (codePtr->nsPtr == nsPtr) @@ -1919,11 +1933,12 @@ TclProcCompileProc( codePtr->compileEpoch = iPtr->compileEpoch; codePtr->nsPtr = nsPtr; } else { - TclFreeIntRep(bodyPtr); + Tcl_StoreIntRep(bodyPtr, &tclByteCodeType, NULL); + codePtr = NULL; } } - if (bodyPtr->typePtr != &tclByteCodeType) { + if (codePtr == NULL) { Tcl_HashEntry *hePtr; #ifdef TCL_COMPILE_DEBUG @@ -2045,7 +2060,7 @@ MakeProcError( * messages and trace information. */ { int overflow, limit = 60, nameLen; - const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen); + const char *procName = TclGetStringFromObj(procNameObj, &nameLen); overflow = (nameLen > limit); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( @@ -2104,9 +2119,9 @@ TclProcDeleteProc( void TclProcCleanupProc( - register Proc *procPtr) /* Procedure to be deleted. */ + Proc *procPtr) /* Procedure to be deleted. */ { - register CompiledLocal *localPtr; + CompiledLocal *localPtr; Tcl_Obj *bodyPtr = procPtr->bodyPtr; Tcl_Obj *defPtr; Tcl_ResolvedVarInfo *resVarInfo; @@ -2272,10 +2287,7 @@ TclNewProcBodyObj( TclNewObj(objPtr); if (objPtr) { - objPtr->typePtr = &tclProcBodyType; - objPtr->internalRep.twoPtrValue.ptr1 = procPtr; - - procPtr->refCount++; + ProcSetIntRep(objPtr, procPtr); } return objPtr; @@ -2303,11 +2315,10 @@ ProcBodyDup( Tcl_Obj *srcPtr, /* Object to copy. */ Tcl_Obj *dupPtr) /* Target object for the duplication. */ { - Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1; + Proc *procPtr; + ProcGetIntRep(srcPtr, procPtr); - dupPtr->typePtr = &tclProcBodyType; - dupPtr->internalRep.twoPtrValue.ptr1 = procPtr; - procPtr->refCount++; + ProcSetIntRep(dupPtr, procPtr); } /* @@ -2333,7 +2344,9 @@ static void ProcBodyFree( Tcl_Obj *objPtr) /* The object to clean up. */ { - Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1; + Proc *procPtr; + + ProcGetIntRep(objPtr, procPtr); if (procPtr->refCount-- <= 1) { TclProcCleanupProc(procPtr); @@ -2357,38 +2370,40 @@ ProcBodyFree( static void DupLambdaInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ - register Tcl_Obj *copyPtr) /* Object with internal rep to set. */ + Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - Proc *procPtr = srcPtr->internalRep.twoPtrValue.ptr1; - Tcl_Obj *nsObjPtr = srcPtr->internalRep.twoPtrValue.ptr2; + Proc *procPtr; + Tcl_Obj *nsObjPtr; - copyPtr->internalRep.twoPtrValue.ptr1 = procPtr; - copyPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr; + LambdaGetIntRep(srcPtr, procPtr, nsObjPtr); + assert(procPtr != NULL); procPtr->refCount++; - Tcl_IncrRefCount(nsObjPtr); - copyPtr->typePtr = &tclLambdaType; + + LambdaSetIntRep(copyPtr, procPtr, nsObjPtr); } static void FreeLambdaInternalRep( - register Tcl_Obj *objPtr) /* CmdName object with internal representation + Tcl_Obj *objPtr) /* CmdName object with internal representation * to free. */ { - Proc *procPtr = objPtr->internalRep.twoPtrValue.ptr1; - Tcl_Obj *nsObjPtr = objPtr->internalRep.twoPtrValue.ptr2; + Proc *procPtr; + Tcl_Obj *nsObjPtr; + + LambdaGetIntRep(objPtr, procPtr, nsObjPtr); + assert(procPtr != NULL); - if (procPtr->refCount-- == 1) { + if (procPtr->refCount-- <= 1) { TclProcCleanupProc(procPtr); } TclDecrRefCount(nsObjPtr); - objPtr->typePtr = NULL; } static int SetLambdaFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - register Tcl_Obj *objPtr) /* The object to convert. */ + Tcl_Obj *objPtr) /* The object to convert. */ { Interp *iPtr = (Interp *) interp; const char *name; @@ -2403,7 +2418,7 @@ SetLambdaFromAny( /* * Convert objPtr to list type first; if it cannot be converted, or if its - * length is not 2, then it cannot be converted to tclLambdaType. + * length is not 2, then it cannot be converted to lambdaType. */ result = TclListObjGetElements(NULL, objPtr, &objc, &objv); @@ -2544,21 +2559,42 @@ SetLambdaFromAny( } } - Tcl_IncrRefCount(nsObjPtr); - /* * Free the list internalrep of objPtr - this will free argsPtr, but * bodyPtr retains a reference from the Proc structure. Then finish the - * conversion to tclLambdaType. + * conversion to lambdaType. */ - TclFreeIntRep(objPtr); - - objPtr->internalRep.twoPtrValue.ptr1 = procPtr; - objPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr; - objPtr->typePtr = &tclLambdaType; + LambdaSetIntRep(objPtr, procPtr, nsObjPtr); return TCL_OK; } + +Proc * +TclGetLambdaFromObj( + Tcl_Interp *interp, + Tcl_Obj *objPtr, + Tcl_Obj **nsObjPtrPtr) +{ + Proc *procPtr; + Tcl_Obj *nsObjPtr; + + LambdaGetIntRep(objPtr, procPtr, nsObjPtr); + + if (procPtr == NULL) { + if (SetLambdaFromAny(interp, objPtr) != TCL_OK) { + return NULL; + } + LambdaGetIntRep(objPtr, procPtr, nsObjPtr); + } + + assert(procPtr != NULL); + if (procPtr->iPtr != (Interp *)interp) { + return NULL; + } + + *nsObjPtrPtr = nsObjPtr; + return procPtr; +} /* *---------------------------------------------------------------------- @@ -2594,7 +2630,6 @@ TclNRApplyObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Interp *iPtr = (Interp *) interp; Proc *procPtr = NULL; Tcl_Obj *lambdaPtr, *nsObjPtr; int result; @@ -2612,48 +2647,17 @@ TclNRApplyObjCmd( */ lambdaPtr = objv[1]; - if (lambdaPtr->typePtr == &tclLambdaType) { - 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; + procPtr = TclGetLambdaFromObj(interp, lambdaPtr, &nsObjPtr); - 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) { - return result; - } - procPtr = lambdaPtr->internalRep.twoPtrValue.ptr1; + if (procPtr == NULL) { + return TCL_ERROR; } /* - * Find the namespace where this lambda should run, and push a call frame - * for that namespace. Note that TclObjInterpProc() will pop it. + * Push a call frame for the lambda namespace. + * Note that TclObjInterpProc() will pop it. */ - nsObjPtr = lambdaPtr->internalRep.twoPtrValue.ptr2; result = TclGetNamespaceFromObj(interp, nsObjPtr, &nsPtr); if (result != TCL_OK) { return TCL_ERROR; @@ -2726,7 +2730,7 @@ MakeLambdaError( * messages and trace information. */ { int overflow, limit = 60, nameLen; - const char *procName = Tcl_GetStringFromObj(procNameObj, &nameLen); + const char *procName = TclGetStringFromObj(procNameObj, &nameLen); overflow = (nameLen > limit); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( diff --git a/generic/tclProcess.c b/generic/tclProcess.c new file mode 100644 index 0000000..2f3f4ba --- /dev/null +++ b/generic/tclProcess.c @@ -0,0 +1,957 @@ +/* + * tclProcess.c -- + * + * This file implements the "tcl::process" ensemble for subprocess + * management as defined by TIP #462. + * + * Copyright (c) 2017 Frederic Bonnet. + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + */ + +#include "tclInt.h" + +/* + * Autopurge flag. Process-global because of the way Tcl manages child + * processes (see tclPipe.c). + */ + +static int autopurge = 1; /* Autopurge flag. */ + +/* + * Hash tables that keeps track of all child process statuses. Keys are the + * child process ids and resolved pids, values are (ProcessInfo *). + */ + +typedef struct ProcessInfo { + Tcl_Pid pid; /* Process id. */ + int resolvedPid; /* Resolved process id. */ + int purge; /* Purge eventualy. */ + TclProcessWaitStatus status;/* Process status. */ + int code; /* Error code, exit status or signal + number. */ + Tcl_Obj *msg; /* Error message. */ + Tcl_Obj *error; /* Error code. */ +} ProcessInfo; +static Tcl_HashTable infoTablePerPid; +static Tcl_HashTable infoTablePerResolvedPid; +static int infoTablesInitialized = 0; /* 0 means not yet initialized. */ +TCL_DECLARE_MUTEX(infoTablesMutex) + + /* + * Prototypes for functions defined later in this file: + */ + +static void InitProcessInfo(ProcessInfo *info, Tcl_Pid pid, + int resolvedPid); +static void FreeProcessInfo(ProcessInfo *info); +static int RefreshProcessInfo(ProcessInfo *info, int options); +static TclProcessWaitStatus WaitProcessStatus(Tcl_Pid pid, int resolvedPid, + int options, int *codePtr, Tcl_Obj **msgPtr, + Tcl_Obj **errorObjPtr); +static Tcl_Obj * BuildProcessStatusObj(ProcessInfo *info); +static int ProcessListObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int ProcessStatusObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int ProcessPurgeObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int ProcessAutopurgeObjCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); + +/* + *---------------------------------------------------------------------- + * + * InitProcessInfo -- + * + * Initializes the ProcessInfo structure. + * + * Results: + * None. + * + * Side effects: + * Memory written. + * + *---------------------------------------------------------------------- + */ + +void +InitProcessInfo( + ProcessInfo *info, /* Structure to initialize. */ + Tcl_Pid pid, /* Process id. */ + int resolvedPid) /* Resolved process id. */ +{ + info->pid = pid; + info->resolvedPid = resolvedPid; + info->purge = 0; + info->status = TCL_PROCESS_UNCHANGED; + info->code = 0; + info->msg = NULL; + info->error = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * FreeProcessInfo -- + * + * Free the ProcessInfo structure. + * + * Results: + * None. + * + * Side effects: + * Memory deallocated, Tcl_Obj refcount decreased. + * + *---------------------------------------------------------------------- + */ + +void +FreeProcessInfo( + ProcessInfo *info) /* Structure to free. */ +{ + /* + * Free stored Tcl_Objs. + */ + + if (info->msg) { + Tcl_DecrRefCount(info->msg); + } + if (info->error) { + Tcl_DecrRefCount(info->error); + } + + /* + * Free allocated structure. + */ + + ckfree(info); +} + +/* + *---------------------------------------------------------------------- + * + * RefreshProcessInfo -- + * + * Refresh process info. + * + * Results: + * Nonzero if state changed, else zero. + * + * Side effects: + * May call WaitProcessStatus, which can block if WNOHANG option is set. + * + *---------------------------------------------------------------------- + */ + +int +RefreshProcessInfo( + ProcessInfo *info, /* Structure to refresh. */ + int options /* Options passed to WaitProcessStatus. */ +) +{ + if (info->status == TCL_PROCESS_UNCHANGED) { + /* + * Refresh & store status. + */ + + info->status = WaitProcessStatus(info->pid, info->resolvedPid, + options, &info->code, &info->msg, &info->error); + if (info->msg) Tcl_IncrRefCount(info->msg); + if (info->error) Tcl_IncrRefCount(info->error); + return (info->status != TCL_PROCESS_UNCHANGED); + } else { + /* + * No change. + */ + + return 0; + } +} + +/* + *---------------------------------------------------------------------- + * + * WaitProcessStatus -- + * + * Wait for process status to change. + * + * Results: + * TclProcessWaitStatus enum value. + * + * Side effects: + * May call WaitProcessStatus, which can block if WNOHANG option is set. + * + *---------------------------------------------------------------------- + */ + +TclProcessWaitStatus +WaitProcessStatus( + Tcl_Pid pid, /* Process id. */ + int resolvedPid, /* Resolved process id. */ + int options, /* Options passed to Tcl_WaitPid. */ + int *codePtr, /* If non-NULL, will receive either: + * - 0 for normal exit. + * - errno in case of error. + * - non-zero exit code for abormal exit. + * - signal number if killed or suspended. + * - Tcl_WaitPid status in all other cases. + */ + Tcl_Obj **msgObjPtr, /* If non-NULL, will receive error message. */ + Tcl_Obj **errorObjPtr) /* If non-NULL, will receive error code. */ +{ + int waitStatus; + Tcl_Obj *errorStrings[5]; + const char *msg; + + pid = Tcl_WaitPid(pid, &waitStatus, options); + if (pid == 0) { + /* + * No change. + */ + + return TCL_PROCESS_UNCHANGED; + } + + /* + * Get process status. + */ + + if (pid == (Tcl_Pid) -1) { + /* + * POSIX errName msg + */ + + msg = Tcl_ErrnoMsg(errno); + if (errno == ECHILD) { + /* + * This changeup in message suggested by Mark Diekhans to + * remind people that ECHILD errors can occur on some + * systems if SIGCHLD isn't in its default state. + */ + + msg = "child process lost (is SIGCHLD ignored or trapped?)"; + } + if (codePtr) *codePtr = errno; + if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf( + "error waiting for process to exit: %s", msg); + if (errorObjPtr) { + errorStrings[0] = Tcl_NewStringObj("POSIX", -1); + errorStrings[1] = Tcl_NewStringObj(Tcl_ErrnoId(), -1); + errorStrings[2] = Tcl_NewStringObj(msg, -1); + *errorObjPtr = Tcl_NewListObj(3, errorStrings); + } + return TCL_PROCESS_ERROR; + } else if (WIFEXITED(waitStatus)) { + if (codePtr) *codePtr = WEXITSTATUS(waitStatus); + if (!WEXITSTATUS(waitStatus)) { + /* + * Normal exit. + */ + + if (msgObjPtr) *msgObjPtr = NULL; + if (errorObjPtr) *errorObjPtr = NULL; + } else { + /* + * CHILDSTATUS pid code + * + * Child exited with a non-zero exit status. + */ + + if (msgObjPtr) *msgObjPtr = Tcl_NewStringObj( + "child process exited abnormally", -1); + if (errorObjPtr) { + errorStrings[0] = Tcl_NewStringObj("CHILDSTATUS", -1); + errorStrings[1] = Tcl_NewIntObj(resolvedPid); + errorStrings[2] = Tcl_NewIntObj(WEXITSTATUS(waitStatus)); + *errorObjPtr = Tcl_NewListObj(3, errorStrings); + } + } + return TCL_PROCESS_EXITED; + } else if (WIFSIGNALED(waitStatus)) { + /* + * CHILDKILLED pid sigName msg + * + * Child killed because of a signal. + */ + + msg = Tcl_SignalMsg(WTERMSIG(waitStatus)); + if (codePtr) *codePtr = WTERMSIG(waitStatus); + if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf( + "child killed: %s", msg); + if (errorObjPtr) { + errorStrings[0] = Tcl_NewStringObj("CHILDKILLED", -1); + errorStrings[1] = Tcl_NewIntObj(resolvedPid); + errorStrings[2] = Tcl_NewStringObj(Tcl_SignalId(WTERMSIG(waitStatus)), -1); + errorStrings[3] = Tcl_NewStringObj(msg, -1); + *errorObjPtr = Tcl_NewListObj(4, errorStrings); + } + return TCL_PROCESS_SIGNALED; + } else if (WIFSTOPPED(waitStatus)) { + /* + * CHILDSUSP pid sigName msg + * + * Child suspended because of a signal. + */ + + msg = Tcl_SignalMsg(WSTOPSIG(waitStatus)); + if (codePtr) *codePtr = WSTOPSIG(waitStatus); + if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf( + "child suspended: %s", msg); + if (errorObjPtr) { + errorStrings[0] = Tcl_NewStringObj("CHILDSUSP", -1); + errorStrings[1] = Tcl_NewIntObj(resolvedPid); + errorStrings[2] = Tcl_NewStringObj(Tcl_SignalId(WSTOPSIG(waitStatus)), -1); + errorStrings[3] = Tcl_NewStringObj(msg, -1); + *errorObjPtr = Tcl_NewListObj(4, errorStrings); + } + return TCL_PROCESS_STOPPED; + } else { + /* + * TCL OPERATION EXEC ODDWAITRESULT + * + * Child wait status didn't make sense. + */ + + if (codePtr) *codePtr = waitStatus; + if (msgObjPtr) *msgObjPtr = Tcl_NewStringObj( + "child wait status didn't make sense\n", -1); + if (errorObjPtr) { + errorStrings[0] = Tcl_NewStringObj("TCL", -1); + errorStrings[1] = Tcl_NewStringObj("OPERATION", -1); + errorStrings[2] = Tcl_NewStringObj("EXEC", -1); + errorStrings[3] = Tcl_NewStringObj("ODDWAITRESULT", -1); + errorStrings[4] = Tcl_NewIntObj(resolvedPid); + *errorObjPtr = Tcl_NewListObj(5, errorStrings); + } + return TCL_PROCESS_UNKNOWN_STATUS; + } +} + + +/* + *---------------------------------------------------------------------- + * + * BuildProcessStatusObj -- + * + * Build a list object with process status. The first element is always + * a standard Tcl return value, which can be either TCL_OK or TCL_ERROR. + * In the latter case, the second element is the error message and the + * third element is a Tcl error code (see tclvars). + * + * Results: + * A list object. + * + * Side effects: + * Tcl_Objs are created. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +BuildProcessStatusObj( + ProcessInfo *info) +{ + Tcl_Obj *resultObjs[3]; + + if (info->status == TCL_PROCESS_UNCHANGED) { + /* + * Process still running, return empty obj. + */ + + return Tcl_NewObj(); + } + if (info->status == TCL_PROCESS_EXITED && info->code == 0) { + /* + * Normal exit, return TCL_OK. + */ + + return Tcl_NewIntObj(TCL_OK); + } + + /* + * Abnormal exit, return {TCL_ERROR msg error} + */ + + resultObjs[0] = Tcl_NewIntObj(TCL_ERROR); + resultObjs[1] = info->msg; + resultObjs[2] = info->error; + return Tcl_NewListObj(3, resultObjs); +} + +/*---------------------------------------------------------------------- + * + * ProcessListObjCmd -- + * + * This function implements the 'tcl::process list' Tcl command. + * Refer to the user documentation for details on what it does. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * Access to the internal structures is protected by infoTablesMutex. + * + *---------------------------------------------------------------------- + */ + +static int +ProcessListObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Obj *list; + Tcl_HashEntry *entry; + Tcl_HashSearch search; + ProcessInfo *info; + + if (objc != 1) { + Tcl_WrongNumArgs(interp, 1, objv, NULL); + return TCL_ERROR; + } + + /* + * Return the list of all chid process ids. + */ + + list = Tcl_NewListObj(0, NULL); + Tcl_MutexLock(&infoTablesMutex); + for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); + entry != NULL; entry = Tcl_NextHashEntry(&search)) { + info = (ProcessInfo *) Tcl_GetHashValue(entry); + Tcl_ListObjAppendElement(interp, list, + Tcl_NewIntObj(info->resolvedPid)); + } + Tcl_MutexUnlock(&infoTablesMutex); + Tcl_SetObjResult(interp, list); + return TCL_OK; +} + +/*---------------------------------------------------------------------- + * + * ProcessStatusObjCmd -- + * + * This function implements the 'tcl::process status' Tcl command. + * Refer to the user documentation for details on what it does. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * Access to the internal structures is protected by infoTablesMutex. + * Calls RefreshProcessInfo, which can block if -wait switch is given. + * + *---------------------------------------------------------------------- + */ + +static int +ProcessStatusObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Obj *dict; + int index, options = WNOHANG; + Tcl_HashEntry *entry; + Tcl_HashSearch search; + ProcessInfo *info; + int numPids; + Tcl_Obj **pidObjs; + int result; + int i; + int pid; + Tcl_Obj *const *savedobjv = objv; + static const char *const switches[] = { + "-wait", "--", NULL + }; + enum switches { + STATUS_WAIT, STATUS_LAST + }; + + while (objc > 1) { + if (TclGetString(objv[1])[0] != '-') { + break; + } + if (Tcl_GetIndexFromObj(interp, objv[1], switches, "switches", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + ++objv; --objc; + if (STATUS_WAIT == (enum switches) index) { + options = 0; + } else { + break; + } + } + + if (objc != 1 && objc != 2) { + Tcl_WrongNumArgs(interp, 1, savedobjv, "?switches? ?pids?"); + return TCL_ERROR; + } + + if (objc == 1) { + /* + * Return a dict with all child process statuses. + */ + + dict = Tcl_NewDictObj(); + Tcl_MutexLock(&infoTablesMutex); + for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); + entry != NULL; entry = Tcl_NextHashEntry(&search)) { + info = (ProcessInfo *) Tcl_GetHashValue(entry); + RefreshProcessInfo(info, options); + + if (info->purge && autopurge) { + /* + * Purge entry. + */ + + Tcl_DeleteHashEntry(entry); + entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); + Tcl_DeleteHashEntry(entry); + FreeProcessInfo(info); + } else { + /* + * Add to result. + */ + + Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid), + BuildProcessStatusObj(info)); + } + } + Tcl_MutexUnlock(&infoTablesMutex); + } else { + /* + * Only return statuses of provided processes. + */ + + result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs); + if (result != TCL_OK) { + return result; + } + dict = Tcl_NewDictObj(); + Tcl_MutexLock(&infoTablesMutex); + for (i = 0; i < numPids; i++) { + result = Tcl_GetIntFromObj(interp, pidObjs[i], &pid); + if (result != TCL_OK) { + Tcl_MutexUnlock(&infoTablesMutex); + Tcl_DecrRefCount(dict); + return result; + } + + entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(pid)); + if (!entry) { + /* + * Skip unknown process. + */ + + continue; + } + + info = (ProcessInfo *) Tcl_GetHashValue(entry); + RefreshProcessInfo(info, options); + + if (info->purge && autopurge) { + /* + * Purge entry. + */ + + Tcl_DeleteHashEntry(entry); + entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); + Tcl_DeleteHashEntry(entry); + FreeProcessInfo(info); + } else { + /* + * Add to result. + */ + + Tcl_DictObjPut(interp, dict, Tcl_NewIntObj(info->resolvedPid), + BuildProcessStatusObj(info)); + } + } + Tcl_MutexUnlock(&infoTablesMutex); + } + Tcl_SetObjResult(interp, dict); + return TCL_OK; +} + +/*---------------------------------------------------------------------- + * + * ProcessPurgeObjCmd -- + * + * This function implements the 'tcl::process purge' Tcl command. + * Refer to the user documentation for details on what it does. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * Frees all ProcessInfo structures with their purge flag set. + * + *---------------------------------------------------------------------- + */ + +static int +ProcessPurgeObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_HashEntry *entry; + Tcl_HashSearch search; + ProcessInfo *info; + int numPids; + Tcl_Obj **pidObjs; + int result; + int i; + int pid; + + if (objc != 1 && objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?pids?"); + return TCL_ERROR; + } + + /* + * First reap detached procs so that their purge flag is up-to-date. + */ + + Tcl_ReapDetachedProcs(); + + if (objc == 1) { + /* + * Purge all terminated processes. + */ + + Tcl_MutexLock(&infoTablesMutex); + for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); + entry != NULL; entry = Tcl_NextHashEntry(&search)) { + info = (ProcessInfo *) Tcl_GetHashValue(entry); + if (info->purge) { + Tcl_DeleteHashEntry(entry); + entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); + Tcl_DeleteHashEntry(entry); + FreeProcessInfo(info); + } + } + Tcl_MutexUnlock(&infoTablesMutex); + } else { + /* + * Purge only provided processes. + */ + + result = Tcl_ListObjGetElements(interp, objv[1], &numPids, &pidObjs); + if (result != TCL_OK) { + return result; + } + Tcl_MutexLock(&infoTablesMutex); + for (i = 0; i < numPids; i++) { + result = Tcl_GetIntFromObj(interp, pidObjs[i], &pid); + if (result != TCL_OK) { + Tcl_MutexUnlock(&infoTablesMutex); + return result; + } + + entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(pid)); + if (!entry) { + /* + * Skip unknown process. + */ + + continue; + } + + info = (ProcessInfo *) Tcl_GetHashValue(entry); + if (info->purge) { + Tcl_DeleteHashEntry(entry); + entry = Tcl_FindHashEntry(&infoTablePerPid, info->pid); + Tcl_DeleteHashEntry(entry); + FreeProcessInfo(info); + } + } + Tcl_MutexUnlock(&infoTablesMutex); + } + + return TCL_OK; +} + +/*---------------------------------------------------------------------- + * + * ProcessAutopurgeObjCmd -- + * + * This function implements the 'tcl::process autopurge' Tcl command. + * Refer to the user documentation for details on what it does. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * Alters detached process handling by Tcl_ReapDetachedProcs(). + * + *---------------------------------------------------------------------- + */ + +static int +ProcessAutopurgeObjCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + if (objc != 1 && objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "?flag?"); + return TCL_ERROR; + } + + if (objc == 2) { + /* + * Set given value. + */ + + int flag; + int result = Tcl_GetBooleanFromObj(interp, objv[1], &flag); + if (result != TCL_OK) { + return result; + } + + autopurge = !!flag; + } + + /* + * Return current value. + */ + + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(autopurge)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclInitProcessCmd -- + * + * This procedure creates the "tcl::process" Tcl command. See the user + * documentation for details on what it does. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +Tcl_Command +TclInitProcessCmd( + Tcl_Interp *interp) /* Current interpreter. */ +{ + static const EnsembleImplMap processImplMap[] = { + {"list", ProcessListObjCmd, TclCompileBasic0ArgCmd, NULL, NULL, 1}, + {"status", ProcessStatusObjCmd, TclCompileBasicMin0ArgCmd, NULL, NULL, 1}, + {"purge", ProcessPurgeObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, + {"autopurge", ProcessAutopurgeObjCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 1}, + {NULL, NULL, NULL, NULL, NULL, 0} + }; + Tcl_Command processCmd; + + if (infoTablesInitialized == 0) { + Tcl_MutexLock(&infoTablesMutex); + if (infoTablesInitialized == 0) { + Tcl_InitHashTable(&infoTablePerPid, TCL_ONE_WORD_KEYS); + Tcl_InitHashTable(&infoTablePerResolvedPid, TCL_ONE_WORD_KEYS); + infoTablesInitialized = 1; + } + Tcl_MutexUnlock(&infoTablesMutex); + } + + processCmd = TclMakeEnsemble(interp, "::tcl::process", processImplMap); + Tcl_Export(interp, Tcl_FindNamespace(interp, "::tcl", NULL, 0), + "process", 0); + return processCmd; +} + +/* + *---------------------------------------------------------------------- + * + * TclProcessCreated -- + * + * Called when a child process has been created by Tcl. + * + * Results: + * None. + * + * Side effects: + * Internal structures are updated with a new ProcessInfo. + * + *---------------------------------------------------------------------- + */ + +void +TclProcessCreated( + Tcl_Pid pid) /* Process id. */ +{ + int resolvedPid; + Tcl_HashEntry *entry, *entry2; + int isNew; + ProcessInfo *info; + + /* + * Get resolved pid first. + */ + + resolvedPid = TclpGetPid(pid); + + Tcl_MutexLock(&infoTablesMutex); + + /* + * Create entry in pid table. + */ + + entry = Tcl_CreateHashEntry(&infoTablePerPid, pid, &isNew); + if (!isNew) { + /* + * Pid was reused, free old info and reuse structure. + */ + + info = (ProcessInfo *) Tcl_GetHashValue(entry); + entry2 = Tcl_FindHashEntry(&infoTablePerResolvedPid, + INT2PTR(resolvedPid)); + if (entry2) Tcl_DeleteHashEntry(entry2); + FreeProcessInfo(info); + } + + /* + * Allocate and initialize info structure. + */ + + info = (ProcessInfo *) ckalloc(sizeof(ProcessInfo)); + InitProcessInfo(info, pid, resolvedPid); + + /* + * Add entry to tables. + */ + + Tcl_SetHashValue(entry, info); + entry = Tcl_CreateHashEntry(&infoTablePerResolvedPid, INT2PTR(resolvedPid), + &isNew); + Tcl_SetHashValue(entry, info); + + Tcl_MutexUnlock(&infoTablesMutex); +} + +/* + *---------------------------------------------------------------------- + * + * TclProcessWait -- + * + * Wait for process status to change. + * + * Results: + * TclProcessWaitStatus enum value. + * + * Side effects: + * Completed process info structures are purged immediately (autopurge on) + * or eventually (autopurge off). + * + *---------------------------------------------------------------------- + */ + +TclProcessWaitStatus +TclProcessWait( + Tcl_Pid pid, /* Process id. */ + int options, /* Options passed to WaitProcessStatus. */ + int *codePtr, /* If non-NULL, will receive either: + * - 0 for normal exit. + * - errno in case of error. + * - non-zero exit code for abormal exit. + * - signal number if killed or suspended. + * - Tcl_WaitPid status in all other cases. + */ + Tcl_Obj **msgObjPtr, /* If non-NULL, will receive error message. */ + Tcl_Obj **errorObjPtr) /* If non-NULL, will receive error code. */ +{ + Tcl_HashEntry *entry; + ProcessInfo *info; + TclProcessWaitStatus result; + + /* + * First search for pid in table. + */ + + Tcl_MutexLock(&infoTablesMutex); + entry = Tcl_FindHashEntry(&infoTablePerPid, pid); + if (!entry) { + /* + * Unknown process, just call WaitProcessStatus and return. + */ + + result = WaitProcessStatus(pid, TclpGetPid(pid), options, codePtr, + msgObjPtr, errorObjPtr); + if (msgObjPtr && *msgObjPtr) Tcl_IncrRefCount(*msgObjPtr); + if (errorObjPtr && *errorObjPtr) Tcl_IncrRefCount(*errorObjPtr); + Tcl_MutexUnlock(&infoTablesMutex); + return result; + } + + info = (ProcessInfo *) Tcl_GetHashValue(entry); + if (info->purge) { + /* + * Process has completed but TclProcessWait has already been called, + * so report no change. + */ + Tcl_MutexUnlock(&infoTablesMutex); + + return TCL_PROCESS_UNCHANGED; + } + + RefreshProcessInfo(info, options); + if (info->status == TCL_PROCESS_UNCHANGED) { + /* + * No change, stop there. + */ + Tcl_MutexUnlock(&infoTablesMutex); + + return TCL_PROCESS_UNCHANGED; + } + + /* + * Set return values. + */ + + result = info->status; + if (codePtr) *codePtr = info->code; + if (msgObjPtr) *msgObjPtr = info->msg; + if (errorObjPtr) *errorObjPtr = info->error; + if (msgObjPtr && *msgObjPtr) Tcl_IncrRefCount(*msgObjPtr); + if (errorObjPtr && *errorObjPtr) Tcl_IncrRefCount(*errorObjPtr); + + if (autopurge) { + /* + * Purge now. + */ + + Tcl_DeleteHashEntry(entry); + entry = Tcl_FindHashEntry(&infoTablePerResolvedPid, + INT2PTR(info->resolvedPid)); + Tcl_DeleteHashEntry(entry); + FreeProcessInfo(info); + } else { + /* + * Eventually purge. Subsequent calls will return + * TCL_PROCESS_UNCHANGED. + */ + + info->purge = 1; + } + Tcl_MutexUnlock(&infoTablesMutex); + return result; +} diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c index cfe6388..d3f7428 100644 --- a/generic/tclRegexp.c +++ b/generic/tclRegexp.c @@ -13,6 +13,7 @@ #include "tclInt.h" #include "tclRegexp.h" +#include <assert.h> /* *---------------------------------------------------------------------- @@ -64,7 +65,7 @@ #define NUM_REGEXPS 30 -typedef struct ThreadSpecificData { +typedef struct { int initialized; /* Set to 1 when the module is initialized. */ char *patterns[NUM_REGEXPS];/* Strings corresponding to compiled regular * expression patterns. NULL means that this @@ -107,6 +108,23 @@ const Tcl_ObjType tclRegexpType = { NULL, /* updateStringProc */ SetRegexpFromAny /* setFromAnyProc */ }; + +#define RegexpSetIntRep(objPtr, rePtr) \ + do { \ + Tcl_ObjIntRep ir; \ + (rePtr)->refCount++; \ + ir.twoPtrValue.ptr1 = (rePtr); \ + ir.twoPtrValue.ptr2 = NULL; \ + Tcl_StoreIntRep((objPtr), &tclRegexpType, &ir); \ + } while (0) + +#define RegexpGetIntRep(objPtr, rePtr) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = TclFetchIntRep((objPtr), &tclRegexpType); \ + (rePtr) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + } while (0) + /* *---------------------------------------------------------------------- @@ -245,7 +263,7 @@ Tcl_RegExpRange( if ((size_t) index > regexpPtr->re.re_nsub) { *startPtr = *endPtr = NULL; - } else if (regexpPtr->matches[index].rm_so < 0) { + } else if (regexpPtr->matches[index].rm_so == TCL_INDEX_NONE) { *startPtr = *endPtr = NULL; } else { if (regexpPtr->objPtr) { @@ -346,7 +364,7 @@ TclRegExpRangeUniChar( * passed to Tcl_RegExpExec. */ int index, /* 0 means give the range of the entire match, * > 0 means give the range of a matching - * subrange, -1 means the range of the + * subrange, TCL_INDEX_NONE means the range of the * rm_extend field. */ int *startPtr, /* Store address of first character in * (sub-)range here. */ @@ -355,12 +373,12 @@ TclRegExpRangeUniChar( { TclRegexp *regexpPtr = (TclRegexp *) re; - if ((regexpPtr->flags®_EXPECT) && index == -1) { + if ((regexpPtr->flags®_EXPECT) && (index == TCL_INDEX_NONE)) { *startPtr = regexpPtr->details.rm_extend.rm_so; *endPtr = regexpPtr->details.rm_extend.rm_eo; } else if ((size_t) index > regexpPtr->re.re_nsub) { - *startPtr = -1; - *endPtr = -1; + *startPtr = TCL_INDEX_NONE; + *endPtr = TCL_INDEX_NONE; } else { *startPtr = regexpPtr->matches[index].rm_so; *endPtr = regexpPtr->matches[index].rm_eo; @@ -510,9 +528,9 @@ Tcl_RegExpMatchObj( */ if (!(re = Tcl_GetRegExpFromObj(interp, patternObj, - TCL_REG_ADVANCED | TCL_REG_NOSUB)) + TCL_REG_ADVANCED | TCL_REG_NOSUB)) && !(re = Tcl_GetRegExpFromObj(interp, patternObj, TCL_REG_ADVANCED))) { - return -1; + return -1; } return Tcl_RegExpExecObj(interp, re, textObj, 0 /* offset */, 0 /* nmatches */, 0 /* flags */); @@ -580,14 +598,9 @@ Tcl_GetRegExpFromObj( TclRegexp *regexpPtr; const char *pattern; - /* - * This is OK because we only actually interpret this value properly as a - * TclRegexp* when the type is tclRegexpType. - */ + RegexpGetIntRep(objPtr, regexpPtr); - regexpPtr = objPtr->internalRep.twoPtrValue.ptr1; - - if ((objPtr->typePtr != &tclRegexpType) || (regexpPtr->flags != flags)) { + if ((regexpPtr == NULL) || (regexpPtr->flags != flags)) { pattern = TclGetStringFromObj(objPtr, &length); regexpPtr = CompileRegexp(interp, pattern, length, flags); @@ -595,21 +608,7 @@ Tcl_GetRegExpFromObj( return NULL; } - /* - * Add a reference to the regexp so it will persist even if it is - * pushed out of the current thread's regexp cache. This reference - * will be removed when the object's internal rep is freed. - */ - - regexpPtr->refCount++; - - /* - * Free the old representation and set our type. - */ - - TclFreeIntRep(objPtr); - objPtr->internalRep.twoPtrValue.ptr1 = regexpPtr; - objPtr->typePtr = &tclRegexpType; + RegexpSetIntRep(objPtr, regexpPtr); } return (Tcl_RegExp) regexpPtr; } @@ -679,7 +678,7 @@ TclRegAbout( resultObj = Tcl_NewObj(); Tcl_ListObjAppendElement(NULL, resultObj, - Tcl_NewIntObj((int) regexpPtr->re.re_nsub)); + Tcl_NewWideIntObj((Tcl_WideInt) regexpPtr->re.re_nsub)); /* * Now append a list of all the bit-flags set for the RE. @@ -756,7 +755,11 @@ static void FreeRegexpInternalRep( Tcl_Obj *objPtr) /* Regexp object with internal rep to free. */ { - TclRegexp *regexpRepPtr = objPtr->internalRep.twoPtrValue.ptr1; + TclRegexp *regexpRepPtr; + + RegexpGetIntRep(objPtr, regexpRepPtr); + + assert(regexpRepPtr != NULL); /* * If this is the last reference to the regexp, free it. @@ -765,7 +768,6 @@ FreeRegexpInternalRep( if (regexpRepPtr->refCount-- <= 1) { FreeRegexp(regexpRepPtr); } - objPtr->typePtr = NULL; } /* @@ -790,11 +792,13 @@ DupRegexpInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - TclRegexp *regexpPtr = srcPtr->internalRep.twoPtrValue.ptr1; + TclRegexp *regexpPtr; + + RegexpGetIntRep(srcPtr, regexpPtr); + + assert(regexpPtr != NULL); - regexpPtr->refCount++; - copyPtr->internalRep.twoPtrValue.ptr1 = srcPtr->internalRep.twoPtrValue.ptr1; - copyPtr->typePtr = &tclRegexpType; + RegexpSetIntRep(copyPtr, regexpPtr); } /* @@ -994,7 +998,7 @@ CompileRegexp( tsdPtr->regexps[i+1] = tsdPtr->regexps[i]; } tsdPtr->patterns[0] = ckalloc(length + 1); - memcpy(tsdPtr->patterns[0], string, (unsigned) length + 1); + memcpy(tsdPtr->patterns[0], string, length + 1); tsdPtr->patLengths[0] = length; tsdPtr->regexps[0] = regexpPtr; diff --git a/generic/tclRegexp.h b/generic/tclRegexp.h index 3b2433e..a263dfd 100644 --- a/generic/tclRegexp.h +++ b/generic/tclRegexp.h @@ -37,7 +37,7 @@ typedef struct TclRegexp { * of subexpressions. */ rm_detail_t details; /* Detailed information on match (currently * used only for REG_EXPECT). */ - int refCount; /* Count of number of references to this + size_t refCount; /* Count of number of references to this * compiled regexp. */ } TclRegexp; diff --git a/generic/tclResult.c b/generic/tclResult.c index 9d0714c..6e9d4a6 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -27,7 +27,9 @@ enum returnKeys { static Tcl_Obj ** GetKeys(void); static void ReleaseKeys(ClientData clientData); static void ResetObjResult(Interp *iPtr); +#ifndef TCL_NO_DEPRECATED static void SetupAppendBuffer(Interp *iPtr, int newSpace); +#endif /* !TCL_NO_DEPRECATED */ /* * This structure is used to take a snapshot of the interpreter state in @@ -35,7 +37,7 @@ static void SetupAppendBuffer(Interp *iPtr, int newSpace); * then back up to the result or the error that was previously in progress. */ -typedef struct InterpState { +typedef struct { int status; /* return code status */ int flags; /* Each remaining field saves the */ int returnLevel; /* corresponding field of the Interp */ @@ -230,6 +232,7 @@ Tcl_DiscardInterpState( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_SaveResult void Tcl_SaveResult( @@ -435,7 +438,7 @@ Tcl_SetResult( iPtr->result = iPtr->resultSpace; iPtr->freeProc = 0; } - memcpy(iPtr->result, result, (unsigned) length+1); + memcpy(iPtr->result, result, length+1); } else { iPtr->result = (char *) result; iPtr->freeProc = freeProc; @@ -483,19 +486,19 @@ const char * Tcl_GetStringResult( register Tcl_Interp *interp)/* Interpreter whose result to return. */ { + Interp *iPtr = (Interp *) interp; /* * 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 /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -536,6 +539,7 @@ Tcl_SetObjResult( TclDecrRefCount(oldObjResult); +#ifndef TCL_NO_DEPRECATED /* * Reset the string result since we just set the result object. */ @@ -550,6 +554,7 @@ Tcl_SetObjResult( } iPtr->result = iPtr->resultSpace; iPtr->resultSpace[0] = 0; +#endif } /* @@ -578,6 +583,7 @@ Tcl_GetObjResult( Tcl_Interp *interp) /* Interpreter whose result to return. */ { register Interp *iPtr = (Interp *) interp; +#ifndef TCL_NO_DEPRECATED Tcl_Obj *objResultPtr; int length; @@ -604,6 +610,7 @@ Tcl_GetObjResult( iPtr->result = iPtr->resultSpace; iPtr->result[0] = 0; } +#endif /* !TCL_NO_DEPRECATED */ return iPtr->objResultPtr; } @@ -640,23 +647,6 @@ Tcl_AppendResultVA( } Tcl_AppendStringsToObjVA(objPtr, argList); Tcl_SetObjResult(interp, objPtr); - - /* - * Strictly we should call Tcl_GetStringResult(interp) here to make sure - * that interp->result is correct according to the old contract, but that - * makes the performance of much code (e.g. in Tk) absolutely awful. So we - * leave it out; code that really wants interp->result can just insert the - * calls to Tcl_GetStringResult() itself. [Patch 1041072 discussion] - */ - -#ifdef USE_INTERP_RESULT - /* - * Ensure that the interp->result is legal so old Tcl 7.* code still - * works. There's still embarrasingly much of it about... - */ - - (void) Tcl_GetStringResult(interp); -#endif /* USE_INTERP_RESULT */ } /* @@ -722,6 +712,21 @@ Tcl_AppendElement( * to result. */ { Interp *iPtr = (Interp *) interp; +#ifdef TCL_NO_DEPRECATED + Tcl_Obj *elementPtr = Tcl_NewStringObj(element, -1); + Tcl_Obj *listPtr = Tcl_NewListObj(1, &elementPtr); + const char *bytes; + + if (Tcl_IsShared(iPtr->objResultPtr)) { + Tcl_SetObjResult(interp, Tcl_DuplicateObj(iPtr->objResultPtr)); + } + bytes = TclGetString(iPtr->objResultPtr); + if (TclNeedSpace(bytes, bytes+iPtr->objResultPtr->length)) { + Tcl_AppendToObj(iPtr->objResultPtr, " ", 1); + } + Tcl_AppendObjToObj(iPtr->objResultPtr, listPtr); + Tcl_DecrRefCount(listPtr); +#else char *dst; int size; int flags; @@ -765,6 +770,7 @@ Tcl_AppendElement( flags |= TCL_DONT_QUOTE_HASH; } iPtr->appendUsed += Tcl_ConvertElement(element, dst, flags); +#endif /* !TCL_NO_DEPRECATED */ } /* @@ -786,6 +792,7 @@ Tcl_AppendElement( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED static void SetupAppendBuffer( Interp *iPtr, /* Interpreter whose result is being set up. */ @@ -825,19 +832,19 @@ SetupAppendBuffer( totalSpace = newSpace + iPtr->appendUsed; if (totalSpace >= iPtr->appendAvl) { - char *new; + char *newSpace; if (totalSpace < 100) { totalSpace = 200; } else { totalSpace *= 2; } - new = ckalloc(totalSpace); - strcpy(new, iPtr->result); + newSpace = ckalloc(totalSpace); + strcpy(newSpace, iPtr->result); if (iPtr->appendResult != NULL) { ckfree(iPtr->appendResult); } - iPtr->appendResult = new; + iPtr->appendResult = newSpace; iPtr->appendAvl = totalSpace; } else if (iPtr->result != iPtr->appendResult) { strcpy(iPtr->appendResult, iPtr->result); @@ -846,6 +853,7 @@ SetupAppendBuffer( Tcl_FreeResult((Tcl_Interp *) iPtr); iPtr->result = iPtr->appendResult; } +#endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -875,6 +883,7 @@ Tcl_FreeResult( { register Interp *iPtr = (Interp *) interp; +#ifndef TCL_NO_DEPRECATED if (iPtr->freeProc != NULL) { if (iPtr->freeProc == TCL_DYNAMIC) { ckfree(iPtr->result); @@ -884,6 +893,7 @@ Tcl_FreeResult( iPtr->freeProc = 0; } +#endif /* !TCL_NO_DEPRECATED */ ResetObjResult(iPtr); } @@ -913,6 +923,7 @@ Tcl_ResetResult( register Interp *iPtr = (Interp *) interp; ResetObjResult(iPtr); +#ifndef TCL_NO_DEPRECATED if (iPtr->freeProc != NULL) { if (iPtr->freeProc == TCL_DYNAMIC) { ckfree(iPtr->result); @@ -923,6 +934,7 @@ Tcl_ResetResult( } iPtr->result = iPtr->resultSpace; iPtr->resultSpace[0] = 0; +#endif /* !TCL_NO_DEPRECATED */ if (iPtr->errorCode) { /* Legacy support */ if (iPtr->flags & ERR_LEGACY_COPY) { @@ -982,11 +994,11 @@ ResetObjResult( Tcl_IncrRefCount(objResultPtr); iPtr->objResultPtr = objResultPtr; } else { - if (objResultPtr->bytes != tclEmptyStringRep) { + if (objResultPtr->bytes != &tclEmptyString) { if (objResultPtr->bytes) { ckfree(objResultPtr->bytes); } - objResultPtr->bytes = tclEmptyStringRep; + objResultPtr->bytes = &tclEmptyString; objResultPtr->length = 0; } TclFreeIntRep(objResultPtr); @@ -1276,10 +1288,8 @@ TclProcessReturn( Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO], &valuePtr); if (valuePtr != NULL) { - int infoLen; - - (void) TclGetStringFromObj(valuePtr, &infoLen); - if (infoLen) { + (void) TclGetString(valuePtr); + if (valuePtr->length) { iPtr->errorInfo = valuePtr; Tcl_IncrRefCount(iPtr->errorInfo); iPtr->flags |= ERR_ALREADY_LOGGED; @@ -1382,13 +1392,11 @@ TclMergeReturnOptions( Tcl_Obj **keys = GetKeys(); for (; objc > 1; objv += 2, objc -= 2) { - int optLen; - const char *opt = TclGetStringFromObj(objv[0], &optLen); - int compareLen; - const char *compare = - TclGetStringFromObj(keys[KEY_OPTIONS], &compareLen); + const char *opt = TclGetString(objv[0]); + const char *compare = TclGetString(keys[KEY_OPTIONS]); - if ((optLen == compareLen) && (memcmp(opt, compare, optLen) == 0)) { + if ((objv[0]->length == keys[KEY_OPTIONS]->length) + && (memcmp(opt, compare, objv[0]->length) == 0)) { Tcl_DictSearch search; int done = 0; Tcl_Obj *keyPtr; diff --git a/generic/tclScan.c b/generic/tclScan.c index 1ff83af..74ec2da 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -10,6 +10,7 @@ */ #include "tclInt.h" +#include "tommath.h" /* * Flag values used by Tcl_ScanObjCmd. @@ -260,7 +261,7 @@ ValidateFormat( Tcl_UniChar ch = 0; int objIndex, xpgSize, nspace = numVars; int *nassign = TclStackAlloc(interp, nspace * sizeof(int)); - char buf[TCL_UTF_MAX+1] = ""; + char buf[TCL_UTF_MAX + 1] = ""; Tcl_Obj *errorMsg; /* Place to build an error messages. Note that * these are messy operations because we do * not want to use the formatting engine; @@ -415,14 +416,7 @@ ValidateFormat( case 'x': case 'X': case 'b': - break; case 'u': - if (flags & SCAN_BIG) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "unsigned bignum scans are invalid", -1)); - Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADUNSIGNED",NULL); - goto error; - } break; /* * Bracket terms need special checking @@ -725,7 +719,7 @@ Tcl_ScanObjCmd( switch (ch) { case 'n': if (!(flags & SCAN_SUPPRESS)) { - objPtr = Tcl_NewIntObj(string - baseString); + objPtr = Tcl_NewWideIntObj(string - baseString); Tcl_IncrRefCount(objPtr); CLANG_ASSERT(objs); objs[objIndex++] = objPtr; @@ -887,7 +881,7 @@ Tcl_ScanObjCmd( offset = TclUtfToUniChar(string, &sch); i = (int)sch; -#if TCL_UTF_MAX == 4 +#if TCL_UTF_MAX <= 4 if ((sch >= 0xD800) && (offset < 3)) { offset += TclUtfToUniChar(string+offset, &sch); i = (((i<<10) & 0x0FFC00) + 0x10000) + (sch & 0x3FF); @@ -895,7 +889,7 @@ Tcl_ScanObjCmd( #endif string += offset; if (!(flags & SCAN_SUPPRESS)) { - objPtr = Tcl_NewIntObj(i); + objPtr = Tcl_NewWideIntObj(i); Tcl_IncrRefCount(objPtr); CLANG_ASSERT(objs); objs[objIndex++] = objPtr; @@ -906,7 +900,7 @@ Tcl_ScanObjCmd( /* * Scan an unsigned or signed integer. */ - objPtr = Tcl_NewLongObj(0); + objPtr = Tcl_NewWideIntObj(0); Tcl_IncrRefCount(objPtr); if (width == 0) { width = ~0; @@ -932,19 +926,42 @@ Tcl_ScanObjCmd( } if (flags & SCAN_LONGER) { if (Tcl_GetWideIntFromObj(NULL, objPtr, &wideValue) != TCL_OK) { - wideValue = ~(Tcl_WideUInt)0 >> 1; /* WIDE_MAX */ + wideValue = WIDE_MAX; if (TclGetString(objPtr)[0] == '-') { - wideValue++; /* WIDE_MAX + 1 = WIDE_MIN */ + wideValue = WIDE_MIN; } } if ((flags & SCAN_UNSIGNED) && (wideValue < 0)) { - sprintf(buf, "%" TCL_LL_MODIFIER "u", - (Tcl_WideUInt)wideValue); + sprintf(buf, "%" TCL_LL_MODIFIER "u", wideValue); Tcl_SetStringObj(objPtr, buf, -1); } else { - Tcl_SetWideIntObj(objPtr, wideValue); + TclSetIntObj(objPtr, wideValue); + } + } else if (flags & SCAN_BIG) { + if (flags & SCAN_UNSIGNED) { + mp_int big; + int code = Tcl_GetBignumFromObj(interp, objPtr, &big); + + if (code == TCL_OK) { + if (big.sign != MP_ZPOS) { + code = TCL_ERROR; + } + mp_clear(&big); + } + + if (code == TCL_ERROR) { + if (objs != NULL) { + ckfree(objs); + } + Tcl_DecrRefCount(objPtr); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "unsigned bignum scans are invalid", -1)); + Tcl_SetErrorCode(interp, "TCL", "FORMAT", + "BADUNSIGNED",NULL); + return TCL_ERROR; + } } - } else if (!(flags & SCAN_BIG)) { + } else { if (TclGetLongFromObj(NULL, objPtr, &value) != TCL_OK) { if (TclGetString(objPtr)[0] == '-') { value = LONG_MIN; @@ -956,7 +973,7 @@ Tcl_ScanObjCmd( sprintf(buf, "%lu", value); /* INTL: ISO digit */ Tcl_SetStringObj(objPtr, buf, -1); } else { - Tcl_SetLongObj(objPtr, value); + TclSetIntObj(objPtr, value); } } objs[objIndex++] = objPtr; @@ -992,8 +1009,10 @@ Tcl_ScanObjCmd( double dvalue; if (Tcl_GetDoubleFromObj(NULL, objPtr, &dvalue) != TCL_OK) { #ifdef ACCEPT_NAN - if (objPtr->typePtr == &tclDoubleType) { - dvalue = objPtr->internalRep.doubleValue; + const Tcl_ObjIntRep *irPtr + = TclFetchIntRep(objPtr, &tclDoubleType); + if (irPtr) { + dvalue = irPtr->doubleValue; } else #endif { @@ -1062,7 +1081,7 @@ Tcl_ScanObjCmd( if (code == TCL_OK) { if (underflow && (nconversions == 0)) { if (numVars) { - objPtr = Tcl_NewIntObj(-1); + objPtr = Tcl_NewWideIntObj(-1); } else { if (objPtr) { Tcl_SetListObj(objPtr, 0, NULL); @@ -1071,7 +1090,7 @@ Tcl_ScanObjCmd( } } } else if (numVars) { - objPtr = Tcl_NewIntObj(result); + objPtr = Tcl_NewWideIntObj(result); } Tcl_SetObjResult(interp, objPtr); } diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 94e7600..fd87446 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -18,13 +18,6 @@ #include <math.h> /* - * Define KILL_OCTAL to suppress interpretation of numbers with leading zero - * as octal. (Ceterum censeo: numeros octonarios delendos esse.) - */ - -#undef KILL_OCTAL - -/* * This code supports (at least hypothetically), IBM, Cray, VAX and IEEE-754 * floating point; of these, only IEEE-754 can represent NaN. IEEE-754 can be * uniquely determined by radix and by the widths of significand and exponent. @@ -327,36 +320,36 @@ static char * StrictQuickFormat(double, int, int, double, static char * QuickConversion(double, int, int, int, int, int, int, int *, char **); static void CastOutPowersOf2(int *, int *, int *); -static char * ShorteningInt64Conversion(Double *, int, Tcl_WideUInt, +static char * ShorteningInt64Conversion(Double *, Tcl_WideUInt, int, int, int, int, int, int, int, int, int, int, int, int *, char **); -static char * StrictInt64Conversion(Double *, int, Tcl_WideUInt, +static char * StrictInt64Conversion(Double *, Tcl_WideUInt, int, int, int, int, int, int, int, int, int *, char **); static int ShouldBankerRoundUpPowD(mp_int *, int, int); static int ShouldBankerRoundUpToNextPowD(mp_int *, mp_int *, - int, int, int, mp_int *); + int, int, mp_int *); static char * ShorteningBignumConversionPowD(Double *dPtr, - int convType, Tcl_WideUInt bw, int b2, int b5, + Tcl_WideUInt bw, int b2, int b5, int m2plus, int m2minus, int m5, int sd, int k, int len, int ilim, int ilim1, int *decpt, char **endPtr); -static char * StrictBignumConversionPowD(Double *dPtr, int convType, +static char * StrictBignumConversionPowD(Double *dPtr, Tcl_WideUInt bw, int b2, int b5, int sd, int k, int len, int ilim, int ilim1, int *decpt, char **endPtr); static int ShouldBankerRoundUp(mp_int *, mp_int *, int); static int ShouldBankerRoundUpToNext(mp_int *, mp_int *, - mp_int *, int, int, mp_int *); -static char * ShorteningBignumConversion(Double *dPtr, int convType, + mp_int *, int); +static char * ShorteningBignumConversion(Double *dPtr, Tcl_WideUInt bw, int b2, int m2plus, int m2minus, int s2, int s5, int k, int len, int ilim, int ilim1, int *decpt, char **endPtr); -static char * StrictBignumConversion(Double *dPtr, int convType, +static char * StrictBignumConversion(Double *dPtr, Tcl_WideUInt bw, int b2, int s2, int s5, int k, int len, int ilim, int ilim1, int *decpt, @@ -489,7 +482,7 @@ TclParseNumber( { enum State { INITIAL, SIGNUM, ZERO, ZERO_X, - ZERO_O, ZERO_B, BINARY, + ZERO_O, ZERO_B, ZERO_D, BINARY, HEXADECIMAL, OCTAL, BAD_OCTAL, DECIMAL, LEADING_RADIX_POINT, FRACTION, EXPONENT_START, EXPONENT_SIGNUM, EXPONENT, @@ -537,7 +530,7 @@ TclParseNumber( int shift = 0; /* Amount to shift when accumulating binary */ int explicitOctal = 0; -#define ALL_BITS (~(Tcl_WideUInt)0) +#define ALL_BITS ((Tcl_WideUInt)-1) #define MOST_BITS (ALL_BITS >> 1) /* @@ -546,6 +539,20 @@ TclParseNumber( */ if (bytes == NULL) { + if (interp == NULL && endPtrPtr == NULL) { + if (TclHasIntRep(objPtr, &tclDictType)) { + /* A dict can never be a (single) number */ + return TCL_ERROR; + } + if (TclHasIntRep(objPtr, &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); } @@ -657,7 +664,11 @@ TclParseNumber( state = ZERO_O; break; } -#ifdef KILL_OCTAL + if (c == 'd' || c == 'D') { + state = ZERO_D; + break; + } +#ifdef TCL_NO_DEPRECATED goto decimal; #endif /* FALLTHROUGH */ @@ -698,9 +709,9 @@ TclParseNumber( && (((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt)) || (octalSignificandWide > - (~(Tcl_WideUInt)0 >> shift)))) { + ((Tcl_WideUInt)-1 >> shift)))) { octalSignificandOverflow = 1; - TclBNInitBignumFromWideUInt(&octalSignificandBig, + TclInitBignumFromWideUInt(&octalSignificandBig, octalSignificandWide); } } @@ -740,7 +751,7 @@ TclParseNumber( goto endgame; } -#ifndef KILL_OCTAL +#ifndef TCL_NO_DEPRECATED /* * Scanned a number with a leading zero that contains an 8, 9, @@ -815,9 +826,9 @@ TclParseNumber( if (significandWide != 0 && ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) || - significandWide > (~(Tcl_WideUInt)0 >> shift))) { + significandWide > ((Tcl_WideUInt)-1 >> shift))) { significandOverflow = 1; - TclBNInitBignumFromWideUInt(&significandBig, + TclInitBignumFromWideUInt(&significandBig, significandWide); } } @@ -856,9 +867,9 @@ TclParseNumber( if (significandWide != 0 && ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) || - significandWide > (~(Tcl_WideUInt)0 >> shift))) { + significandWide > ((Tcl_WideUInt)-1 >> shift))) { significandOverflow = 1; - TclBNInitBignumFromWideUInt(&significandBig, + TclInitBignumFromWideUInt(&significandBig, significandWide); } } @@ -873,13 +884,23 @@ TclParseNumber( state = BINARY; break; + case ZERO_D: + if (c == '0') { + numTrailZeros++; + } else if ( ! isdigit(UCHAR(c))) { + goto endgame; + } + state = DECIMAL; + flags |= TCL_PARSE_INTEGER_ONLY; + /* FALLTHROUGH */ + case DECIMAL: /* * Scanned an optional + or - followed by a string of decimal * digits. */ -#ifdef KILL_OCTAL +#ifdef TCL_NO_DEPRECATED decimal: #endif acceptState = state; @@ -1169,6 +1190,7 @@ TclParseNumber( case ZERO_X: case ZERO_O: case ZERO_B: + case ZERO_D: case LEADING_RADIX_POINT: case EXPONENT_START: case EXPONENT_SIGNUM: @@ -1192,7 +1214,7 @@ TclParseNumber( ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) || significandWide > (MOST_BITS + signum) >> shift)) { significandOverflow = 1; - TclBNInitBignumFromWideUInt(&significandBig, significandWide); + TclInitBignumFromWideUInt(&significandBig, significandWide); } if (shift) { if (!significandOverflow) { @@ -1213,7 +1235,7 @@ TclParseNumber( ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) || significandWide > (MOST_BITS + signum) >> shift)) { significandOverflow = 1; - TclBNInitBignumFromWideUInt(&significandBig, significandWide); + TclInitBignumFromWideUInt(&significandBig, significandWide); } if (shift) { if (!significandOverflow) { @@ -1234,7 +1256,7 @@ TclParseNumber( ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideUInt) || octalSignificandWide > (MOST_BITS + signum) >> shift)) { octalSignificandOverflow = 1; - TclBNInitBignumFromWideUInt(&octalSignificandBig, + TclInitBignumFromWideUInt(&octalSignificandBig, octalSignificandWide); } if (shift) { @@ -1246,32 +1268,18 @@ TclParseNumber( } } if (!octalSignificandOverflow) { - if (octalSignificandWide > - (Tcl_WideUInt)(((~(unsigned long)0) >> 1) + signum)) { -#ifndef TCL_WIDE_INT_IS_LONG - if (octalSignificandWide <= (MOST_BITS + signum)) { - objPtr->typePtr = &tclWideIntType; - if (signum) { - objPtr->internalRep.wideValue = - - (Tcl_WideInt) octalSignificandWide; - } else { - objPtr->internalRep.wideValue = - (Tcl_WideInt) octalSignificandWide; - } - break; - } -#endif - TclBNInitBignumFromWideUInt(&octalSignificandBig, + if (octalSignificandWide > (MOST_BITS + signum)) { + TclInitBignumFromWideUInt(&octalSignificandBig, octalSignificandWide); octalSignificandOverflow = 1; } else { objPtr->typePtr = &tclIntType; if (signum) { - objPtr->internalRep.longValue = - - (long) octalSignificandWide; + objPtr->internalRep.wideValue = + - (Tcl_WideInt) octalSignificandWide; } else { - objPtr->internalRep.longValue = - (long) octalSignificandWide; + objPtr->internalRep.wideValue = + (Tcl_WideInt) octalSignificandWide; } } } @@ -1289,36 +1297,22 @@ TclParseNumber( &significandWide, &significandBig, significandOverflow); if (!significandOverflow && (significandWide > MOST_BITS+signum)){ significandOverflow = 1; - TclBNInitBignumFromWideUInt(&significandBig, significandWide); + TclInitBignumFromWideUInt(&significandBig, significandWide); } returnInteger: if (!significandOverflow) { - if (significandWide > - (Tcl_WideUInt)(((~(unsigned long)0) >> 1) + signum)) { -#ifndef TCL_WIDE_INT_IS_LONG - if (significandWide <= MOST_BITS+signum) { - objPtr->typePtr = &tclWideIntType; - if (signum) { - objPtr->internalRep.wideValue = - - (Tcl_WideInt) significandWide; - } else { - objPtr->internalRep.wideValue = - (Tcl_WideInt) significandWide; - } - break; - } -#endif - TclBNInitBignumFromWideUInt(&significandBig, + if (significandWide > MOST_BITS+signum) { + TclInitBignumFromWideUInt(&significandBig, significandWide); significandOverflow = 1; } else { objPtr->typePtr = &tclIntType; if (signum) { - objPtr->internalRep.longValue = - - (long) significandWide; + objPtr->internalRep.wideValue = + - (Tcl_WideInt) significandWide; } else { - objPtr->internalRep.longValue = - (long) significandWide; + objPtr->internalRep.wideValue = + (Tcl_WideInt) significandWide; } } } @@ -1457,13 +1451,13 @@ AccumulateDecimalDigit( *wideRepPtr = digit; return 0; } else if (numZeros >= maxpow10_wide - || w > ((~(Tcl_WideUInt)0)-digit)/pow10_wide[numZeros+1]) { + || w > ((Tcl_WideUInt)-1-digit)/pow10_wide[numZeros+1]) { /* * Wide multiplication will overflow. Expand the number to a * bignum and fall through into the bignum case. */ - TclBNInitBignumFromWideUInt(bignumRepPtr, w); + TclInitBignumFromWideUInt(bignumRepPtr, w); } else { /* * Wide multiplication. @@ -1606,7 +1600,7 @@ MakeLowPrecisionDouble( * call MakeHighPrecisionDouble to do it the hard way. */ - TclBNInitBignumFromWideUInt(&significandBig, significand); + TclInitBignumFromWideUInt(&significandBig, significand); retval = MakeHighPrecisionDouble(0, &significandBig, numSigDigs, exponent); mp_clear(&significandBig); @@ -2416,9 +2410,8 @@ ComputeScale( static inline void SetPrecisionLimits( - int convType, /* Type of conversion: TCL_DD_SHORTEST, - * TCL_DD_STEELE0, TCL_DD_E_FMT, - * TCL_DD_F_FMT. */ + int flags, /* Type of conversion: TCL_DD_SHORTEST, + * TCL_DD_E_FMT, TCL_DD_F_FMT. */ int k, /* Floor(log10(number to convert)) */ int *ndigitsPtr, /* IN/OUT: Number of digits requested (will be * adjusted if needed). */ @@ -2428,13 +2421,7 @@ SetPrecisionLimits( int *iLim1Ptr) /* OUT: Number of digits of significance if * the quick method is used. */ { - switch (convType) { - case TCL_DD_SHORTEST0: - case TCL_DD_STEELE0: - *iLimPtr = *iLim1Ptr = -1; - *iPtr = 18; - *ndigitsPtr = 0; - break; + switch (flags & TCL_DD_CONVERSION_TYPE_MASK) { case TCL_DD_E_FORMAT: if (*ndigitsPtr <= 0) { *ndigitsPtr = 1; @@ -2450,10 +2437,10 @@ SetPrecisionLimits( } break; default: - *iPtr = -1; - *iLimPtr = -1; - *iLim1Ptr = -1; - Tcl_Panic("impossible conversion type in TclDoubleDigits"); + *iLimPtr = *iLim1Ptr = -1; + *iPtr = 18; + *ndigitsPtr = 0; + break; } } @@ -2883,8 +2870,6 @@ CastOutPowersOf2( static inline char * ShorteningInt64Conversion( Double *dPtr, /* Original number to convert. */ - int convType, /* Type of conversion (shortest, Steele, - * E format, F format). */ Tcl_WideUInt bw, /* Integer significand. */ int b2, int b5, /* Scale factor for the significand in the * numerator. */ @@ -2951,7 +2936,7 @@ ShorteningInt64Conversion( */ if (b < mplus || (b == mplus - && convType != TCL_DD_STEELE0 && (dPtr->w.word1 & 1) == 0)) { + && (dPtr->w.word1 & 1) == 0)) { /* * Make sure we shouldn't be rounding *up* instead, in case the * next number above is closer. @@ -2980,7 +2965,7 @@ ShorteningInt64Conversion( */ if (b > S - mminus || (b == S - mminus - && convType != TCL_DD_STEELE0 && (dPtr->w.word1 & 1) == 0)) { + && (dPtr->w.word1 & 1) == 0)) { if (digit == 9) { *s++ = '9'; s = BumpUp(s, retval, &k); @@ -3052,8 +3037,6 @@ ShorteningInt64Conversion( static inline char * StrictInt64Conversion( Double *dPtr, /* Original number to convert. */ - int convType, /* Type of conversion (shortest, Steele, - * E format, F format). */ Tcl_WideUInt bw, /* Integer significand. */ int b2, int b5, /* Scale factor for the significand in the * numerator. */ @@ -3198,9 +3181,6 @@ ShouldBankerRoundUpToNextPowD( mp_int *b, /* Numerator of the fraction. */ mp_int *m, /* Numerator of the rounding tolerance. */ int sd, /* Common denominator is 2**(sd*DIGIT_BIT). */ - int convType, /* Conversion type: STEELE defeats - * round-to-even (not sure why one wants to do - * this; I copied it from Gay). FIXME */ int isodd, /* 1 if the integer significand is odd. */ mp_int *temp) /* Work area for the calculation. */ { @@ -3226,10 +3206,6 @@ ShouldBankerRoundUpToNextPowD( return 1; } } - if (convType == TCL_DD_STEELE0) { - /* Biased rounding. */ - return 0; - } return isodd; } @@ -3259,8 +3235,6 @@ ShouldBankerRoundUpToNextPowD( static inline char * ShorteningBignumConversionPowD( Double *dPtr, /* Original number to convert. */ - int convType, /* Type of conversion (shortest, Steele, - * E format, F format). */ Tcl_WideUInt bw, /* Integer significand. */ int b2, int b5, /* Scale factor for the significand in the * numerator. */ @@ -3293,7 +3267,7 @@ ShorteningBignumConversionPowD( * mminus = 5**m5 */ - TclBNInitBignumFromWideUInt(&b, bw); + TclInitBignumFromWideUInt(&b, bw); mp_init_set(&mminus, 1); MulPow5(&b, b5, &b); mp_mul_2d(&b, b2, &b); @@ -3346,7 +3320,7 @@ ShorteningBignumConversionPowD( r1 = mp_cmp_mag(&b, (m2plus > m2minus)? &mplus : &mminus); if (r1 == MP_LT || (r1 == MP_EQ - && convType != TCL_DD_STEELE0 && (dPtr->w.word1 & 1) == 0)) { + && (dPtr->w.word1 & 1) == 0)) { /* * Make sure we shouldn't be rounding *up* instead, in case the * next number above is closer. @@ -3374,7 +3348,7 @@ ShorteningBignumConversionPowD( * number? */ - if (ShouldBankerRoundUpToNextPowD(&b, &mminus, sd, convType, + if (ShouldBankerRoundUpToNextPowD(&b, &mminus, sd, dPtr->w.word1 & 1, &temp)) { if (digit == 9) { *s++ = '9'; @@ -3452,8 +3426,6 @@ ShorteningBignumConversionPowD( static inline char * StrictBignumConversionPowD( Double *dPtr, /* Original number to convert. */ - int convType, /* Type of conversion (shortest, Steele, - * E format, F format). */ Tcl_WideUInt bw, /* Integer significand. */ int b2, int b5, /* Scale factor for the significand in the * numerator. */ @@ -3474,13 +3446,12 @@ StrictBignumConversionPowD( mp_digit digit; /* Current output digit. */ char *s = retval; /* Cursor in the output buffer. */ int i; /* Index in the output buffer. */ - mp_int temp; /* * b = bw * 2**b2 * 5**b5 */ - TclBNInitBignumFromWideUInt(&b, bw); + TclInitBignumFromWideUInt(&b, bw); MulPow5(&b, b5, &b); mp_mul_2d(&b, b2, &b); @@ -3493,7 +3464,6 @@ StrictBignumConversionPowD( ilim = ilim1; --k; } - mp_init(&temp); /* * Loop through the digits. Do division and mod by s == 2**(sd*DIGIT_BIT) @@ -3542,7 +3512,7 @@ StrictBignumConversionPowD( * string. */ - mp_clear_multi(&b, &temp, NULL); + mp_clear(&b); *s = '\0'; *decpt = k; if (endPtr) { @@ -3606,29 +3576,24 @@ ShouldBankerRoundUpToNext( * the last digit. */ mp_int *m, /* Numerator of the rounding tolerance. */ mp_int *S, /* Denominator. */ - int convType, /* Conversion type: STEELE0 defeats - * round-to-even. (Not sure why one would want - * this; I coped it from Gay). FIXME */ - int isodd, /* 1 if the integer significand is odd. */ - mp_int *temp) /* Work area needed for the calculation. */ + int isodd) /* 1 if the integer significand is odd. */ { int r; + mp_int temp; /* * Compare b and S-m: this is the same as comparing B+m and S. */ - mp_add(b, m, temp); - r = mp_cmp_mag(temp, S); + mp_init(&temp); + mp_add(b, m, &temp); + r = mp_cmp_mag(&temp, S); + mp_clear(&temp); switch(r) { case MP_LT: return 0; case MP_EQ: - if (convType == TCL_DD_STEELE0) { - return 0; - } else { - return isodd; - } + return isodd; case MP_GT: return 1; } @@ -3657,7 +3622,6 @@ ShouldBankerRoundUpToNext( static inline char * ShorteningBignumConversion( Double *dPtr, /* Original number being converted. */ - int convType, /* Conversion type. */ Tcl_WideUInt bw, /* Integer significand and exponent. */ int b2, /* Scale factor for the significand. */ int m2plus, int m2minus, /* Scale factors for 1/2 ulp in numerator. */ @@ -3678,7 +3642,6 @@ ShorteningBignumConversion( mp_int S; /* Denominator of the result. */ mp_int dig; /* Current digit of the result. */ int digit; /* Current digit of the result. */ - mp_int temp; /* Work area. */ int minit = 1; /* Fudge factor for when we misguess k. */ int i; int r1; @@ -3688,7 +3651,7 @@ ShorteningBignumConversion( * S = 2**s2 * 5*s5 */ - TclBNInitBignumFromWideUInt(&b, bw); + TclInitBignumFromWideUInt(&b, bw); mp_mul_2d(&b, b2, &b); mp_init_set(&S, 1); MulPow5(&S, s5, &S); mp_mul_2d(&S, s2, &S); @@ -3714,7 +3677,6 @@ ShorteningBignumConversion( mp_init_copy(&mplus, &mminus); mp_mul_2d(&mplus, m2plus-m2minus, &mplus); } - mp_init(&temp); /* * Loop through the digits. @@ -3735,8 +3697,7 @@ ShorteningBignumConversion( */ r1 = mp_cmp_mag(&b, (m2plus > m2minus)? &mplus : &mminus); - if (r1 == MP_LT || (r1 == MP_EQ - && convType != TCL_DD_STEELE0 && (dPtr->w.word1 & 1) == 0)) { + if (r1 == MP_LT || (r1 == MP_EQ && (dPtr->w.word1 & 1) == 0)) { mp_mul_2d(&b, 1, &b); if (ShouldBankerRoundUp(&b, &S, digit&1)) { ++digit; @@ -3755,8 +3716,8 @@ ShorteningBignumConversion( * commit to rounding up to the next higher digit? */ - if (ShouldBankerRoundUpToNext(&b, &mminus, &S, convType, - dPtr->w.word1 & 1, &temp)) { + if (ShouldBankerRoundUpToNext(&b, &mminus, &S, + dPtr->w.word1 & 1)) { ++digit; if (digit == 10) { *s++ = '9'; @@ -3843,7 +3804,7 @@ ShorteningBignumConversion( if (m2plus > m2minus) { mp_clear(&mplus); } - mp_clear_multi(&b, &mminus, &temp, &dig, &S, NULL); + mp_clear_multi(&b, &mminus, &dig, &S, NULL); *s = '\0'; *decpt = k; if (endPtr) { @@ -3873,7 +3834,6 @@ ShorteningBignumConversion( static inline char * StrictBignumConversion( Double *dPtr, /* Original number being converted. */ - int convType, /* Conversion type. */ Tcl_WideUInt bw, /* Integer significand and exponent. */ int b2, /* Scale factor for the significand. */ int s2, int s5, /* Scale factors for denominator. */ @@ -3891,7 +3851,6 @@ StrictBignumConversion( mp_int S; /* Denominator of the result. */ mp_int dig; /* Current digit of the result. */ int digit; /* Current digit of the result. */ - mp_int temp; /* Work area. */ int g; /* Size of the current digit ground. */ int i, j; @@ -3900,8 +3859,8 @@ StrictBignumConversion( * S = 2**s2 * 5*s5 */ - mp_init_multi(&temp, &dig, NULL); - TclBNInitBignumFromWideUInt(&b, bw); + mp_init_multi(&dig, NULL); + TclInitBignumFromWideUInt(&b, bw); mp_mul_2d(&b, b2, &b); mp_init_set(&S, 1); MulPow5(&S, s5, &S); mp_mul_2d(&S, s2, &S); @@ -4007,7 +3966,7 @@ StrictBignumConversion( * string. */ - mp_clear_multi(&b, &S, &temp, &dig, NULL); + mp_clear_multi(&b, &S, &dig, NULL); *s = '\0'; *decpt = k; if (endPtr) { @@ -4043,15 +4002,6 @@ StrictBignumConversion( * For floating point numbers that are exactly between two * decimal numbers, it resolves using the 'round to even' rule. * With this value, the 'ndigits' parameter is ignored. - * TCL_DD_STEELE - This value is not recommended and may be removed in - * the future. It follows the conversion algorithm outlined in - * "How to Print Floating-Point Numbers Accurately" by Guy - * L. Steele, Jr. and Jon L. White [Proc. ACM SIGPLAN '90, - * pp. 112-126]. This rule has the effect of rendering 1e23 as - * 9.9999999999999999e22 - which is a 'better' approximation in - * the sense that it will reconvert correctly even if a - * subsequent input conversion is 'round up' or 'round down' - * rather than 'round to nearest', but is surprising otherwise. * TCL_DD_E_FORMAT - This value is used to prepare numbers for %e format * conversion (or for default floating->string if tcl_precision * is not 0). It constructs a string of at most 'ndigits' digits, @@ -4102,10 +4052,6 @@ TclDoubleDigits( * one character beyond the end of the * returned string. */ { - int convType = (flags & TCL_DD_CONVERSION_TYPE_MASK); - /* Type of conversion being performed: - * TCL_DD_SHORTEST0, TCL_DD_STEELE0, - * TCL_DD_E_FORMAT, or TCL_DD_F_FORMAT. */ Double d; /* Union for deconstructing doubles. */ Tcl_WideUInt bw; /* Integer significand. */ int be; /* Power of 2 by which b must be multiplied */ @@ -4173,18 +4119,18 @@ TclDoubleDigits( * Correct an incorrect caller-supplied 'ndigits'. Also determine: * i = The maximum number of decimal digits that will be returned in the * formatted string. This is k + 1 + ndigits for F format, 18 for - * shortest and Steele, and ndigits for E format. + * shortest, and ndigits for E format. * ilim = The number of significant digits to convert if k has been - * guessed correctly. This is -1 for shortest and Steele (which + * guessed correctly. This is -1 for shortest (which * stop when all significance has been lost), 'ndigits' for E * format, and 'k + 1 + ndigits' for F format. * ilim1 = The minimum number of significant digits to convert if k has - * been guessed 1 too high. This, too, is -1 for shortest and - * Steele, and 'ndigits' for E format, but it's 'ndigits-1' for F + * been guessed 1 too high. This, too, is -1 for shortest, + * and 'ndigits' for E format, but it's 'ndigits-1' for F * format. */ - SetPrecisionLimits(convType, k, &ndigits, &i, &ilim, &ilim1); + SetPrecisionLimits(flags, k, &ndigits, &i, &ilim, &ilim1); /* * Try to do low-precision conversion in floating point rather than @@ -4257,7 +4203,7 @@ TclDoubleDigits( * [1.0e-3 .. 1.0e+24]). */ - return ShorteningInt64Conversion(&d, convType, bw, b2, b5, m2plus, + return ShorteningInt64Conversion(&d, bw, b2, b5, m2plus, m2minus, m5, s2, s5, k, len, ilim, ilim1, decpt, endPtr); } else if (s5 == 0) { /* @@ -4276,7 +4222,7 @@ TclDoubleDigits( m2minus += delta; s2 += delta; } - return ShorteningBignumConversionPowD(&d, convType, bw, b2, b5, + return ShorteningBignumConversionPowD(&d, bw, b2, b5, m2plus, m2minus, m5, s2/MP_DIGIT_BIT, k, len, ilim, ilim1, decpt, endPtr); } else { @@ -4285,7 +4231,7 @@ TclDoubleDigits( * arithmetic for the conversion. */ - return ShorteningBignumConversion(&d, convType, bw, b2, m2plus, + return ShorteningBignumConversion(&d, bw, b2, m2plus, m2minus, s2, s5, k, len, ilim, ilim1, decpt, endPtr); } } else { @@ -4313,7 +4259,7 @@ TclDoubleDigits( * operations. */ - return StrictInt64Conversion(&d, convType, bw, b2, b5, s2, s5, k, + return StrictInt64Conversion(&d, bw, b2, b5, s2, s5, k, len, ilim, ilim1, decpt, endPtr); } else if (s5 == 0) { /* @@ -4330,7 +4276,7 @@ TclDoubleDigits( b2 += delta; s2 += delta; } - return StrictBignumConversionPowD(&d, convType, bw, b2, b5, + return StrictBignumConversionPowD(&d, bw, b2, b5, s2/MP_DIGIT_BIT, k, len, ilim, ilim1, decpt, endPtr); } else { /* @@ -4340,7 +4286,7 @@ TclDoubleDigits( * fewer mp_int divisions. */ - return StrictBignumConversion(&d, convType, bw, b2, s2, s5, k, + return StrictBignumConversion(&d, bw, b2, s2, s5, k, len, ilim, ilim1, decpt, endPtr); } } @@ -4549,7 +4495,7 @@ Tcl_InitBignumFromDouble( return TCL_ERROR; } - fract = frexp(d,&expt); + fract = frexp(d, &expt); if (expt <= 0) { mp_init(b); mp_zero(b); @@ -4557,7 +4503,7 @@ Tcl_InitBignumFromDouble( Tcl_WideInt w = (Tcl_WideInt) ldexp(fract, mantBits); int shift = expt - mantBits; - TclBNInitBignumFromWideInt(b, w); + TclInitBignumFromWideInt(b, w); if (shift < 0) { mp_div_2d(b, -shift, b, NULL); } else if (shift > 0) { @@ -4703,7 +4649,7 @@ TclCeil( mp_int b; mp_init(&b); - if (mp_cmp_d(a, 0) == MP_LT) { + if (a->sign != MP_ZPOS) { mp_neg(a, &b); r = -TclFloor(&b); } else { @@ -4760,7 +4706,7 @@ TclFloor( mp_int b; mp_init(&b); - if (mp_cmp_d(a, 0) == MP_LT) { + if (a->sign != MP_ZPOS) { mp_neg(a, &b); r = -TclCeil(&b); } else { @@ -4889,7 +4835,7 @@ Pow10TimesFrExp( * Multiply by 10**exponent. */ - retval = frexp(retval * pow10vals[exponent&0xf], &j); + retval = frexp(retval * pow10vals[exponent & 0xf], &j); expt += j; for (i=4; i<9; ++i) { if (exponent & (1<<i)) { diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index ad578b1..ce687c6 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -38,15 +38,7 @@ #include "tommath.h" #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 - +#include "assert.h" /* * Prototypes for functions defined later in this file: */ @@ -145,12 +137,12 @@ GrowStringBuffer( char *ptr = NULL; int attempt; - if (objPtr->bytes == tclEmptyStringRep) { + if (objPtr->bytes == &tclEmptyString) { objPtr->bytes = NULL; } if (flag == 0 || stringPtr->allocated > 0) { - attempt = 2 * needed; - if (attempt >= 0) { + if (needed <= INT_MAX / 2) { + attempt = 2 * needed; ptr = attemptckrealloc(objPtr->bytes, attempt + 1); } if (ptr == NULL) { @@ -199,8 +191,8 @@ GrowUnicodeBuffer( * Subsequent appends - apply the growth algorithm. */ - attempt = 2 * needed; - if (attempt >= 0 && attempt <= STRING_MAXCHARS) { + if (needed <= STRING_MAXCHARS / 2) { + attempt = 2 * needed; ptr = stringAttemptRealloc(stringPtr, attempt); } if (ptr == NULL) { @@ -418,23 +410,32 @@ 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; * we don't need to convert to a string to perform the get-length operation. * - * NOTE that we do not need the bytearray to be "pure". A ByteArray value - * with a string rep cannot be trusted to represent the same value as the - * string rep, but it *can* be trusted to have the same character length - * as the string rep, which is all this routine cares about. + * Starting in Tcl 8.7, we check for a "pure" bytearray, because the + * machinery behind that test is using a proper bytearray ObjType. We + * could also compute length of an improper bytearray without shimmering + * but there's no value in that. We *want* to shimmer an improper bytearray + * because improper bytearrays have worthless internal reps. */ - if (objPtr->typePtr == &tclByteArrayType) { + if (TclIsPureByteArray(objPtr)) { int length; (void) Tcl_GetByteArrayFromObj(objPtr, &length); return length; } - /* * OK, need to work with the object as a string. */ @@ -450,23 +451,9 @@ 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; } - - /* *---------------------------------------------------------------------- @@ -485,16 +472,16 @@ Tcl_GetCharLength( *---------------------------------------------------------------------- */ int -TclCheckEmptyString ( - Tcl_Obj *objPtr -) { +TclCheckEmptyString( + Tcl_Obj *objPtr) +{ int length = -1; - if (objPtr->bytes == tclEmptyStringRep) { + if (objPtr->bytes == &tclEmptyString) { return TCL_EMPTYSTRING_YES; } - if (TclIsPureList(objPtr)) { + if (TclListObjIsCanonical(objPtr)) { Tcl_ListObjLength(NULL, objPtr, &length); return length == 0; } @@ -515,8 +502,9 @@ TclCheckEmptyString ( * * Tcl_GetUniChar -- * - * Get the index'th Unicode character from the String object. The index - * is assumed to be in the appropriate range. + * Get the index'th Unicode character from the String object. If index + * is out of range or it references a low surrogate preceded by a high + * surrogate, the result = -1; * * Results: * Returns the index'th Unicode character in the Object. @@ -527,24 +515,31 @@ TclCheckEmptyString ( *---------------------------------------------------------------------- */ -Tcl_UniChar +int Tcl_GetUniChar( Tcl_Obj *objPtr, /* The object to get the Unicode charater * from. */ int index) /* Get the index'th Unicode character. */ { String *stringPtr; + int ch, length; + + if (index < 0) { + return -1; + } /* * 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 indexing operation. + * we don't need to convert to a string to perform the indexing operation. */ if (TclIsPureByteArray(objPtr)) { - unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, NULL); + unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length); + if (index >= length) { + return -1; + } - return (Tcl_UniChar) bytes[index]; + return (int) bytes[index]; } /* @@ -568,7 +563,28 @@ Tcl_GetUniChar( FillUnicodeRep(objPtr); stringPtr = GET_STRING(objPtr); } - return stringPtr->unicode[index]; + + if (index >= stringPtr->numChars) { + return -1; + } + ch = stringPtr->unicode[index]; +#if TCL_UTF_MAX <= 4 + /* See: bug [11ae2be95dac9417] */ + if ((ch & 0xF800) == 0xD800) { + if (ch & 0x400) { + if ((index > 0) + && ((stringPtr->unicode[index-1] & 0xFC00) == 0xD800)) { + ch = -1; /* low surrogate preceded by high surrogate */ + } + } else if ((++index < stringPtr->numChars) + && ((stringPtr->unicode[index] & 0xFC00) == 0xDC00)) { + /* high surrogate followed by low surrogate */ + ch = (((ch & 0x3FF) << 10) | + (stringPtr->unicode[index] & 0x3FF)) + 0x10000; + } + } +#endif + return ch; } /* @@ -590,6 +606,8 @@ Tcl_GetUniChar( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED +#undef Tcl_GetUnicode Tcl_UniChar * Tcl_GetUnicode( Tcl_Obj *objPtr) /* The object to find the unicode string @@ -597,6 +615,7 @@ Tcl_GetUnicode( { return Tcl_GetUnicodeFromObj(objPtr, NULL); } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -668,17 +687,27 @@ Tcl_GetRange( { Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */ String *stringPtr; + int length; + + if (first < 0) { + first = 0; + } /* * 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 substring operation. + * we don't need to convert to a string to perform the substring operation. */ if (TclIsPureByteArray(objPtr)) { - unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, NULL); + unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length); - return Tcl_NewByteArrayObj(bytes+first, last-first+1); + if (last >= length) { + last = length - 1; + } + if (last < first) { + return Tcl_NewObj(); + } + return Tcl_NewByteArrayObj(bytes + first, last - first + 1); } /* @@ -697,6 +726,12 @@ Tcl_GetRange( TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length); } if (stringPtr->numChars == objPtr->length) { + if (last >= stringPtr->numChars) { + last = stringPtr->numChars - 1; + } + if (last < first) { + return Tcl_NewObj(); + } newObjPtr = Tcl_NewStringObj(objPtr->bytes + first, last-first+1); /* @@ -711,19 +746,25 @@ Tcl_GetRange( FillUnicodeRep(objPtr); stringPtr = GET_STRING(objPtr); } - -#if TCL_UTF_MAX == 4 - /* See: bug [11ae2be95dac9417] */ - if ((first>0) && ((stringPtr->unicode[first]&0xFC00) == 0xDC00) - && ((stringPtr->unicode[first-1]&0xFC00) == 0xD800)) { - ++first; - } - if ((last+1<stringPtr->numChars) && ((stringPtr->unicode[last+1]&0xFC00) == 0xDC00) - && ((stringPtr->unicode[last]&0xFC00) == 0xD800)) { - ++last; - } + if (last > stringPtr->numChars) { + last = stringPtr->numChars; + } + if (last < first) { + return Tcl_NewObj(); + } +#if TCL_UTF_MAX <= 4 + /* See: bug [11ae2be95dac9417] */ + if ((first > 0) && ((stringPtr->unicode[first] & 0xFC00) == 0xDC00) + && ((stringPtr->unicode[first-1] & 0xFC00) == 0xD800)) { + ++first; + } + if ((last + 1 < stringPtr->numChars) + && ((stringPtr->unicode[last+1] & 0xFC00) == 0xDC00) + && ((stringPtr->unicode[last] & 0xFC00) == 0xD800)) { + ++last; + } #endif - return Tcl_NewUnicodeObj(stringPtr->unicode + first, last-first+1); + return Tcl_NewUnicodeObj(stringPtr->unicode + first, last - first + 1); } /* @@ -839,7 +880,7 @@ Tcl_SetObjLength( /* * Need to enlarge the buffer. */ - if (objPtr->bytes == tclEmptyStringRep) { + if (objPtr->bytes == &tclEmptyString) { objPtr->bytes = ckalloc(length + 1); } else { objPtr->bytes = ckrealloc(objPtr->bytes, length + 1); @@ -945,7 +986,7 @@ Tcl_AttemptSetObjLength( char *newBytes; - if (objPtr->bytes == tclEmptyStringRep) { + if (objPtr->bytes == &tclEmptyString) { newBytes = attemptckalloc(length + 1); } else { newBytes = attemptckrealloc(objPtr->bytes, length + 1); @@ -1233,11 +1274,7 @@ Tcl_AppendUnicodeToObj( * objPtr's string rep. */ - if (stringPtr->hasUnicode -#if COMPAT - && stringPtr->numChars > 0 -#endif - ) { + if (stringPtr->hasUnicode) { AppendUnicodeToUnicodeRep(objPtr, unicode, length); } else { AppendUnicodeToUtfRep(objPtr, unicode, length); @@ -1278,52 +1315,58 @@ Tcl_AppendObjToObj( * that appending nothing to anything leaves that starting anything... */ - if (appendObjPtr->bytes == tclEmptyStringRep) { + if (appendObjPtr->bytes == &tclEmptyString) { return; } /* * Handle append of one bytearray object to another as a special case. - * Note that we only do this when the objects don't have string reps; if - * it did, then appending the byte arrays together could well lose - * information; this is a special-case optimization only. + * Note that we only do this when the objects are pure so that the + * bytearray faithfully represent the true value; Otherwise appending the + * byte arrays together could lose information; */ - if ((TclIsPureByteArray(objPtr) || objPtr->bytes == tclEmptyStringRep) + if ((TclIsPureByteArray(objPtr) || objPtr->bytes == &tclEmptyString) && TclIsPureByteArray(appendObjPtr)) { - /* * You might expect the code here to be * * bytes = Tcl_GetByteArrayFromObj(appendObjPtr, &length); * TclAppendBytesToByteArray(objPtr, bytes, length); * - * and essentially all of the time that would be fine. However, - * it would run into trouble in the case where objPtr and - * appendObjPtr point to the same thing. That may never be a - * good idea. It seems to violate Copy On Write, and we don't - * have any tests for the situation, since making any Tcl commands - * that call Tcl_AppendObjToObj() do that appears impossible - * (They honor Copy On Write!). For the sake of extensions that - * go off into that realm, though, here's a more complex approach - * that can handle all the cases. + * and essentially all of the time that would be fine. However, it + * would run into trouble in the case where objPtr and appendObjPtr + * point to the same thing. That may never be a good idea. It seems to + * violate Copy On Write, and we don't have any tests for the + * situation, since making any Tcl commands that call + * Tcl_AppendObjToObj() do that appears impossible (They honor Copy On + * Write!). For the sake of extensions that go off into that realm, + * though, here's a more complex approach that can handle all the + * cases. + * + * First, get the lengths. */ - /* Get lengths */ int lengthSrc; (void) Tcl_GetByteArrayFromObj(objPtr, &length); (void) Tcl_GetByteArrayFromObj(appendObjPtr, &lengthSrc); - /* Grow buffer enough for the append */ + /* + * Grow buffer enough for the append. + */ + TclAppendBytesToByteArray(objPtr, NULL, lengthSrc); - /* Reset objPtr back to the original value */ + /* + * Reset objPtr back to the original value. + */ + Tcl_SetByteArrayLength(objPtr, length); /* - * Now do the append knowing that buffer growth cannot cause - * any trouble. + * Now do the append knowing that buffer growth cannot cause any + * trouble. */ TclAppendBytesToByteArray(objPtr, @@ -1343,16 +1386,12 @@ Tcl_AppendObjToObj( * appendObjPtr and append it. */ - if (stringPtr->hasUnicode -#if COMPAT - && stringPtr->numChars > 0 -#endif - ) { + if (stringPtr->hasUnicode) { /* * If appendObjPtr is not of the "String" type, don't convert it. */ - if (appendObjPtr->typePtr == &tclStringType) { + if (TclHasIntRep(appendObjPtr, &tclStringType)) { Tcl_UniChar *unicode = Tcl_GetUnicodeFromObj(appendObjPtr, &numChars); @@ -1373,18 +1412,15 @@ Tcl_AppendObjToObj( bytes = TclGetStringFromObj(appendObjPtr, &length); numChars = stringPtr->numChars; - if ((numChars >= 0) && (appendObjPtr->typePtr == &tclStringType)) { + if ((numChars >= 0) && TclHasIntRep(appendObjPtr, &tclStringType)) { String *appendStringPtr = GET_STRING(appendObjPtr); + appendNumChars = appendStringPtr->numChars; } AppendUtfToUtfRep(objPtr, bytes, length); - if (numChars >= 0 && appendNumChars >= 0 -#if COMPAT - && appendNumChars == length -#endif - ) { + if (numChars >= 0 && appendNumChars >= 0) { stringPtr->numChars = numChars + appendNumChars; } } @@ -1508,14 +1544,6 @@ AppendUnicodeToUtfRep( if (stringPtr->numChars != -1) { stringPtr->numChars += numChars; } - -#if COMPAT - /* - * Invalidate the unicode rep. - */ - - stringPtr->hasUnicode = 0; -#endif } /* @@ -1963,6 +1991,25 @@ Tcl_AppendFormatToObj( useWide = 1; #endif } + } else if (ch == 'I') { + if ((format[1] == '6') && (format[2] == '4')) { + format += (step + 2); + step = TclUtfToUniChar(format, &ch); +#ifndef TCL_WIDE_INT_IS_LONG + useWide = 1; +#endif + } else if ((format[1] == '3') && (format[2] == '2')) { + format += (step + 2); + step = TclUtfToUniChar(format, &ch); + } else { + format += step; + step = TclUtfToUniChar(format, &ch); + } + } else if ((ch == 't') || (ch == 'z') || (ch == 'q') || (ch == 'j') + || (ch == 'L')) { + format += step; + step = TclUtfToUniChar(format, &ch); + useBig = 1; } format += step; @@ -1994,19 +2041,17 @@ Tcl_AppendFormatToObj( } break; case 'c': { - char buf[TCL_UTF_MAX]; + char buf[4] = ""; int code, length; if (TclGetIntFromObj(interp, segment, &code) != TCL_OK) { goto error; } length = Tcl_UniCharToUtf(code, buf); -#if TCL_UTF_MAX > 3 if ((code >= 0xD800) && (length < 3)) { /* Special case for handling high surrogates. */ length += Tcl_UniCharToUtf(-1, buf + length); } -#endif segment = Tcl_NewStringObj(buf, length); Tcl_IncrRefCount(segment); allocSegment = 1; @@ -2014,13 +2059,9 @@ Tcl_AppendFormatToObj( } case 'u': - if (useBig) { - msg = "unsigned bignum format is invalid"; - errCode = "BADUNSIGNED"; - goto errorMsg; - } case 'd': case 'o': + case 'p': case 'x': case 'X': case 'b': { @@ -2031,53 +2072,58 @@ Tcl_AppendFormatToObj( mp_int big; int toAppend, isNegative = 0; +#ifndef TCL_WIDE_INT_IS_LONG + if (ch == 'p') { + useWide = 1; + } +#endif if (useBig) { + int cmpResult; if (Tcl_GetBignumFromObj(interp, segment, &big) != TCL_OK) { goto error; } - isNegative = (mp_cmp_d(&big, 0) == MP_LT); + cmpResult = mp_cmp_d(&big, 0); + isNegative = (cmpResult == MP_LT); + if (cmpResult == MP_EQ) gotHash = 0; + if (ch == 'u') { + if (isNegative) { + mp_clear(&big); + msg = "unsigned bignum format is invalid"; + errCode = "BADUNSIGNED"; + goto errorMsg; + } else { + ch = 'd'; + } + } #ifndef TCL_WIDE_INT_IS_LONG } else if (useWide) { - if (Tcl_GetWideIntFromObj(NULL, segment, &w) != TCL_OK) { - Tcl_Obj *objPtr; - - if (Tcl_GetBignumFromObj(interp,segment,&big) != TCL_OK) { - goto error; - } - mp_mod_2d(&big, CHAR_BIT*sizeof(Tcl_WideInt), &big); - objPtr = Tcl_NewBignumObj(&big); - Tcl_IncrRefCount(objPtr); - Tcl_GetWideIntFromObj(NULL, objPtr, &w); - Tcl_DecrRefCount(objPtr); + if (TclGetWideBitsFromObj(interp, segment, &w) != TCL_OK) { + goto error; } isNegative = (w < (Tcl_WideInt) 0); + if (w == (Tcl_WideInt) 0) gotHash = 0; #endif } else if (TclGetLongFromObj(NULL, segment, &l) != TCL_OK) { - if (Tcl_GetWideIntFromObj(NULL, segment, &w) != TCL_OK) { - Tcl_Obj *objPtr; - - if (Tcl_GetBignumFromObj(interp,segment,&big) != TCL_OK) { - goto error; - } - mp_mod_2d(&big, CHAR_BIT * sizeof(long), &big); - objPtr = Tcl_NewBignumObj(&big); - Tcl_IncrRefCount(objPtr); - TclGetLongFromObj(NULL, objPtr, &l); - Tcl_DecrRefCount(objPtr); + if (TclGetWideBitsFromObj(interp, segment, &w) != TCL_OK) { + goto error; } else { - l = Tcl_WideAsLong(w); + l = (long) w; } if (useShort) { s = (short) l; isNegative = (s < (short) 0); + if (s == (short) 0) gotHash = 0; } else { isNegative = (l < (long) 0); + if (l == (long) 0) gotHash = 0; } } else if (useShort) { s = (short) l; isNegative = (s < (short) 0); + if (s == (short) 0) gotHash = 0; } else { isNegative = (l < (long) 0); + if (l == (long) 0) gotHash = 0; } segment = Tcl_NewObj(); @@ -2091,18 +2137,15 @@ Tcl_AppendFormatToObj( segmentLimit -= 1; } - if (gotHash) { + if (gotHash || (ch == 'p')) { switch (ch) { case 'o': - Tcl_AppendToObj(segment, "0", 1); - segmentLimit -= 1; - precision--; - break; - case 'X': - Tcl_AppendToObj(segment, "0X", 2); + Tcl_AppendToObj(segment, "0o", 2); segmentLimit -= 2; break; + case 'p': case 'x': + case 'X': Tcl_AppendToObj(segment, "0x", 2); segmentLimit -= 2; break; @@ -2110,6 +2153,14 @@ Tcl_AppendFormatToObj( Tcl_AppendToObj(segment, "0b", 2); segmentLimit -= 2; break; +#if TCL_MAJOR_VERSION < 9 + case 'd': + if (gotZero) { + Tcl_AppendToObj(segment, "0d", 2); + segmentLimit -= 2; + } + break; +#endif } } @@ -2120,7 +2171,7 @@ Tcl_AppendFormatToObj( const char *bytes; if (useShort) { - pure = Tcl_NewIntObj((int) s); + pure = Tcl_NewWideIntObj(s); #ifndef TCL_WIDE_INT_IS_LONG } else if (useWide) { pure = Tcl_NewWideIntObj(w); @@ -2128,7 +2179,7 @@ Tcl_AppendFormatToObj( } else if (useBig) { pure = Tcl_NewBignumObj(&big); } else { - pure = Tcl_NewLongObj(l); + pure = Tcl_NewWideIntObj(l); } Tcl_IncrRefCount(pure); bytes = TclGetStringFromObj(pure, &length); @@ -2181,6 +2232,7 @@ Tcl_AppendFormatToObj( case 'u': case 'o': + case 'p': case 'x': case 'X': case 'b': { @@ -2246,7 +2298,7 @@ Tcl_AppendFormatToObj( * Need to be sure zero becomes "0", not "". */ - if ((numDigits == 0) && !((ch == 'o') && gotHash)) { + if (numDigits == 0) { numDigits = 1; } pure = Tcl_NewObj(); @@ -2313,6 +2365,8 @@ Tcl_AppendFormatToObj( break; } + case 'a': + case 'A': case 'e': case 'E': case 'f': @@ -2381,6 +2435,12 @@ Tcl_AppendFormatToObj( errCode = "OVERFLOW"; goto errorMsg; } + if (ch == 'A') { + char *p = TclGetString(segment) + 1; + *p = 'x'; + p = strchr(p, 'P'); + if (p) *p = 'p'; + } break; } default: @@ -2457,7 +2517,7 @@ Tcl_AppendFormatToObj( /* *--------------------------------------------------------------------------- * - * Tcl_Format-- + * Tcl_Format -- * * Results: * A refcount zero Tcl_Obj. @@ -2568,33 +2628,49 @@ AppendPrintfToObjVA( case 'u': case 'd': case 'o': + case 'p': case 'x': case 'X': seekingConversion = 0; switch (size) { case -1: case 0: - Tcl_ListObjAppendElement(NULL, list, Tcl_NewLongObj( - (long) va_arg(argList, int))); + Tcl_ListObjAppendElement(NULL, list, Tcl_NewWideIntObj( + va_arg(argList, int))); break; case 1: - Tcl_ListObjAppendElement(NULL, list, Tcl_NewLongObj( + Tcl_ListObjAppendElement(NULL, list, Tcl_NewWideIntObj( va_arg(argList, long))); break; + case 2: + Tcl_ListObjAppendElement(NULL, list, Tcl_NewWideIntObj( + va_arg(argList, Tcl_WideInt))); + break; + case 3: + Tcl_ListObjAppendElement(NULL, list, Tcl_NewBignumObj( + va_arg(argList, mp_int *))); + break; } break; + case 'a': + case 'A': case 'e': case 'E': case 'f': case 'g': case 'G': + if (size > 0) { Tcl_ListObjAppendElement(NULL, list, Tcl_NewDoubleObj( - va_arg(argList, double))); + (double)va_arg(argList, long double))); + } else { + Tcl_ListObjAppendElement(NULL, list, Tcl_NewDoubleObj( + va_arg(argList, double))); + } seekingConversion = 0; break; case '*': lastNum = (int) va_arg(argList, int); - Tcl_ListObjAppendElement(NULL, list, Tcl_NewIntObj(lastNum)); + Tcl_ListObjAppendElement(NULL, list, Tcl_NewWideIntObj(lastNum)); p++; break; case '0': case '1': case '2': case '3': case '4': @@ -2609,9 +2685,35 @@ AppendPrintfToObjVA( gotPrecision = 1; p++; break; - /* TODO: support for wide (and bignum?) arguments */ case 'l': - size = 1; + ++size; + p++; + break; + case 't': + case 'z': + if (sizeof(size_t) == sizeof(Tcl_WideInt)) { + size = 2; + } + p++; + break; + case 'j': + case 'q': + size = 2; + p++; + break; + case 'I': + if (p[1]=='6' && p[2]=='4') { + p += 2; + size = 2; + } else if (p[1]=='3' && p[2]=='2') { + p += 2; + } else if (sizeof(size_t) == sizeof(Tcl_WideInt)) { + size = 2; + } + p++; + break; + case 'L': + size = 3; p++; break; case 'h': @@ -2710,7 +2812,7 @@ TclGetStringStorage( { String *stringPtr; - if (objPtr->typePtr != &tclStringType || objPtr->bytes == NULL) { + if (!TclHasIntRep(objPtr, &tclStringType) || objPtr->bytes == NULL) { return TclGetStringFromObj(objPtr, (int *)sizePtr); } @@ -2718,17 +2820,909 @@ TclGetStringStorage( *sizePtr = stringPtr->allocated; return objPtr->bytes; } + +/* + *--------------------------------------------------------------------------- + * + * TclStringRepeat -- + * + * Performs the [string repeat] function. + * + * Results: + * A (Tcl_Obj *) pointing to the result value, or NULL in case of an + * error. + * + * Side effects: + * On error, when interp is not NULL, error information is left in it. + * + *--------------------------------------------------------------------------- + */ + +Tcl_Obj * +TclStringRepeat( + Tcl_Interp *interp, + Tcl_Obj *objPtr, + int count, + int flags) +{ + Tcl_Obj *objResultPtr; + int inPlace = flags & TCL_STRING_IN_PLACE; + 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 (TclHasIntRep(objPtr, &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. */ + return objPtr; + } + + 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 NULL; + } + + if (binary) { + /* Efficiently produce a pure byte array result */ + objResultPtr = (!inPlace || 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 (!inPlace || 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_Z_MODIFIER "u bytes", + STRING_SIZE(count*length))); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return NULL; + } + 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 (!inPlace || 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 NULL; + } + Tcl_SetObjLength(objResultPtr, length); + while (count - done > done) { + Tcl_AppendObjToObj(objResultPtr, objResultPtr); + done *= 2; + } + Tcl_AppendToObj(objResultPtr, Tcl_GetString(objResultPtr), + (count - done) * length); + } + return objResultPtr; +} + +/* + *--------------------------------------------------------------------------- + * + * TclStringCat -- + * + * Performs the [string cat] function. + * + * Results: + * A (Tcl_Obj *) pointing to the result value, or NULL in case of an + * error. + * + * Side effects: + * On error, when interp is not NULL, error information is left in it. + * + *--------------------------------------------------------------------------- + */ + +Tcl_Obj * +TclStringCat( + Tcl_Interp *interp, + int objc, + Tcl_Obj * const objv[], + int flags) +{ + Tcl_Obj *objResultPtr, * const *ov; + int oc, length = 0, binary = 1; + int allowUniChar = 1, requestUniChar = 0; + int first = objc - 1; /* Index of first value possibly not empty */ + int last = 0; /* Index of last value possibly not empty */ + int inPlace = flags & TCL_STRING_IN_PLACE; + + /* assert ( objc >= 0 ) */ + + if (objc <= 1) { + /* Only one or no objects; return first or empty */ + return objc ? objv[0] : Tcl_NewObj(); + } + + /* 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; + do { + Tcl_Obj *objPtr = *ov++; + + if (TclIsPureByteArray(objPtr)) { + allowUniChar = 0; + } else 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! */ + binary = 0; + if (TclHasIntRep(objPtr, &tclStringType)) { + /* Have a pure Unicode value; ask to preserve it */ + requestUniChar = 1; + } else { + /* Have another type; prevent shimmer */ + allowUniChar = 0; + } + } + } while (--oc && (binary || allowUniChar)); + + if (binary) { + /* + * Result will be pure byte array. Pre-size it + */ + + int numBytes; + ov = objv; + oc = objc; + do { + Tcl_Obj *objPtr = *ov++; + + /* + * Every argument is either a bytearray with a ("pure") + * value we know we can safely use, or it is an empty string. + * We don't need to count bytes for the empty strings. + */ + + if (TclIsPureByteArray(objPtr)) { + Tcl_GetByteArrayFromObj(objPtr, &numBytes); /* PANIC? */ + + if (numBytes) { + last = objc - oc; + if (length == 0) { + first = last; + } else if (numBytes > INT_MAX - length) { + goto overflow; + } + length += numBytes; + } + } + } while (--oc); + } else if (allowUniChar && requestUniChar) { + /* + * Result will be pure Tcl_UniChar array. Pre-size it. + */ + + ov = objv; + oc = objc; + do { + Tcl_Obj *objPtr = *ov++; + + if ((objPtr->bytes == NULL) || (objPtr->length)) { + int numChars; + + Tcl_GetUnicodeFromObj(objPtr, &numChars); /* PANIC? */ + if (numChars) { + last = objc - oc; + if (length == 0) { + first = last; + } else if (numChars > INT_MAX - length) { + goto overflow; + } + length += numChars; + } + } + } while (--oc); + } else { + /* Result will be concat of string reps. Pre-size it. */ + ov = objv; oc = objc; + do { + Tcl_Obj *pendingPtr = NULL; + + /* + * Loop until a possibly non-empty value is reached. + * Keep string rep generation pending when possible. + */ + + do { + /* assert ( pendingPtr == NULL ) */ + /* assert ( length == 0 ) */ + + Tcl_Obj *objPtr = *ov++; + + if (objPtr->bytes == NULL) { + /* No string rep; Take the chance we can avoid making it */ + pendingPtr = objPtr; + } else { + Tcl_GetStringFromObj(objPtr, &length); /* PANIC? */ + } + } while (--oc && (length == 0) && (pendingPtr == NULL)); + + /* + * Either we found a possibly non-empty value, and we remember + * this index as the first and last such value so far seen, + * or (oc == 0) and all values are known empty, + * so first = last = objc - 1 signals the right quick return. + */ + + first = last = objc - oc - 1; + + if (oc && (length == 0)) { + int numBytes; + + /* assert ( pendingPtr != NULL ) */ + + /* + * There's a pending value followed by more values. Loop over + * remaining values generating strings until a non-empty value + * is found, or the pending value gets its string generated. + */ + + do { + Tcl_Obj *objPtr = *ov++; + Tcl_GetStringFromObj(objPtr, &numBytes); /* PANIC? */ + } while (--oc && numBytes == 0 && pendingPtr->bytes == NULL); + + if (numBytes) { + last = objc -oc -1; + } + if (oc || numBytes) { + Tcl_GetStringFromObj(pendingPtr, &length); + } + if (length == 0) { + if (numBytes) { + first = last; + } + } else if (numBytes > INT_MAX - length) { + goto overflow; + } + length += numBytes; + } + } while (oc && (length == 0)); + + while (oc) { + int numBytes; + Tcl_Obj *objPtr = *ov++; + + /* assert ( length > 0 && pendingPtr == NULL ) */ + + Tcl_GetStringFromObj(objPtr, &numBytes); /* PANIC? */ + if (numBytes) { + last = objc - oc; + if (numBytes > INT_MAX - length) { + goto overflow; + } + length += numBytes; + } + --oc; + } + } + + if (last <= first /*|| length == 0 */) { + /* Only one non-empty value or zero length; return first */ + /* NOTE: (length == 0) implies (last <= first) */ + return objv[first]; + } + + objv += first; objc = (last - first + 1); + + 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++; + + /* + * Every argument is either a bytearray with a ("pure") + * value we know we can safely use, or it is an empty string. + * We don't need to copy bytes from the empty strings. + */ + + if (TclIsPureByteArray(objPtr)) { + int more; + unsigned char *src = Tcl_GetByteArrayFromObj(objPtr, &more); + memcpy(dst, src, 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_Z_MODIFIER "u bytes", + STRING_SIZE(length))); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return NULL; + } + 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)) { + Tcl_DecrRefCount(objResultPtr); + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "concatenation failed: unable to alloc %" + TCL_Z_MODIFIER "u bytes", + STRING_SIZE(length))); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return NULL; + } + 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 NULL; + } + dst = Tcl_GetString(objResultPtr) + start; + + /* assert ( length > start ) */ + TclFreeIntRep(objResultPtr); + } else { + objResultPtr = Tcl_NewObj(); /* PANIC? */ + if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { + Tcl_DecrRefCount(objResultPtr); + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "concatenation failed: unable to alloc %u bytes", + length)); + Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL); + } + return NULL; + } + 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, more); + dst += more; + } + } + /* Must NUL-terminate! */ + *dst = '\0'; + } + return objResultPtr; + + overflow: + 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 NULL; +} + +/* + *--------------------------------------------------------------------------- + * + * TclStringCmp -- + * Compare two Tcl_Obj values as strings. + * + * Results: + * Like memcmp, return -1, 0, or 1. + * + * Side effects: + * String representations may be generated. Internal representation may + * be changed. + * + *--------------------------------------------------------------------------- + */ + +int +TclStringCmp( + Tcl_Obj *value1Ptr, + Tcl_Obj *value2Ptr, + int checkEq, /* comparison is only for equality */ + int nocase, /* comparison is not case sensitive */ + int reqlength) /* requested length */ +{ + char *s1, *s2; + int empty, length, match, s1len, s2len; + memCmpFn_t memCmpFn; + + if ((reqlength == 0) || (value1Ptr == value2Ptr)) { + /* + * Always match at 0 chars of if it is the same obj. + */ + match = 0; + } else { + if (!nocase && TclIsPureByteArray(value1Ptr) + && TclIsPureByteArray(value2Ptr)) { + /* + * Use binary versions of comparisons since that won't cause undue + * type conversions and it is much faster. Only do this if we're + * case-sensitive (which is all that really makes sense with byte + * arrays anyway, and we have no memcasecmp() for some reason... :^) + */ + + s1 = (char *) Tcl_GetByteArrayFromObj(value1Ptr, &s1len); + s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len); + memCmpFn = memcmp; + } else if (TclHasIntRep(value1Ptr, &tclStringType) + && TclHasIntRep(value2Ptr, &tclStringType)) { + /* + * Do a unicode-specific comparison if both of the args are of + * String type. If the char length == byte length, we can do a + * memcmp. In benchmark testing this proved the most efficient + * check between the unicode and string comparison operations. + */ + + if (nocase) { + s1 = (char *) Tcl_GetUnicodeFromObj(value1Ptr, &s1len); + s2 = (char *) Tcl_GetUnicodeFromObj(value2Ptr, &s2len); + memCmpFn = (memCmpFn_t)Tcl_UniCharNcasecmp; + } else { + s1len = Tcl_GetCharLength(value1Ptr); + s2len = Tcl_GetCharLength(value2Ptr); + if ((s1len == value1Ptr->length) + && (value1Ptr->bytes != NULL) + && (s2len == value2Ptr->length) + && (value2Ptr->bytes != NULL)) { + s1 = value1Ptr->bytes; + s2 = value2Ptr->bytes; + memCmpFn = memcmp; + } else { + s1 = (char *) Tcl_GetUnicode(value1Ptr); + s2 = (char *) Tcl_GetUnicode(value2Ptr); + if ( +#ifdef WORDS_BIGENDIAN + 1 +#else + checkEq +#endif + ) { + memCmpFn = memcmp; + s1len *= sizeof(Tcl_UniChar); + s2len *= sizeof(Tcl_UniChar); + } else { + memCmpFn = (memCmpFn_t) Tcl_UniCharNcmp; + } + } + } + } else { + empty = TclCheckEmptyString(value1Ptr); + if (empty > 0) { + switch (TclCheckEmptyString(value2Ptr)) { + case -1: + s1 = 0; + s1len = 0; + s2 = TclGetStringFromObj(value2Ptr, &s2len); + break; + case 0: + match = -1; + goto matchdone; + case 1: + default: /* avoid warn: `s2` may be used uninitialized */ + match = 0; + goto matchdone; + } + } else if (TclCheckEmptyString(value2Ptr) > 0) { + switch (empty) { + case -1: + s2 = 0; + s2len = 0; + s1 = TclGetStringFromObj(value1Ptr, &s1len); + break; + case 0: + match = 1; + goto matchdone; + case 1: + default: /* avoid warn: `s1` may be used uninitialized */ + match = 0; + goto matchdone; + } + } else { + s1 = TclGetStringFromObj(value1Ptr, &s1len); + s2 = TclGetStringFromObj(value2Ptr, &s2len); + } + if (!nocase && checkEq) { + /* + * When we have equal-length we can check only for + * (in)equality. We can use memcmp in all (n)eq cases because + * we don't need to worry about lexical LE/BE variance. + */ + + memCmpFn = memcmp; + } else { + /* + * As a catch-all we will work with UTF-8. We cannot use + * memcmp() as that is unsafe with any string containing NUL + * (\xC0\x80 in Tcl's utf rep). We can use the more efficient + * TclpUtfNcmp2 if we are case-sensitive and no specific + * length was requested. + */ + + if ((reqlength < 0) && !nocase) { + memCmpFn = (memCmpFn_t) TclpUtfNcmp2; + } else { + s1len = Tcl_NumUtfChars(s1, s1len); + s2len = Tcl_NumUtfChars(s2, s2len); + memCmpFn = (memCmpFn_t) + (nocase ? Tcl_UtfNcasecmp : Tcl_UtfNcmp); + } + } + } + + length = (s1len < s2len) ? s1len : s2len; + if (reqlength > 0 && reqlength < length) { + length = reqlength; + } else if (reqlength < 0) { + /* + * The requested length is negative, so we ignore it by setting it + * to length + 1 so we correct the match var. + */ + + reqlength = length + 1; + } + + if (checkEq && (s1len != s2len)) { + match = 1; /* This will be reversed below. */ + } else { + /* + * The comparison function should compare up to the minimum byte + * length only. + */ + + match = memCmpFn(s1, s2, (size_t) length); + } + if ((match == 0) && (reqlength > length)) { + match = s1len - s2len; + } + match = (match > 0) ? 1 : (match < 0) ? -1 : 0; + } + matchdone: + return match; +} + /* *--------------------------------------------------------------------------- * - * TclStringObjReverse -- + * TclStringFirst -- + * + * 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 +TclStringFirst( + Tcl_Obj *needle, + Tcl_Obj *haystack, + int start) +{ + int lh, ln = Tcl_GetCharLength(needle); + + if (start < 0) { + start = 0; + } + if (ln == 0) { + /* We don't find empty substrings. Bizarre! + * Whenever this routine is turned into a proper substring + * finder, change to `return start` after limits imposed. */ + return -1; + } + + if (TclIsPureByteArray(needle) && TclIsPureByteArray(haystack)) { + unsigned char *end, *check, *bh; + unsigned char *bn = Tcl_GetByteArrayFromObj(needle, &ln); + + /* Find bytes in bytes */ + bh = Tcl_GetByteArrayFromObj(haystack, &lh); + if ((lh < ln) || (start > lh - ln)) { + /* Don't start the loop if there cannot be a valid answer */ + return -1; + } + end = bh + lh; + + check = bh + start; + while (check + ln <= end) { + /* + * Look for the leading byte of the needle in the haystack + * starting at check and stopping when there's not enough room + * for the needle left. + */ + check = memchr(check, bn[0], (end + 1 - ln) - check); + if (check == NULL) { + /* Leading byte not found -> needle cannot be found. */ + return -1; + } + /* Leading byte found, check rest of needle. */ + if (0 == memcmp(check+1, bn+1, ln-1)) { + /* Checks! Return the successful index. */ + return (check - bh); + } + /* Rest of needle match failed; Iterate to continue search. */ + check++; + } + return -1; + } + + /* + * TODO: It might be nice to support some cases where it is not + * necessary to shimmer to &tclStringType to compute the result, + * and instead operate just on the objPtr->bytes values directly. + * However, we also do not want the answer to change based on the + * code pathway, or if it does we want that to be for some values + * we explicitly decline to support. Getting there will involve + * locking down in practice more firmly just what encodings produce + * what supported results for the objPtr->bytes values. For now, + * do only the well-defined Tcl_UniChar array search. + */ + + { + Tcl_UniChar *check, *end, *uh; + Tcl_UniChar *un = Tcl_GetUnicodeFromObj(needle, &ln); + + uh = Tcl_GetUnicodeFromObj(haystack, &lh); + if ((lh < ln) || (start > lh - ln)) { + /* Don't start the loop if there cannot be a valid answer */ + return -1; + } + end = uh + lh; + + for (check = uh + start; check + ln <= end; check++) { + if ((*check == *un) && (0 == + memcmp(check + 1, un + 1, (ln-1) * sizeof(Tcl_UniChar)))) { + return (check - uh); + } + } + 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 last", after limitation. + */ + return -1; + } + + if (TclIsPureByteArray(needle) && TclIsPureByteArray(haystack)) { + unsigned char *check, *bh = Tcl_GetByteArrayFromObj(haystack, &lh); + unsigned char *bn = Tcl_GetByteArrayFromObj(needle, &ln); + + if (last >= lh) { + last = lh - 1; + } + if (last + 1 < ln) { + /* Don't start the loop if there cannot be a valid answer */ + return -1; + } + check = bh + last + 1 - ln; + + while (check >= bh) { + if ((*check == bn[0]) + && (0 == memcmp(check+1, bn+1, ln-1))) { + return (check - bh); + } + check--; + } + return -1; + } + + { + Tcl_UniChar *check, *uh = Tcl_GetUnicodeFromObj(haystack, &lh); + Tcl_UniChar *un = Tcl_GetUnicodeFromObj(needle, &ln); + + if (last >= lh) { + last = lh - 1; + } + if (last + 1 < ln) { + /* Don't start the loop if there cannot be a valid answer */ + return -1; + } + check = uh + last + 1 - ln; + while (check >= uh) { + if ((*check == un[0]) + && (0 == memcmp(check+1, un+1, (ln-1)*sizeof(Tcl_UniChar)))) { + return (check - uh); + } + check--; + } + return -1; + } +} + +/* + *--------------------------------------------------------------------------- + * + * TclStringReverse -- * * Implements the [string reverse] operation. * * Results: - * An unshared Tcl value which is the [string reverse] of the argument - * supplied. When sharing rules permit, the returned value might be the - * argument with modifications done in place. + * A Tcl value which is the [string reverse] of the argument supplied. + * When sharing rules permit and the caller requests, the returned value + * might be the argument with modifications done in place. * * Side effects: * May allocate a new Tcl_Obj. @@ -2740,18 +3734,20 @@ static void ReverseBytes( unsigned char *to, /* Copy bytes into here... */ unsigned char *from, /* ...from here... */ - int count) /* Until this many are copied, */ + int count) /* Until this many are copied, */ /* reversing as you go. */ { unsigned char *src = from + count; + if (to == from) { /* Reversing in place */ while (--src > to) { unsigned char c = *src; + *src = *to; *to++ = c; } - } else { + } else { while (--src >= from) { *to++ = *src; } @@ -2759,17 +3755,19 @@ ReverseBytes( } Tcl_Obj * -TclStringObjReverse( - Tcl_Obj *objPtr) +TclStringReverse( + Tcl_Obj *objPtr, + int flags) { String *stringPtr; Tcl_UniChar ch = 0; + int inPlace = flags & TCL_STRING_IN_PLACE; if (TclIsPureByteArray(objPtr)) { int numBytes; unsigned char *from = Tcl_GetByteArrayFromObj(objPtr, &numBytes); - if (Tcl_IsShared(objPtr)) { + if (!inPlace || Tcl_IsShared(objPtr)) { objPtr = Tcl_NewByteArrayObj(NULL, numBytes); } ReverseBytes(Tcl_GetByteArrayFromObj(objPtr, NULL), from, numBytes); @@ -2783,7 +3781,7 @@ TclStringObjReverse( Tcl_UniChar *from = Tcl_GetUnicode(objPtr); Tcl_UniChar *src = from + stringPtr->numChars; - if (Tcl_IsShared(objPtr)) { + if (!inPlace || Tcl_IsShared(objPtr)) { Tcl_UniChar *to; /* @@ -2798,7 +3796,10 @@ TclStringObjReverse( *to++ = *src; } } else { - /* Reversing in place */ + /* + * Reversing in place. + */ + while (--src > from) { ch = *src; *src = *from; @@ -2812,7 +3813,7 @@ TclStringObjReverse( int numBytes = objPtr->length; char *to, *from = objPtr->bytes; - if (Tcl_IsShared(objPtr)) { + if (!inPlace || Tcl_IsShared(objPtr)) { objPtr = Tcl_NewObj(); Tcl_SetObjLength(objPtr, numBytes); } @@ -2822,20 +3823,22 @@ TclStringObjReverse( /* * Either numChars == -1 and we don't know how many chars are * represented by objPtr->bytes and we need Pass 1 just in case, - * or numChars >= 0 and we know we have fewer chars than bytes, - * so we know there's a multibyte character needing Pass 1. + * or numChars >= 0 and we know we have fewer chars than bytes, so + * we know there's a multibyte character needing Pass 1. * * Pass 1. Reverse the bytes of each multi-byte character. */ + int charCount = 0; int bytesLeft = numBytes; while (bytesLeft) { /* - * NOTE: We know that the from buffer is NUL-terminated. - * It's part of the contract for objPtr->bytes values. - * Thus, we can skip calling Tcl_UtfCharComplete() here. + * NOTE: We know that the from buffer is NUL-terminated. It's + * part of the contract for objPtr->bytes values. Thus, we can + * skip calling Tcl_UtfCharComplete() here. */ + int bytesInChar = TclUtfToUniChar(from, &ch); ReverseBytes((unsigned char *)to, (unsigned char *)from, @@ -2859,6 +3862,151 @@ TclStringObjReverse( /* *--------------------------------------------------------------------------- * + * TclStringReplace -- + * + * Implements the inner engine of the [string replace] and + * [string insert] commands. + * + * The result is a concatenation of a prefix from objPtr, characters + * 0 through first-1, the insertPtr string value, and a suffix from + * objPtr, characters from first + count to the end. The effect is as if + * the inner substring of characters first through first+count-1 are + * removed and replaced with insertPtr. If insertPtr is NULL, it is + * treated as an empty string. When passed the flag TCL_STRING_IN_PLACE, + * this routine will try to do the work within objPtr, so long as no + * sharing forbids it. Without that request, or as needed, a new Tcl + * value will be allocated to be the result. + * + * Results: + * A Tcl value that is the result of the substring replacement. May + * return NULL in case of an error. When NULL is returned and interp is + * non-NULL, error information is left in interp + * + *--------------------------------------------------------------------------- + */ + +Tcl_Obj * +TclStringReplace( + Tcl_Interp *interp, /* For error reporting, may be NULL */ + Tcl_Obj *objPtr, /* String to act upon */ + int first, /* First index to replace */ + int count, /* How many chars to replace */ + Tcl_Obj *insertPtr, /* Replacement string, may be NULL */ + int flags) /* TCL_STRING_IN_PLACE => attempt in-place */ +{ + int inPlace = flags & TCL_STRING_IN_PLACE; + Tcl_Obj *result; + + /* Caller is expected to pass sensible arguments */ + assert ( count >= 0 ) ; + assert ( first >= 0 ) ; + + /* Replace nothing with nothing */ + if ((insertPtr == NULL) && (count == 0)) { + if (inPlace) { + return objPtr; + } else { + return Tcl_DuplicateObj(objPtr); + } + } + + /* + * The caller very likely had to call Tcl_GetCharLength() or similar + * to be able to process index values. This means it is likely that + * objPtr is either a proper "bytearray" or a "string" or else it has + * a known and short string rep. + */ + + if (TclIsPureByteArray(objPtr)) { + int numBytes; + unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &numBytes); + + if (insertPtr == NULL) { + /* Replace something with nothing. */ + + assert ( first <= numBytes ) ; + assert ( count <= numBytes ) ; + assert ( first + count <= numBytes ) ; + + result = Tcl_NewByteArrayObj(NULL, numBytes - count);/* PANIC? */ + TclAppendBytesToByteArray(result, bytes, first); + TclAppendBytesToByteArray(result, bytes + first + count, + numBytes - count - first); + return result; + } + + /* Replace everything */ + if ((first == 0) && (count == numBytes)) { + return insertPtr; + } + + if (TclIsPureByteArray(insertPtr)) { + int newBytes; + unsigned char *iBytes + = Tcl_GetByteArrayFromObj(insertPtr, &newBytes); + + if (count == newBytes && inPlace && !Tcl_IsShared(objPtr)) { + /* + * Removal count and replacement count are equal. + * Other conditions permit. Do in-place splice. + */ + + memcpy(bytes + first, iBytes, count); + Tcl_InvalidateStringRep(objPtr); + return objPtr; + } + + if (newBytes > INT_MAX - (numBytes - count)) { + 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 NULL; + } + result = Tcl_NewByteArrayObj(NULL, numBytes - count + newBytes); + /* PANIC? */ + Tcl_SetByteArrayLength(result, 0); + TclAppendBytesToByteArray(result, bytes, first); + TclAppendBytesToByteArray(result, iBytes, newBytes); + TclAppendBytesToByteArray(result, bytes + first + count, + numBytes - count - first); + return result; + } + + /* Flow through to try other approaches below */ + } + + /* + * TODO: Figure out how not to generate a Tcl_UniChar array rep + * when it can be determined objPtr->bytes points to a string of + * all single-byte characters so we can index it directly. + */ + + /* The traditional implementation... */ + { + int numChars; + Tcl_UniChar *ustring = Tcl_GetUnicodeFromObj(objPtr, &numChars); + + /* TODO: Is there an in-place option worth pursuing here? */ + + result = Tcl_NewUnicodeObj(ustring, first); + if (insertPtr) { + Tcl_AppendObjToObj(result, insertPtr); + } + if (first + count < numChars) { + Tcl_AppendUnicodeToObj(result, ustring + first + count, + numChars - first - count); + } + + return result; + } +} + +/* + *--------------------------------------------------------------------------- + * * FillUnicodeRep -- * * Populate the Unicode internal rep with the Unicode form of its string @@ -2950,7 +4098,6 @@ 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 @@ -2993,41 +4140,6 @@ 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; @@ -3055,7 +4167,7 @@ SetStringFromAny( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *objPtr) /* The object to convert. */ { - if (objPtr->typePtr != &tclStringType) { + if (!TclHasIntRep(objPtr, &tclStringType)) { String *stringPtr = stringAlloc(0); /* @@ -3115,7 +4227,7 @@ UpdateStringOfString( stringPtr->allocated = 0; if (stringPtr->numChars == 0) { - TclInitStringRep(objPtr, tclEmptyStringRep, 0); + TclInitStringRep(objPtr, NULL, 0); } else { (void) ExtendStringRepWithUnicode(objPtr, stringPtr->unicode, stringPtr->numChars); @@ -3133,7 +4245,7 @@ ExtendStringRepWithUnicode( */ int i, origLength, size = 0; - char *dst, buf[TCL_UTF_MAX]; + char *dst; String *stringPtr = GET_STRING(objPtr); if (numChars < 0) { @@ -3159,7 +4271,7 @@ ExtendStringRepWithUnicode( } for (i = 0; i < numChars && size >= 0; i++) { - size += Tcl_UniCharToUtf((int) unicode[i], buf); + size += TclUtfCount(unicode[i]); } 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 227e6bc..fc5a713 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 String { +typedef struct { 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,20 +72,21 @@ typedef struct String { do { \ if ((numChars) < 0 || (numChars) > STRING_MAXCHARS) { \ Tcl_Panic("max length for a Tcl unicode value (%d chars) exceeded", \ - STRING_MAXCHARS); \ + (int)STRING_MAXCHARS); \ } \ } while (0) #define stringAttemptAlloc(numChars) \ - (String *) attemptckalloc((unsigned) STRING_SIZE(numChars)) + (String *) attemptckalloc(STRING_SIZE(numChars)) #define stringAlloc(numChars) \ - (String *) ckalloc((unsigned) STRING_SIZE(numChars)) + (String *) ckalloc(STRING_SIZE(numChars)) #define stringRealloc(ptr, numChars) \ - (String *) ckrealloc((ptr), (unsigned) STRING_SIZE(numChars)) + (String *) ckrealloc((ptr), STRING_SIZE(numChars)) #define stringAttemptRealloc(ptr, numChars) \ - (String *) attemptckrealloc((ptr), (unsigned) STRING_SIZE(numChars)) + (String *) attemptckrealloc((ptr), STRING_SIZE(numChars)) #define GET_STRING(objPtr) \ ((String *) (objPtr)->internalRep.twoPtrValue.ptr1) #define SET_STRING(objPtr, stringPtr) \ + ((objPtr)->internalRep.twoPtrValue.ptr2 = NULL), \ ((objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (stringPtr)) /* diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index bf05158..5e918f5 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -35,22 +35,32 @@ #undef Tcl_NewIntObj #undef Tcl_NewListObj #undef Tcl_NewLongObj +#undef Tcl_DbNewLongObj #undef Tcl_NewObj #undef Tcl_NewStringObj +#undef Tcl_GetUnicode #undef Tcl_DumpActiveMemory #undef Tcl_ValidateAllMemory #undef Tcl_FindHashEntry #undef Tcl_CreateHashEntry #undef Tcl_Panic #undef Tcl_FindExecutable +#undef Tcl_SetExitProc +#undef Tcl_SetPanicProc #undef TclpGetPid #undef TclSockMinimumBuffers -#define TclBackgroundException Tcl_BackgroundException #undef Tcl_SetIntObj +#undef Tcl_SetLongObj #undef TclpInetNtoa #undef TclWinGetServByName #undef TclWinGetSockOpt #undef TclWinSetSockOpt +#undef TclWinNToHS +#undef TclStaticPackage +#undef TclBNInitBignumFromLong +#undef Tcl_BackgroundError +#define TclStaticPackage Tcl_StaticPackage + #undef TclBN_mp_tc_and #undef TclBN_mp_tc_or #undef TclBN_mp_tc_xor @@ -59,7 +69,7 @@ #define TclBN_mp_tc_xor TclBN_mp_xor /* See bug 510001: TclSockMinimumBuffers needs plat imp */ -#ifdef _WIN64 +#if defined(_WIN64) || defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 # define TclSockMinimumBuffersOld 0 #else #define TclSockMinimumBuffersOld sockMinimumBuffersOld @@ -69,6 +79,43 @@ static int TclSockMinimumBuffersOld(int sock, int size) } #endif +#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 +# define TclSetStartupScriptPath 0 +# define TclGetStartupScriptPath 0 +# define TclSetStartupScriptFileName 0 +# define TclGetStartupScriptFileName 0 +# define TclPrecTraceProc 0 +# define TclpInetNtoa 0 +# define TclWinGetServByName 0 +# define TclWinGetSockOpt 0 +# define TclWinSetSockOpt 0 +# define TclWinNToHS 0 +# define TclWinGetPlatformId 0 +# define TclWinResetInterfaces 0 +# define TclWinSetInterfaces 0 +# define TclWinGetPlatformId 0 +# define TclBNInitBignumFromWideUInt 0 +# define TclBNInitBignumFromWideInt 0 +# define TclBNInitBignumFromLong 0 +# define Tcl_Backslash 0 +# define Tcl_GetDefaultEncodingDir 0 +# define Tcl_SetDefaultEncodingDir 0 +# define Tcl_EvalTokens 0 +# define Tcl_CreateMathFunc 0 +# define Tcl_GetMathFuncInfo 0 +# define Tcl_ListMathFuncs 0 +# define Tcl_SetIntObj 0 +# define Tcl_SetLongObj 0 +# define Tcl_NewIntObj 0 +# define Tcl_NewLongObj 0 +# define Tcl_DbNewLongObj 0 +# define Tcl_BackgroundError 0 +#else +#define TclBNInitBignumFromLong initBignumFromLong +static void TclBNInitBignumFromLong(mp_int *a, long b) +{ + TclInitBignumFromWideInt(a, b); +} #define TclSetStartupScriptPath setStartupScriptPath static void TclSetStartupScriptPath(Tcl_Obj *path) { @@ -94,14 +141,32 @@ static const char *TclGetStartupScriptFileName(void) } return Tcl_GetString(path); } - #if defined(_WIN32) || defined(__CYGWIN__) #undef TclWinNToHS +#undef TclWinGetPlatformId +#undef TclWinResetInterfaces +#undef TclWinSetInterfaces +static void +doNothing(void) +{ + /* dummy implementation, no need to do anything */ +} #define TclWinNToHS winNToHS static unsigned short TclWinNToHS(unsigned short ns) { return ntohs(ns); } +#define TclWinGetPlatformId winGetPlatformId +static int +TclWinGetPlatformId(void) +{ + return 2; /* VER_PLATFORM_WIN32_NT */; +} +#define TclWinResetInterfaces doNothing +#define TclWinSetInterfaces (void (*) (int)) doNothing #endif +# define TclBNInitBignumFromWideUInt TclInitBignumFromWideUInt +# define TclBNInitBignumFromWideInt TclInitBignumFromWideInt +#endif /* TCL_NO_DEPRECATED */ #ifdef _WIN32 # define TclUnixWaitForFile 0 @@ -111,10 +176,15 @@ static unsigned short TclWinNToHS(unsigned short ns) { # define TclpIsAtty 0 #elif defined(__CYGWIN__) # define TclpIsAtty TclPlatIsAtty -# define TclWinSetInterfaces (void (*) (int)) doNothing +#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 +static void +doNothing(void) +{ + /* dummy implementation, no need to do anything */ +} +#endif # define TclWinAddProcess (void (*) (void *, unsigned int)) doNothing # define TclWinFlushDirtyChannels doNothing -# define TclWinResetInterfaces doNothing static int TclpIsAtty(int fd) @@ -122,15 +192,6 @@ TclpIsAtty(int fd) return isatty(fd); } -#define TclWinGetPlatformId winGetPlatformId -static int -TclWinGetPlatformId() -{ - /* Don't bother to determine the real platform on cygwin, - * because VER_PLATFORM_WIN32_NT is the only supported platform */ - return 2; /* VER_PLATFORM_WIN32_NT */; -} - void *TclWinGetTclInstance() { void *hInstance = NULL; @@ -139,6 +200,7 @@ void *TclWinGetTclInstance() return hInstance; } +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 #define TclWinSetSockOpt winSetSockOpt static int TclWinSetSockOpt(SOCKET s, int level, int optname, @@ -161,6 +223,7 @@ TclWinGetServByName(const char *name, const char *proto) { return getservbyname(name, proto); } +#endif /* TCL_NO_DEPRECATED */ #define TclWinNoBackslash winNoBackslash static char * @@ -182,80 +245,17 @@ TclpGetPid(Tcl_Pid pid) return (int) (size_t) pid; } -static void -doNothing(void) -{ - /* dummy implementation, no need to do anything */ -} - char * Tcl_WinUtfToTChar( const char *string, int len, Tcl_DString *dsPtr) { -#if TCL_UTF_MAX > 4 - Tcl_UniChar ch = 0; - wchar_t *w, *wString; - const char *p, *end; - int oldLength; -#endif - Tcl_DStringInit(dsPtr); if (!string) { return NULL; } -#if TCL_UTF_MAX > 4 - - if (len < 0) { - len = strlen(string); - } - - /* - * Unicode string length in Tcl_UniChars will be <= UTF-8 string length in - * bytes. - */ - - oldLength = Tcl_DStringLength(dsPtr); - - Tcl_DStringSetLength(dsPtr, - oldLength + (int) ((len + 1) * sizeof(wchar_t))); - wString = (wchar_t *) (Tcl_DStringValue(dsPtr) + oldLength); - - w = wString; - p = string; - end = string + len - 4; - while (p < end) { - p += TclUtfToUniChar(p, &ch); - if (ch > 0xFFFF) { - *w++ = (wchar_t) (0xD800 + ((ch -= 0x10000) >> 10)); - *w++ = (wchar_t) (0xDC00 | (ch & 0x3FF)); - } else { - *w++ = ch; - } - } - end += 4; - while (p < end) { - if (Tcl_UtfCharComplete(p, end-p)) { - p += TclUtfToUniChar(p, &ch); - } else { - ch = UCHAR(*p++); - } - if (ch > 0xFFFF) { - *w++ = (wchar_t) (0xD800 + ((ch -= 0x10000) >> 10)); - *w++ = (wchar_t) (0xDC00 | (ch & 0x3FF)); - } else { - *w++ = ch; - } - } - *w = '\0'; - Tcl_DStringSetLength(dsPtr, - oldLength + ((char *) w - (char *) wString)); - - return (char *)wString; -#else - return (char *)Tcl_UtfToUniCharDString(string, len, dsPtr); -#endif + return (char *)TclUtfToWCharDString(string, len, dsPtr); } char * @@ -264,12 +264,6 @@ Tcl_WinTCharToUtf( int len, Tcl_DString *dsPtr) { -#if TCL_UTF_MAX > 4 - const wchar_t *w, *wEnd; - char *p, *result; - int oldLength, blen = 1; -#endif - Tcl_DStringInit(dsPtr); if (!string) { return NULL; @@ -279,36 +273,7 @@ Tcl_WinTCharToUtf( } else { len /= 2; } -#if TCL_UTF_MAX > 4 - oldLength = Tcl_DStringLength(dsPtr); - Tcl_DStringSetLength(dsPtr, oldLength + (len + 1) * 4); - result = Tcl_DStringValue(dsPtr) + oldLength; - - p = result; - wEnd = (wchar_t *)string + len; - for (w = (wchar_t *)string; w < wEnd; ) { - if (!blen && ((*w & 0xFC00) != 0xDC00)) { - /* Special case for handling high surrogates. */ - p += Tcl_UniCharToUtf(-1, p); - } - blen = Tcl_UniCharToUtf(*w, p); - p += blen; - if ((*w >= 0xD800) && (blen < 3)) { - /* Indication that high surrogate is handled */ - blen = 0; - } - w++; - } - if (!blen) { - /* Special case for handling high surrogates. */ - p += Tcl_UniCharToUtf(-1, p); - } - Tcl_DStringSetLength(dsPtr, oldLength + (p - result)); - - return result; -#else - return Tcl_UniCharToUtfDString((Tcl_UniChar *)string, len, dsPtr); -#endif + return TclWCharToUtfDString((const WCHAR *)string, len, dsPtr); } #if defined(TCL_WIDE_INT_IS_LONG) @@ -317,33 +282,11 @@ Tcl_WinTCharToUtf( * signature. Tcl 9 must find a better solution, but that cannot be done * without introducing a binary incompatibility. */ -#define Tcl_DbNewLongObj ((Tcl_Obj*(*)(long,const char*,int))dbNewLongObj) -static Tcl_Obj *dbNewLongObj( - int intValue, - const char *file, - int line -) { -#ifdef TCL_MEM_DEBUG - register Tcl_Obj *objPtr; - - TclDbNewObj(objPtr, file, line); - objPtr->bytes = NULL; - - objPtr->internalRep.longValue = (long) intValue; - objPtr->typePtr = &tclIntType; - return objPtr; -#else - return Tcl_NewIntObj(intValue); -#endif -} -#define Tcl_GetLongFromObj (int(*)(Tcl_Interp*,Tcl_Obj*,long*))Tcl_GetIntFromObj -#define Tcl_NewLongObj (Tcl_Obj*(*)(long))Tcl_NewIntObj -#define Tcl_SetLongObj (void(*)(Tcl_Obj*,long))Tcl_SetIntObj static int exprInt(Tcl_Interp *interp, const char *expr, int *ptr){ long longValue; int result = Tcl_ExprLong(interp, expr, &longValue); if (result == TCL_OK) { - if ((longValue >= -(long)(UINT_MAX)) + if ((longValue >= (long)(INT_MIN)) && (longValue <= (long)(UINT_MAX))) { *ptr = (int)longValue; } else { @@ -359,7 +302,7 @@ static int exprIntObj(Tcl_Interp *interp, Tcl_Obj*expr, int *ptr){ long longValue; int result = Tcl_ExprLongObj(interp, expr, &longValue); if (result == TCL_OK) { - if ((longValue >= -(long)(UINT_MAX)) + if ((longValue >= (long)(INT_MIN)) && (longValue <= (long)(UINT_MAX))) { *ptr = (int)longValue; } else { @@ -387,17 +330,154 @@ static int uniCharNcasecmp(const Tcl_UniChar *ucs, const Tcl_UniChar *uct, unsig return Tcl_UniCharNcasecmp(ucs, uct, (unsigned long)n); } #define Tcl_UniCharNcasecmp (int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned long))uniCharNcasecmp -static int formatInt(char *buffer, int n){ - return TclFormatInt(buffer, (long)n); -} -#define TclFormatInt (int(*)(char *, long))formatInt -#endif +#endif /* TCL_WIDE_INT_IS_LONG */ -#else /* UNIX and MAC */ +#endif /* __CYGWIN__ */ + +#if defined(TCL_NO_DEPRECATED) +# define Tcl_SeekOld 0 +# define Tcl_TellOld 0 +# undef Tcl_SetBooleanObj +# define Tcl_SetBooleanObj 0 +# undef Tcl_PkgPresent +# define Tcl_PkgPresent 0 +# undef Tcl_PkgProvide +# define Tcl_PkgProvide 0 +# undef Tcl_PkgRequire +# define Tcl_PkgRequire 0 +# undef Tcl_GetIndexFromObj +# define Tcl_GetIndexFromObj 0 +# define Tcl_NewBooleanObj 0 +# undef Tcl_DbNewBooleanObj +# define Tcl_DbNewBooleanObj 0 +# undef Tcl_SetBooleanObj +# define Tcl_SetBooleanObj 0 +# undef Tcl_SetVar +# define Tcl_SetVar 0 +# undef Tcl_UnsetVar +# define Tcl_UnsetVar 0 +# undef Tcl_GetVar +# define Tcl_GetVar 0 +# undef Tcl_TraceVar +# define Tcl_TraceVar 0 +# undef Tcl_UntraceVar +# define Tcl_UntraceVar 0 +# undef Tcl_VarTraceInfo +# define Tcl_VarTraceInfo 0 +# undef Tcl_UpVar +# define Tcl_UpVar 0 +# undef Tcl_AddErrorInfo +# define Tcl_AddErrorInfo 0 +# undef Tcl_AddObjErrorInfo +# define Tcl_AddObjErrorInfo 0 +# undef Tcl_Eval +# define Tcl_Eval 0 +# undef Tcl_GlobalEval +# define Tcl_GlobalEval 0 +# undef Tcl_GetStringResult +# define Tcl_GetStringResult 0 +# undef Tcl_SaveResult +# define Tcl_SaveResult 0 +# undef Tcl_RestoreResult +# define Tcl_RestoreResult 0 +# undef Tcl_DiscardResult +# define Tcl_DiscardResult 0 +# undef Tcl_SetResult +# define Tcl_SetResult 0 +# undef Tcl_EvalObj +# define Tcl_EvalObj 0 +# undef Tcl_GlobalEvalObj +# define Tcl_GlobalEvalObj 0 +# define TclBackgroundException 0 +# undef TclpReaddir +# define TclpReaddir 0 +# define TclSetStartupScript 0 +# define TclGetStartupScript 0 +# define TclGetIntForIndex 0 +# define TclCreateNamespace 0 +# define TclDeleteNamespace 0 +# define TclAppendExportList 0 +# define TclExport 0 +# define TclImport 0 +# define TclForgetImport 0 +# define TclGetCurrentNamespace_ 0 +# define TclGetGlobalNamespace_ 0 +# define TclFindNamespace 0 +# define TclFindCommand 0 +# define TclGetCommandFromObj 0 +# define TclGetCommandFullName 0 +# define TclCopyChannelOld 0 +# define Tcl_AppendResultVA 0 +# define Tcl_AppendStringsToObjVA 0 +# define Tcl_SetErrorCodeVA 0 +# define Tcl_PanicVA 0 +# define Tcl_VarEvalVA 0 +# undef TclpGetDate +# define TclpGetDate 0 +# undef TclpLocaltime +# define TclpLocaltime 0 +# undef TclpGmtime +# define TclpGmtime 0 +# define TclpLocaltime_unix 0 +# define TclpGmtime_unix 0 +# define Tcl_SetExitProc 0 +# define Tcl_SetPanicProc 0 +# define Tcl_FindExecutable 0 +# define Tcl_GetUnicode 0 +# define TclOldFreeObj 0 +# undef Tcl_StringMatch +# define Tcl_StringMatch 0 +# define TclBN_reverse 0 +# define TclBN_fast_s_mp_mul_digs 0 +# define TclBN_fast_s_mp_sqr 0 +# define TclBN_mp_karatsuba_mul 0 +# define TclBN_mp_karatsuba_sqr 0 +# define TclBN_mp_toom_mul 0 +# define TclBN_mp_toom_sqr 0 +# define TclBN_s_mp_add 0 +# define TclBN_s_mp_mul_digs 0 +# define TclBN_s_mp_sqr 0 +# define TclBN_s_mp_sub 0 +#else /* TCL_NO_DEPRECATED */ +# define Tcl_SeekOld seekOld +# define Tcl_TellOld tellOld +# define TclBackgroundException Tcl_BackgroundException +# define TclSetStartupScript Tcl_SetStartupScript +# define TclGetStartupScript Tcl_GetStartupScript +# define TclGetIntForIndex Tcl_GetIntForIndex +# define TclCreateNamespace Tcl_CreateNamespace +# define TclDeleteNamespace Tcl_DeleteNamespace +# define TclAppendExportList Tcl_AppendExportList +# define TclExport Tcl_Export +# define TclImport Tcl_Import +# define TclForgetImport Tcl_ForgetImport +# define TclGetCurrentNamespace_ Tcl_GetCurrentNamespace +# define TclGetGlobalNamespace_ Tcl_GetGlobalNamespace +# define TclFindNamespace Tcl_FindNamespace +# define TclFindCommand Tcl_FindCommand +# define TclGetCommandFromObj Tcl_GetCommandFromObj +# define TclGetCommandFullName Tcl_GetCommandFullName # define TclpLocaltime_unix TclpLocaltime # define TclpGmtime_unix TclpGmtime -#endif +# define TclOldFreeObj TclFreeObj + +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? */ +{ + return Tcl_Seek(chan, offset, mode); +} + +static int +tellOld( + Tcl_Channel chan) /* The channel to return pos for. */ +{ + return Tcl_Tell(chan); +} +#endif /* !TCL_NO_DEPRECATED */ /* * WARNING: The contents of this file is automatically generated by the @@ -408,6 +488,15 @@ static int formatInt(char *buffer, int n){ MODULE_SCOPE const TclStubs tclStubs; MODULE_SCOPE const TclTomMathStubs tclTomMathStubs; +#ifdef __GNUC__ +/* + * The rest of this file shouldn't warn about deprecated functions; they're + * there because we intend them to be so and know that this file is OK to + * touch those fields. + */ +#pragma GCC diagnostic ignored "-Wdeprecated-declarations" +#endif + /* !BEGIN!: Do not edit below this line. */ static const TclIntStubs tclIntStubs = { @@ -525,22 +614,22 @@ static const TclIntStubs tclIntStubs = { TclUpdateReturnInfo, /* 109 */ TclSockMinimumBuffers, /* 110 */ Tcl_AddInterpResolvers, /* 111 */ - Tcl_AppendExportList, /* 112 */ - Tcl_CreateNamespace, /* 113 */ - Tcl_DeleteNamespace, /* 114 */ - Tcl_Export, /* 115 */ - Tcl_FindCommand, /* 116 */ - Tcl_FindNamespace, /* 117 */ + TclAppendExportList, /* 112 */ + TclCreateNamespace, /* 113 */ + TclDeleteNamespace, /* 114 */ + TclExport, /* 115 */ + TclFindCommand, /* 116 */ + TclFindNamespace, /* 117 */ Tcl_GetInterpResolvers, /* 118 */ Tcl_GetNamespaceResolvers, /* 119 */ Tcl_FindNamespaceVar, /* 120 */ - Tcl_ForgetImport, /* 121 */ - Tcl_GetCommandFromObj, /* 122 */ - Tcl_GetCommandFullName, /* 123 */ - Tcl_GetCurrentNamespace, /* 124 */ - Tcl_GetGlobalNamespace, /* 125 */ + TclForgetImport, /* 121 */ + TclGetCommandFromObj, /* 122 */ + TclGetCommandFullName, /* 123 */ + TclGetCurrentNamespace_, /* 124 */ + TclGetGlobalNamespace_, /* 125 */ Tcl_GetVariableFullName, /* 126 */ - Tcl_Import, /* 127 */ + TclImport, /* 127 */ Tcl_PopCallFrame, /* 128 */ Tcl_PushCallFrame, /* 129 */ Tcl_RemoveInterpResolvers, /* 130 */ @@ -591,8 +680,8 @@ static const TclIntStubs tclIntStubs = { TclCallVarTraces, /* 175 */ TclCleanupVar, /* 176 */ TclVarErrMsg, /* 177 */ - Tcl_SetStartupScript, /* 178 */ - Tcl_GetStartupScript, /* 179 */ + TclSetStartupScript, /* 178 */ + TclGetStartupScript, /* 179 */ 0, /* 180 */ 0, /* 181 */ TclpLocaltime, /* 182 */ @@ -670,6 +759,8 @@ static const TclIntStubs tclIntStubs = { TclPtrIncrObjVar, /* 254 */ TclPtrObjMakeUpvar, /* 255 */ TclPtrUnsetVar, /* 256 */ + TclStaticPackage, /* 257 */ + TclpCreateTemporaryDirectory, /* 258 */ }; static const TclIntPlatStubs tclIntPlatStubs = { @@ -860,11 +951,11 @@ const TclTomMathStubs tclTomMathStubs = { TclBNInitBignumFromWideInt, /* 65 */ TclBNInitBignumFromWideUInt, /* 66 */ TclBN_mp_expt_d_ex, /* 67 */ - 0, /* 68 */ - 0, /* 69 */ + TclBN_mp_set_long_long, /* 68 */ + TclBN_mp_get_long_long, /* 69 */ TclBN_mp_set_long, /* 70 */ - 0, /* 71 */ - 0, /* 72 */ + TclBN_mp_get_long, /* 71 */ + TclBN_mp_get_int, /* 72 */ TclBN_mp_tc_and, /* 73 */ TclBN_mp_tc_or, /* 74 */ TclBN_mp_tc_xor, /* 75 */ @@ -927,7 +1018,7 @@ const TclStubs tclStubs = { Tcl_DbNewObj, /* 27 */ Tcl_DbNewStringObj, /* 28 */ Tcl_DuplicateObj, /* 29 */ - TclFreeObj, /* 30 */ + TclOldFreeObj, /* 30 */ Tcl_GetBoolean, /* 31 */ Tcl_GetBooleanFromObj, /* 32 */ Tcl_GetByteArrayFromObj, /* 33 */ @@ -1536,6 +1627,21 @@ const TclStubs tclStubs = { Tcl_FindSymbol, /* 628 */ Tcl_FSUnloadFile, /* 629 */ Tcl_ZlibStreamSetCompressionDictionary, /* 630 */ + Tcl_OpenTcpServerEx, /* 631 */ + TclZipfs_Mount, /* 632 */ + TclZipfs_Unmount, /* 633 */ + TclZipfs_TclLibrary, /* 634 */ + TclZipfs_MountBuffer, /* 635 */ + Tcl_FreeIntRep, /* 636 */ + Tcl_InitStringRep, /* 637 */ + Tcl_FetchIntRep, /* 638 */ + Tcl_StoreIntRep, /* 639 */ + Tcl_HasStringRep, /* 640 */ + Tcl_IncrRefCount, /* 641 */ + Tcl_DecrRefCount, /* 642 */ + Tcl_IsShared, /* 643 */ + Tcl_LinkArray, /* 644 */ + Tcl_GetIntForIndex, /* 645 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclStubLib.c b/generic/tclStubLib.c index bebea81..5261591 100644 --- a/generic/tclStubLib.c +++ b/generic/tclStubLib.c @@ -24,13 +24,10 @@ 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 */ -static int isDigit(const int c) -{ - return (c >= '0' && c <= '9'); -} +#define ISDIGIT(c) (((unsigned)((c)-'0')) <= 9) /* *---------------------------------------------------------------------- @@ -54,7 +51,8 @@ MODULE_SCOPE const char * Tcl_InitStubs( Tcl_Interp *interp, const char *version, - int exact) + int exact, + int magic) { Interp *iPtr = (Interp *) interp; const char *actualVersion = NULL; @@ -67,9 +65,9 @@ Tcl_InitStubs( * times. [Bug 615304] */ - if (!stubsPtr || (stubsPtr->magic != TCL_STUB_MAGIC)) { + if (!stubsPtr || (stubsPtr->magic != (((exact&0xff00) >= 0x900) ? magic : TCL_STUB_MAGIC))) { iPtr->result = (char *)"interpreter uses an incompatible stubs mechanism"; - iPtr->freeProc = TCL_STATIC; + iPtr->freeProc = 0; return NULL; } @@ -77,12 +75,12 @@ Tcl_InitStubs( if (actualVersion == NULL) { return NULL; } - if (exact) { + if (exact&1) { const char *p = version; int count = 0; while (*p) { - count += !isDigit(*p++); + count += !ISDIGIT(*p++); } if (count == 1) { const char *q = actualVersion; @@ -91,7 +89,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; @@ -103,12 +101,16 @@ Tcl_InitStubs( } } } - tclStubsPtr = (TclStubs *)pkgData; + if (((exact&0xff00) < 0x900)) { + /* We are running Tcl 8.x */ + stubsPtr = (TclStubs *)pkgData; + } + tclStubsPtr = stubsPtr; - if (tclStubsPtr->hooks) { - tclPlatStubsPtr = tclStubsPtr->hooks->tclPlatStubs; - tclIntStubsPtr = tclStubsPtr->hooks->tclIntStubs; - tclIntPlatStubsPtr = tclStubsPtr->hooks->tclIntPlatStubs; + if (stubsPtr->hooks) { + tclPlatStubsPtr = stubsPtr->hooks->tclPlatStubs; + tclIntStubsPtr = stubsPtr->hooks->tclIntStubs; + tclIntPlatStubsPtr = stubsPtr->hooks->tclIntPlatStubs; } else { tclPlatStubsPtr = NULL; tclIntStubsPtr = NULL; diff --git a/generic/tclTest.c b/generic/tclTest.c index 473368c..63a657c 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -29,11 +29,6 @@ #include "tclRegexp.h" /* - * Required for TestlocaleCmd - */ -#include <locale.h> - -/* * Required for the TestChannelCmd and TestChannelEventCmd */ #include "tclIO.h" @@ -42,16 +37,8 @@ * Declare external functions used in Windows tests. */ -/* - * 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); +DLLEXPORT int Tcltest_Init(Tcl_Interp *interp); +DLLEXPORT int Tcltest_SafeInit(Tcl_Interp *interp); /* * Dynamic string shared by TestdcallCmd and DelCallbackProc; used to collect @@ -60,6 +47,7 @@ EXTERN int Tcltest_SafeInit(Tcl_Interp *interp); static Tcl_DString delString; static Tcl_Interp *delInterp; +static const Tcl_ObjType *properByteArrayType; /* * One of the following structures exists for each asynchronous handler @@ -75,6 +63,18 @@ typedef struct TestAsyncHandler { /* Next is list of handlers. */ } TestAsyncHandler; +/* + * Start of the socket driver state structure to acces field testFlags + */ + +typedef struct TcpState TcpState; + +struct TcpState { + Tcl_Channel channel; /* Channel associated with this socket. */ + int testFlags; /* bit field for tests. Is set by testsocket + * test procedure */ +}; + TCL_DECLARE_MUTEX(asyncTestMutex) static TestAsyncHandler *firstHandler = NULL; @@ -98,7 +98,7 @@ static Tcl_Trace cmdTrace; * TestdelCmd: */ -typedef struct DelCmd { +typedef struct { Tcl_Interp *interp; /* Interpreter in which command exists. */ char *deleteCmd; /* Script to execute when command is deleted. * Malloc'ed. */ @@ -109,7 +109,7 @@ typedef struct DelCmd { * command. */ -typedef struct TclEncoding { +typedef struct { Tcl_Interp *interp; char *toUtfCmd; char *fromUtfCmd; @@ -132,7 +132,7 @@ static int exitMainLoop = 0; * Event structure used in testing the event queue management procedures. */ -typedef struct TestEvent { +typedef struct { Tcl_Event header; /* Header common to all events */ Tcl_Interp *interp; /* Interpreter that will handle the event */ Tcl_Obj *command; /* Command to evaluate when the event occurs */ @@ -155,223 +155,232 @@ static TestChannel *firstDetached; * Forward declarations for procedures defined later in this file: */ -static int AsyncHandlerProc(ClientData clientData, +static int AsyncHandlerProc(void *clientData, Tcl_Interp *interp, int code); -#ifdef TCL_THREADS -static Tcl_ThreadCreateType AsyncThreadProc(ClientData); +#if TCL_THREADS +static Tcl_ThreadCreateType AsyncThreadProc(void *); #endif static void CleanupTestSetassocdataTests( - ClientData clientData, Tcl_Interp *interp); -static void CmdDelProc1(ClientData clientData); -static void CmdDelProc2(ClientData clientData); -static int CmdProc1(ClientData clientData, + void *clientData, Tcl_Interp *interp); +static void CmdDelProc1(void *clientData); +static void CmdDelProc2(void *clientData); +static int CmdProc1(void *clientData, Tcl_Interp *interp, int argc, const char **argv); -static int CmdProc2(ClientData clientData, +static int CmdProc2(void *clientData, Tcl_Interp *interp, int argc, const char **argv); static void CmdTraceDeleteProc( - ClientData clientData, Tcl_Interp *interp, + void *clientData, Tcl_Interp *interp, int level, char *command, Tcl_CmdProc *cmdProc, - ClientData cmdClientData, int argc, + void *cmdClientData, int argc, const char *argv[]); -static void CmdTraceProc(ClientData clientData, +static void CmdTraceProc(void *clientData, Tcl_Interp *interp, int level, char *command, - Tcl_CmdProc *cmdProc, ClientData cmdClientData, + Tcl_CmdProc *cmdProc, void *cmdClientData, int argc, const char *argv[]); static int CreatedCommandProc( - ClientData clientData, Tcl_Interp *interp, + void *clientData, Tcl_Interp *interp, int argc, const char **argv); static int CreatedCommandProc2( - ClientData clientData, Tcl_Interp *interp, + void *clientData, Tcl_Interp *interp, int argc, const char **argv); -static void DelCallbackProc(ClientData clientData, +static void DelCallbackProc(void *clientData, Tcl_Interp *interp); -static int DelCmdProc(ClientData clientData, +static int DelCmdProc(void *clientData, Tcl_Interp *interp, int argc, const char **argv); -static void DelDeleteProc(ClientData clientData); -static void EncodingFreeProc(ClientData clientData); -static int EncodingToUtfProc(ClientData clientData, +static void DelDeleteProc(void *clientData); +static void EncodingFreeProc(void *clientData); +static int EncodingToUtfProc(void *clientData, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); -static int EncodingFromUtfProc(ClientData clientData, +static int EncodingFromUtfProc(void *clientData, const char *src, int srcLen, int flags, Tcl_EncodingState *statePtr, char *dst, int dstLen, int *srcReadPtr, int *dstWrotePtr, int *dstCharsPtr); -static void ExitProcEven(ClientData clientData); -static void ExitProcOdd(ClientData clientData); -static int GetTimesObjCmd(ClientData clientData, +static void ExitProcEven(void *clientData); +static void ExitProcOdd(void *clientData); +static int GetTimesObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static void MainLoop(void); -static int NoopCmd(ClientData clientData, +static int NoopCmd(void *clientData, Tcl_Interp *interp, int argc, const char **argv); -static int NoopObjCmd(ClientData clientData, +static int NoopObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int ObjTraceProc(ClientData clientData, +static int ObjTraceProc(void *clientData, Tcl_Interp *interp, int level, const char *command, Tcl_Command commandToken, int objc, Tcl_Obj *const objv[]); -static void ObjTraceDeleteProc(ClientData clientData); +static void ObjTraceDeleteProc(void *clientData); static void PrintParse(Tcl_Interp *interp, Tcl_Parse *parsePtr); static void SpecialFree(char *blockPtr); static int StaticInitProc(Tcl_Interp *interp); -static int TestasyncCmd(ClientData dummy, +static int TestasyncCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); +static int TestbytestringObjCmd(void *clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); static int TestpurebytesobjObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestbytestringObjCmd(ClientData clientData, +static int TeststringbytesObjCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestcmdinfoCmd(ClientData dummy, +static int TestcmdinfoCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestcmdtokenCmd(ClientData dummy, +static int TestcmdtokenCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestcmdtraceCmd(ClientData dummy, +static int TestcmdtraceCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestconcatobjCmd(ClientData dummy, +static int TestconcatobjCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestcreatecommandCmd(ClientData dummy, +static int TestcreatecommandCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestdcallCmd(ClientData dummy, +static int TestdcallCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestdelCmd(ClientData dummy, +static int TestdelCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestdelassocdataCmd(ClientData dummy, +static int TestdelassocdataCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestdoubledigitsObjCmd(ClientData dummy, - Tcl_Interp* interp, - int objc, Tcl_Obj* const objv[]); -static int TestdstringCmd(ClientData dummy, +static int TestdoubledigitsObjCmd(void *dummy, + Tcl_Interp* interp, int objc, + Tcl_Obj* const objv[]); +static int TestdstringCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestencodingObjCmd(ClientData dummy, +static int TestencodingObjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestevalexObjCmd(ClientData dummy, +static int TestevalexObjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestevalobjvObjCmd(ClientData dummy, +static int TestevalobjvObjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TesteventObjCmd(ClientData unused, +static int TesteventObjCmd(void *unused, Tcl_Interp *interp, int argc, Tcl_Obj *const objv[]); static int TesteventProc(Tcl_Event *event, int flags); static int TesteventDeleteProc(Tcl_Event *event, - ClientData clientData); -static int TestexithandlerCmd(ClientData dummy, + void *clientData); +static int TestexithandlerCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestexprlongCmd(ClientData dummy, +static int TestexprlongCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestexprlongobjCmd(ClientData dummy, +static int TestexprlongobjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestexprdoubleCmd(ClientData dummy, +static int TestexprdoubleCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestexprdoubleobjCmd(ClientData dummy, +static int TestexprdoubleobjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestexprparserObjCmd(ClientData dummy, +static int TestexprparserObjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestexprstringCmd(ClientData dummy, +static int TestexprstringCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestfileCmd(ClientData dummy, +static int TestfileCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestfilelinkCmd(ClientData dummy, +static int TestfilelinkCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestfeventCmd(ClientData dummy, +static int TestfeventCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestgetassocdataCmd(ClientData dummy, +static int TestgetassocdataCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestgetintCmd(ClientData dummy, +static int TestgetintCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestgetplatformCmd(ClientData dummy, +static int TestlongsizeCmd(void *dummy, + Tcl_Interp *interp, int argc, const char **argv); +static int TestgetplatformCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestgetvarfullnameCmd( - ClientData dummy, Tcl_Interp *interp, + void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestinterpdeleteCmd(ClientData dummy, +static int TestinterpdeleteCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestlinkCmd(ClientData dummy, +static int TestlinkCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestlocaleCmd(ClientData dummy, +static int TestlinkarrayCmd(void *dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); +static int TestlocaleCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -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); -static int TestmainthreadCmd(ClientData dummy, +static int TestmainthreadCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestsetmainloopCmd(ClientData dummy, +static int TestsetmainloopCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestexitmainloopCmd(ClientData dummy, +static int TestexitmainloopCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestpanicCmd(ClientData dummy, +static int TestpanicCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestparseargsCmd(ClientData dummy, Tcl_Interp *interp, +static int TestparseargsCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestparserObjCmd(ClientData dummy, +static int TestparserObjCmd(void *dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int TestparsevarObjCmd(void *dummy, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int TestparsevarnameObjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestparsevarObjCmd(ClientData dummy, +static int TestpreferstableObjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestparsevarnameObjCmd(ClientData dummy, +static int TestprintObjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestregexpObjCmd(ClientData dummy, +static int TestregexpObjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestreturnObjCmd(ClientData dummy, +static int TestreturnObjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static void TestregexpXflags(const char *string, int length, int *cflagsPtr, int *eflagsPtr); -static int TestsaveresultCmd(ClientData dummy, +static int TestsaveresultCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static void TestsaveresultFree(char *blockPtr); -static int TestsetassocdataCmd(ClientData dummy, +static int TestsetassocdataCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestsetCmd(ClientData dummy, +static int TestsetCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int Testset2Cmd(ClientData dummy, +static int Testset2Cmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestseterrorcodeCmd(ClientData dummy, +static int TestseterrorcodeCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestsetobjerrorcodeCmd( - ClientData dummy, Tcl_Interp *interp, + void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestsetplatformCmd(ClientData dummy, +static int TestsetplatformCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TeststaticpkgCmd(ClientData dummy, +static int TeststaticpkgCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TesttranslatefilenameCmd(ClientData dummy, +static int TesttranslatefilenameCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); -static int TestupvarCmd(ClientData dummy, +static int TestupvarCmd(void *dummy, Tcl_Interp *interp, int argc, const char **argv); static int TestWrongNumArgsObjCmd( - ClientData clientData, Tcl_Interp *interp, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestGetIndexFromObjStructObjCmd( - ClientData clientData, Tcl_Interp *interp, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestChannelCmd(ClientData clientData, +static int TestChannelCmd(void *clientData, + Tcl_Interp *interp, int argc, const char **argv); +static int TestChannelEventCmd(void *clientData, Tcl_Interp *interp, int argc, const char **argv); -static int TestChannelEventCmd(ClientData clientData, +static int TestSocketCmd(void *clientData, Tcl_Interp *interp, int argc, const char **argv); -static int TestFilesystemObjCmd(ClientData dummy, +static int TestFilesystemObjCmd(void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int TestSimpleFilesystemObjCmd( - ClientData dummy, Tcl_Interp *interp, int objc, + void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static void TestReport(const char *cmd, Tcl_Obj *arg1, Tcl_Obj *arg2); @@ -407,31 +416,31 @@ static Tcl_FSListVolumesProc SimpleListVolumes; static Tcl_FSPathInFilesystemProc SimplePathInFilesystem; static Tcl_Obj * SimpleRedirect(Tcl_Obj *pathPtr); static Tcl_FSMatchInDirectoryProc SimpleMatchInDirectory; -static int TestNumUtfCharsCmd(ClientData clientData, +static int TestNumUtfCharsCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestFindFirstCmd(ClientData clientData, +static int TestFindFirstCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestFindLastCmd(ClientData clientData, +static int TestFindLastCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestHashSystemHashCmd(ClientData clientData, +static int TestHashSystemHashCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static Tcl_NRPostProc NREUnwind_callback; -static int TestNREUnwind(ClientData clientData, +static int TestNREUnwind(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestNRELevels(ClientData clientData, +static int TestNRELevels(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int TestInterpResolverCmd(ClientData clientData, +static int TestInterpResolverCmd(void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); #if defined(HAVE_CPUID) || defined(_WIN32) -static int TestcpuidCmd(ClientData dummy, +static int TestcpuidCmd(void *dummy, Tcl_Interp* interp, int objc, Tcl_Obj *const objv[]); #endif @@ -541,20 +550,17 @@ int Tcltest_Init( Tcl_Interp *interp) /* Interpreter for application. */ { - Tcl_ValueType t3ArgTypes[2]; - - Tcl_Obj *listPtr; - Tcl_Obj **objv; + Tcl_Obj **objv, *objPtr; int objc, index; static const char *const specialOptions[] = { "-appinitprocerror", "-appinitprocdeleteinterp", "-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) { @@ -562,10 +568,15 @@ Tcltest_Init( } /* TIP #268: Full patchlevel instead of just major.minor */ - if (Tcl_PkgProvide(interp, "Tcltest", TCL_PATCH_LEVEL) == TCL_ERROR) { + if (Tcl_PkgProvideEx(interp, "Tcltest", TCL_PATCH_LEVEL, NULL) == TCL_ERROR) { return TCL_ERROR; } + objPtr = Tcl_NewStringObj("abc", 3); + (void)Tcl_GetByteArrayFromObj(objPtr, &index); + properByteArrayType = objPtr->typePtr; + Tcl_DecrRefCount(objPtr); + /* * Create additional commands and math functions for testing Tcl. */ @@ -575,6 +586,7 @@ Tcltest_Init( Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testpurebytesobj", TestpurebytesobjObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testbytestring", TestbytestringObjCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "teststringbytes", TeststringbytesObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd, @@ -641,6 +653,8 @@ Tcltest_Init( NULL, NULL); Tcl_CreateCommand(interp, "testgetint", TestgetintCmd, NULL, NULL); + Tcl_CreateCommand(interp, "testlongsize", TestlongsizeCmd, + NULL, NULL); Tcl_CreateCommand(interp, "testgetplatform", TestgetplatformCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testgetvarfullname", @@ -648,6 +662,7 @@ Tcltest_Init( Tcl_CreateCommand(interp, "testinterpdelete", TestinterpdeleteCmd, NULL, NULL); Tcl_CreateCommand(interp, "testlink", TestlinkCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testlinkarray", TestlinkarrayCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testlocale", TestlocaleCmd, NULL, NULL); Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, NULL, NULL); @@ -658,6 +673,10 @@ 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, @@ -669,9 +688,9 @@ Tcltest_Init( Tcl_CreateCommand(interp, "testsetnoerr", TestsetCmd, NULL, NULL); Tcl_CreateCommand(interp, "testseterr", TestsetCmd, - (ClientData) TCL_LEAVE_ERR_MSG, NULL); + INT2PTR(TCL_LEAVE_ERR_MSG), NULL); Tcl_CreateCommand(interp, "testset2", Testset2Cmd, - (ClientData) TCL_LEAVE_ERR_MSG, NULL); + INT2PTR(TCL_LEAVE_ERR_MSG), NULL); Tcl_CreateCommand(interp, "testseterrorcode", TestseterrorcodeCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testsetobjerrorcode", @@ -684,13 +703,13 @@ Tcltest_Init( TestFindLastCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsetplatform", TestsetplatformCmd, NULL, NULL); + Tcl_CreateCommand(interp, "testsocket", TestSocketCmd, + NULL, NULL); Tcl_CreateCommand(interp, "teststaticpkg", TeststaticpkgCmd, NULL, NULL); Tcl_CreateCommand(interp, "testtranslatefilename", TesttranslatefilenameCmd, NULL, NULL); Tcl_CreateCommand(interp, "testupvar", TestupvarCmd, NULL, NULL); - Tcl_CreateMathFunc(interp, "T1", 0, NULL, TestMathFunc, (ClientData) 123); - Tcl_CreateMathFunc(interp, "T2", 0, NULL, TestMathFunc, (ClientData) 345); Tcl_CreateCommand(interp, "testmainthread", TestmainthreadCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsetmainloop", TestsetmainloopCmd, @@ -699,13 +718,8 @@ Tcltest_Init( NULL, NULL); #if defined(HAVE_CPUID) || defined(_WIN32) Tcl_CreateObjCommand(interp, "testcpuid", TestcpuidCmd, - (ClientData) 0, NULL); + NULL, NULL); #endif - t3ArgTypes[0] = TCL_EITHER; - t3ArgTypes[1] = TCL_EITHER; - Tcl_CreateMathFunc(interp, "T3", 2, t3ArgTypes, TestMathFunc2, - NULL); - Tcl_CreateObjCommand(interp, "testnreunwind", TestNREUnwind, NULL, NULL); Tcl_CreateObjCommand(interp, "testnrelevels", TestNRELevels, @@ -719,7 +733,7 @@ Tcltest_Init( if (Procbodytest_Init(interp) != TCL_OK) { return TCL_ERROR; } -#ifdef TCL_THREADS +#if TCL_THREADS if (TclThread_Init(interp) != TCL_OK) { return TCL_ERROR; } @@ -729,9 +743,9 @@ Tcltest_Init( * Check for special options used in ../tests/main.test */ - listPtr = Tcl_GetVar2Ex(interp, "argv", NULL, TCL_GLOBAL_ONLY); - if (listPtr != NULL) { - if (Tcl_ListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) { + objPtr = Tcl_GetVar2Ex(interp, "argv", NULL, TCL_GLOBAL_ONLY); + if (objPtr != NULL) { + if (Tcl_ListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) { return TCL_ERROR; } if (objc && (Tcl_GetIndexFromObj(NULL, objv[0], specialOptions, NULL, @@ -788,7 +802,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); @@ -814,7 +828,7 @@ Tcltest_SafeInit( /* ARGSUSED */ static int TestasyncCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -825,7 +839,7 @@ TestasyncCmd( if (argc < 2) { wrongNumArgs: - Tcl_SetResult(interp, "wrong # args", TCL_STATIC); + Tcl_AppendResult(interp, "wrong # args", NULL); return TCL_ERROR; } if (strcmp(argv[1], "create") == 0) { @@ -899,7 +913,7 @@ TestasyncCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj(argv[3], -1)); Tcl_MutexUnlock(&asyncTestMutex); return code; -#ifdef TCL_THREADS +#if TCL_THREADS } else if (strcmp(argv[1], "marklater") == 0) { if (argc != 3) { goto wrongNumArgs; @@ -915,7 +929,7 @@ TestasyncCmd( if (Tcl_CreateThread(&threadID, AsyncThreadProc, INT2PTR(id), TCL_THREAD_STACK_DEFAULT, TCL_THREAD_NOFLAGS) != TCL_OK) { - Tcl_SetResult(interp, "can't create thread", TCL_STATIC); + Tcl_AppendResult(interp, "can't create thread", NULL); Tcl_MutexUnlock(&asyncTestMutex); return TCL_ERROR; } @@ -939,7 +953,7 @@ TestasyncCmd( static int AsyncHandlerProc( - ClientData clientData, /* If of TestAsyncHandler structure. + void *clientData, /* If of TestAsyncHandler structure. * in global list. */ Tcl_Interp *interp, /* Interpreter in which command was * executed, or NULL. */ @@ -998,10 +1012,10 @@ AsyncHandlerProc( *---------------------------------------------------------------------- */ -#ifdef TCL_THREADS +#if TCL_THREADS static Tcl_ThreadCreateType AsyncThreadProc( - ClientData clientData) /* Parameter is the id of a + void *clientData) /* Parameter is the id of a * TestAsyncHandler, defined above. */ { TestAsyncHandler *asyncPtr; @@ -1043,7 +1057,7 @@ AsyncThreadProc( /* ARGSUSED */ static int TestcmdinfoCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -1056,7 +1070,7 @@ TestcmdinfoCmd( return TCL_ERROR; } if (strcmp(argv[1], "create") == 0) { - Tcl_CreateCommand(interp, argv[2], CmdProc1, (ClientData) "original", + Tcl_CreateCommand(interp, argv[2], CmdProc1, (void *) "original", CmdDelProc1); } else if (strcmp(argv[1], "delete") == 0) { Tcl_DStringInit(&delString); @@ -1064,7 +1078,7 @@ TestcmdinfoCmd( Tcl_DStringResult(interp, &delString); } else if (strcmp(argv[1], "get") == 0) { if (Tcl_GetCommandInfo(interp, argv[2], &info) ==0) { - Tcl_SetResult(interp, "??", TCL_STATIC); + Tcl_AppendResult(interp, "??", NULL); return TCL_OK; } if (info.proc == CmdProc1) { @@ -1093,11 +1107,11 @@ TestcmdinfoCmd( } } else if (strcmp(argv[1], "modify") == 0) { info.proc = CmdProc2; - info.clientData = (ClientData) "new_command_data"; + info.clientData = (void *) "new_command_data"; info.objProc = NULL; info.objClientData = NULL; info.deleteProc = CmdDelProc2; - info.deleteData = (ClientData) "new_delete_data"; + info.deleteData = (void *) "new_delete_data"; if (Tcl_SetCommandInfo(interp, argv[2], &info) == 0) { Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); } else { @@ -1114,7 +1128,7 @@ TestcmdinfoCmd( /*ARGSUSED*/ static int CmdProc1( - ClientData clientData, /* String to return. */ + void *clientData, /* String to return. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -1126,7 +1140,7 @@ CmdProc1( /*ARGSUSED*/ static int CmdProc2( - ClientData clientData, /* String to return. */ + void *clientData, /* String to return. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -1137,7 +1151,7 @@ CmdProc2( static void CmdDelProc1( - ClientData clientData) /* String to save. */ + void *clientData) /* String to save. */ { Tcl_DStringInit(&delString); Tcl_DStringAppend(&delString, "CmdDelProc1 ", -1); @@ -1146,7 +1160,7 @@ CmdDelProc1( static void CmdDelProc2( - ClientData clientData) /* String to save. */ + void *clientData) /* String to save. */ { Tcl_DStringInit(&delString); Tcl_DStringAppend(&delString, "CmdDelProc2 ", -1); @@ -1173,7 +1187,7 @@ CmdDelProc2( /* ARGSUSED */ static int TestcmdtokenCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -1189,9 +1203,9 @@ TestcmdtokenCmd( } if (strcmp(argv[1], "create") == 0) { token = Tcl_CreateCommand(interp, argv[2], CmdProc1, - (ClientData) "original", NULL); + (void *) "original", NULL); sprintf(buf, "%p", (void *)token); - Tcl_SetResult(interp, buf, TCL_VOLATILE); + Tcl_AppendResult(interp, buf, NULL); } else if (strcmp(argv[1], "name") == 0) { Tcl_Obj *objPtr; @@ -1237,7 +1251,7 @@ TestcmdtokenCmd( /* ARGSUSED */ static int TestcmdtraceCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -1293,11 +1307,11 @@ TestcmdtraceCmd( deleteCalled = 0; cmdTrace = Tcl_CreateObjTrace(interp, 50000, TCL_ALLOW_INLINE_COMPILATION, ObjTraceProc, - (ClientData) &deleteCalled, ObjTraceDeleteProc); - result = Tcl_Eval(interp, argv[2]); + &deleteCalled, ObjTraceDeleteProc); + result = Tcl_EvalEx(interp, argv[2], -1, 0); Tcl_DeleteTrace(interp, cmdTrace); if (!deleteCalled) { - Tcl_SetResult(interp, "Delete wasn't called", TCL_STATIC); + Tcl_AppendResult(interp, "Delete wasn't called", NULL); return TCL_ERROR; } else { return result; @@ -1308,7 +1322,7 @@ TestcmdtraceCmd( Tcl_DStringInit(&buffer); t1 = Tcl_CreateTrace(interp, 1, CmdTraceProc, &buffer); t2 = Tcl_CreateTrace(interp, 50000, CmdTraceProc, &buffer); - result = Tcl_Eval(interp, argv[2]); + result = Tcl_EvalEx(interp, argv[2], -1, 0); if (result == TCL_OK) { Tcl_ResetResult(interp); Tcl_AppendResult(interp, Tcl_DStringValue(&buffer), NULL); @@ -1326,7 +1340,7 @@ TestcmdtraceCmd( static void CmdTraceProc( - ClientData clientData, /* Pointer to buffer in which the + void *clientData, /* Pointer to buffer in which the * command and arguments are appended. * Accumulates test result. */ Tcl_Interp *interp, /* Current interpreter. */ @@ -1334,7 +1348,7 @@ CmdTraceProc( char *command, /* The command being traced (after * substitutions). */ Tcl_CmdProc *cmdProc, /* Points to command's command procedure. */ - ClientData cmdClientData, /* Client data associated with command + void *cmdClientData, /* Client data associated with command * procedure. */ int argc, /* Number of arguments. */ const char *argv[]) /* Argument strings. */ @@ -1353,13 +1367,13 @@ CmdTraceProc( static void CmdTraceDeleteProc( - ClientData clientData, /* Unused. */ + void *clientData, /* Unused. */ Tcl_Interp *interp, /* Current interpreter. */ int level, /* Current trace level. */ char *command, /* The command being traced (after * substitutions). */ Tcl_CmdProc *cmdProc, /* Points to command's command procedure. */ - ClientData cmdClientData, /* Client data associated with command + void *cmdClientData, /* Client data associated with command * procedure. */ int argc, /* Number of arguments. */ const char *argv[]) /* Argument strings. */ @@ -1375,7 +1389,7 @@ CmdTraceDeleteProc( static int ObjTraceProc( - ClientData clientData, /* unused */ + void *clientData, /* unused */ Tcl_Interp *interp, /* Tcl interpreter */ int level, /* Execution level */ const char *command, /* Command being executed */ @@ -1403,7 +1417,7 @@ ObjTraceProc( static void ObjTraceDeleteProc( - ClientData clientData) + void *clientData) { int *intPtr = (int *) clientData; *intPtr = 1; /* Record that the trace was deleted */ @@ -1432,7 +1446,7 @@ ObjTraceDeleteProc( static int TestcreatecommandCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -1462,7 +1476,7 @@ TestcreatecommandCmd( static int CreatedCommandProc( - ClientData clientData, /* String to return. */ + void *clientData, /* String to return. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -1484,7 +1498,7 @@ CreatedCommandProc( static int CreatedCommandProc2( - ClientData clientData, /* String to return. */ + void *clientData, /* String to return. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -1523,7 +1537,7 @@ CreatedCommandProc2( /* ARGSUSED */ static int TestdcallCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -1538,10 +1552,10 @@ TestdcallCmd( } if (id < 0) { Tcl_DontCallWhenDeleted(delInterp, DelCallbackProc, - (ClientData) INT2PTR(-id)); + INT2PTR(-id)); } else { Tcl_CallWhenDeleted(delInterp, DelCallbackProc, - (ClientData) INT2PTR(id)); + INT2PTR(id)); } } Tcl_DeleteInterp(delInterp); @@ -1555,7 +1569,7 @@ TestdcallCmd( static void DelCallbackProc( - ClientData clientData, /* Numerical value to append to delString. */ + void *clientData, /* Numerical value to append to delString. */ Tcl_Interp *interp) /* Interpreter being deleted. */ { int id = PTR2INT(clientData); @@ -1588,7 +1602,7 @@ DelCallbackProc( /* ARGSUSED */ static int TestdelCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -1597,7 +1611,7 @@ TestdelCmd( Tcl_Interp *slave; if (argc != 4) { - Tcl_SetResult(interp, "wrong # args", TCL_STATIC); + Tcl_AppendResult(interp, "wrong # args", NULL); return TCL_ERROR; } @@ -1611,14 +1625,14 @@ TestdelCmd( dPtr->deleteCmd = ckalloc(strlen(argv[3]) + 1); strcpy(dPtr->deleteCmd, argv[3]); - Tcl_CreateCommand(slave, argv[2], DelCmdProc, (ClientData) dPtr, + Tcl_CreateCommand(slave, argv[2], DelCmdProc, dPtr, DelDeleteProc); return TCL_OK; } static int DelCmdProc( - ClientData clientData, /* String result to return. */ + void *clientData, /* String result to return. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -1633,11 +1647,11 @@ DelCmdProc( static void DelDeleteProc( - ClientData clientData) /* String command to evaluate. */ + void *clientData) /* String command to evaluate. */ { DelCmd *dPtr = clientData; - Tcl_Eval(dPtr->interp, dPtr->deleteCmd); + Tcl_EvalEx(dPtr->interp, dPtr->deleteCmd, -1, 0); Tcl_ResetResult(dPtr->interp); ckfree(dPtr->deleteCmd); ckfree(dPtr); @@ -1663,7 +1677,7 @@ DelDeleteProc( static int TestdelassocdataCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -1692,14 +1706,14 @@ TestdelassocdataCmd( * Parameters: * fpval - Floating-point value to format. * ndigits - Digit count to request from Tcl_DoubleDigits - * type - One of 'shortest', 'Steele', 'e', 'f' + * type - One of 'shortest', 'e', 'f' * shorten - Indicates that the 'shorten' flag should be passed in. * *----------------------------------------------------------------------------- */ static int -TestdoubledigitsObjCmd(ClientData unused, +TestdoubledigitsObjCmd(void *unused, /* NULL */ Tcl_Interp* interp, /* Tcl interpreter */ @@ -1710,14 +1724,12 @@ TestdoubledigitsObjCmd(ClientData unused, { static const char* options[] = { "shortest", - "Steele", "e", "f", NULL }; static const int types[] = { TCL_DD_SHORTEST, - TCL_DD_STEELE, TCL_DD_E_FORMAT, TCL_DD_F_FORMAT }; @@ -1741,8 +1753,8 @@ TestdoubledigitsObjCmd(ClientData unused, status = Tcl_GetDoubleFromObj(interp, objv[1], &d); if (status != TCL_OK) { doubleType = Tcl_GetObjType("double"); - if (objv[1]->typePtr == doubleType - || TclIsNaN(objv[1]->internalRep.doubleValue)) { + if (Tcl_FetchIntRep(objv[1], doubleType) + && TclIsNaN(objv[1]->internalRep.doubleValue)) { status = TCL_OK; memcpy(&d, &(objv[1]->internalRep.doubleValue), sizeof(double)); } @@ -1793,7 +1805,7 @@ TestdoubledigitsObjCmd(ClientData unused, /* ARGSUSED */ static int TestdstringCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -1802,7 +1814,7 @@ TestdstringCmd( if (argc < 2) { wrongNumArgs: - Tcl_SetResult(interp, "wrong # args", TCL_STATIC); + Tcl_AppendResult(interp, "wrong # args", NULL); return TCL_ERROR; } if (strcmp(argv[1], "append") == 0) { @@ -1838,9 +1850,9 @@ TestdstringCmd( goto wrongNumArgs; } if (strcmp(argv[2], "staticsmall") == 0) { - Tcl_SetResult(interp, "short", TCL_STATIC); + Tcl_AppendResult(interp, "short", NULL); } else if (strcmp(argv[2], "staticlarge") == 0) { - Tcl_SetResult(interp, "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n", TCL_STATIC); + Tcl_AppendResult(interp, "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n", NULL); } else if (strcmp(argv[2], "free") == 0) { char *s = ckalloc(100); strcpy(s, "This is a malloc-ed string"); @@ -1920,7 +1932,7 @@ static void SpecialFree(blockPtr) /* ARGSUSED */ static int TestencodingObjCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -1953,11 +1965,11 @@ TestencodingObjCmd( string = Tcl_GetStringFromObj(objv[3], &length); encodingPtr->toUtfCmd = ckalloc(length + 1); - memcpy(encodingPtr->toUtfCmd, string, (unsigned) length + 1); + memcpy(encodingPtr->toUtfCmd, string, length + 1); string = Tcl_GetStringFromObj(objv[4], &length); encodingPtr->fromUtfCmd = ckalloc(length + 1); - memcpy(encodingPtr->fromUtfCmd, string, (unsigned) (length + 1)); + memcpy(encodingPtr->fromUtfCmd, string, length + 1); string = Tcl_GetStringFromObj(objv[2], &length); @@ -1965,7 +1977,7 @@ TestencodingObjCmd( type.toUtfProc = EncodingToUtfProc; type.fromUtfProc = EncodingFromUtfProc; type.freeProc = EncodingFreeProc; - type.clientData = (ClientData) encodingPtr; + type.clientData = encodingPtr; type.nullSize = 1; Tcl_CreateEncoding(&type); @@ -1975,9 +1987,12 @@ TestencodingObjCmd( if (objc != 3) { return TCL_ERROR; } - encoding = Tcl_GetEncoding(NULL, Tcl_GetString(objv[2])); - Tcl_FreeEncoding(encoding); - Tcl_FreeEncoding(encoding); + if (TCL_OK != Tcl_GetEncodingFromObj(interp, objv[2], &encoding)) { + return TCL_ERROR; + } + Tcl_FreeEncoding(encoding); /* Free returned reference */ + Tcl_FreeEncoding(encoding); /* Free to match CREATE */ + TclFreeIntRep(objv[2]); /* Free the cached ref */ break; } return TCL_OK; @@ -1985,7 +2000,7 @@ TestencodingObjCmd( static int EncodingToUtfProc( - ClientData clientData, /* TclEncoding structure. */ + void *clientData, /* TclEncoding structure. */ const char *src, /* Source string in specified encoding. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ @@ -2000,13 +2015,13 @@ 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) { len = dstLen; } - memcpy(dst, Tcl_GetStringResult(encodingPtr->interp), (unsigned) len); + memcpy(dst, Tcl_GetStringResult(encodingPtr->interp), len); Tcl_ResetResult(encodingPtr->interp); *srcReadPtr = srcLen; @@ -2017,7 +2032,7 @@ EncodingToUtfProc( static int EncodingFromUtfProc( - ClientData clientData, /* TclEncoding structure. */ + void *clientData, /* TclEncoding structure. */ const char *src, /* Source string in specified encoding. */ int srcLen, /* Source string length in bytes. */ int flags, /* Conversion control flags. */ @@ -2032,13 +2047,13 @@ 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) { len = dstLen; } - memcpy(dst, Tcl_GetStringResult(encodingPtr->interp), (unsigned) len); + memcpy(dst, Tcl_GetStringResult(encodingPtr->interp), len); Tcl_ResetResult(encodingPtr->interp); *srcReadPtr = srcLen; @@ -2049,7 +2064,7 @@ EncodingFromUtfProc( static void EncodingFreeProc( - ClientData clientData) /* ClientData associated with type. */ + void *clientData) /* ClientData associated with type. */ { TclEncoding *encodingPtr = clientData; @@ -2077,7 +2092,7 @@ EncodingFreeProc( static int TestevalexObjCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -2122,7 +2137,7 @@ TestevalexObjCmd( static int TestevalobjvObjCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -2171,7 +2186,7 @@ TestevalobjvObjCmd( static int TesteventObjCmd( - ClientData unused, /* Not used */ + void *unused, /* Not used */ Tcl_Interp *interp, /* Tcl interpreter */ int objc, /* Parameter count */ Tcl_Obj *const objv[]) /* Parameter vector */ @@ -2268,14 +2283,14 @@ TesteventProc( if (result != TCL_OK) { Tcl_AddErrorInfo(interp, " (command bound to \"testevent\" callback)"); - Tcl_BackgroundError(interp); + Tcl_BackgroundException(interp, TCL_ERROR); return 1; /* Avoid looping on errors */ } if (Tcl_GetBooleanFromObj(interp, Tcl_GetObjResult(interp), &retval) != TCL_OK) { Tcl_AddErrorInfo(interp, " (return value from \"testevent\" callback)"); - Tcl_BackgroundError(interp); + Tcl_BackgroundException(interp, TCL_ERROR); return 1; } if (retval) { @@ -2307,7 +2322,7 @@ TesteventProc( static int TesteventDeleteProc( Tcl_Event *event, /* Event to examine */ - ClientData clientData) /* Tcl_Obj containing the name of the event(s) + void *clientData) /* Tcl_Obj containing the name of the event(s) * to remove */ { TestEvent *ev; /* Event to examine */ @@ -2350,7 +2365,7 @@ TesteventDeleteProc( static int TestexithandlerCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -2367,10 +2382,10 @@ TestexithandlerCmd( } if (strcmp(argv[1], "create") == 0) { Tcl_CreateExitHandler((value & 1) ? ExitProcOdd : ExitProcEven, - (ClientData) INT2PTR(value)); + INT2PTR(value)); } else if (strcmp(argv[1], "delete") == 0) { Tcl_DeleteExitHandler((value & 1) ? ExitProcOdd : ExitProcEven, - (ClientData) INT2PTR(value)); + INT2PTR(value)); } else { Tcl_AppendResult(interp, "bad option \"", argv[1], "\": must be create or delete", NULL); @@ -2381,7 +2396,7 @@ TestexithandlerCmd( static void ExitProcOdd( - ClientData clientData) /* Integer value to print. */ + void *clientData) /* Integer value to print. */ { char buf[16 + TCL_INTEGER_SPACE]; int len; @@ -2395,7 +2410,7 @@ ExitProcOdd( static void ExitProcEven( - ClientData clientData) /* Integer value to print. */ + void *clientData) /* Integer value to print. */ { char buf[16 + TCL_INTEGER_SPACE]; int len; @@ -2426,7 +2441,7 @@ ExitProcEven( static int TestexprlongCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -2440,7 +2455,7 @@ TestexprlongCmd( " expression\"", NULL); return TCL_ERROR; } - Tcl_SetResult(interp, "This is a result", TCL_STATIC); + Tcl_AppendResult(interp, "This is a result", NULL); result = Tcl_ExprLong(interp, argv[1], &exprResult); if (result != TCL_OK) { return result; @@ -2469,7 +2484,7 @@ TestexprlongCmd( static int TestexprlongobjCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Argument objects. */ @@ -2482,7 +2497,7 @@ TestexprlongobjCmd( Tcl_WrongNumArgs(interp, 1, objv, "expression"); return TCL_ERROR; } - Tcl_SetResult(interp, "This is a result", TCL_STATIC); + Tcl_AppendResult(interp, "This is a result", NULL); result = Tcl_ExprLongObj(interp, objv[1], &exprResult); if (result != TCL_OK) { return result; @@ -2511,7 +2526,7 @@ TestexprlongobjCmd( static int TestexprdoubleCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -2525,7 +2540,7 @@ TestexprdoubleCmd( " expression\"", NULL); return TCL_ERROR; } - Tcl_SetResult(interp, "This is a result", TCL_STATIC); + Tcl_AppendResult(interp, "This is a result", NULL); result = Tcl_ExprDouble(interp, argv[1], &exprResult); if (result != TCL_OK) { return result; @@ -2555,7 +2570,7 @@ TestexprdoubleCmd( static int TestexprdoubleobjCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const *objv) /* Argument objects. */ @@ -2568,7 +2583,7 @@ TestexprdoubleobjCmd( Tcl_WrongNumArgs(interp, 1, objv, "expression"); return TCL_ERROR; } - Tcl_SetResult(interp, "This is a result", TCL_STATIC); + Tcl_AppendResult(interp, "This is a result", NULL); result = Tcl_ExprDoubleObj(interp, objv[1], &exprResult); if (result != TCL_OK) { return result; @@ -2597,7 +2612,7 @@ TestexprdoubleobjCmd( static int TestexprstringCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -2629,7 +2644,7 @@ TestexprstringCmd( static int TestfilelinkCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ @@ -2696,7 +2711,7 @@ TestfilelinkCmd( static int TestgetassocdataCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -2734,7 +2749,7 @@ TestgetassocdataCmd( static int TestgetplatformCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -2775,7 +2790,7 @@ TestgetplatformCmd( /* ARGSUSED */ static int TestinterpdeleteCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -2816,7 +2831,7 @@ TestinterpdeleteCmd( /* ARGSUSED */ static int TestlinkCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -2824,7 +2839,7 @@ TestlinkCmd( static int intVar = 43; static int boolVar = 4; static double realVar = 1.23; - static Tcl_WideInt wideVar = Tcl_LongAsWide(79); + static Tcl_WideInt wideVar = 79; static char *stringVar = NULL; static char charVar = '@'; static unsigned char ucharVar = 130; @@ -2834,7 +2849,7 @@ TestlinkCmd( static long longVar = 123456789L; static unsigned long ulongVar = 3456789012UL; static float floatVar = 4.5; - static Tcl_WideUInt uwideVar = (Tcl_WideUInt) Tcl_LongAsWide(123); + static Tcl_WideUInt uwideVar = 123; static int created = 0; char buffer[2*TCL_DOUBLE_SPACE]; int writable, flag; @@ -3024,10 +3039,10 @@ TestlinkCmd( Tcl_AppendElement(interp, buffer); TclFormatInt(buffer, (int) uintVar); Tcl_AppendElement(interp, buffer); - tmp = Tcl_NewLongObj(longVar); + tmp = Tcl_NewWideIntObj(longVar); Tcl_AppendElement(interp, Tcl_GetString(tmp)); Tcl_DecrRefCount(tmp); - tmp = Tcl_NewLongObj((long)ulongVar); + tmp = Tcl_NewWideIntObj((long)ulongVar); Tcl_AppendElement(interp, Tcl_GetString(tmp)); Tcl_DecrRefCount(tmp); Tcl_PrintDouble(NULL, (double)floatVar, buffer); @@ -3268,6 +3283,124 @@ TestlinkCmd( /* *---------------------------------------------------------------------- * + * TestlinkarrayCmd -- + * + * This function is invoked to process the "testlinkarray" Tcl command. + * It is used to test the 'Tcl_LinkArray' function. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Creates, deletes, and invokes variable links. + * + *---------------------------------------------------------------------- + */ + +static int +TestlinkarrayCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + static const char *LinkOption[] = { + "update", "remove", "create", NULL + }; + enum LinkOption { LINK_UPDATE, LINK_REMOVE, LINK_CREATE }; + static const char *LinkType[] = { + "char", "uchar", "short", "ushort", "int", "uint", "long", "ulong", + "wide", "uwide", "float", "double", "string", "char*", "binary", NULL + }; + /* all values after TCL_LINK_CHARS_ARRAY are used as arrays (see below) */ + static int LinkTypes[] = { + TCL_LINK_CHAR, TCL_LINK_UCHAR, + TCL_LINK_SHORT, TCL_LINK_USHORT, TCL_LINK_INT, TCL_LINK_UINT, + TCL_LINK_LONG, TCL_LINK_ULONG, TCL_LINK_WIDE_INT, TCL_LINK_WIDE_UINT, + TCL_LINK_FLOAT, TCL_LINK_DOUBLE, TCL_LINK_STRING, TCL_LINK_CHARS, + TCL_LINK_BINARY + }; + int optionIndex, typeIndex, readonly, i, size, length; + char *name, *arg; + Tcl_WideInt addr; + + if (objc < 2) { + Tcl_WrongNumArgs(interp, 1, objv, "option args"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], LinkOption, "option", 0, + &optionIndex) != TCL_OK) { + return TCL_ERROR; + } + switch ((enum LinkOption) optionIndex) { + case LINK_UPDATE: + for (i=2; i<objc; i++) { + Tcl_UpdateLinkedVar(interp, Tcl_GetString(objv[i])); + } + return TCL_OK; + case LINK_REMOVE: + for (i=2; i<objc; i++) { + Tcl_UnlinkVar(interp, Tcl_GetString(objv[i])); + } + return TCL_OK; + case LINK_CREATE: + if (objc < 4) { + goto wrongArgs; + } + readonly = 0; + i = 2; + + /* + * test on switch -r... + */ + + arg = Tcl_GetStringFromObj(objv[i], &length); + if (length < 2) { + goto wrongArgs; + } + if (arg[0] == '-') { + if (arg[1] != 'r') { + goto wrongArgs; + } + readonly = TCL_LINK_READ_ONLY; + i++; + } + if (Tcl_GetIndexFromObj(interp, objv[i++], LinkType, "type", 0, + &typeIndex) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetIntFromObj(interp, objv[i++], &size) == TCL_ERROR) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("wrong size value", -1)); + return TCL_ERROR; + } + name = Tcl_GetString(objv[i++]); + + /* + * If no address is given request one in the underlying function + */ + + if (i < objc) { + if (Tcl_GetWideIntFromObj(interp, objv[i], &addr) == TCL_ERROR) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "wrong address value", -1)); + return TCL_ERROR; + } + } else { + addr = 0; + } + return Tcl_LinkArray(interp, name, INT2PTR(addr), + LinkTypes[typeIndex] | readonly, size); + } + return TCL_OK; + + wrongArgs: + Tcl_WrongNumArgs(interp, 2, objv, "?-readonly? type size name ?address?"); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * * TestlocaleCmd -- * * This procedure implements the "testlocale" command. It is used @@ -3284,7 +3417,7 @@ TestlinkCmd( static int TestlocaleCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ @@ -3330,144 +3463,6 @@ TestlocaleCmd( /* *---------------------------------------------------------------------- * - * TestMathFunc -- - * - * This is a user-defined math procedure to test out math procedures - * with no arguments. - * - * Results: - * A normal Tcl completion code. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -TestMathFunc( - ClientData clientData, /* Integer value to return. */ - Tcl_Interp *interp, /* Not used. */ - Tcl_Value *args, /* Not used. */ - Tcl_Value *resultPtr) /* Where to store result. */ -{ - resultPtr->type = TCL_INT; - resultPtr->intValue = PTR2INT(clientData); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TestMathFunc2 -- - * - * This is a user-defined math procedure to test out math procedures - * that do have arguments, in this case 2. - * - * Results: - * A normal Tcl completion code. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - - /* ARGSUSED */ -static int -TestMathFunc2( - ClientData clientData, /* Integer value to return. */ - Tcl_Interp *interp, /* Used to report errors. */ - Tcl_Value *args, /* Points to an array of two Tcl_Value structs - * for the two arguments. */ - Tcl_Value *resultPtr) /* Where to store the result. */ -{ - int result = TCL_OK; - - /* - * Return the maximum of the two arguments with the correct type. - */ - - if (args[0].type == TCL_INT) { - int i0 = args[0].intValue; - - if (args[1].type == TCL_INT) { - int i1 = args[1].intValue; - - resultPtr->type = TCL_INT; - resultPtr->intValue = ((i0 > i1)? i0 : i1); - } else if (args[1].type == TCL_DOUBLE) { - double d0 = i0; - double d1 = args[1].doubleValue; - - resultPtr->type = TCL_DOUBLE; - resultPtr->doubleValue = ((d0 > d1)? d0 : d1); - } else if (args[1].type == TCL_WIDE_INT) { - Tcl_WideInt w0 = Tcl_LongAsWide(i0); - Tcl_WideInt w1 = args[1].wideValue; - - resultPtr->type = TCL_WIDE_INT; - resultPtr->wideValue = ((w0 > w1)? w0 : w1); - } else { - Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC); - result = TCL_ERROR; - } - } else if (args[0].type == TCL_DOUBLE) { - double d0 = args[0].doubleValue; - - if (args[1].type == TCL_INT) { - double d1 = args[1].intValue; - - resultPtr->type = TCL_DOUBLE; - resultPtr->doubleValue = ((d0 > d1)? d0 : d1); - } else if (args[1].type == TCL_DOUBLE) { - double d1 = args[1].doubleValue; - - resultPtr->type = TCL_DOUBLE; - resultPtr->doubleValue = ((d0 > d1)? d0 : d1); - } else if (args[1].type == TCL_WIDE_INT) { - double d1 = Tcl_WideAsDouble(args[1].wideValue); - - resultPtr->type = TCL_DOUBLE; - resultPtr->doubleValue = ((d0 > d1)? d0 : d1); - } else { - Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC); - result = TCL_ERROR; - } - } else if (args[0].type == TCL_WIDE_INT) { - Tcl_WideInt w0 = args[0].wideValue; - - if (args[1].type == TCL_INT) { - Tcl_WideInt w1 = Tcl_LongAsWide(args[1].intValue); - - resultPtr->type = TCL_WIDE_INT; - resultPtr->wideValue = ((w0 > w1)? w0 : w1); - } else if (args[1].type == TCL_DOUBLE) { - double d0 = Tcl_WideAsDouble(w0); - double d1 = args[1].doubleValue; - - resultPtr->type = TCL_DOUBLE; - resultPtr->doubleValue = ((d0 > d1)? d0 : d1); - } else if (args[1].type == TCL_WIDE_INT) { - Tcl_WideInt w1 = args[1].wideValue; - - resultPtr->type = TCL_WIDE_INT; - resultPtr->wideValue = ((w0 > w1)? w0 : w1); - } else { - Tcl_SetResult(interp, "T3: wrong type for arg 2", TCL_STATIC); - result = TCL_ERROR; - } - } else { - Tcl_SetResult(interp, "T3: wrong type for arg 1", TCL_STATIC); - result = TCL_ERROR; - } - return result; -} - -/* - *---------------------------------------------------------------------- - * * CleanupTestSetassocdataTests -- * * This function is called when an interpreter is deleted to clean @@ -3484,7 +3479,7 @@ TestMathFunc2( /* ARGSUSED */ static void CleanupTestSetassocdataTests( - ClientData clientData, /* Data to be released. */ + void *clientData, /* Data to be released. */ Tcl_Interp *interp) /* Interpreter being deleted. */ { ckfree(clientData); @@ -3509,7 +3504,7 @@ CleanupTestSetassocdataTests( static int TestparserObjCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ @@ -3565,7 +3560,7 @@ TestparserObjCmd( static int TestexprparserObjCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ @@ -3712,7 +3707,7 @@ PrintParse( static int TestparsevarObjCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ @@ -3753,7 +3748,7 @@ TestparsevarObjCmd( static int TestparsevarnameObjCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ @@ -3799,6 +3794,75 @@ 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( + void *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( + void *clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ +{ + Tcl_WideInt argv1 = 0; + size_t argv2; + + if (objc < 2 || objc > 3) { + Tcl_WrongNumArgs(interp, 1, objv, "format wideint"); + } + + if (objc > 1) { + Tcl_GetWideIntFromObj(interp, objv[2], &argv1); + } + argv2 = (size_t)argv1; + Tcl_SetObjResult(interp, Tcl_ObjPrintf(Tcl_GetString(objv[1]), argv1, argv2, argv2)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TestregexpObjCmd -- * * This procedure implements the "testregexp" command. It is used to give @@ -3818,7 +3882,7 @@ TestparsevarnameObjCmd( /* ARGSUSED */ static int TestregexpObjCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -3942,7 +4006,7 @@ TestregexpObjCmd( varName = Tcl_GetString(objv[2]); TclRegExpRangeUniChar(regExpr, -1, &start, &end); sprintf(resinfo, "%d %d", start, end-1); - value = Tcl_SetVar(interp, varName, resinfo, 0); + value = Tcl_SetVar2(interp, varName, NULL, resinfo, 0); if (value == NULL) { Tcl_AppendResult(interp, "couldn't set variable \"", varName, "\"", NULL); @@ -3956,7 +4020,7 @@ TestregexpObjCmd( Tcl_RegExpGetInfo(regExpr, &info); varName = Tcl_GetString(objv[2]); sprintf(resinfo, "%ld", info.extendStart); - value = Tcl_SetVar(interp, varName, resinfo, 0); + value = Tcl_SetVar2(interp, varName, NULL, resinfo, 0); if (value == NULL) { Tcl_AppendResult(interp, "couldn't set variable \"", varName, "\"", NULL); @@ -4003,8 +4067,8 @@ TestregexpObjCmd( end--; } - objs[0] = Tcl_NewLongObj(start); - objs[1] = Tcl_NewLongObj(end); + objs[0] = Tcl_NewWideIntObj(start); + objs[1] = Tcl_NewWideIntObj(end); newPtr = Tcl_NewListObj(2, objs); } else { @@ -4142,7 +4206,7 @@ TestregexpXflags( /* ARGSUSED */ static int TestreturnObjCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -4170,7 +4234,7 @@ TestreturnObjCmd( static int TestsetassocdataCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -4197,8 +4261,7 @@ TestsetassocdataCmd( ckfree(oldData); } - Tcl_SetAssocData(interp, argv[1], CleanupTestSetassocdataTests, - (ClientData) buf); + Tcl_SetAssocData(interp, argv[1], CleanupTestSetassocdataTests, buf); return TCL_OK; } @@ -4222,7 +4285,7 @@ TestsetassocdataCmd( static int TestsetplatformCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -4271,7 +4334,7 @@ TestsetplatformCmd( static int TeststaticpkgCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -4289,7 +4352,7 @@ TeststaticpkgCmd( if (Tcl_GetInt(interp, argv[3], &loaded) != TCL_OK) { return TCL_ERROR; } - tclStubsPtr->tcl_StaticPackage((loaded) ? interp : NULL, argv[1], + Tcl_StaticPackage((loaded) ? interp : NULL, argv[1], StaticInitProc, (safe) ? StaticInitProc : NULL); return TCL_OK; } @@ -4299,7 +4362,7 @@ StaticInitProc( Tcl_Interp *interp) /* Interpreter in which package is supposedly * being loaded. */ { - Tcl_SetVar(interp, "x", "loaded", TCL_GLOBAL_ONLY); + Tcl_SetVar2(interp, "x", NULL, "loaded", TCL_GLOBAL_ONLY); return TCL_OK; } @@ -4322,7 +4385,7 @@ StaticInitProc( static int TesttranslatefilenameCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -4364,7 +4427,7 @@ TesttranslatefilenameCmd( /* ARGSUSED */ static int TestupvarCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -4383,7 +4446,7 @@ TestupvarCmd( } else if (strcmp(argv[4], "namespace") == 0) { flags = TCL_NAMESPACE_ONLY; } - return Tcl_UpVar(interp, argv[1], argv[2], argv[3], flags); + return Tcl_UpVar2(interp, argv[1], argv[2], NULL, argv[3], flags); } else { if (strcmp(argv[5], "global") == 0) { flags = TCL_GLOBAL_ONLY; @@ -4417,13 +4480,13 @@ TestupvarCmd( /* ARGSUSED */ static int TestseterrorcodeCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ { if (argc > 6) { - Tcl_SetResult(interp, "too many args", TCL_STATIC); + Tcl_AppendResult(interp, "too many args", NULL); return TCL_ERROR; } switch (argc) { @@ -4470,7 +4533,7 @@ TestseterrorcodeCmd( /* ARGSUSED */ static int TestsetobjerrorcodeCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ @@ -4499,7 +4562,7 @@ TestsetobjerrorcodeCmd( /* ARGSUSED */ static int TestfeventCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -4571,7 +4634,7 @@ TestfeventCmd( static int TestpanicCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -4592,7 +4655,7 @@ TestpanicCmd( static int TestfileCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ Tcl_Obj *const argv[]) /* The argument objects. */ @@ -4674,7 +4737,7 @@ TestfileCmd( static int TestgetvarfullnameCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ @@ -4748,7 +4811,7 @@ TestgetvarfullnameCmd( static int GetTimesObjCmd( - ClientData unused, /* Unused. */ + void *unused, /* Unused. */ Tcl_Interp *interp, /* The current interpreter. */ int notused1, /* Number of arguments. */ Tcl_Obj *const notused2[]) /* The argument objects. */ @@ -4877,10 +4940,10 @@ GetTimesObjCmd( timePer/100000); /* Tcl_SetVar 100000 times */ - fprintf(stderr, "Tcl_SetVar of \"12345\" 100000 times\n"); + fprintf(stderr, "Tcl_SetVar2 of \"12345\" 100000 times\n"); Tcl_GetTime(&start); for (i = 0; i < 100000; i++) { - s = Tcl_SetVar(interp, "a", "12345", TCL_LEAVE_ERR_MSG); + s = Tcl_SetVar2(interp, "a", NULL, "12345", TCL_LEAVE_ERR_MSG); if (s == NULL) { return TCL_ERROR; } @@ -4894,7 +4957,7 @@ GetTimesObjCmd( fprintf(stderr, "Tcl_GetVar of a==\"12345\" 100000 times\n"); Tcl_GetTime(&start); for (i = 0; i < 100000; i++) { - s = Tcl_GetVar(interp, "a", TCL_LEAVE_ERR_MSG); + s = Tcl_GetVar2(interp, "a", NULL, TCL_LEAVE_ERR_MSG); if (s == NULL) { return TCL_ERROR; } @@ -4927,7 +4990,7 @@ GetTimesObjCmd( static int NoopCmd( - ClientData unused, /* Unused. */ + void *unused, /* Unused. */ Tcl_Interp *interp, /* The current interpreter. */ int argc, /* The number of arguments. */ const char **argv) /* The argument strings. */ @@ -4954,7 +5017,7 @@ NoopCmd( static int NoopObjCmd( - ClientData unused, /* Not used. */ + void *unused, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ @@ -4965,6 +5028,40 @@ NoopObjCmd( /* *---------------------------------------------------------------------- * + * TeststringbytesObjCmd -- + * Returns bytearray value of the bytes in argument string rep + * + * Results: + * Returns the TCL_OK result code. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +TeststringbytesObjCmd( + void *unused, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ +{ + int n; + const unsigned char *p; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "value"); + return TCL_ERROR; + } + p = (const unsigned char *)Tcl_GetStringFromObj(objv[1], &n); + Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(p, n)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TestpurebytesobjObjCmd -- * * This object-based procedure constructs a pure bytes object @@ -5032,12 +5129,12 @@ TestpurebytesobjObjCmd( static int TestbytestringObjCmd( - ClientData unused, /* Not used. */ + void *unused, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ { - int n; + int n = 0; const char *p; if (objc != 2) { @@ -5045,6 +5142,10 @@ TestbytestringObjCmd( return TCL_ERROR; } p = (const char *)Tcl_GetByteArrayFromObj(objv[1], &n); + if ((p == NULL) || !Tcl_FetchIntRep(objv[1], properByteArrayType)) { + Tcl_AppendResult(interp, "testbytestring expects bytes", NULL); + return TCL_ERROR; + } Tcl_SetObjResult(interp, Tcl_NewStringObj(p, n)); return TCL_OK; } @@ -5069,7 +5170,7 @@ TestbytestringObjCmd( /* ARGSUSED */ static int TestsetCmd( - ClientData data, /* Additional flags for Get/SetVar2. */ + void *data, /* Additional flags for Get/SetVar2. */ register Tcl_Interp *interp,/* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -5078,7 +5179,7 @@ TestsetCmd( const char *value; if (argc == 2) { - Tcl_SetResult(interp, "before get", TCL_STATIC); + Tcl_AppendResult(interp, "before get", NULL); value = Tcl_GetVar2(interp, argv[1], NULL, flags); if (value == NULL) { return TCL_ERROR; @@ -5086,7 +5187,7 @@ TestsetCmd( Tcl_AppendElement(interp, value); return TCL_OK; } else if (argc == 3) { - Tcl_SetResult(interp, "before set", TCL_STATIC); + Tcl_AppendResult(interp, "before set", NULL); value = Tcl_SetVar2(interp, argv[1], NULL, argv[2], flags); if (value == NULL) { return TCL_ERROR; @@ -5101,7 +5202,7 @@ TestsetCmd( } static int Testset2Cmd( - ClientData data, /* Additional flags for Get/SetVar2. */ + void *data, /* Additional flags for Get/SetVar2. */ register Tcl_Interp *interp,/* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -5110,7 +5211,7 @@ Testset2Cmd( const char *value; if (argc == 3) { - Tcl_SetResult(interp, "before get", TCL_STATIC); + Tcl_AppendResult(interp, "before get", NULL); value = Tcl_GetVar2(interp, argv[1], argv[2], flags); if (value == NULL) { return TCL_ERROR; @@ -5118,7 +5219,7 @@ Testset2Cmd( Tcl_AppendElement(interp, value); return TCL_OK; } else if (argc == 4) { - Tcl_SetResult(interp, "before set", TCL_STATIC); + Tcl_AppendResult(interp, "before set", NULL); value = Tcl_SetVar2(interp, argv[1], argv[2], argv[3], flags); if (value == NULL) { return TCL_ERROR; @@ -5152,7 +5253,7 @@ Testset2Cmd( /* ARGSUSED */ static int TestsaveresultCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ register Tcl_Interp *interp,/* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* The argument objects. */ @@ -5184,10 +5285,11 @@ TestsaveresultCmd( return TCL_ERROR; } + freeCount = 0; objPtr = NULL; /* Lint. */ switch ((enum options) index) { case RESULT_SMALL: - Tcl_SetResult(interp, "small result", TCL_VOLATILE); + Tcl_AppendResult(interp, "small result", NULL); break; case RESULT_APPEND: Tcl_AppendResult(interp, "append result", NULL); @@ -5208,13 +5310,12 @@ TestsaveresultCmd( break; } - freeCount = 0; Tcl_SaveResult(interp, &state); if (((enum options) index) == RESULT_OBJECT) { result = Tcl_EvalObjEx(interp, objv[2], 0); } else { - result = Tcl_Eval(interp, Tcl_GetString(objv[2])); + result = Tcl_EvalEx(interp, Tcl_GetString(objv[2]), -1, 0); } if (discard) { @@ -5226,11 +5327,9 @@ TestsaveresultCmd( switch ((enum options) index) { case RESULT_DYNAMIC: { - int present = iPtr->freeProc == TestsaveresultFree; - int called = freeCount; + int presentOrFreed = (iPtr->freeProc == TestsaveresultFree) ^ freeCount; - Tcl_AppendElement(interp, called ? "called" : "notCalled"); - Tcl_AppendElement(interp, present ? "present" : "missing"); + Tcl_AppendElement(interp, presentOrFreed ? "presentOrFreed" : "missingOrLeak"); break; } case RESULT_OBJECT: @@ -5285,7 +5384,7 @@ TestsaveresultFree( static int TestmainthreadCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ register Tcl_Interp *interp,/* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -5296,7 +5395,7 @@ TestmainthreadCmd( Tcl_SetObjResult(interp, idObj); return TCL_OK; } else { - Tcl_SetResult(interp, "wrong # args", TCL_STATIC); + Tcl_AppendResult(interp, "wrong # args", NULL); return TCL_ERROR; } } @@ -5346,7 +5445,7 @@ MainLoop(void) static int TestsetmainloopCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ register Tcl_Interp *interp,/* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -5375,7 +5474,7 @@ TestsetmainloopCmd( static int TestexitmainloopCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ register Tcl_Interp *interp,/* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -5404,7 +5503,7 @@ TestexitmainloopCmd( /* ARGSUSED */ static int TestChannelCmd( - ClientData clientData, /* Not used. */ + void *clientData, /* Not used. */ Tcl_Interp *interp, /* Interpreter for result. */ int argc, /* Count of additional args. */ const char **argv) /* Additional arg strings. */ @@ -5873,7 +5972,7 @@ TestChannelCmd( /* ARGSUSED */ static int TestChannelEventCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -5898,7 +5997,7 @@ TestChannelEventCmd( cmd = argv[2]; len = strlen(cmd); - if ((cmd[0] == 'a') && (strncmp(cmd, "add", (unsigned) len) == 0)) { + if ((cmd[0] == 'a') && (strncmp(cmd, "add", len) == 0)) { if (argc != 5) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " channelName add eventSpec script\"", NULL); @@ -5927,12 +6026,12 @@ TestChannelEventCmd( Tcl_IncrRefCount(esPtr->scriptPtr); Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask, - TclChannelEventScriptInvoker, (ClientData) esPtr); + TclChannelEventScriptInvoker, esPtr); return TCL_OK; } - if ((cmd[0] == 'd') && (strncmp(cmd, "delete", (unsigned) len) == 0)) { + if ((cmd[0] == 'd') && (strncmp(cmd, "delete", len) == 0)) { if (argc != 4) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " channelName delete index\"", NULL); @@ -5971,14 +6070,14 @@ TestChannelEventCmd( prevEsPtr->nextPtr = esPtr->nextPtr; } Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, - TclChannelEventScriptInvoker, (ClientData) esPtr); + TclChannelEventScriptInvoker, esPtr); Tcl_DecrRefCount(esPtr->scriptPtr); ckfree(esPtr); return TCL_OK; } - if ((cmd[0] == 'l') && (strncmp(cmd, "list", (unsigned) len) == 0)) { + if ((cmd[0] == 'l') && (strncmp(cmd, "list", len) == 0)) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " channelName list\"", NULL); @@ -6001,7 +6100,7 @@ TestChannelEventCmd( return TCL_OK; } - if ((cmd[0] == 'r') && (strncmp(cmd, "removeall", (unsigned) len) == 0)) { + if ((cmd[0] == 'r') && (strncmp(cmd, "removeall", len) == 0)) { if (argc != 3) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " channelName removeall\"", NULL); @@ -6012,7 +6111,7 @@ TestChannelEventCmd( esPtr = nextEsPtr) { nextEsPtr = esPtr->nextPtr; Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, - TclChannelEventScriptInvoker, (ClientData) esPtr); + TclChannelEventScriptInvoker, esPtr); Tcl_DecrRefCount(esPtr->scriptPtr); ckfree(esPtr); } @@ -6020,7 +6119,7 @@ TestChannelEventCmd( return TCL_OK; } - if ((cmd[0] == 's') && (strncmp(cmd, "set", (unsigned) len) == 0)) { + if ((cmd[0] == 's') && (strncmp(cmd, "set", len) == 0)) { if (argc != 5) { Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], " channelName delete index event\"", NULL); @@ -6058,7 +6157,7 @@ TestChannelEventCmd( } esPtr->mask = mask; Tcl_CreateChannelHandler((Tcl_Channel) chanPtr, mask, - TclChannelEventScriptInvoker, (ClientData) esPtr); + TclChannelEventScriptInvoker, esPtr); return TCL_OK; } Tcl_AppendResult(interp, "bad command ", cmd, ", must be one of " @@ -6069,6 +6168,75 @@ TestChannelEventCmd( /* *---------------------------------------------------------------------- * + * TestSocketCmd -- + * + * Implements the Tcl "testsocket" debugging command and its + * subcommands. This is part of the testing environment. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +TestSocketCmd( + void *clientData, /* Not used. */ + Tcl_Interp *interp, /* Interpreter for result. */ + int argc, /* Count of additional args. */ + const char **argv) /* Additional arg strings. */ +{ + const char *cmdName; /* Sub command. */ + size_t len; /* Length of subcommand string. */ + + if (argc < 2) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " subcommand ?additional args..?\"", NULL); + return TCL_ERROR; + } + cmdName = argv[1]; + len = strlen(cmdName); + + if ((cmdName[0] == 't') && (strncmp(cmdName, "testflags", len) == 0)) { + Tcl_Channel hChannel; + int modePtr; + TcpState *statePtr; + /* Set test value in the socket driver + */ + /* Check for argument "channel name" + */ + if (argc < 4) { + Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0], + " testflags channel flags\"", NULL); + return TCL_ERROR; + } + hChannel = Tcl_GetChannel(interp, argv[2], &modePtr); + if ( NULL == hChannel ) { + Tcl_AppendResult(interp, "unknown channel:", argv[2], NULL); + return TCL_ERROR; + } + statePtr = (TcpState *)Tcl_GetChannelInstanceData(hChannel); + if ( NULL == statePtr) { + Tcl_AppendResult(interp, "No channel instance data:", argv[2], + NULL); + return TCL_ERROR; + } + statePtr->testFlags = atoi(argv[3]); + return TCL_OK; + } + + Tcl_AppendResult(interp, "bad option \"", cmdName, "\": should be " + "testflags", NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * * TestWrongNumArgsObjCmd -- * * Test the Tcl_WrongNumArgs function. @@ -6084,7 +6252,7 @@ TestChannelEventCmd( static int TestWrongNumArgsObjCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -6097,7 +6265,7 @@ TestWrongNumArgsObjCmd( * Don't use Tcl_WrongNumArgs here, as that is the function * we want to test! */ - Tcl_SetResult(interp, "insufficient arguments", TCL_STATIC); + Tcl_AppendResult(interp, "insufficient arguments", NULL); return TCL_ERROR; } @@ -6114,7 +6282,7 @@ TestWrongNumArgsObjCmd( /* * Asked for more arguments than were given. */ - Tcl_SetResult(interp, "insufficient arguments", TCL_STATIC); + Tcl_AppendResult(interp, "insufficient arguments", NULL); return TCL_ERROR; } @@ -6140,7 +6308,7 @@ TestWrongNumArgsObjCmd( static int TestGetIndexFromObjStructObjCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -6194,7 +6362,7 @@ TestGetIndexFromObjStructObjCmd( static int TestFilesystemObjCmd( - ClientData dummy, + void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -6210,7 +6378,7 @@ TestFilesystemObjCmd( return TCL_ERROR; } if (boolVal) { - res = Tcl_FSRegister((ClientData)interp, &testReportingFilesystem); + res = Tcl_FSRegister(interp, &testReportingFilesystem); msg = (res == TCL_OK) ? "registered" : "failed"; } else { res = Tcl_FSUnregister(&testReportingFilesystem); @@ -6223,7 +6391,7 @@ TestFilesystemObjCmd( static int TestReportInFilesystem( Tcl_Obj *pathPtr, - ClientData *clientDataPtr) + void **clientDataPtr) { static Tcl_Obj *lastPathPtr = NULL; Tcl_Obj *newPathPtr; @@ -6245,7 +6413,7 @@ TestReportInFilesystem( return -1; } lastPathPtr = NULL; - *clientDataPtr = (ClientData) newPathPtr; + *clientDataPtr = newPathPtr; return TCL_OK; } @@ -6263,7 +6431,7 @@ TestReportGetNativePath( static void TestReportFreeInternalRep( - ClientData clientData) + void *clientData) { Tcl_Obj *nativeRep = (Tcl_Obj *) clientData; @@ -6275,7 +6443,7 @@ TestReportFreeInternalRep( static ClientData TestReportDupInternalRep( - ClientData clientData) + void *clientData) { Tcl_Obj *original = (Tcl_Obj *) clientData; @@ -6316,7 +6484,7 @@ TestReport( savedResult = Tcl_GetObjResult(interp); Tcl_IncrRefCount(savedResult); Tcl_SetObjResult(interp, Tcl_NewObj()); - Tcl_Eval(interp, Tcl_DStringValue(&ds)); + Tcl_EvalEx(interp, Tcl_DStringValue(&ds), -1, 0); Tcl_DStringFree(&ds); Tcl_ResetResult(interp); Tcl_SetObjResult(interp, savedResult); @@ -6541,7 +6709,7 @@ TestReportNormalizePath( static int SimplePathInFilesystem( Tcl_Obj *pathPtr, - ClientData *clientDataPtr) + void **clientDataPtr) { const char *str = Tcl_GetString(pathPtr); @@ -6570,7 +6738,7 @@ SimplePathInFilesystem( static int TestSimpleFilesystemObjCmd( - ClientData dummy, + void *dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -6586,7 +6754,7 @@ TestSimpleFilesystemObjCmd( return TCL_ERROR; } if (boolVal) { - res = Tcl_FSRegister((ClientData)interp, &simpleFilesystem); + res = Tcl_FSRegister(interp, &simpleFilesystem); msg = (res == TCL_OK) ? "registered" : "failed"; } else { res = Tcl_FSUnregister(&simpleFilesystem); @@ -6730,7 +6898,7 @@ SimpleListVolumes(void) static int TestNumUtfCharsCmd( - ClientData clientData, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -6753,7 +6921,7 @@ TestNumUtfCharsCmd( static int TestFindFirstCmd( - ClientData clientData, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -6775,7 +6943,7 @@ TestFindFirstCmd( static int TestFindLastCmd( - ClientData clientData, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -6817,13 +6985,13 @@ TestFindLastCmd( static int TestcpuidCmd( - ClientData dummy, + void *dummy, Tcl_Interp* interp, /* Tcl interpreter */ int objc, /* Parameter count */ Tcl_Obj *const * objv) /* Parameter vector */ { int status, index, i; - unsigned int regs[4]; + int regs[4]; Tcl_Obj *regsObjs[4]; if (objc != 2) { @@ -6833,14 +7001,14 @@ TestcpuidCmd( if (Tcl_GetIntFromObj(interp, objv[1], &index) != TCL_OK) { return TCL_ERROR; } - status = TclWinCPUID((unsigned) index, regs); + status = TclWinCPUID(index, regs); if (status != TCL_OK) { Tcl_SetObjResult(interp, Tcl_NewStringObj("operation not available", -1)); return status; } for (i=0 ; i<4 ; ++i) { - regsObjs[i] = Tcl_NewIntObj((int) regs[i]); + regsObjs[i] = Tcl_NewIntObj(regs[i]); } Tcl_SetObjResult(interp, Tcl_NewListObj(4, regsObjs)); return TCL_OK; @@ -6853,7 +7021,7 @@ TestcpuidCmd( static int TestHashSystemHashCmd( - ClientData clientData, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -6929,13 +7097,13 @@ TestHashSystemHashCmd( */ static int TestgetintCmd( - ClientData dummy, + void *dummy, Tcl_Interp *interp, int argc, const char **argv) { if (argc < 2) { - Tcl_SetResult(interp, "wrong # args", TCL_STATIC); + Tcl_AppendResult(interp, "wrong # args", NULL); return TCL_ERROR; } else { int val, i, total=0; @@ -6951,9 +7119,27 @@ TestgetintCmd( } } +/* + * Used for determining sizeof(long) at script level. + */ +static int +TestlongsizeCmd( + void *dummy, + Tcl_Interp *interp, + int argc, + const char **argv) +{ + if (argc != 1) { + Tcl_AppendResult(interp, "wrong # args", NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, Tcl_NewIntObj((int)sizeof(long))); + return TCL_OK; +} + static int NREUnwind_callback( - ClientData data[], + void *data[], Tcl_Interp *interp, int result) { @@ -6980,7 +7166,7 @@ NREUnwind_callback( static int TestNREUnwind( - ClientData clientData, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -6998,7 +7184,7 @@ TestNREUnwind( static int TestNRELevels( - ClientData clientData, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -7054,7 +7240,7 @@ TestNRELevels( static int TestconcatobjCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int argc, /* Number of arguments. */ const char **argv) /* Argument strings. */ @@ -7075,17 +7261,11 @@ TestconcatobjCmd( list1Ptr = Tcl_NewStringObj("foo bar sum", -1); Tcl_ListObjLength(NULL, list1Ptr, &len); - if (list1Ptr->bytes != NULL) { - ckfree(list1Ptr->bytes); - list1Ptr->bytes = NULL; - } + Tcl_InvalidateStringRep(list1Ptr); list2Ptr = Tcl_NewStringObj("eeny meeny", -1); Tcl_ListObjLength(NULL, list2Ptr, &len); - if (list2Ptr->bytes != NULL) { - ckfree(list2Ptr->bytes); - list2Ptr->bytes = NULL; - } + Tcl_InvalidateStringRep(list2Ptr); /* * Verify that concat'ing a list obj with one or more empty strings does @@ -7357,7 +7537,7 @@ TestconcatobjCmd( static int TestparseargsCmd( - ClientData dummy, /* Not used. */ + void *dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Arguments. */ @@ -7459,7 +7639,7 @@ InterpCmdResolver( */ CallFrame *parentFramePtr = varFramePtr->callerPtr; - char *context = parentFramePtr != NULL ? parentFramePtr->nsPtr->name : "(NULL)"; + const char *context = parentFramePtr != NULL ? parentFramePtr->nsPtr->name : "(NULL)"; if (strcmp(context, "ctx1") == 0 && (name[0] == 'z') && (name[1] == '\0')) { resolvedCmdPtr = Tcl_FindCommand(interp, "y", NULL, TCL_GLOBAL_ONLY); @@ -7525,7 +7705,7 @@ MyCompiledVarFree( } #define TclVarHashGetValue(hPtr) \ - ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry))) + ((Var *) ((char *)hPtr - offsetof(VarInHash, entry))) static Tcl_Var MyCompiledVarFetch( @@ -7596,7 +7776,7 @@ InterpCompiledVarResolver( static int TestInterpResolverCmd( - ClientData clientData, + void *clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index 7f9b561..c9e4a6f 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -385,9 +385,9 @@ TestbooleanobjCmd( */ if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetBooleanObj(varPtr[varIndex], boolValue); + Tcl_SetWideIntObj(varPtr[varIndex], boolValue != 0); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewBooleanObj(boolValue)); + SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(boolValue != 0)); } Tcl_SetObjResult(interp, varPtr[varIndex]); } else if (strcmp(subCmd, "get") == 0) { @@ -410,9 +410,9 @@ TestbooleanobjCmd( return TCL_ERROR; } if (!Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetBooleanObj(varPtr[varIndex], !boolValue); + Tcl_SetWideIntObj(varPtr[varIndex], boolValue == 0); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewBooleanObj(!boolValue)); + SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(boolValue == 0)); } Tcl_SetObjResult(interp, varPtr[varIndex]); } else { @@ -622,23 +622,9 @@ 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", (allowAbbrev? 0 : TCL_EXACT), &index); + argv, "token", INDEX_TEMP_TABLE|(allowAbbrev? 0 : TCL_EXACT), + &index); ckfree(argv); if (result == TCL_OK) { Tcl_SetIntObj(Tcl_GetObjResult(interp), index); @@ -672,7 +658,7 @@ TestintobjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { int intValue, varIndex, i; - long longValue; + Tcl_WideInt wideValue; const char *index, *subCmd, *string; Tcl_Obj **varPtr; @@ -727,7 +713,7 @@ TestintobjCmd( } else { SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(intValue)); } - } else if (strcmp(subCmd, "setlong") == 0) { + } else if (strcmp(subCmd, "setint") == 0) { if (objc != 4) { goto wrongNumArgs; } @@ -737,33 +723,33 @@ TestintobjCmd( } intValue = i; if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetLongObj(varPtr[varIndex], intValue); + Tcl_SetWideIntObj(varPtr[varIndex], intValue); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewLongObj(intValue)); + SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(intValue)); } Tcl_SetObjResult(interp, varPtr[varIndex]); - } else if (strcmp(subCmd, "setmaxlong") == 0) { - long maxLong = LONG_MAX; + } else if (strcmp(subCmd, "setmax") == 0) { + Tcl_WideInt maxWide = WIDE_MAX; if (objc != 3) { goto wrongNumArgs; } if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetLongObj(varPtr[varIndex], maxLong); + Tcl_SetWideIntObj(varPtr[varIndex], maxWide); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewLongObj(maxLong)); + SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(maxWide)); } - } else if (strcmp(subCmd, "ismaxlong") == 0) { + } else if (strcmp(subCmd, "ismax") == 0) { if (objc != 3) { goto wrongNumArgs; } if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } - if (Tcl_GetLongFromObj(interp, varPtr[varIndex], &longValue) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, varPtr[varIndex], &wideValue) != TCL_OK) { return TCL_ERROR; } Tcl_AppendToObj(Tcl_GetObjResult(interp), - ((longValue == LONG_MAX)? "1" : "0"), -1); + ((wideValue == WIDE_MAX)? "1" : "0"), -1); } else if (strcmp(subCmd, "get") == 0) { if (objc != 3) { goto wrongNumArgs; @@ -796,9 +782,9 @@ TestintobjCmd( Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1); #else if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) { - Tcl_SetLongObj(varPtr[varIndex], LONG_MAX); + Tcl_SetWideIntObj(varPtr[varIndex], LONG_MAX); } else { - SetVarToObj(varPtr, varIndex, Tcl_NewLongObj(LONG_MAX)); + SetVarToObj(varPtr, varIndex, Tcl_NewWideIntObj(LONG_MAX)); } if (Tcl_GetIntFromObj(interp, varPtr[varIndex], &i) != TCL_OK) { Tcl_ResetResult(interp); @@ -1102,6 +1088,9 @@ TestobjCmd( Tcl_SetObjResult(interp, Tcl_NewStringObj("none", -1)); } else { typeName = objv[2]->typePtr->name; +#ifndef TCL_WIDE_INT_IS_LONG + if (!strcmp(typeName, "wideInt")) typeName = "int"; +#endif Tcl_SetObjResult(interp, Tcl_NewStringObj(typeName, -1)); } } else if (strcmp(subCmd, "refcount") == 0) { @@ -1115,7 +1104,7 @@ TestobjCmd( if (CheckIfVarUnset(interp, varPtr,varIndex)) { return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewIntObj(varPtr[varIndex]->refCount)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(varPtr[varIndex]->refCount)); } else if (strcmp(subCmd, "type") == 0) { if (objc != 3) { goto wrongNumArgs; @@ -1129,6 +1118,11 @@ TestobjCmd( } if (varPtr[varIndex]->typePtr == NULL) { /* a string! */ Tcl_AppendToObj(Tcl_GetObjResult(interp), "string", -1); +#ifndef TCL_WIDE_INT_IS_LONG + } else if (!strcmp(varPtr[varIndex]->typePtr->name, "wideInt")) { + Tcl_AppendToObj(Tcl_GetObjResult(interp), + "int", -1); +#endif } else { Tcl_AppendToObj(Tcl_GetObjResult(interp), varPtr[varIndex]->typePtr->name, -1); @@ -1354,7 +1348,7 @@ TeststringobjCmd( if (objc != 3) { goto wrongNumArgs; } - Tcl_GetUnicodeFromObj(varPtr[varIndex], NULL); + Tcl_GetUnicode(varPtr[varIndex]); break; case 11: /* appendself */ if (objc != 4) { diff --git a/generic/tclTestProcBodyObj.c b/generic/tclTestProcBodyObj.c index fba2844..11e841f 100644 --- a/generic/tclTestProcBodyObj.c +++ b/generic/tclTestProcBodyObj.c @@ -51,7 +51,7 @@ static int ProcBodyTestCheckObjCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static int ProcBodyTestInitInternal(Tcl_Interp *interp, int isSafe); static int RegisterCommand(Tcl_Interp* interp, - const char *namespace, const CmdTable *cmdTablePtr); + const char *namesp, const CmdTable *cmdTablePtr); /* * List of commands to create when the package is loaded; must go after the @@ -139,7 +139,7 @@ static int RegisterCommand( Tcl_Interp* interp, /* the Tcl interpreter for which the operation * is performed */ - const char *namespace, /* the namespace in which the command is + const char *namesp, /* the namespace in which the command is * registered */ const CmdTable *cmdTablePtr)/* the command to register */ { @@ -147,13 +147,13 @@ RegisterCommand( if (cmdTablePtr->exportIt) { sprintf(buf, "namespace eval %s { namespace export %s }", - namespace, cmdTablePtr->cmdName); + namesp, cmdTablePtr->cmdName); if (Tcl_EvalEx(interp, buf, -1, 0) != TCL_OK) { return TCL_ERROR; } } - sprintf(buf, "%s::%s", namespace, cmdTablePtr->cmdName); + sprintf(buf, "%s::%s", namesp, cmdTablePtr->cmdName); Tcl_CreateObjCommand(interp, buf, cmdTablePtr->proc, 0, 0); return TCL_OK; } @@ -340,7 +340,7 @@ ProcBodyTestCheckObjCmd( } version = Tcl_PkgPresent(interp, packageName, packageVersion, 1); - Tcl_SetObjResult(interp, Tcl_NewBooleanObj( + Tcl_SetObjResult(interp, Tcl_NewWideIntObj( strcmp(version, packageVersion) == 0)); return TCL_OK; } diff --git a/generic/tclThread.c b/generic/tclThread.c index 198fa6a..661ac2f 100644 --- a/generic/tclThread.c +++ b/generic/tclThread.c @@ -41,21 +41,6 @@ static void RememberSyncObject(void *objPtr, SyncObjRecord *recPtr); /* - * Several functions are #defined to nothing in tcl.h if TCL_THREADS is not - * specified. Here we undo that so the functions are defined in the stubs - * table. - */ - -#ifndef TCL_THREADS -#undef Tcl_MutexLock -#undef Tcl_MutexUnlock -#undef Tcl_MutexFinalize -#undef Tcl_ConditionNotify -#undef Tcl_ConditionWait -#undef Tcl_ConditionFinalize -#endif - -/* *---------------------------------------------------------------------- * * Tcl_GetThreadData -- @@ -79,7 +64,7 @@ Tcl_GetThreadData( int size) /* Size of storage block */ { void *result; -#ifdef TCL_THREADS +#if TCL_THREADS /* * Initialize the key for this thread. */ @@ -88,13 +73,13 @@ Tcl_GetThreadData( if (result == NULL) { result = ckalloc(size); - memset(result, 0, (size_t) size); + memset(result, 0, size); TclThreadStorageKeySet(keyPtr, result); } #else /* TCL_THREADS */ if (*keyPtr == NULL) { result = ckalloc(size); - memset(result, 0, (size_t)size); + memset(result, 0, size); *keyPtr = result; RememberSyncObject(keyPtr, &keyRecord); } else { @@ -126,7 +111,7 @@ TclThreadDataKeyGet( Tcl_ThreadDataKey *keyPtr) /* Identifier for the data chunk. */ { -#ifdef TCL_THREADS +#if TCL_THREADS return TclThreadStorageKeyGet(keyPtr); #else /* TCL_THREADS */ return *keyPtr; @@ -269,11 +254,12 @@ TclRememberMutex( *---------------------------------------------------------------------- */ +#undef Tcl_MutexFinalize void Tcl_MutexFinalize( Tcl_Mutex *mutexPtr) { -#ifdef TCL_THREADS +#if TCL_THREADS TclpFinalizeMutex(mutexPtr); #endif TclpMasterLock(); @@ -322,11 +308,12 @@ TclRememberCondition( *---------------------------------------------------------------------- */ +#undef Tcl_ConditionFinalize void Tcl_ConditionFinalize( Tcl_Condition *condPtr) { -#ifdef TCL_THREADS +#if TCL_THREADS TclpFinalizeCondition(condPtr); #endif TclpMasterLock(); @@ -356,7 +343,7 @@ void TclFinalizeThreadData(int quick) { TclFinalizeThreadDataThread(); -#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) +#if TCL_THREADS && defined(USE_THREAD_ALLOC) if (!quick) { /* * Quick exit principle makes it useless to terminate allocators @@ -389,7 +376,7 @@ TclFinalizeSynchronization(void) int i; void *blockPtr; Tcl_ThreadDataKey *keyPtr; -#ifdef TCL_THREADS +#if TCL_THREADS Tcl_Mutex *mutexPtr; Tcl_Condition *condPtr; @@ -413,7 +400,7 @@ TclFinalizeSynchronization(void) keyRecord.max = 0; keyRecord.num = 0; -#ifdef TCL_THREADS +#if TCL_THREADS /* * Call thread storage master cleanup. */ @@ -473,12 +460,10 @@ Tcl_ExitThread( int status) { Tcl_FinalizeThread(); -#ifdef TCL_THREADS TclpThreadExit(status); -#endif } -#ifndef TCL_THREADS +#if !TCL_THREADS /* *---------------------------------------------------------------------- diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c index 2ee758e..3f1abc2 100644 --- a/generic/tclThreadAlloc.c +++ b/generic/tclThreadAlloc.c @@ -13,7 +13,7 @@ */ #include "tclInt.h" -#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC) +#if TCL_THREADS && defined(USE_THREAD_ALLOC) /* * If range checking is enabled, an additional byte will be allocated to store @@ -196,20 +196,11 @@ GetCache(void) if (listLockPtr == NULL) { Tcl_Mutex *initLockPtr; - unsigned int i; initLockPtr = Tcl_GetAllocMutex(); Tcl_MutexLock(initLockPtr); if (listLockPtr == NULL) { - listLockPtr = TclpNewAllocMutex(); - objLockPtr = TclpNewAllocMutex(); - for (i = 0; i < NBUCKETS; ++i) { - bucketInfo[i].blockSize = MINALLOC << i; - bucketInfo[i].maxBlocks = 1 << (NBUCKETS - 1 - i); - bucketInfo[i].numMove = i < NBUCKETS - 1 ? - 1 << (NBUCKETS - 2 - i) : 1; - bucketInfo[i].lockPtr = TclpNewAllocMutex(); - } + TclInitThreadAlloc(); } Tcl_MutexUnlock(initLockPtr); } @@ -1064,6 +1055,40 @@ GetBlocks( } return 1; } + +/* + *---------------------------------------------------------------------- + * + * TclInitThreadAlloc -- + * + * Initializes the allocator cache-maintenance structures. + * It is done early and protected during the TclInitSubsystems(). + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclInitThreadAlloc(void) +{ + unsigned int i; + + listLockPtr = TclpNewAllocMutex(); + objLockPtr = TclpNewAllocMutex(); + for (i = 0; i < NBUCKETS; ++i) { + bucketInfo[i].blockSize = MINALLOC << i; + bucketInfo[i].maxBlocks = 1 << (NBUCKETS - 1 - i); + bucketInfo[i].numMove = i < NBUCKETS - 1 ? + 1 << (NBUCKETS - 2 - i) : 1; + bucketInfo[i].lockPtr = TclpNewAllocMutex(); + } + TclpInitAllocCache(); +} /* *---------------------------------------------------------------------- diff --git a/generic/tclThreadStorage.c b/generic/tclThreadStorage.c index 755a461..b56ec80 100644 --- a/generic/tclThreadStorage.c +++ b/generic/tclThreadStorage.c @@ -13,7 +13,7 @@ #include "tclInt.h" -#ifdef TCL_THREADS +#if TCL_THREADS #include <signal.h> /* diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c index 35b3fc3..e9b1107 100644 --- a/generic/tclThreadTest.c +++ b/generic/tclThreadTest.c @@ -18,7 +18,7 @@ #endif #include "tclInt.h" -#ifdef TCL_THREADS +#if TCL_THREADS /* * Each thread has an single instance of the following structure. There is one * instance of this structure per thread even if that thread contains multiple @@ -508,7 +508,7 @@ ThreadCreate( joinable = joinable ? TCL_THREAD_JOINABLE : TCL_THREAD_NOFLAGS; Tcl_MutexLock(&threadMutex); - if (Tcl_CreateThread(&id, NewTestThread, (ClientData) &ctrl, + if (Tcl_CreateThread(&id, NewTestThread, &ctrl, TCL_THREAD_STACK_DEFAULT, joinable) != TCL_OK) { Tcl_MutexUnlock(&threadMutex); Tcl_AppendResult(interp, "can't create a new thread", NULL); @@ -654,9 +654,9 @@ ThreadErrorProc( char *script; char buf[TCL_DOUBLE_SPACE+1]; - sprintf(buf, "%" TCL_LL_MODIFIER "d", (Tcl_WideInt)(size_t)Tcl_GetCurrentThread()); + sprintf(buf, "%p", Tcl_GetCurrentThread()); - errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY); + errorInfo = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY); if (errorProcString == NULL) { errChannel = Tcl_GetStdChannel(TCL_STDERR); Tcl_WriteChars(errChannel, "Error from thread ", -1); @@ -1031,8 +1031,8 @@ ThreadEventProc( code = Tcl_EvalEx(interp, threadEventPtr->script,-1,TCL_EVAL_GLOBAL); Tcl_DeleteThreadExitHandler(ThreadFreeProc, threadEventPtr->script); if (code != TCL_OK) { - errorCode = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY); - errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY); + errorCode = Tcl_GetVar2(interp, "errorCode", NULL, TCL_GLOBAL_ONLY); + errorInfo = Tcl_GetVar2(interp, "errorInfo", NULL, TCL_GLOBAL_ONLY); } else { errorCode = errorInfo = NULL; } diff --git a/generic/tclTimer.c b/generic/tclTimer.c index 5755edc..ea80320 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 ThreadSpecificData { +typedef struct { TimerHandler *firstTimerHandlerPtr; /* First event in queue. */ int lastTimerId; /* Timer identifier of most recently created * timer. */ @@ -789,7 +789,7 @@ Tcl_AfterObjCmd( AfterInfo *afterPtr; AfterAssocData *assocPtr; int length; - int index; + int index = -1; static const char *const afterSubCmds[] = { "cancel", "idle", "info", NULL }; @@ -818,15 +818,9 @@ Tcl_AfterObjCmd( * First lets see if the command was passed a number as the first argument. */ - if (objv[1]->typePtr == &tclIntType -#ifndef TCL_WIDE_INT_IS_LONG - || objv[1]->typePtr == &tclWideIntType -#endif - || objv[1]->typePtr == &tclBignumType - || (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0, - &index) != TCL_OK)) { - index = -1; - if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) { + if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) { + if (Tcl_GetIndexFromObj(NULL, objv[1], afterSubCmds, "", 0, &index) + != TCL_OK) { const char *arg = Tcl_GetString(objv[1]); Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -900,13 +894,13 @@ Tcl_AfterObjCmd( } else { commandPtr = Tcl_ConcatObj(objc-2, objv+2);; } - command = Tcl_GetStringFromObj(commandPtr, &length); + command = TclGetStringFromObj(commandPtr, &length); for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL; afterPtr = afterPtr->nextPtr) { - tempCommand = Tcl_GetStringFromObj(afterPtr->commandPtr, + tempCommand = TclGetStringFromObj(afterPtr->commandPtr, &tempLength); if ((length == tempLength) - && !memcmp(command, tempCommand, (unsigned) length)) { + && !memcmp(command, tempCommand, length)) { break; } } @@ -1045,11 +1039,6 @@ AfterDelay( if (iPtr->limit.timeEvent == NULL || TCL_TIME_BEFORE(endTime, iPtr->limit.time)) { diff = TCL_TIME_DIFF_MS_CEILING(endTime, now); -#ifndef TCL_WIDE_INT_IS_LONG - if (diff > LONG_MAX) { - diff = LONG_MAX; - } -#endif if (diff > TCL_TIME_MAXIMUM_SLICE) { diff = TCL_TIME_MAXIMUM_SLICE; } @@ -1066,16 +1055,11 @@ AfterDelay( } } else { diff = TCL_TIME_DIFF_MS(iPtr->limit.time, now); -#ifndef TCL_WIDE_INT_IS_LONG - if (diff > LONG_MAX) { - diff = LONG_MAX; - } -#endif if (diff > TCL_TIME_MAXIMUM_SLICE) { diff = TCL_TIME_MAXIMUM_SLICE; } if (diff > 0) { - Tcl_Sleep((long) diff); + Tcl_Sleep((int) diff); } if (Tcl_AsyncReady()) { if (Tcl_AsyncInvoke(interp, TCL_OK) != TCL_OK) { @@ -1089,7 +1073,7 @@ AfterDelay( return TCL_ERROR; } } - Tcl_GetTime(&now); + Tcl_GetTime(&now); } while (TCL_TIME_BEFORE(now, endTime)); return TCL_OK; } diff --git a/generic/tclTomMath.decls b/generic/tclTomMath.decls index 8703082..01b6342 100644 --- a/generic/tclTomMath.decls +++ b/generic/tclTomMath.decls @@ -178,37 +178,37 @@ declare 49 { # internal routines to libtommath - should not be called but must be # exported to accommodate the "tommath" extension -declare 50 { +declare 50 {deprecated {is private function in libtommath}} { void TclBN_reverse(unsigned char *s, int len) } -declare 51 { +declare 51 {deprecated {is private function in libtommath}} { int TclBN_fast_s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs) } -declare 52 { +declare 52 {deprecated {is private function in libtommath}} { int TclBN_fast_s_mp_sqr(const mp_int *a, mp_int *b) } -declare 53 { +declare 53 {deprecated {is private function in libtommath}} { int TclBN_mp_karatsuba_mul(const mp_int *a, const mp_int *b, mp_int *c) } -declare 54 { +declare 54 {deprecated {is private function in libtommath}} { int TclBN_mp_karatsuba_sqr(const mp_int *a, mp_int *b) } -declare 55 { +declare 55 {deprecated {is private function in libtommath}} { int TclBN_mp_toom_mul(const mp_int *a, const mp_int *b, mp_int *c) } -declare 56 { +declare 56 {deprecated {is private function in libtommath}} { int TclBN_mp_toom_sqr(const mp_int *a, mp_int *b) } -declare 57 { +declare 57 {deprecated {is private function in libtommath}} { int TclBN_s_mp_add(const mp_int *a, const mp_int *b, mp_int *c) } -declare 58 { +declare 58 {deprecated {is private function in libtommath}} { int TclBN_s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs) } -declare 59 { +declare 59 {deprecated {is private function in libtommath}} { int TclBN_s_mp_sqr(const mp_int *a, mp_int *b) } -declare 60 { +declare 60 {deprecated {is private function in libtommath}} { int TclBN_s_mp_sub(const mp_int *a, const mp_int *b, mp_int *c) } declare 61 { @@ -223,13 +223,13 @@ declare 63 { # Formerly internal API to allow initialisation of bignums without knowing the # typedefs of how a bignum works internally. -declare 64 { +declare 64 {deprecated {Use mp_init() + mp_set_long_long()}} { void TclBNInitBignumFromLong(mp_int *bignum, long initVal) } -declare 65 { +declare 65 {deprecated {Use mp_init() + mp_set_long_long()}} { void TclBNInitBignumFromWideInt(mp_int *bignum, Tcl_WideInt initVal) } -declare 66 { +declare 66 {deprecated {Use mp_init() + mp_set_long_long()}} { void TclBNInitBignumFromWideUInt(mp_int *bignum, Tcl_WideUInt initVal) } @@ -237,9 +237,22 @@ declare 66 { declare 67 { int TclBN_mp_expt_d_ex(const mp_int *a, mp_digit b, mp_int *c, int fast) } +# Added in libtommath 1.0.1 +declare 68 { + int TclBN_mp_set_long_long(mp_int *a, Tcl_WideUInt i) +} +declare 69 { + Tcl_WideUInt TclBN_mp_get_long_long(const mp_int *a) +} declare 70 { int TclBN_mp_set_long(mp_int *a, unsigned long i) } +declare 71 { + unsigned long TclBN_mp_get_long(const mp_int *a) +} +declare 72 { + unsigned long TclBN_mp_get_int(const mp_int *a) +} # Added in libtommath 1.1.0 declare 73 { @@ -254,7 +267,6 @@ declare 75 { declare 76 { int TclBN_mp_signed_rsh(const mp_int *a, int b, mp_int *c) } - declare 77 { int TclBN_mp_get_bit(const mp_int *a, int b) } diff --git a/generic/tclTomMathDecls.h b/generic/tclTomMathDecls.h index 214a131..52b84ee 100644 --- a/generic/tclTomMathDecls.h +++ b/generic/tclTomMathDecls.h @@ -71,6 +71,10 @@ #define mp_expt_d TclBN_mp_expt_d #define mp_expt_d_ex TclBN_mp_expt_d_ex #define mp_get_bit TclBN_mp_get_bit +#define mp_get_int TclBN_mp_get_int +#define mp_get_long TclBN_mp_get_long +#define mp_get_long_long TclBN_mp_get_long_long +#define mp_grow TclBN_mp_grow #define s_mp_get_bit TclBN_mp_get_bit #define mp_grow TclBN_mp_grow #define mp_init TclBN_mp_init @@ -98,6 +102,7 @@ #define mp_set TclBN_mp_set #define mp_set_int TclBN_mp_set_int #define mp_set_long TclBN_mp_set_long +#define mp_set_long_long TclBN_mp_set_long_long #define mp_shrink TclBN_mp_shrink #define mp_sqr TclBN_mp_sqr #define mp_sqrt TclBN_mp_sqrt @@ -271,32 +276,43 @@ EXTERN int TclBN_mp_xor(const mp_int *a, const mp_int *b, /* 49 */ EXTERN void TclBN_mp_zero(mp_int *a); /* 50 */ -EXTERN void TclBN_reverse(unsigned char *s, int len); +TCL_DEPRECATED("is private function in libtommath") +void TclBN_reverse(unsigned char *s, int len); /* 51 */ -EXTERN int TclBN_fast_s_mp_mul_digs(const mp_int *a, +TCL_DEPRECATED("is private function in libtommath") +int TclBN_fast_s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs); /* 52 */ -EXTERN int TclBN_fast_s_mp_sqr(const mp_int *a, mp_int *b); +TCL_DEPRECATED("is private function in libtommath") +int TclBN_fast_s_mp_sqr(const mp_int *a, mp_int *b); /* 53 */ -EXTERN int TclBN_mp_karatsuba_mul(const mp_int *a, +TCL_DEPRECATED("is private function in libtommath") +int TclBN_mp_karatsuba_mul(const mp_int *a, const mp_int *b, mp_int *c); /* 54 */ -EXTERN int TclBN_mp_karatsuba_sqr(const mp_int *a, mp_int *b); +TCL_DEPRECATED("is private function in libtommath") +int TclBN_mp_karatsuba_sqr(const mp_int *a, mp_int *b); /* 55 */ -EXTERN int TclBN_mp_toom_mul(const mp_int *a, const mp_int *b, +TCL_DEPRECATED("is private function in libtommath") +int TclBN_mp_toom_mul(const mp_int *a, const mp_int *b, mp_int *c); /* 56 */ -EXTERN int TclBN_mp_toom_sqr(const mp_int *a, mp_int *b); +TCL_DEPRECATED("is private function in libtommath") +int TclBN_mp_toom_sqr(const mp_int *a, mp_int *b); /* 57 */ -EXTERN int TclBN_s_mp_add(const mp_int *a, const mp_int *b, +TCL_DEPRECATED("is private function in libtommath") +int TclBN_s_mp_add(const mp_int *a, const mp_int *b, mp_int *c); /* 58 */ -EXTERN int TclBN_s_mp_mul_digs(const mp_int *a, const mp_int *b, +TCL_DEPRECATED("is private function in libtommath") +int TclBN_s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs); /* 59 */ -EXTERN int TclBN_s_mp_sqr(const mp_int *a, mp_int *b); +TCL_DEPRECATED("is private function in libtommath") +int TclBN_s_mp_sqr(const mp_int *a, mp_int *b); /* 60 */ -EXTERN int TclBN_s_mp_sub(const mp_int *a, const mp_int *b, +TCL_DEPRECATED("is private function in libtommath") +int TclBN_s_mp_sub(const mp_int *a, const mp_int *b, mp_int *c); /* 61 */ EXTERN int TclBN_mp_init_set_int(mp_int *a, unsigned long i); @@ -305,22 +321,29 @@ EXTERN int TclBN_mp_set_int(mp_int *a, unsigned long i); /* 63 */ EXTERN int TclBN_mp_cnt_lsb(const mp_int *a); /* 64 */ -EXTERN void TclBNInitBignumFromLong(mp_int *bignum, long initVal); +TCL_DEPRECATED("Use mp_init() + mp_set_long_long()") +void TclBNInitBignumFromLong(mp_int *bignum, long initVal); /* 65 */ -EXTERN void TclBNInitBignumFromWideInt(mp_int *bignum, +TCL_DEPRECATED("Use mp_init() + mp_set_long_long()") +void TclBNInitBignumFromWideInt(mp_int *bignum, Tcl_WideInt initVal); /* 66 */ -EXTERN void TclBNInitBignumFromWideUInt(mp_int *bignum, +TCL_DEPRECATED("Use mp_init() + mp_set_long_long()") +void TclBNInitBignumFromWideUInt(mp_int *bignum, Tcl_WideUInt initVal); /* 67 */ EXTERN int TclBN_mp_expt_d_ex(const mp_int *a, mp_digit b, mp_int *c, int fast); -/* Slot 68 is reserved */ -/* Slot 69 is reserved */ +/* 68 */ +EXTERN int TclBN_mp_set_long_long(mp_int *a, Tcl_WideUInt i); +/* 69 */ +EXTERN Tcl_WideUInt TclBN_mp_get_long_long(const mp_int *a); /* 70 */ EXTERN int TclBN_mp_set_long(mp_int *a, unsigned long i); -/* Slot 71 is reserved */ -/* Slot 72 is reserved */ +/* 71 */ +EXTERN unsigned long TclBN_mp_get_long(const mp_int *a); +/* 72 */ +EXTERN unsigned long TclBN_mp_get_int(const mp_int *a); /* 73 */ EXTERN int TclBN_mp_tc_and(const mp_int *a, const mp_int *b, mp_int *c); @@ -390,29 +413,29 @@ typedef struct TclTomMathStubs { int (*tclBN_mp_unsigned_bin_size) (const mp_int *a); /* 47 */ int (*tclBN_mp_xor) (const mp_int *a, const mp_int *b, mp_int *c); /* 48 */ void (*tclBN_mp_zero) (mp_int *a); /* 49 */ - void (*tclBN_reverse) (unsigned char *s, int len); /* 50 */ - int (*tclBN_fast_s_mp_mul_digs) (const mp_int *a, const mp_int *b, mp_int *c, int digs); /* 51 */ - int (*tclBN_fast_s_mp_sqr) (const mp_int *a, mp_int *b); /* 52 */ - int (*tclBN_mp_karatsuba_mul) (const mp_int *a, const mp_int *b, mp_int *c); /* 53 */ - int (*tclBN_mp_karatsuba_sqr) (const mp_int *a, mp_int *b); /* 54 */ - int (*tclBN_mp_toom_mul) (const mp_int *a, const mp_int *b, mp_int *c); /* 55 */ - int (*tclBN_mp_toom_sqr) (const mp_int *a, mp_int *b); /* 56 */ - int (*tclBN_s_mp_add) (const mp_int *a, const mp_int *b, mp_int *c); /* 57 */ - int (*tclBN_s_mp_mul_digs) (const mp_int *a, const mp_int *b, mp_int *c, int digs); /* 58 */ - int (*tclBN_s_mp_sqr) (const mp_int *a, mp_int *b); /* 59 */ - int (*tclBN_s_mp_sub) (const mp_int *a, const mp_int *b, mp_int *c); /* 60 */ + TCL_DEPRECATED_API("is private function in libtommath") void (*tclBN_reverse) (unsigned char *s, int len); /* 50 */ + TCL_DEPRECATED_API("is private function in libtommath") int (*tclBN_fast_s_mp_mul_digs) (const mp_int *a, const mp_int *b, mp_int *c, int digs); /* 51 */ + TCL_DEPRECATED_API("is private function in libtommath") int (*tclBN_fast_s_mp_sqr) (const mp_int *a, mp_int *b); /* 52 */ + TCL_DEPRECATED_API("is private function in libtommath") int (*tclBN_mp_karatsuba_mul) (const mp_int *a, const mp_int *b, mp_int *c); /* 53 */ + TCL_DEPRECATED_API("is private function in libtommath") int (*tclBN_mp_karatsuba_sqr) (const mp_int *a, mp_int *b); /* 54 */ + TCL_DEPRECATED_API("is private function in libtommath") int (*tclBN_mp_toom_mul) (const mp_int *a, const mp_int *b, mp_int *c); /* 55 */ + TCL_DEPRECATED_API("is private function in libtommath") int (*tclBN_mp_toom_sqr) (const mp_int *a, mp_int *b); /* 56 */ + TCL_DEPRECATED_API("is private function in libtommath") int (*tclBN_s_mp_add) (const mp_int *a, const mp_int *b, mp_int *c); /* 57 */ + TCL_DEPRECATED_API("is private function in libtommath") int (*tclBN_s_mp_mul_digs) (const mp_int *a, const mp_int *b, mp_int *c, int digs); /* 58 */ + TCL_DEPRECATED_API("is private function in libtommath") int (*tclBN_s_mp_sqr) (const mp_int *a, mp_int *b); /* 59 */ + TCL_DEPRECATED_API("is private function in libtommath") int (*tclBN_s_mp_sub) (const mp_int *a, const mp_int *b, mp_int *c); /* 60 */ int (*tclBN_mp_init_set_int) (mp_int *a, unsigned long i); /* 61 */ int (*tclBN_mp_set_int) (mp_int *a, unsigned long i); /* 62 */ int (*tclBN_mp_cnt_lsb) (const mp_int *a); /* 63 */ - void (*tclBNInitBignumFromLong) (mp_int *bignum, long initVal); /* 64 */ - void (*tclBNInitBignumFromWideInt) (mp_int *bignum, Tcl_WideInt initVal); /* 65 */ - void (*tclBNInitBignumFromWideUInt) (mp_int *bignum, Tcl_WideUInt initVal); /* 66 */ + TCL_DEPRECATED_API("Use mp_init() + mp_set_long_long()") void (*tclBNInitBignumFromLong) (mp_int *bignum, long initVal); /* 64 */ + TCL_DEPRECATED_API("Use mp_init() + mp_set_long_long()") void (*tclBNInitBignumFromWideInt) (mp_int *bignum, Tcl_WideInt initVal); /* 65 */ + TCL_DEPRECATED_API("Use mp_init() + mp_set_long_long()") void (*tclBNInitBignumFromWideUInt) (mp_int *bignum, Tcl_WideUInt initVal); /* 66 */ int (*tclBN_mp_expt_d_ex) (const mp_int *a, mp_digit b, mp_int *c, int fast); /* 67 */ - void (*reserved68)(void); - void (*reserved69)(void); + int (*tclBN_mp_set_long_long) (mp_int *a, Tcl_WideUInt i); /* 68 */ + Tcl_WideUInt (*tclBN_mp_get_long_long) (const mp_int *a); /* 69 */ int (*tclBN_mp_set_long) (mp_int *a, unsigned long i); /* 70 */ - void (*reserved71)(void); - void (*reserved72)(void); + unsigned long (*tclBN_mp_get_long) (const mp_int *a); /* 71 */ + unsigned long (*tclBN_mp_get_int) (const mp_int *a); /* 72 */ int (*tclBN_mp_tc_and) (const mp_int *a, const mp_int *b, mp_int *c); /* 73 */ int (*tclBN_mp_tc_or) (const mp_int *a, const mp_int *b, mp_int *c); /* 74 */ int (*tclBN_mp_tc_xor) (const mp_int *a, const mp_int *b, mp_int *c); /* 75 */ @@ -568,12 +591,16 @@ extern const TclTomMathStubs *tclTomMathStubsPtr; (tclTomMathStubsPtr->tclBNInitBignumFromWideUInt) /* 66 */ #define TclBN_mp_expt_d_ex \ (tclTomMathStubsPtr->tclBN_mp_expt_d_ex) /* 67 */ -/* Slot 68 is reserved */ -/* Slot 69 is reserved */ +#define TclBN_mp_set_long_long \ + (tclTomMathStubsPtr->tclBN_mp_set_long_long) /* 68 */ +#define TclBN_mp_get_long_long \ + (tclTomMathStubsPtr->tclBN_mp_get_long_long) /* 69 */ #define TclBN_mp_set_long \ (tclTomMathStubsPtr->tclBN_mp_set_long) /* 70 */ -/* Slot 71 is reserved */ -/* Slot 72 is reserved */ +#define TclBN_mp_get_long \ + (tclTomMathStubsPtr->tclBN_mp_get_long) /* 71 */ +#define TclBN_mp_get_int \ + (tclTomMathStubsPtr->tclBN_mp_get_int) /* 72 */ #define TclBN_mp_tc_and \ (tclTomMathStubsPtr->tclBN_mp_tc_and) /* 73 */ #define TclBN_mp_tc_or \ diff --git a/generic/tclTomMathInterface.c b/generic/tclTomMathInterface.c index 55dadfb..ae1eb7e 100644 --- a/generic/tclTomMathInterface.c +++ b/generic/tclTomMathInterface.c @@ -93,65 +93,7 @@ TclBN_revision(void) /* *---------------------------------------------------------------------- * - * TclBNInitBignumFromLong -- - * - * Allocate and initialize a 'bignum' from a native 'long'. - * - * Results: - * None. - * - * Side effects: - * The 'bignum' is constructed. - * - *---------------------------------------------------------------------- - */ - -extern void -TclBNInitBignumFromLong( - mp_int *a, - long initVal) -{ - int status; - unsigned long v; - mp_digit *p; - - /* - * Allocate enough memory to hold the largest possible long - */ - - status = mp_init(a); - if (status != MP_OKAY) { - Tcl_Panic("initialization failure in TclBNInitBignumFromLong"); - } - - /* - * Convert arg to sign and magnitude. - */ - - if (initVal < 0) { - a->sign = MP_NEG; - v = -initVal; - } else { - a->sign = MP_ZPOS; - v = initVal; - } - - /* - * Store the magnitude in the bignum. - */ - - p = a->dp; - while (v) { - *p++ = (mp_digit) (v & MP_MASK); - v >>= MP_DIGIT_BIT; - } - a->used = p - a->dp; -} - -/* - *---------------------------------------------------------------------- - * - * TclBNInitBignumFromWideInt -- + * TclInitBignumFromWideInt -- * * Allocate and initialize a 'bignum' from a Tcl_WideInt * @@ -164,23 +106,26 @@ TclBNInitBignumFromLong( *---------------------------------------------------------------------- */ -extern void -TclBNInitBignumFromWideInt( +void +TclInitBignumFromWideInt( mp_int *a, /* Bignum to initialize */ Tcl_WideInt v) /* Initial value */ { - if (v < (Tcl_WideInt)0) { - TclBNInitBignumFromWideUInt(a, (Tcl_WideUInt)(-v)); + if (mp_init(a) != MP_OKAY) { + Tcl_Panic("initialization failure in TclInitBignumFromWideInt"); + } + if (v < 0) { + mp_set_long_long(a, (Tcl_WideUInt)(-v)); mp_neg(a, a); } else { - TclBNInitBignumFromWideUInt(a, (Tcl_WideUInt)v); + mp_set_long_long(a, (Tcl_WideUInt)v); } } /* *---------------------------------------------------------------------- * - * TclBNInitBignumFromWideUInt -- + * TclInitBignumFromWideUInt -- * * Allocate and initialize a 'bignum' from a Tcl_WideUInt * @@ -193,35 +138,15 @@ TclBNInitBignumFromWideInt( *---------------------------------------------------------------------- */ -extern void -TclBNInitBignumFromWideUInt( +void +TclInitBignumFromWideUInt( mp_int *a, /* Bignum to initialize */ Tcl_WideUInt v) /* Initial value */ { - int status; - mp_digit *p; - - /* - * Allocate enough memory to hold the largest possible Tcl_WideUInt. - */ - - status = mp_init(a); - if (status != MP_OKAY) { - Tcl_Panic("initialization failure in TclBNInitBignumFromWideUInt"); - } - - a->sign = 0; - - /* - * Store the magnitude in the bignum. - */ - - p = a->dp; - while (v) { - *p++ = (mp_digit) (v & MP_MASK); - v >>= MP_DIGIT_BIT; - } - a->used = p - a->dp; + if (mp_init(a) != MP_OKAY) { + Tcl_Panic("initialization failure in TclInitBignumFromWideUInt"); + } + mp_set_long_long(a, v); } /* diff --git a/generic/tclTomMathStubLib.c b/generic/tclTomMathStubLib.c index 324f2a3..715904c 100644 --- a/generic/tclTomMathStubLib.c +++ b/generic/tclTomMathStubLib.c @@ -55,9 +55,9 @@ TclTomMathInitializeStubs( } if (stubsPtr == NULL) { errMsg = "missing stub table pointer"; - } else if(stubsPtr->tclBN_epoch() != epoch) { + } else if (stubsPtr->tclBN_epoch() != epoch) { errMsg = "epoch number mismatch"; - } else if(stubsPtr->tclBN_revision() != revision) { + } else if (stubsPtr->tclBN_revision() != revision) { errMsg = "requires a later revision"; } else { tclTomMathStubsPtr = stubsPtr; diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 882dc39..1a6d459 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -52,7 +52,7 @@ typedef struct { * invoked step trace */ int curFlags; /* Trace flags for the current command */ int curCode; /* Return code for the current command */ - int refCount; /* Used to ensure this structure is not + size_t refCount; /* Used to ensure this structure is not * deleted too early. Keeps track of how many * pieces of code have a pointer to this * structure. */ @@ -143,7 +143,7 @@ static int TraceVarEx(Tcl_Interp *interp, const char *part1, * trace procs */ -typedef struct StringTraceData { +typedef struct { ClientData clientData; /* Client data from Tcl_CreateTrace */ Tcl_CmdTraceProc *proc; /* Trace function from Tcl_CreateTrace */ } StringTraceData; @@ -280,7 +280,7 @@ Tcl_TraceObjCmd( opsList = Tcl_NewObj(); Tcl_IncrRefCount(opsList); - flagOps = Tcl_GetStringFromObj(objv[3], &numFlags); + flagOps = TclGetStringFromObj(objv[3], &numFlags); if (numFlags == 0) { Tcl_DecrRefCount(opsList); goto badVarOps; @@ -466,11 +466,11 @@ TraceExecutionObjCmd( break; } } - command = Tcl_GetStringFromObj(objv[5], &commandLength); + command = TclGetStringFromObj(objv[5], &commandLength); length = (size_t) commandLength; if ((enum traceOptions) optionIndex == TRACE_ADD) { TraceCommandInfo *tcmdPtr = ckalloc( - TclOffset(TraceCommandInfo, command) + 1 + length); + offsetof(TraceCommandInfo, command) + 1 + length); tcmdPtr->flags = flags; tcmdPtr->stepTrace = NULL; @@ -703,11 +703,11 @@ TraceCommandObjCmd( } } - command = Tcl_GetStringFromObj(objv[5], &commandLength); + command = TclGetStringFromObj(objv[5], &commandLength); length = (size_t) commandLength; if ((enum traceOptions) optionIndex == TRACE_ADD) { TraceCommandInfo *tcmdPtr = ckalloc( - TclOffset(TraceCommandInfo, command) + 1 + length); + offsetof(TraceCommandInfo, command) + 1 + length); tcmdPtr->flags = flags; tcmdPtr->stepTrace = NULL; @@ -906,11 +906,11 @@ TraceVariableObjCmd( break; } } - command = Tcl_GetStringFromObj(objv[5], &commandLength); + command = TclGetStringFromObj(objv[5], &commandLength); length = (size_t) commandLength; if ((enum traceOptions) optionIndex == TRACE_ADD) { CombinedTraceVarInfo *ctvarPtr = ckalloc( - TclOffset(CombinedTraceVarInfo, traceCmdInfo.command) + offsetof(CombinedTraceVarInfo, traceCmdInfo.command) + 1 + length); ctvarPtr->traceCmdInfo.flags = flags; @@ -1689,8 +1689,8 @@ CallTraceFunction( * Copy the command characters into a new string. */ - commandCopy = TclStackAlloc(interp, (unsigned) numChars + 1); - memcpy(commandCopy, command, (size_t) numChars); + commandCopy = TclStackAlloc(interp, numChars + 1); + memcpy(commandCopy, command, numChars); commandCopy[numChars] = '\0'; /* @@ -2275,7 +2275,7 @@ StringTraceProc( */ argv = (const char **) TclStackAlloc(interp, - (unsigned) ((objc + 1) * sizeof(const char *))); + (objc + 1) * sizeof(const char *)); for (i = 0; i < objc; i++) { argv[i] = Tcl_GetString(objv[i]); } @@ -2862,6 +2862,7 @@ DisposeTraceResult( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_UntraceVar void Tcl_UntraceVar( @@ -2877,6 +2878,7 @@ Tcl_UntraceVar( { Tcl_UntraceVar2(interp, varName, NULL, flags, proc, clientData); } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -3031,6 +3033,7 @@ Tcl_UntraceVar2( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_VarTraceInfo ClientData Tcl_VarTraceInfo( @@ -3048,6 +3051,7 @@ Tcl_VarTraceInfo( return Tcl_VarTraceInfo2(interp, varName, NULL, flags, proc, prevClientData); } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -3140,6 +3144,7 @@ Tcl_VarTraceInfo2( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_TraceVar int Tcl_TraceVar( @@ -3157,6 +3162,7 @@ Tcl_TraceVar( { return Tcl_TraceVar2(interp, varName, NULL, flags, proc, clientData); } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- diff --git a/generic/tclUtf.c b/generic/tclUtf.c index 4b70f96..1387ee7 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -67,25 +67,13 @@ static const unsigned char totalBytes[256] = { 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1,1, 2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2,2, - 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3, -#if TCL_UTF_MAX > 3 - 4,4,4,4,4, -#else - 1,1,1,1,1, -#endif - 1,1,1,1,1,1,1,1,1,1,1 + 3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,3,4,4,4,4,4,1,1,1,1,1,1,1,1,1,1,1 }; - -/* - * Functions used only in this module. - */ - -static int UtfCount(int ch); /* *--------------------------------------------------------------------------- * - * UtfCount -- + * TclUtfCount -- * * Find the number of bytes in the Utf character "ch". * @@ -98,8 +86,8 @@ static int UtfCount(int ch); *--------------------------------------------------------------------------- */ -static inline int -UtfCount( +int +TclUtfCount( int ch) /* The Unicode character whose size is returned. */ { if ((unsigned)(ch - 1) < (UNICODE_SELF - 1)) { @@ -108,11 +96,9 @@ UtfCount( if (ch <= 0x7FF) { return 2; } -#if TCL_UTF_MAX > 3 if (((unsigned)(ch - 0x10000) <= 0xFFFFF)) { return 4; } -#endif return 3; } @@ -124,6 +110,19 @@ UtfCount( * Store the given Tcl_UniChar as a sequence of UTF-8 bytes in the * provided buffer. Equivalent to Plan 9 runetochar(). * + * Special handling of Surrogate pairs is handled as follows: + * When this function is called for ch being a high surrogate, + * the first byte of the 4-byte UTF-8 sequence is produced and + * the function returns 1. Calling the function again with a + * low surrogate, the remaining 3 bytes of the 4-byte UTF-8 + * sequence is produced, and the function returns 3. The buffer + * is used to remember the high surrogate between the two calls. + * + * If no low surrogate follows the high surrogate (which is actually + * illegal), this can be handled reasonably by calling Tcl_UniCharToUtf + * again with ch = -1. This will produce a 3-byte UTF-8 sequence + * representing the high surrogate. + * * Results: * The return values is the number of bytes in the buffer that were * consumed. @@ -141,7 +140,7 @@ Tcl_UniCharToUtf( char *buf) /* Buffer in which the UTF-8 representation of * the Tcl_UniChar is stored. Buffer must be * large enough to hold the UTF-8 character - * (at most TCL_UTF_MAX bytes). */ + * (at most 4 bytes). */ { if ((unsigned)(ch - 1) < (UNICODE_SELF - 1)) { buf[0] = (char) ch; @@ -154,7 +153,6 @@ Tcl_UniCharToUtf( return 2; } if (ch <= 0xFFFF) { -#if TCL_UTF_MAX > 3 if ((ch & 0xF800) == 0xD800) { if (ch & 0x0400) { /* Low surrogate */ @@ -176,11 +174,8 @@ Tcl_UniCharToUtf( return 1; } } -#endif goto three; } - -#if TCL_UTF_MAX > 3 if (ch <= 0x10FFFF) { buf[3] = (char) ((ch | 0x80) & 0xBF); buf[2] = (char) (((ch >> 6) | 0x80) & 0xBF); @@ -198,7 +193,6 @@ Tcl_UniCharToUtf( buf[-1] = (char) ((ch >> 12) | 0xE0); return 2; } -#endif } ch = 0xFFFD; @@ -237,28 +231,83 @@ Tcl_UniCharToUtfDString( { const Tcl_UniChar *w, *wEnd; char *p, *string; - int oldLength; + int oldLength, len = 1; /* - * UTF-8 string length in bytes will be <= Unicode string length * - * TCL_UTF_MAX. + * UTF-8 string length in bytes will be <= Unicode string length * 4. */ oldLength = Tcl_DStringLength(dsPtr); - Tcl_DStringSetLength(dsPtr, oldLength + (uniLength + 1) * TCL_UTF_MAX); + Tcl_DStringSetLength(dsPtr, oldLength + (uniLength + 1) * 4); string = Tcl_DStringValue(dsPtr) + oldLength; p = string; wEnd = uniStr + uniLength; for (w = uniStr; w < wEnd; ) { - p += Tcl_UniCharToUtf(*w, p); + if (!len && ((*w & 0xFC00) != 0xDC00)) { + /* Special case for handling high surrogates. */ + p += Tcl_UniCharToUtf(-1, p); + } + len = Tcl_UniCharToUtf(*w, p); + p += len; + if ((*w >= 0xD800) && (len < 3)) { + len = 0; /* Indication that high surrogate was found */ + } w++; } + if (!len) { + /* Special case for handling high surrogates. */ + p += Tcl_UniCharToUtf(-1, p); + } Tcl_DStringSetLength(dsPtr, oldLength + (p - string)); return string; } +#if (TCL_UTF_MAX > 4) && (defined(__CYGWIN__) || defined(_WIN32)) +char * +TclWCharToUtfDString( + const WCHAR *uniStr, /* WCHAR string to convert to UTF-8. */ + int uniLength, /* Length of WCHAR string in Tcl_UniChars + * (must be >= 0). */ + Tcl_DString *dsPtr) /* UTF-8 representation of string is appended + * to this previously initialized DString. */ +{ + const WCHAR *w, *wEnd; + char *p, *string; + int oldLength, len = 1; + + /* + * UTF-8 string length in bytes will be <= Unicode string length * 4. + */ + + oldLength = Tcl_DStringLength(dsPtr); + Tcl_DStringSetLength(dsPtr, oldLength + (uniLength + 1) * 4); + string = Tcl_DStringValue(dsPtr) + oldLength; + + p = string; + wEnd = uniStr + uniLength; + for (w = uniStr; w < wEnd; ) { + if (!len && ((*w & 0xFC00) != 0xDC00)) { + /* Special case for handling high surrogates. */ + p += Tcl_UniCharToUtf(-1, p); + } + len = Tcl_UniCharToUtf(*w, p); + p += len; + if ((*w >= 0xD800) && (len < 3)) { + len = 0; /* Indication that high surrogate was found */ + } + w++; + } + if (!len) { + /* Special case for handling high surrogates. */ + p += Tcl_UniCharToUtf(-1, p); + } + Tcl_DStringSetLength(dsPtr, oldLength + (p - string)); + + return string; +} +#endif /* *--------------------------------------------------------------------------- * @@ -275,11 +324,11 @@ Tcl_UniCharToUtfDString( * Tcl_UtfCharComplete() before calling this routine to ensure that * enough bytes remain in the string. * - * If TCL_UTF_MAX == 4, special handling of Surrogate pairs is done: + * Special handling of Surrogate pairs is handled as follows: * For any UTF-8 string containing a character outside of the BMP, the * first call to this function will fill *chPtr with the high surrogate - * and generate a return value of 0. Calling Tcl_UtfToUniChar again - * will produce the low surrogate and a return value of 4. Because *chPtr + * and generate a return value of 1. Calling Tcl_UtfToUniChar again + * will produce the low surrogate and a return value of 3. Because *chPtr * is used to remember whether the high surrogate is already produced, it * is recommended to initialize the variable it points to as 0 before * the first call to Tcl_UtfToUniChar is done. @@ -294,6 +343,13 @@ Tcl_UniCharToUtfDString( *--------------------------------------------------------------------------- */ +static const unsigned short cp1252[32] = { + 0x20ac, 0x81, 0x201A, 0x0192, 0x201E, 0x2026, 0x2020, 0x2021, + 0x02C6, 0x2030, 0x0160, 0x2039, 0x0152, 0x8D, 0x017D, 0x8F, + 0x90, 0x2018, 0x2019, 0x201C, 0x201D, 0x2022, 0x2013, 0x2014, + 0x2DC, 0x2122, 0x0161, 0x203A, 0x0153, 0x9D, 0x017E, 0x0178 +}; + int Tcl_UtfToUniChar( register const char *src, /* The UTF-8 string. */ @@ -303,18 +359,20 @@ Tcl_UtfToUniChar( Tcl_UniChar byte; /* - * Unroll 1 to 3 (or 4) byte UTF-8 sequences. + * Unroll 1 to 4 byte UTF-8 sequences. */ byte = *((unsigned char *) src); if (byte < 0xC0) { /* * Handles properly formed UTF-8 characters between 0x01 and 0x7F. - * Also treats \0 and naked trail bytes 0x80 to 0xBF as valid + * Treats naked trail bytes 0x80 to 0x9F as valid characters from + * the cp1252 table. See: <https://en.wikipedia.org/wiki/UTF-8> + * Also treats \0 and other naked trail bytes 0xA0 to 0xBF as valid * characters representing themselves. */ -#if TCL_UTF_MAX == 4 +#if TCL_UTF_MAX <= 4 /* If *chPtr contains a high surrogate (produced by a previous * Tcl_UtfToUniChar() call) and the next 3 bytes are UTF-8 continuation * bytes, then we must produce a follow-up low surrogate. We only @@ -328,7 +386,11 @@ Tcl_UtfToUniChar( return 3; } #endif - *chPtr = byte; + if ((unsigned)(byte-0x80) < (unsigned)0x20) { + *chPtr = cp1252[byte-0x80]; + } else { + *chPtr = byte; + } return 1; } else if (byte < 0xE0) { if ((src[1] & 0xC0) == 0x80) { @@ -364,13 +426,12 @@ Tcl_UtfToUniChar( * represents itself. */ } -#if TCL_UTF_MAX > 3 else if (byte < 0xF8) { if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80) && ((src[3] & 0xC0) == 0x80)) { /* * Four-byte-character lead byte followed by three trail bytes. */ -#if TCL_UTF_MAX == 4 +#if TCL_UTF_MAX <= 4 Tcl_UniChar high = (((byte & 0x07) << 8) | ((src[1] & 0x3F) << 2) | ((src[2] & 0x3F) >> 4)) - 0x40; if (high >= 0x400) { @@ -394,12 +455,113 @@ Tcl_UtfToUniChar( * represents itself. */ } -#endif *chPtr = byte; return 1; } - + +#if (TCL_UTF_MAX > 4) && (defined(__CYGWIN__) || defined(_WIN32)) +int +TclUtfToWChar( + const char *src, /* The UTF-8 string. */ + WCHAR *chPtr)/* Filled with the WCHAR represented by + * the UTF-8 string. */ +{ + WCHAR byte; + + /* + * Unroll 1 to 4 byte UTF-8 sequences. + */ + + byte = *((unsigned char *) src); + if (byte < 0xC0) { + /* + * Handles properly formed UTF-8 characters between 0x01 and 0x7F. + * Treats naked trail bytes 0x80 to 0x9F as valid characters from + * the cp1252 table. See: <https://en.wikipedia.org/wiki/UTF-8> + * Also treats \0 and other naked trail bytes 0xA0 to 0xBF as valid + * characters representing themselves. + */ + + /* If *chPtr contains a high surrogate (produced by a previous + * Tcl_UtfToUniChar() call) and the next 3 bytes are UTF-8 continuation + * bytes, then we must produce a follow-up low surrogate. We only + * do that if the high surrogate matches the bits we encounter. + */ + if ((byte >= 0x80) + && (((((byte - 0x10) << 2) & 0xFC) | 0xD800) == (*chPtr & 0xFCFC)) + && ((src[1] & 0xF0) == (((*chPtr << 4) & 0x30) | 0x80)) + && ((src[2] & 0xC0) == 0x80)) { + *chPtr = ((src[1] & 0x0F) << 6) + (src[2] & 0x3F) + 0xDC00; + return 3; + } + if ((unsigned)(byte-0x80) < (unsigned)0x20) { + *chPtr = cp1252[byte-0x80]; + } else { + *chPtr = byte; + } + return 1; + } else if (byte < 0xE0) { + if ((src[1] & 0xC0) == 0x80) { + /* + * Two-byte-character lead-byte followed by a trail-byte. + */ + + *chPtr = (((byte & 0x1F) << 6) | (src[1] & 0x3F)); + if ((unsigned)(*chPtr - 1) >= (UNICODE_SELF - 1)) { + return 2; + } + } + + /* + * A two-byte-character lead-byte not followed by trail-byte + * represents itself. + */ + } else if (byte < 0xF0) { + if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80)) { + /* + * Three-byte-character lead byte followed by two trail bytes. + */ + + *chPtr = (((byte & 0x0F) << 12) + | ((src[1] & 0x3F) << 6) | (src[2] & 0x3F)); + if (*chPtr > 0x7FF) { + return 3; + } + } + + /* + * A three-byte-character lead-byte not followed by two trail-bytes + * represents itself. + */ + } + else if (byte < 0xF8) { + if (((src[1] & 0xC0) == 0x80) && ((src[2] & 0xC0) == 0x80) && ((src[3] & 0xC0) == 0x80)) { + /* + * Four-byte-character lead byte followed by three trail bytes. + */ + WCHAR high = (((byte & 0x07) << 8) | ((src[1] & 0x3F) << 2) + | ((src[2] & 0x3F) >> 4)) - 0x40; + if (high >= 0x400) { + /* out of range, < 0x10000 or > 0x10ffff */ + } else { + /* produce high surrogate, advance source pointer */ + *chPtr = 0xD800 + high; + return 1; + } + } + + /* + * A four-byte-character lead-byte not followed by three trail-bytes + * represents itself. + */ + } + + *chPtr = byte; + return 1; +} +#endif + /* *--------------------------------------------------------------------------- * @@ -448,12 +610,12 @@ Tcl_UtfToUniCharDString( w = wString; p = src; - end = src + length - TCL_UTF_MAX; + end = src + length - 4; while (p < end) { p += TclUtfToUniChar(p, &ch); *w++ = ch; } - end += TCL_UTF_MAX; + end += 4; while (p < end) { if (Tcl_UtfCharComplete(p, end-p)) { p += TclUtfToUniChar(p, &ch); @@ -464,11 +626,63 @@ Tcl_UtfToUniCharDString( } *w = '\0'; Tcl_DStringSetLength(dsPtr, - (oldLength + ((char *) w - (char *) wString))); + oldLength + ((char *) w - (char *) wString)); return wString; } - + +#if (TCL_UTF_MAX > 4) && (defined(__CYGWIN__) || defined(_WIN32)) +WCHAR * +TclUtfToWCharDString( + const char *src, /* UTF-8 string to convert to Unicode. */ + int length, /* Length of UTF-8 string in bytes, or -1 for + * strlen(). */ + Tcl_DString *dsPtr) /* Unicode representation of string is + * appended to this previously initialized + * DString. */ +{ + WCHAR ch = 0, *w, *wString; + const char *p, *end; + int oldLength; + + if (length < 0) { + length = strlen(src); + } + + /* + * Unicode string length in Tcl_UniChars will be <= UTF-8 string length in + * bytes. + */ + + oldLength = Tcl_DStringLength(dsPtr); + + Tcl_DStringSetLength(dsPtr, + oldLength + (int) ((length + 1) * sizeof(WCHAR))); + wString = (WCHAR *) (Tcl_DStringValue(dsPtr) + oldLength); + + w = wString; + p = src; + end = src + length - 4; + while (p < end) { + p += TclUtfToWChar(p, &ch); + *w++ = ch; + } + end += 4; + while (p < end) { + if (Tcl_UtfCharComplete(p, end-p)) { + p += TclUtfToWChar(p, &ch); + } else { + ch = UCHAR(*p++); + } + *w++ = ch; + } + *w = '\0'; + Tcl_DStringSetLength(dsPtr, + oldLength + ((char *) w - (char *) wString)); + + return wString; +} +#endif /* *--------------------------------------------------------------------------- * @@ -538,13 +752,13 @@ Tcl_NumUtfChars( } if (i < 0) i = INT_MAX; /* Bug [2738427] */ } else { - register const char *endPtr = src + length - TCL_UTF_MAX; + register const char *endPtr = src + length - 4; while (src < endPtr) { src += TclUtfToUniChar(src, &ch); i++; } - endPtr += TCL_UTF_MAX; + endPtr += 4; while ((src < endPtr) && Tcl_UtfCharComplete(src, endPtr - src)) { src += TclUtfToUniChar(src, &ch); i++; @@ -586,7 +800,7 @@ Tcl_UtfFindFirst( while (1) { len = TclUtfToUniChar(src, &find); fullchar = find; -#if TCL_UTF_MAX == 4 +#if TCL_UTF_MAX <= 4 if ((ch >= 0xD800) && (len < 3)) { len += TclUtfToUniChar(src + len, &find); fullchar = (((fullchar & 0x3ff) << 10) | (find & 0x3ff)) + 0x10000; @@ -634,7 +848,7 @@ Tcl_UtfFindLast( while (1) { len = TclUtfToUniChar(src, &find); fullchar = find; -#if TCL_UTF_MAX == 4 +#if TCL_UTF_MAX <= 4 if ((ch >= 0xD800) && (len < 3)) { len += TclUtfToUniChar(src + len, &find); fullchar = (((fullchar & 0x3ff) << 10) | (find & 0x3ff)) + 0x10000; @@ -677,7 +891,7 @@ Tcl_UtfNext( Tcl_UniChar ch = 0; int len = TclUtfToUniChar(src, &ch); -#if TCL_UTF_MAX == 4 +#if TCL_UTF_MAX <= 4 if ((ch >= 0xD800) && (len < 3)) { len += TclUtfToUniChar(src + len, &ch); } @@ -716,7 +930,7 @@ Tcl_UtfPrev( int i, byte; look = --src; - for (i = 0; i < TCL_UTF_MAX; i++) { + for (i = 0; i < 4; i++) { if (look < start) { if (src < start) { src = start; @@ -752,17 +966,33 @@ Tcl_UtfPrev( *--------------------------------------------------------------------------- */ -Tcl_UniChar +int Tcl_UniCharAtIndex( register const char *src, /* The UTF-8 string to dereference. */ register int index) /* The position of the desired character. */ { Tcl_UniChar ch = 0; + int fullchar = 0; +#if TCL_UTF_MAX <= 4 + int len = 0; +#endif while (index-- >= 0) { +#if TCL_UTF_MAX <= 4 + src += (len = TclUtfToUniChar(src, &ch)); +#else src += TclUtfToUniChar(src, &ch); +#endif + } + fullchar = ch; +#if TCL_UTF_MAX <= 4 + if ((ch >= 0xD800) && (len < 3)) { + /* If last Tcl_UniChar was a high surrogate, combine with low surrogate */ + (void)TclUtfToUniChar(src, &ch); + fullchar = (((fullchar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; } - return ch; +#endif + return fullchar; } /* @@ -771,7 +1001,9 @@ Tcl_UniCharAtIndex( * Tcl_UtfAtIndex -- * * Returns a pointer to the specified character (not byte) position in - * the UTF-8 string. + * the UTF-8 string. If TCL_UTF_MAX <= 4, characters > U+FFFF count as + * 2 positions, but then the pointer should never be placed between + * the two positions. * * Results: * As above. @@ -794,7 +1026,7 @@ Tcl_UtfAtIndex( len = TclUtfToUniChar(src, &ch); src += len; } -#if TCL_UTF_MAX == 4 +#if TCL_UTF_MAX <= 4 if ((ch >= 0xD800) && (len < 3)) { /* Index points at character following high Surrogate */ src += TclUtfToUniChar(src, &ch); @@ -812,7 +1044,7 @@ Tcl_UtfAtIndex( * * Results: * Stores the bytes represented by the backslash sequence in dst and - * returns the number of bytes written to dst. At most TCL_UTF_MAX bytes + * returns the number of bytes written to dst. At most 4 bytes * are written to dst; dst must have been large enough to accept those * bytes. If readPtr isn't NULL then it is filled in with a count of the * number of bytes in the backslash sequence. @@ -878,7 +1110,8 @@ int Tcl_UtfToUpper( char *str) /* String to convert in place. */ { - Tcl_UniChar ch = 0, upChar; + Tcl_UniChar ch = 0; + int upChar; char *src, *dst; int len; @@ -889,7 +1122,15 @@ Tcl_UtfToUpper( src = dst = str; while (*src) { len = TclUtfToUniChar(src, &ch); - upChar = Tcl_UniCharToUpper(ch); + upChar = ch; +#if TCL_UTF_MAX <= 4 + if ((ch >= 0xD800) && (len < 3)) { + len += TclUtfToUniChar(src + len, &ch); + /* Combine surrogates */ + upChar = (((upChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; + } +#endif + upChar = Tcl_UniCharToUpper(upChar); /* * To keep badly formed Utf strings from getting inflated by the @@ -897,7 +1138,7 @@ Tcl_UtfToUpper( * char to dst if its size is <= the original char. */ - if (len < UtfCount(upChar)) { + if ((len < TclUtfCount(upChar)) || ((upChar & 0xF800) == 0xD800)) { memmove(dst, src, len); dst += len; } else { @@ -931,7 +1172,8 @@ int Tcl_UtfToLower( char *str) /* String to convert in place. */ { - Tcl_UniChar ch = 0, lowChar; + Tcl_UniChar ch = 0; + int lowChar; char *src, *dst; int len; @@ -942,7 +1184,15 @@ Tcl_UtfToLower( src = dst = str; while (*src) { len = TclUtfToUniChar(src, &ch); - lowChar = Tcl_UniCharToLower(ch); + lowChar = ch; +#if TCL_UTF_MAX <= 4 + if ((ch >= 0xD800) && (len < 3)) { + len += TclUtfToUniChar(src + len, &ch); + /* Combine surrogates */ + lowChar = (((lowChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; + } +#endif + lowChar = Tcl_UniCharToLower(lowChar); /* * To keep badly formed Utf strings from getting inflated by the @@ -950,7 +1200,7 @@ Tcl_UtfToLower( * char to dst if its size is <= the original char. */ - if (len < UtfCount(lowChar)) { + if ((len < TclUtfCount(lowChar)) || ((lowChar & 0xF800) == 0xD800)) { memmove(dst, src, len); dst += len; } else { @@ -985,7 +1235,8 @@ int Tcl_UtfToTitle( char *str) /* String to convert in place. */ { - Tcl_UniChar ch = 0, titleChar, lowChar; + Tcl_UniChar ch = 0; + int titleChar, lowChar; char *src, *dst; int len; @@ -998,9 +1249,17 @@ Tcl_UtfToTitle( if (*src) { len = TclUtfToUniChar(src, &ch); - titleChar = Tcl_UniCharToTitle(ch); + titleChar = ch; +#if TCL_UTF_MAX <= 4 + if ((ch >= 0xD800) && (len < 3)) { + len += TclUtfToUniChar(src + len, &ch); + /* Combine surrogates */ + titleChar = (((titleChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; + } +#endif + titleChar = Tcl_UniCharToTitle(titleChar); - if (len < UtfCount(titleChar)) { + if ((len < TclUtfCount(titleChar)) || ((titleChar & 0xF800) == 0xD800)) { memmove(dst, src, len); dst += len; } else { @@ -1011,12 +1270,19 @@ Tcl_UtfToTitle( while (*src) { len = TclUtfToUniChar(src, &ch); lowChar = ch; +#if TCL_UTF_MAX <= 4 + if ((ch >= 0xD800) && (len < 3)) { + len += TclUtfToUniChar(src + len, &ch); + /* Combine surrogates */ + lowChar = (((lowChar & 0x3ff) << 10) | (ch & 0x3ff)) + 0x10000; + } +#endif /* Special exception for Georgian Asomtavruli chars, no titlecase. */ if ((unsigned)(lowChar - 0x1C90) >= 0x30) { lowChar = Tcl_UniCharToLower(lowChar); } - if (len < UtfCount(lowChar)) { + if ((len < TclUtfCount(lowChar)) || ((lowChar & 0xF800) == 0xD800)) { memmove(dst, src, len); dst += len; } else { @@ -1116,7 +1382,7 @@ Tcl_UtfNcmp( cs += TclUtfToUniChar(cs, &ch1); ct += TclUtfToUniChar(ct, &ch2); if (ch1 != ch2) { -#if TCL_UTF_MAX == 4 +#if TCL_UTF_MAX <= 4 /* Surrogates always report higher than non-surrogates */ if (((ch1 & 0xFC00) == 0xD800)) { if ((ch2 & 0xFC00) != 0xD800) { @@ -1167,7 +1433,7 @@ Tcl_UtfNcasecmp( cs += TclUtfToUniChar(cs, &ch1); ct += TclUtfToUniChar(ct, &ch2); if (ch1 != ch2) { -#if TCL_UTF_MAX == 4 +#if TCL_UTF_MAX <= 4 /* Surrogates always report higher than non-surrogates */ if (((ch1 & 0xFC00) == 0xD800)) { if ((ch2 & 0xFC00) != 0xD800) { @@ -1186,6 +1452,52 @@ Tcl_UtfNcasecmp( } return 0; } + +/* + *---------------------------------------------------------------------- + * + * Tcl_UtfCmp -- + * + * Compare UTF chars of string cs to string ct case sensitively. + * Replacement for strcmp in Tcl core, in places where UTF-8 should + * be handled. + * + * Results: + * Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclUtfCmp( + const char *cs, /* UTF string to compare to ct. */ + const char *ct) /* UTF string cs is compared to. */ +{ + Tcl_UniChar ch1 = 0, ch2 = 0; + + while (*cs && *ct) { + cs += TclUtfToUniChar(cs, &ch1); + ct += TclUtfToUniChar(ct, &ch2); + if (ch1 != ch2) { +#if TCL_UTF_MAX <= 4 + /* Surrogates always report higher than non-surrogates */ + if (((ch1 & 0xFC00) == 0xD800)) { + if ((ch2 & 0xFC00) != 0xD800) { + return ch1; + } + } else if ((ch2 & 0xFC00) == 0xD800) { + return -ch2; + } +#endif + return ch1 - ch2; + } + } + return UCHAR(*cs) - UCHAR(*ct); +} + /* *---------------------------------------------------------------------- @@ -1216,7 +1528,7 @@ TclUtfCasecmp( cs += TclUtfToUniChar(cs, &ch1); ct += TclUtfToUniChar(ct, &ch2); if (ch1 != ch2) { -#if TCL_UTF_MAX == 4 +#if TCL_UTF_MAX <= 4 /* Surrogates always report higher than non-surrogates */ if (((ch1 & 0xFC00) == 0xD800)) { if ((ch2 & 0xFC00) != 0xD800) { @@ -1253,16 +1565,18 @@ TclUtfCasecmp( *---------------------------------------------------------------------- */ -Tcl_UniChar +int Tcl_UniCharToUpper( int ch) /* Unicode character to convert. */ { - int info = GetUniCharInfo(ch); + if (!UNICODE_OUT_OF_RANGE(ch)) { + int info = GetUniCharInfo(ch); - if (GetCaseType(info) & 0x04) { - ch -= GetDelta(info); + if (GetCaseType(info) & 0x04) { + ch -= GetDelta(info); + } } - return (Tcl_UniChar) ch; + return ch & 0x1FFFFF; } /* @@ -1281,17 +1595,19 @@ Tcl_UniCharToUpper( *---------------------------------------------------------------------- */ -Tcl_UniChar +int Tcl_UniCharToLower( int ch) /* Unicode character to convert. */ { - int info = GetUniCharInfo(ch); - int mode = GetCaseType(info); + if (!UNICODE_OUT_OF_RANGE(ch)) { + int info = GetUniCharInfo(ch); + int mode = GetCaseType(info); - if ((mode & 0x02) && (mode != 0x7)) { - ch += GetDelta(info); + if ((mode & 0x02) && (mode != 0x7)) { + ch += GetDelta(info); + } } - return (Tcl_UniChar) ch; + return ch & 0x1FFFFF; } /* @@ -1310,25 +1626,27 @@ Tcl_UniCharToLower( *---------------------------------------------------------------------- */ -Tcl_UniChar +int Tcl_UniCharToTitle( int ch) /* Unicode character to convert. */ { - int info = GetUniCharInfo(ch); - int mode = GetCaseType(info); + if (!UNICODE_OUT_OF_RANGE(ch)) { + int info = GetUniCharInfo(ch); + int mode = GetCaseType(info); - if (mode & 0x1) { - /* - * Subtract or add one depending on the original case. - */ + if (mode & 0x1) { + /* + * Subtract or add one depending on the original case. + */ - if (mode != 0x7) { - ch += ((mode & 0x4) ? -1 : 1); + if (mode != 0x7) { + ch += ((mode & 0x4) ? -1 : 1); + } + } else if (mode == 0x4) { + ch -= GetDelta(info); } - } else if (mode == 0x4) { - ch -= GetDelta(info); } - return (Tcl_UniChar) ch; + return ch & 0x1FFFFF; } /* @@ -1462,11 +1780,9 @@ int Tcl_UniCharIsAlnum( int ch) /* Unicode character to test. */ { -#if TCL_UTF_MAX > 3 if (UNICODE_OUT_OF_RANGE(ch)) { return 0; } -#endif return (((ALPHA_BITS | DIGIT_BITS) >> GetCategory(ch)) & 1); } @@ -1490,11 +1806,9 @@ int Tcl_UniCharIsAlpha( int ch) /* Unicode character to test. */ { -#if TCL_UTF_MAX > 3 if (UNICODE_OUT_OF_RANGE(ch)) { return 0; } -#endif return ((ALPHA_BITS >> GetCategory(ch)) & 1); } @@ -1518,7 +1832,6 @@ int Tcl_UniCharIsControl( int ch) /* Unicode character to test. */ { -#if TCL_UTF_MAX > 3 if (UNICODE_OUT_OF_RANGE(ch)) { ch &= 0x1FFFFF; if ((ch == 0xE0001) || ((ch >= 0xE0020) && (ch <= 0xE007f))) { @@ -1529,7 +1842,6 @@ Tcl_UniCharIsControl( } return 0; } -#endif return ((CONTROL_BITS >> GetCategory(ch)) & 1); } @@ -1553,11 +1865,9 @@ int Tcl_UniCharIsDigit( int ch) /* Unicode character to test. */ { -#if TCL_UTF_MAX > 3 if (UNICODE_OUT_OF_RANGE(ch)) { return 0; } -#endif return (GetCategory(ch) == DECIMAL_DIGIT_NUMBER); } @@ -1581,12 +1891,10 @@ int Tcl_UniCharIsGraph( int ch) /* Unicode character to test. */ { -#if TCL_UTF_MAX > 3 if (UNICODE_OUT_OF_RANGE(ch)) { ch &= 0x1FFFFF; return (ch >= 0xE0100) && (ch <= 0xE01EF); } -#endif return ((GRAPH_BITS >> GetCategory(ch)) & 1); } @@ -1610,11 +1918,9 @@ int Tcl_UniCharIsLower( int ch) /* Unicode character to test. */ { -#if TCL_UTF_MAX > 3 if (UNICODE_OUT_OF_RANGE(ch)) { return 0; } -#endif return (GetCategory(ch) == LOWERCASE_LETTER); } @@ -1638,12 +1944,10 @@ int Tcl_UniCharIsPrint( int ch) /* Unicode character to test. */ { -#if TCL_UTF_MAX > 3 if (UNICODE_OUT_OF_RANGE(ch)) { ch &= 0x1FFFFF; return (ch >= 0xE0100) && (ch <= 0xE01EF); } -#endif return (((GRAPH_BITS|SPACE_BITS) >> GetCategory(ch)) & 1); } @@ -1667,11 +1971,9 @@ int Tcl_UniCharIsPunct( int ch) /* Unicode character to test. */ { -#if TCL_UTF_MAX > 3 if (UNICODE_OUT_OF_RANGE(ch)) { return 0; } -#endif return ((PUNCT_BITS >> GetCategory(ch)) & 1); } @@ -1695,13 +1997,8 @@ int Tcl_UniCharIsSpace( int ch) /* Unicode character to test. */ { -#if TCL_UTF_MAX > 3 /* Ignore upper 11 bits. */ ch &= 0x1FFFFF; -#else - /* Ignore upper 16 bits. */ - ch &= 0xFFFF; -#endif /* * If the character is within the first 127 characters, just use the @@ -1710,10 +2007,8 @@ Tcl_UniCharIsSpace( if (ch < 0x80) { return TclIsSpaceProc((char) ch); -#if TCL_UTF_MAX > 3 } else if (UNICODE_OUT_OF_RANGE(ch)) { return 0; -#endif } else if (ch == 0x0085 || ch == 0x180E || ch == 0x200B || ch == 0x202F || ch == 0x2060 || ch == 0xFEFF) { return 1; @@ -1742,11 +2037,9 @@ int Tcl_UniCharIsUpper( int ch) /* Unicode character to test. */ { -#if TCL_UTF_MAX > 3 if (UNICODE_OUT_OF_RANGE(ch)) { return 0; } -#endif return (GetCategory(ch) == UPPERCASE_LETTER); } @@ -1770,11 +2063,9 @@ int Tcl_UniCharIsWordChar( int ch) /* Unicode character to test. */ { -#if TCL_UTF_MAX > 3 if (UNICODE_OUT_OF_RANGE(ch)) { return 0; } -#endif return ((WORD_BITS >> GetCategory(ch)) & 1); } @@ -1860,7 +2151,7 @@ Tcl_UniCharCaseMatch( if ((p != '[') && (p != '?') && (p != '\\')) { if (nocase) { while (*uniStr && (p != *uniStr) - && (p != Tcl_UniCharToLower(*uniStr))) { + && (p != (Tcl_UniChar)Tcl_UniCharToLower(*uniStr))) { uniStr++; } } else { @@ -1900,13 +2191,13 @@ Tcl_UniCharCaseMatch( Tcl_UniChar startChar, endChar; uniPattern++; - ch1 = (nocase ? Tcl_UniCharToLower(*uniStr) : *uniStr); + ch1 = (nocase ? (Tcl_UniChar)Tcl_UniCharToLower(*uniStr) : *uniStr); uniStr++; while (1) { if ((*uniPattern == ']') || (*uniPattern == 0)) { return 0; } - startChar = (nocase ? Tcl_UniCharToLower(*uniPattern) + startChar = (nocase ? (Tcl_UniChar)Tcl_UniCharToLower(*uniPattern) : *uniPattern); uniPattern++; if (*uniPattern == '-') { @@ -1914,7 +2205,7 @@ Tcl_UniCharCaseMatch( if (*uniPattern == 0) { return 0; } - endChar = (nocase ? Tcl_UniCharToLower(*uniPattern) + endChar = (nocase ? (Tcl_UniChar)Tcl_UniCharToLower(*uniPattern) : *uniPattern); uniPattern++; if (((startChar <= ch1) && (ch1 <= endChar)) @@ -2052,7 +2343,7 @@ TclUniCharMatch( if ((p != '[') && (p != '?') && (p != '\\')) { if (nocase) { while ((string < stringEnd) && (p != *string) - && (p != Tcl_UniCharToLower(*string))) { + && (p != (Tcl_UniChar)Tcl_UniCharToLower(*string))) { string++; } } else { @@ -2093,20 +2384,20 @@ TclUniCharMatch( Tcl_UniChar ch1, startChar, endChar; pattern++; - ch1 = (nocase ? Tcl_UniCharToLower(*string) : *string); + ch1 = (nocase ? (Tcl_UniChar)Tcl_UniCharToLower(*string) : *string); string++; while (1) { if ((*pattern == ']') || (pattern == patternEnd)) { return 0; } - startChar = (nocase ? Tcl_UniCharToLower(*pattern) : *pattern); + startChar = (nocase ? (Tcl_UniChar)Tcl_UniCharToLower(*pattern) : *pattern); pattern++; if (*pattern == '-') { pattern++; if (pattern == patternEnd) { return 0; } - endChar = (nocase ? Tcl_UniCharToLower(*pattern) + endChar = (nocase ? (Tcl_UniChar)Tcl_UniCharToLower(*pattern) : *pattern); pattern++; if (((startChar <= ch1) && (ch1 <= endChar)) diff --git a/generic/tclUtil.c b/generic/tclUtil.c index fc5a2ac..4387c75 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -15,6 +15,7 @@ #include "tclInt.h" #include "tclParse.h" #include "tclStringTrim.h" +#include "tommath.h" #include <math.h> /* @@ -107,12 +108,11 @@ static Tcl_ThreadDataKey precisionKey; static void ClearHash(Tcl_HashTable *tablePtr); static void FreeProcessGlobalValue(ClientData clientData); static void FreeThreadHash(ClientData clientData); -static int GetEndOffsetFromObj(Tcl_Obj *objPtr, int endValue, - int *indexPtr); +static int GetEndOffsetFromObj(Tcl_Obj *objPtr, + size_t endValue, Tcl_WideInt *indexPtr); static Tcl_HashTable * GetThreadHash(Tcl_ThreadDataKey *keyPtr); -static int SetEndOffsetFromAny(Tcl_Interp *interp, - Tcl_Obj *objPtr); -static void UpdateStringOfEndOffset(Tcl_Obj *objPtr); +static int GetWideForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr, + size_t endValue, Tcl_WideInt *widePtr); static int FindElement(Tcl_Interp *interp, const char *string, int stringLength, const char *typeStr, const char *typeCode, const char **elementPtr, @@ -121,16 +121,20 @@ static int FindElement(Tcl_Interp *interp, const char *string, /* * The following is the Tcl object type definition for an object that * represents a list index in the form, "end-offset". It is used as a - * performance optimization in TclGetIntForIndex. The internal rep is an - * integer, so no memory management is required for it. + * performance optimization in Tcl_GetIntForIndex. The internal rep is + * stored directly in the wideValue, so no memory management is required + * for it. This is a caching intrep, keeping the result of a parse + * around. This type is only created from a pre-existing string, so an + * updateStringProc will never be called and need not exist. The type + * is unregistered, so has no need of a setFromAnyProc either. */ -const Tcl_ObjType tclEndOffsetType = { +static const Tcl_ObjType endOffsetType = { "end-offset", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ - UpdateStringOfEndOffset, /* updateStringProc */ - SetEndOffsetFromAny + NULL, /* updateStringProc */ + NULL /* setFromAnyProc */ }; /* @@ -901,7 +905,7 @@ Tcl_SplitList( } argv[i] = p; if (literal) { - memcpy(p, element, (size_t) elSize); + memcpy(p, element, elSize); p += elSize; *p = 0; p++; @@ -1403,9 +1407,9 @@ TclConvertElement( */ if ((src == NULL) || (length == 0) || (*src == '\0' && length == -1)) { - src = tclEmptyStringRep; - length = 0; - conversion = CONVERT_BRACE; + p[0] = '{'; + p[1] = '}'; + return 2; } /* @@ -1623,6 +1627,7 @@ Tcl_Merge( return result; } +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 /* *---------------------------------------------------------------------- * @@ -1649,13 +1654,14 @@ Tcl_Backslash( int *readPtr) /* Fill in with number of characters read from * src, unless NULL. */ { - char buf[TCL_UTF_MAX] = ""; + char buf[4] = ""; Tcl_UniChar ch = 0; Tcl_UtfBackslash(src, readPtr, buf); TclUtfToUniChar(buf, &ch); return (char) ch; } +#endif /* !TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -1719,13 +1725,13 @@ TrimRight( { const char *p = bytes + numBytes; int pInc; + Tcl_UniChar ch1 = 0, ch2 = 0; /* * Outer loop: iterate over string to be trimmed. */ do { - Tcl_UniChar ch1; const char *q = trim; int bytesLeft = numTrim; @@ -1737,7 +1743,6 @@ TrimRight( */ do { - Tcl_UniChar ch2; int qInc = TclUtfToUniChar(q, &ch2); if (ch1 == ch2) { @@ -1818,13 +1823,13 @@ TrimLeft( int numTrim) /* ...and its length in bytes */ { const char *p = bytes; + Tcl_UniChar ch1 = 0, ch2 = 0; /* * Outer loop: iterate over string to be trimmed. */ do { - Tcl_UniChar ch1; int pInc = TclUtfToUniChar(p, &ch1); const char *q = trim; int bytesLeft = numTrim; @@ -1834,7 +1839,6 @@ TrimLeft( */ do { - Tcl_UniChar ch2; int qInc = TclUtfToUniChar(q, &ch2); if (ch1 == ch2) { @@ -2012,7 +2016,7 @@ Tcl_Concat( * All element bytes + (argc - 1) spaces + 1 terminating NULL. */ - result = ckalloc((unsigned) (bytesNeeded + argc)); + result = ckalloc(bytesNeeded + argc); for (p = result, i = 0; i < argc; i++) { int triml, trimr, elemLength; @@ -2045,7 +2049,7 @@ Tcl_Concat( if (needSpace) { *p++ = ' '; } - memcpy(p, element, (size_t) elemLength); + memcpy(p, element, elemLength); p += elemLength; needSpace = 1; } @@ -2093,7 +2097,7 @@ Tcl_ConcatObj( if (TclListObjIsCanonical(objPtr)) { continue; } - Tcl_GetStringFromObj(objPtr, &length); + TclGetStringFromObj(objPtr, &length); if (length > 0) { break; } @@ -2102,7 +2106,7 @@ Tcl_ConcatObj( resPtr = NULL; for (i = 0; i < objc; i++) { objPtr = objv[i]; - if (objPtr->bytes && objPtr->length == 0) { + if (!TclListObjIsCanonical(objPtr)) { continue; } if (resPtr) { @@ -2182,6 +2186,7 @@ Tcl_ConcatObj( return resPtr; } +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 /* *---------------------------------------------------------------------- * @@ -2200,6 +2205,7 @@ Tcl_ConcatObj( *---------------------------------------------------------------------- */ +#undef Tcl_StringMatch int Tcl_StringMatch( const char *str, /* String. */ @@ -2208,7 +2214,7 @@ Tcl_StringMatch( { return Tcl_StringCaseMatch(str, pattern, 0); } - +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- * @@ -2237,7 +2243,7 @@ Tcl_StringCaseMatch( { int p, charLen; const char *pstart = pattern; - Tcl_UniChar ch1, ch2; + Tcl_UniChar ch1 = 0, ch2 = 0; while (1) { p = *pattern; @@ -2298,7 +2304,7 @@ Tcl_StringCaseMatch( if (nocase) { while (*str) { charLen = TclUtfToUniChar(str, &ch1); - if (ch2==ch1 || ch2==Tcl_UniCharToLower(ch1)) { + if (ch2==ch1 || ch2==(Tcl_UniChar)Tcl_UniCharToLower(ch1)) { break; } str += charLen; @@ -2347,7 +2353,7 @@ Tcl_StringCaseMatch( */ if (p == '[') { - Tcl_UniChar startChar, endChar; + Tcl_UniChar startChar = 0, endChar = 0; pattern++; if (UCHAR(*str) < 0x80) { @@ -2654,7 +2660,7 @@ TclStringMatchObj( trivial = nocase ? 0 : TclMatchIsTrivial(TclGetString(ptnObj)); */ - if ((strObj->typePtr == &tclStringType) || (strObj->typePtr == NULL)) { + if (TclHasIntRep(strObj, &tclStringType) || (strObj->typePtr == NULL)) { Tcl_UniChar *udata, *uptn; udata = Tcl_GetUnicodeFromObj(strObj, &length); @@ -2747,7 +2753,7 @@ Tcl_DStringAppend( if (dsPtr->string == dsPtr->staticSpace) { char *newString = ckalloc(dsPtr->spaceAvl); - memcpy(newString, dsPtr->string, (size_t) dsPtr->length); + memcpy(newString, dsPtr->string, dsPtr->length); dsPtr->string = newString; } else { int offset = -1; @@ -2793,7 +2799,7 @@ TclDStringAppendObj( Tcl_Obj *objPtr) { int length; - char *bytes = Tcl_GetStringFromObj(objPtr, &length); + char *bytes = TclGetStringFromObj(objPtr, &length); return Tcl_DStringAppend(dsPtr, bytes, length); } @@ -2850,7 +2856,7 @@ Tcl_DStringAppendElement( if (dsPtr->string == dsPtr->staticSpace) { char *newString = ckalloc(dsPtr->spaceAvl); - memcpy(newString, dsPtr->string, (size_t) dsPtr->length); + memcpy(newString, dsPtr->string, dsPtr->length); dsPtr->string = newString; } else { int offset = -1; @@ -2944,7 +2950,7 @@ Tcl_DStringSetLength( if (dsPtr->string == dsPtr->staticSpace) { char *newString = ckalloc(dsPtr->spaceAvl); - memcpy(newString, dsPtr->string, (size_t) dsPtr->length); + memcpy(newString, dsPtr->string, dsPtr->length); dsPtr->string = newString; } else { dsPtr->string = ckrealloc(dsPtr->string, dsPtr->spaceAvl); @@ -3010,7 +3016,6 @@ Tcl_DStringResult( Tcl_DString *dsPtr) /* Dynamic string that is to become the * result of interp. */ { - Tcl_ResetResult(interp); Tcl_SetObjResult(interp, TclDStringToObj(dsPtr)); } @@ -3040,6 +3045,14 @@ Tcl_DStringGetResult( Tcl_DString *dsPtr) /* Dynamic string that is to become the result * of interp. */ { +#ifdef TCL_NO_DEPRECATED + Tcl_Obj *obj = Tcl_GetObjResult(interp); + const char *bytes = TclGetString(obj); + + Tcl_DStringFree(dsPtr); + Tcl_DStringAppend(dsPtr, bytes, obj->length); + Tcl_ResetResult(interp); +#else Interp *iPtr = (Interp *) interp; if (dsPtr->string != dsPtr->staticSpace) { @@ -3048,7 +3061,7 @@ Tcl_DStringGetResult( /* * Do more efficient transfer when we know the result is a Tcl_Obj. When - * there's no st`ring result, we only have to deal with two cases: + * there's no string result, we only have to deal with two cases: * * 1. When the string rep is the empty string, when we don't copy but * instead use the staticSpace in the DString to hold an empty string. @@ -3063,17 +3076,17 @@ Tcl_DStringGetResult( if (!iPtr->result[0] && iPtr->objResultPtr && !Tcl_IsShared(iPtr->objResultPtr)) { - if (iPtr->objResultPtr->bytes == tclEmptyStringRep) { + if (iPtr->objResultPtr->bytes == &tclEmptyString) { dsPtr->string = dsPtr->staticSpace; dsPtr->string[0] = 0; dsPtr->length = 0; dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; } else { - dsPtr->string = Tcl_GetString(iPtr->objResultPtr); + dsPtr->string = TclGetString(iPtr->objResultPtr); dsPtr->length = iPtr->objResultPtr->length; dsPtr->spaceAvl = dsPtr->length + 1; TclFreeIntRep(iPtr->objResultPtr); - iPtr->objResultPtr->bytes = tclEmptyStringRep; + iPtr->objResultPtr->bytes = &tclEmptyString; iPtr->objResultPtr->length = 0; } return; @@ -3093,7 +3106,7 @@ Tcl_DStringGetResult( dsPtr->spaceAvl = dsPtr->length+1; } else { dsPtr->string = ckalloc(dsPtr->length+1); - memcpy(dsPtr->string, iPtr->result, (unsigned) dsPtr->length+1); + memcpy(dsPtr->string, iPtr->result, dsPtr->length+1); iPtr->freeProc(iPtr->result); } dsPtr->spaceAvl = dsPtr->length+1; @@ -3106,11 +3119,12 @@ Tcl_DStringGetResult( dsPtr->string = ckalloc(dsPtr->length+1); dsPtr->spaceAvl = dsPtr->length + 1; } - memcpy(dsPtr->string, iPtr->result, (unsigned) dsPtr->length+1); + memcpy(dsPtr->string, iPtr->result, dsPtr->length+1); } iPtr->result = iPtr->resultSpace; iPtr->resultSpace[0] = 0; +#endif /* !TCL_NO_DEPRECATED */ } /* @@ -3261,7 +3275,7 @@ Tcl_PrintDouble( int signum; char *digits; char *end; - int *precisionPtr = Tcl_GetThreadData(&precisionKey, (int) sizeof(int)); + int *precisionPtr = Tcl_GetThreadData(&precisionKey, sizeof(int)); /* * Handle NaN. @@ -3423,6 +3437,7 @@ Tcl_PrintDouble( *---------------------------------------------------------------------- */ +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 /* ARGSUSED */ char * TclPrecTraceProc( @@ -3433,8 +3448,8 @@ TclPrecTraceProc( int flags) /* Information about what happened. */ { Tcl_Obj *value; - int prec; - int *precisionPtr = Tcl_GetThreadData(&precisionKey, (int) sizeof(int)); + Tcl_WideInt prec; + int *precisionPtr = Tcl_GetThreadData(&precisionKey, sizeof(int)); /* * If the variable is unset, then recreate the trace. @@ -3457,7 +3472,7 @@ TclPrecTraceProc( if (flags & TCL_TRACE_READS) { - Tcl_SetVar2Ex(interp, name1, name2, Tcl_NewIntObj(*precisionPtr), + Tcl_SetVar2Ex(interp, name1, name2, Tcl_NewWideIntObj(*precisionPtr), flags & TCL_GLOBAL_ONLY); return NULL; } @@ -3473,13 +3488,14 @@ TclPrecTraceProc( } value = Tcl_GetVar2Ex(interp, name1, name2, flags & TCL_GLOBAL_ONLY); if (value == NULL - || Tcl_GetIntFromObj(NULL, value, &prec) != TCL_OK + || Tcl_GetWideIntFromObj(NULL, value, &prec) != TCL_OK || prec < 0 || prec > TCL_MAX_PREC) { return (char *) "improper value for precision"; } - *precisionPtr = prec; + *precisionPtr = (int)prec; return NULL; } +#endif /* !TCL_NO_DEPRECATED)*/ /* *---------------------------------------------------------------------- @@ -3597,9 +3613,9 @@ int TclFormatInt( char *buffer, /* Points to the storage into which the * formatted characters are written. */ - long n) /* The integer to format. */ + Tcl_WideInt n) /* The integer to format. */ { - long intVal; + Tcl_WideInt intVal; int i; int numFormatted, j; const char *digits = "0123456789"; @@ -3622,7 +3638,7 @@ TclFormatInt( intVal = -n; /* [Bug 3390638] Workaround for*/ if (n == -n || intVal == n) { /* broken compiler optimizers. */ - return sprintf(buffer, "%ld", n); + return sprintf(buffer, "%" TCL_LL_MODIFIER "d", n); } /* @@ -3659,165 +3675,263 @@ TclFormatInt( /* *---------------------------------------------------------------------- * - * TclGetIntForIndex -- - * - * Provides an integer corresponding to the list index held in a Tcl - * object. The string value 'objPtr' is expected have the format - * integer([+-]integer)? or end([+-]integer)?. - * - * Value - * TCL_OK - * - * The index is stored at the address given by by 'indexPtr'. If - * 'objPtr' has the value "end", the value stored is 'endValue'. + * GetWideForIndex -- * - * TCL_ERROR + * This function produces a wide integer value corresponding to the + * index value held in *objPtr. The parsing supports all values + * recognized as any size of integer, and the syntaxes end[-+]$integer + * and $integer[-+]$integer. The argument endValue is used to give + * the meaning of the literal index value "end". Index arithmetic + * on arguments outside the wide integer range are only accepted + * when interp is a working interpreter, not NULL. * - * The value of 'objPtr' does not have one of the expected formats. If - * 'interp' is non-NULL, an error message is left in the interpreter's - * result object. - * - * Effect + * Results: + * When parsing of *objPtr successfully recognizes an index value, + * TCL_OK is returned, and the wide integer value corresponding to + * the recognized index value is written to *widePtr. When parsing + * fails, TCL_ERROR is returned and error information is written to + * interp, if non-NULL. * - * The object referenced by 'objPtr' is converted, as needed, to an - * integer, wide integer, or end-based-index object. + * Side effects: + * The type of *objPtr may change. * *---------------------------------------------------------------------- */ -int -TclGetIntForIndex( - Tcl_Interp *interp, /* Interpreter to use for error reporting. If - * NULL, then no error message is left after - * errors. */ - Tcl_Obj *objPtr, /* Points to an object containing either "end" - * or an integer. */ - int endValue, /* The value to be stored at "indexPtr" if - * "objPtr" holds "end". */ - int *indexPtr) /* Location filled in with an integer - * representing an index. */ +static int +GetWideForIndex( + Tcl_Interp *interp, /* Interpreter to use for error reporting. If + * NULL, then no error message is left after + * errors. */ + Tcl_Obj *objPtr, /* Points to the value to be parsed */ + size_t endValue, /* The value to be stored at *widePtr if + * objPtr holds "end". + * NOTE: this value may be TCL_INDEX_NONE. */ + Tcl_WideInt *widePtr) /* Location filled in with a wide integer + * representing an index. */ { - int length; - char *opPtr; - const char *bytes; + ClientData cd; + const char *opPtr; + int numType, length, t1 = 0, t2 = 0; + int code = TclGetNumberFromObj(NULL, objPtr, &cd, &numType); + + if (code == TCL_OK) { + if (numType == TCL_NUMBER_INT) { + /* objPtr holds an integer in the signed wide range */ + *widePtr = *(Tcl_WideInt *)cd; + return TCL_OK; + } + if (numType != TCL_NUMBER_BIG) { + /* Must be a double -> not a valid index */ + goto parseError; + } - if (TclGetIntFromObj(NULL, objPtr, indexPtr) == TCL_OK) { - return TCL_OK; + /* objPtr holds an integer outside the signed wide range */ + /* Truncate to the signed wide range. */ + *widePtr = (((mp_int *)cd)->sign != MP_ZPOS) ? WIDE_MIN : WIDE_MAX; + return TCL_OK; } - if (GetEndOffsetFromObj(objPtr, endValue, indexPtr) == TCL_OK) { + /* objPtr does not hold a number, check the end+/- format... */ + if (GetEndOffsetFromObj(objPtr, endValue, widePtr) == TCL_OK) { return TCL_OK; } - bytes = TclGetStringFromObj(objPtr, &length); + /* If we reach here, the string rep of objPtr exists. */ /* - * Leading whitespace is acceptable in an index. + * The valid index syntax does not include any value that is + * a list of more than one element. This is necessary so that + * lists of index values can be reliably distinguished from any + * single index value. */ - while (length && TclIsSpaceProc(*bytes)) { - bytes++; - length--; + /* + * Quick scan to see if multi-value list is even possible. + * This relies on TclGetString() returning a NUL-terminated string. + */ + if ((TclMaxListLength(TclGetString(objPtr), -1, NULL) > 1) + + /* If it's possible, do the full list parse. */ + && (TCL_OK == Tcl_ListObjLength(NULL, objPtr, &length)) + && (length > 1)) { + goto parseError; } - if (TclParseNumber(NULL, NULL, NULL, bytes, length, (const char **)&opPtr, - TCL_PARSE_INTEGER_ONLY | TCL_PARSE_NO_WHITESPACE) == TCL_OK) { - int code, first, second; - char savedOp = *opPtr; + /* Passed the list screen, so parse for index arithmetic expression */ + if (TCL_OK == TclParseNumber(NULL, objPtr, NULL, NULL, -1, &opPtr, + TCL_PARSE_INTEGER_ONLY)) { + Tcl_WideInt w1=0, w2=0; - if ((savedOp != '+') && (savedOp != '-')) { - goto parseError; - } - if (TclIsSpaceProc(opPtr[1])) { - goto parseError; - } - *opPtr = '\0'; - code = Tcl_GetInt(interp, bytes, &first); - *opPtr = savedOp; - if (code == TCL_ERROR) { - goto parseError; - } - if (TCL_ERROR == Tcl_GetInt(interp, opPtr+1, &second)) { - goto parseError; - } - if (savedOp == '+') { - *indexPtr = first + second; - } else { - *indexPtr = first - second; + /* value starts with valid integer... */ + + if ((*opPtr == '-') || (*opPtr == '+')) { + /* ... value continues with [-+] ... */ + + /* Save first integer as wide if possible */ + TclGetNumberFromObj(NULL, objPtr, &cd, &t1); + if (t1 == TCL_NUMBER_INT) { + w1 = (*(Tcl_WideInt *)cd); + } + + if (TCL_OK == TclParseNumber(NULL, objPtr, NULL, opPtr + 1, + -1, NULL, TCL_PARSE_INTEGER_ONLY)) { + /* ... value concludes with second valid integer */ + + /* Save second integer as wide if possible */ + TclGetNumberFromObj(NULL, objPtr, &cd, &t2); + if (t2 == TCL_NUMBER_INT) { + w2 = (*(Tcl_WideInt *)cd); + } + } + } + /* Clear invalid intreps left by TclParseNumber */ + TclFreeIntRep(objPtr); + + if (t1 && t2) { + /* We have both integer values */ + if ((t1 == TCL_NUMBER_INT) && (t2 == TCL_NUMBER_INT)) { + /* Both are wide, do wide-integer math */ + if (*opPtr == '-') { + if ((w2 == WIDE_MIN) && (interp != NULL)) { + goto extreme; + } + w2 = -w2; + } + + if ((w1 ^ w2) < 0) { + /* Different signs, sum cannot overflow */ + *widePtr = w1 + w2; + } else if (w1 >= 0) { + if (w1 < WIDE_MAX - w2) { + *widePtr = w1 + w2; + } else { + *widePtr = WIDE_MAX; + } + } else { + if (w1 > WIDE_MIN - w2) { + *widePtr = w1 + w2; + } else { + *widePtr = WIDE_MIN; + } + } + } else if (interp == NULL) { + /* + * We use an interp to do bignum index calculations. + * If we don't get one, call all indices with bignums errors, + * and rely on callers to handle it. + */ + return TCL_ERROR; + } else { + /* + * At least one is big, do bignum math. Little reason to + * value performance here. Re-use code. Parse has verified + * objPtr is an expression. Compute it. + */ + + Tcl_Obj *sum; + + extreme: + Tcl_ExprObj(interp, objPtr, &sum); + TclGetNumberFromObj(NULL, sum, &cd, &numType); + + if (numType == TCL_NUMBER_INT) { + /* sum holds an integer in the signed wide range */ + *widePtr = *(Tcl_WideInt *)cd; + } else { + /* sum holds an integer outside the signed wide range */ + /* Truncate to the signed wide range. */ + if (((mp_int *)cd)->sign != MP_ZPOS) { + *widePtr = WIDE_MIN; + } else { + *widePtr = WIDE_MAX; + } + } + Tcl_DecrRefCount(sum); + } + return TCL_OK; } - return TCL_OK; } - /* - * Report a parse error. - */ - + /* Report a parse error. */ parseError: if (interp != NULL) { - bytes = Tcl_GetString(objPtr); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad index \"%s\": must be integer?[+-]integer? or" - " end?[+-]integer?", bytes)); - if (!strncmp(bytes, "end-", 4)) { - bytes += 4; - } - TclCheckBadOctal(interp, bytes); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL); + char * bytes = TclGetString(objPtr); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad index \"%s\": must be integer?[+-]integer? or" + " end?[+-]integer?", bytes)); + if (!strncmp(bytes, "end-", 4)) { + bytes += 4; + } + TclCheckBadOctal(interp, bytes); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL); } - return TCL_ERROR; } /* *---------------------------------------------------------------------- * - * UpdateStringOfEndOffset -- + * Tcl_GetIntForIndex -- * - * Update the string rep of a Tcl object holding an "end-offset" - * expression. + * This function returns an integer corresponding to the list index held + * in a Tcl object. The Tcl object's value is expected to be in the + * format integer([+-]integer)? or the format end([+-]integer)?. * * Results: - * None. + * The return value is normally TCL_OK, which means that the index was + * successfully stored into the location referenced by "indexPtr". If the + * Tcl object referenced by "objPtr" has the value "end", the value + * stored is "endValue". If "objPtr"s values is not of one of the + * expected formats, TCL_ERROR is returned and, if "interp" is non-NULL, + * an error message is left in the interpreter's result object. * * Side effects: - * Stores a valid string in the object's string rep. - * - * This function does NOT free any earlier string rep. If it is called on an - * object that already has a valid string rep, it will leak memory. + * The object referenced by "objPtr" might be converted to an integer, + * wide integer, or end-based-index object. * *---------------------------------------------------------------------- */ -static void -UpdateStringOfEndOffset( - register Tcl_Obj *objPtr) +int +Tcl_GetIntForIndex( + Tcl_Interp *interp, /* Interpreter to use for error reporting. If + * NULL, then no error message is left after + * errors. */ + Tcl_Obj *objPtr, /* Points to an object containing either "end" + * or an integer. */ + int endValue, /* The value to be stored at "indexPtr" if + * "objPtr" holds "end". */ + int *indexPtr) /* Location filled in with an integer + * representing an index. */ { - char buffer[TCL_INTEGER_SPACE + 5]; - register int len = 3; + Tcl_WideInt wide; - memcpy(buffer, "end", 4); - if (objPtr->internalRep.longValue != 0) { - buffer[len++] = '-'; - len += TclFormatInt(buffer+len, -(objPtr->internalRep.longValue)); + if (GetWideForIndex(interp, objPtr, endValue, &wide) == TCL_ERROR) { + return TCL_ERROR; + } + if (wide < 0) { + *indexPtr = -1; + } else if (wide > INT_MAX) { + *indexPtr = INT_MAX; + } else { + *indexPtr = (int) wide; } - objPtr->bytes = ckalloc((unsigned) len+1); - memcpy(objPtr->bytes, buffer, (unsigned) len+1); - objPtr->length = len; + return TCL_OK; } - /* *---------------------------------------------------------------------- * * GetEndOffsetFromObj -- * - * Look for a string of the form "end[+-]offset" and convert it to an - * internal representation holding the offset. + * Look for a string of the form "end[+-]offset" and convert it to an + * internal representation holding the offset. * * Results: - * Tcl return code. + * Tcl return code. * * Side effects: - * May store a Tcl_ObjType. + * May store a Tcl_ObjType. * *---------------------------------------------------------------------- */ @@ -3825,117 +3939,86 @@ UpdateStringOfEndOffset( static int GetEndOffsetFromObj( Tcl_Obj *objPtr, /* Pointer to the object to parse */ - int endValue, /* The value to be stored at "indexPtr" if + size_t endValue, /* The value to be stored at "indexPtr" if * "objPtr" holds "end". */ - int *indexPtr) /* Location filled in with an integer + Tcl_WideInt *widePtr) /* Location filled in with an integer * representing an index. */ { - if (SetEndOffsetFromAny(NULL, objPtr) != TCL_OK) { - return TCL_ERROR; - } + Tcl_ObjIntRep *irPtr; + Tcl_WideInt offset = 0; /* Offset in the "end-offset" expression */ - /* TODO: Handle overflow cases sensibly */ - *indexPtr = endValue + (int)objPtr->internalRep.longValue; - return TCL_OK; -} + while ((irPtr = TclFetchIntRep(objPtr, &endOffsetType)) == NULL) { + Tcl_ObjIntRep ir; + int length; + const char *bytes = TclGetStringFromObj(objPtr, &length); + if ((length < 3) || (length == 4)) { + /* Too short to be "end" or to be "end-$integer" */ + return TCL_ERROR; + } + if ((*bytes != 'e') || (strncmp(bytes, "end", 3) != 0)) { + /* Value doesn't start with "end" */ + return TCL_ERROR; + } -/* - *---------------------------------------------------------------------- - * - * SetEndOffsetFromAny -- - * - * Look for a string of the form "end[+-]offset" and convert it to an - * internal representation holding the offset. - * - * Results: - * Returns TCL_OK if ok, TCL_ERROR if the string was badly formed. - * - * Side effects: - * If interp is not NULL, stores an error message in the interpreter - * result. - * - *---------------------------------------------------------------------- - */ + if (length > 4) { + ClientData cd; + int t; -static int -SetEndOffsetFromAny( - Tcl_Interp *interp, /* Tcl interpreter or NULL */ - Tcl_Obj *objPtr) /* Pointer to the object to parse */ -{ - int offset; /* Offset in the "end-offset" expression */ - register const char *bytes; /* String rep of the object */ - int length; /* Length of the object's string rep */ + /* Parse for the "end-..." or "end+..." formats */ - /* - * If it's already the right type, we're fine. - */ + if ((bytes[3] != '-') && (bytes[3] != '+')) { + /* No operator where we need one */ + return TCL_ERROR; + } + if (TclIsSpaceProc(bytes[4])) { + /* Space after + or - not permitted. */ + return TCL_ERROR; + } - if (objPtr->typePtr == &tclEndOffsetType) { - return TCL_OK; - } + /* Parse the integer offset */ + if (TCL_OK != TclParseNumber(NULL, objPtr, NULL, + bytes+4, length-4, NULL, TCL_PARSE_INTEGER_ONLY)) { + /* Not a recognized integer format */ + return TCL_ERROR; + } - /* - * Check for a string rep of the right form. - */ + /* Got an integer offset; pull it from where parser left it. */ + TclGetNumberFromObj(NULL, objPtr, &cd, &t); - bytes = TclGetStringFromObj(objPtr, &length); - if ((*bytes != 'e') || (strncmp(bytes, "end", - (size_t)((length > 3) ? 3 : length)) != 0)) { - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad index \"%s\": must be end?[+-]integer?", bytes)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL); + if (t == TCL_NUMBER_BIG) { + /* Truncate to the signed wide range. */ + if (((mp_int *)cd)->sign != MP_ZPOS) { + offset = (bytes[3] == '-') ? WIDE_MAX : WIDE_MIN; + } else { + offset = (bytes[3] == '-') ? WIDE_MIN : WIDE_MAX; + } + } else { + /* assert (t == TCL_NUMBER_INT); */ + offset = (*(Tcl_WideInt *)cd); + if (bytes[3] == '-') { + offset = (offset == WIDE_MIN) ? WIDE_MAX : -offset; + } + } } - return TCL_ERROR; - } - /* - * Convert the string rep. - */ - - if (length <= 3) { - offset = 0; - } else if ((length > 4) && ((bytes[3] == '-') || (bytes[3] == '+'))) { - /* - * This is our limited string expression evaluator. Pass everything - * after "end-" to Tcl_GetInt, then reverse for offset. - */ + /* Success. Store the new internal rep. */ + ir.wideValue = offset; + Tcl_StoreIntRep(objPtr, &endOffsetType, &ir); + } - if (TclIsSpaceProc(bytes[4])) { - goto badIndexFormat; - } - if (Tcl_GetInt(interp, bytes+4, &offset) != TCL_OK) { - return TCL_ERROR; - } - if (bytes[3] == '-') { + offset = irPtr->wideValue; - /* TODO: Review overflow concerns here! */ - offset = -offset; - } + if (endValue == (size_t)-1) { + *widePtr = offset - 1; + } else if (offset < 0) { + /* Different signs, sum cannot overflow */ + *widePtr = endValue + offset; + } else if (endValue < (Tcl_WideUInt)WIDE_MAX - offset) { + *widePtr = endValue + offset; } else { - /* - * Conversion failed. Report the error. - */ - - badIndexFormat: - if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "bad index \"%s\": must be end?[+-]integer?", bytes)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", NULL); - } - return TCL_ERROR; + *widePtr = WIDE_MAX; } - - /* - * The conversion succeeded. Free the old internal rep and set the new - * one. - */ - - TclFreeIntRep(objPtr); - objPtr->internalRep.longValue = offset; - objPtr->typePtr = &tclEndOffsetType; - return TCL_OK; } @@ -3951,7 +4034,7 @@ SetEndOffsetFromAny( * arithmetic expressions. The absolute index values that can be * directly meaningful as an index into either a list or a string are * those integer values >= TCL_INDEX_START (0) - * and < TCL_INDEX_AFTER (INT_MAX). + * and < INT_MAX. * The largest string supported in Tcl 8 has bytelength INT_MAX. * This means the largest supported character length is also INT_MAX, * and the index of the last character in a string of length INT_MAX @@ -3960,9 +4043,9 @@ SetEndOffsetFromAny( * Any absolute index value parsed outside that range is encoded * using the before and after values passed in by the * caller as the encoding to use for indices that are either - * less than or greater than the usable index range. TCL_INDEX_AFTER + * less than or greater than the usable index range. TCL_INDEX_NONE * is available as a good choice for most callers to use for - * after. Likewise, the value TCL_INDEX_BEFORE is good for + * after. Likewise, the value TCL_INDEX_NONE is good for * most callers to use for before. Other values are possible * when the caller knows it is helpful in producing its own behavior * for indices before and after the indexed item. @@ -4002,43 +4085,48 @@ TclIndexEncode( int after, /* Value to return for index after end */ int *indexPtr) /* Where to write the encoded answer, not NULL */ { - int idx; + ClientData cd; + Tcl_WideInt wide; + int idx, numType, code = TclGetNumberFromObj(NULL, objPtr, &cd, &numType); - if (TCL_OK == TclGetIntFromObj(NULL, objPtr, &idx)) { - /* We parsed a value in the range INT_MIN...INT_MAX */ + if ((code == TCL_OK) && (numType == TCL_NUMBER_INT)) { + /* We parsed a value in the range WIDE_MIN...WIDE_MAX */ + wide = (*(Tcl_WideInt *)cd); integerEncode: - if (idx < TCL_INDEX_START) { + if (wide < TCL_INDEX_START) { /* All negative absolute indices are "before the beginning" */ idx = before; - } else if (idx == INT_MAX) { + } else if (wide >= INT_MAX) { /* This index value is always "after the end" */ idx = after; - } + } else { + idx = (int) wide; + } /* usual case, the absolute index value encodes itself */ - } else if (TCL_OK == GetEndOffsetFromObj(objPtr, 0, &idx)) { + } else if (TCL_OK == GetEndOffsetFromObj(objPtr, 0, &wide)) { /* * We parsed an end+offset index value. - * idx holds the offset value in the range INT_MIN...INT_MAX. + * wide holds the offset value in the range WIDE_MIN...WIDE_MAX. */ - if (idx > 0) { + if (wide > 0) { /* * All end+postive or end-negative expressions * always indicate "after the end". */ idx = after; - } else if (idx < INT_MIN - TCL_INDEX_END) { + } else if (wide < INT_MIN - TCL_INDEX_END) { /* These indices always indicate "before the beginning */ idx = before; } else { /* Encoded end-positive (or end+negative) are offset */ - idx += TCL_INDEX_END; + idx = (int)wide + TCL_INDEX_END; } /* TODO: Consider flag to suppress repeated end-offset parse. */ - } else if (TCL_OK == TclGetIntForIndexM(interp, objPtr, 0, &idx)) { + } else if (TCL_OK == GetWideForIndex(interp, objPtr, 0, &wide)) { /* * Only reach this case when the index value is a - * constant index arithmetic expression, and idx + * constant index arithmetic expression, and wide * holds the result. Treat it the same as if it were * parsed as an absolute integer value. */ @@ -4070,10 +4158,14 @@ TclIndexDecode( int encoded, /* Value to decode */ int endValue) /* Meaning of "end" to use, > TCL_INDEX_END */ { - if (encoded <= TCL_INDEX_END) { - return (encoded - TCL_INDEX_END) + endValue; + if (encoded > TCL_INDEX_END) { + return encoded; } - return encoded; + endValue += encoded - TCL_INDEX_END; + if (endValue >= 0) { + return endValue; + } + return TCL_INDEX_NONE; } /* @@ -4289,9 +4381,10 @@ TclSetProcessGlobalValue( } else { Tcl_CreateExitHandler(FreeProcessGlobalValue, pgvPtr); } - bytes = Tcl_GetStringFromObj(newValue, &pgvPtr->numBytes); + bytes = TclGetString(newValue); + pgvPtr->numBytes = newValue->length; pgvPtr->value = ckalloc(pgvPtr->numBytes + 1); - memcpy(pgvPtr->value, bytes, (unsigned) pgvPtr->numBytes + 1); + memcpy(pgvPtr->value, bytes, pgvPtr->numBytes + 1); if (pgvPtr->encoding) { Tcl_FreeEncoding(pgvPtr->encoding); } @@ -4306,7 +4399,7 @@ TclSetProcessGlobalValue( Tcl_IncrRefCount(newValue); cacheMap = GetThreadHash(&pgvPtr->key); ClearHash(cacheMap); - hPtr = Tcl_CreateHashEntry(cacheMap, INT2PTR(pgvPtr->epoch), &dummy); + hPtr = Tcl_CreateHashEntry(cacheMap, (void *)(size_t)(pgvPtr->epoch), &dummy); Tcl_SetHashValue(hPtr, newValue); Tcl_MutexUnlock(&pgvPtr->mutex); } @@ -4332,7 +4425,7 @@ TclGetProcessGlobalValue( Tcl_Obj *value = NULL; Tcl_HashTable *cacheMap; Tcl_HashEntry *hPtr; - int epoch = pgvPtr->epoch; + unsigned int epoch = pgvPtr->epoch; if (pgvPtr->encoding) { Tcl_Encoding current = Tcl_GetEncoding(NULL, NULL); @@ -4347,8 +4440,7 @@ TclGetProcessGlobalValue( Tcl_DString native, newValue; Tcl_MutexLock(&pgvPtr->mutex); - pgvPtr->epoch++; - epoch = pgvPtr->epoch; + epoch = ++pgvPtr->epoch; Tcl_UtfToExternalDString(pgvPtr->encoding, pgvPtr->value, pgvPtr->numBytes, &native); Tcl_ExternalToUtfDString(current, Tcl_DStringValue(&native), @@ -4357,7 +4449,7 @@ TclGetProcessGlobalValue( ckfree(pgvPtr->value); pgvPtr->value = ckalloc(Tcl_DStringLength(&newValue) + 1); memcpy(pgvPtr->value, Tcl_DStringValue(&newValue), - (size_t) Tcl_DStringLength(&newValue) + 1); + Tcl_DStringLength(&newValue) + 1); Tcl_DStringFree(&newValue); Tcl_FreeEncoding(pgvPtr->encoding); pgvPtr->encoding = current; @@ -4367,7 +4459,7 @@ TclGetProcessGlobalValue( } } cacheMap = GetThreadHash(&pgvPtr->key); - hPtr = Tcl_FindHashEntry(cacheMap, (char *) INT2PTR(epoch)); + hPtr = Tcl_FindHashEntry(cacheMap, (void *)(size_t)epoch); if (NULL == hPtr) { int dummy; @@ -4400,7 +4492,7 @@ TclGetProcessGlobalValue( value = Tcl_NewStringObj(pgvPtr->value, pgvPtr->numBytes); hPtr = Tcl_CreateHashEntry(cacheMap, - INT2PTR(pgvPtr->epoch), &dummy); + (void *)(size_t)(pgvPtr->epoch), &dummy); Tcl_MutexUnlock(&pgvPtr->mutex); Tcl_SetHashValue(hPtr, value); Tcl_IncrRefCount(value); @@ -4483,11 +4575,10 @@ TclGetObjNameOfExecutable(void) const char * Tcl_GetNameOfExecutable(void) { - int numBytes; - const char *bytes = - Tcl_GetStringFromObj(TclGetObjNameOfExecutable(), &numBytes); + Tcl_Obj *obj = TclGetObjNameOfExecutable(); + const char *bytes = TclGetString(obj); - if (numBytes == 0) { + if (obj->length == 0) { return NULL; } return bytes; diff --git a/generic/tclVar.c b/generic/tclVar.c index 7b3db7e..e8ebd3c 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -45,7 +45,7 @@ static inline Var * VarHashNextVar(Tcl_HashSearch *searchPtr); static inline void CleanupVar(Var *varPtr, Var *arrayPtr); #define VarHashGetValue(hPtr) \ - ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry))) + ((Var *) ((char *)hPtr - offsetof(VarInHash, entry))) /* * NOTE: VarHashCreateVar increments the recount of its key argument. @@ -60,14 +60,12 @@ VarHashCreateVar( Tcl_Obj *key, int *newPtr) { - Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&tablePtr->table, - key, newPtr); + Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(&tablePtr->table, key, newPtr); - if (hPtr) { - return VarHashGetValue(hPtr); - } else { + if (!hPtr) { return NULL; } + return VarHashGetValue(hPtr); } #define VarHashFindVar(tablePtr, key) \ @@ -92,11 +90,10 @@ VarHashFirstVar( { Tcl_HashEntry *hPtr = VarHashFirstEntry(tablePtr, searchPtr); - if (hPtr) { - return VarHashGetValue(hPtr); - } else { + if (!hPtr) { return NULL; } + return VarHashGetValue(hPtr); } static inline Var * @@ -105,11 +102,10 @@ VarHashNextVar( { Tcl_HashEntry *hPtr = VarHashNextEntry(searchPtr); - if (hPtr) { - return VarHashGetValue(hPtr); - } else { + if (!hPtr) { return NULL; } + return VarHashGetValue(hPtr); } #define VarHashGetKey(varPtr) \ @@ -149,6 +145,7 @@ 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. */ @@ -168,11 +165,31 @@ typedef struct ArraySearch { } ArraySearch; /* + * TIP #508: [array default] + * + * The following structure extends the regular TclVarHashTable used by array + * variables to store their optional default value. + */ + +typedef struct ArrayVarHashTable { + TclVarHashTable table; + Tcl_Obj *defaultObj; +} ArrayVarHashTable; + +/* * Forward references to functions defined later in this file: */ static void AppendLocals(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *patternPtr, int includeLinks); +static void ArrayPopulateSearch(Tcl_Interp *interp, + Tcl_Obj *arrayNameObj, Var *varPtr, + ArraySearch *searchPtr); +static void ArrayDoneSearch(Interp *iPtr, Var *varPtr, + ArraySearch *searchPtr); +static Tcl_NRPostProc ArrayForLoopCallback; +static int ArrayForNRCmd(ClientData dummy, Tcl_Interp *interp, + int objc, Tcl_Obj *const *objv); static void DeleteSearches(Interp *iPtr, Var *arrayVarPtr); static void DeleteArray(Interp *iPtr, Tcl_Obj *arrayNamePtr, Var *varPtr, int flags, int index); @@ -191,8 +208,16 @@ 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 int SetArraySearchObj(Tcl_Interp *interp, - Tcl_Obj *objPtr); + +/* + * TIP #508: [array default] + */ + +static int ArrayDefaultCmd(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static void DeleteArrayVar(Var *arrayPtr); +static void SetArrayDefault(Var *arrayPtr, Tcl_Obj *defaultObj); /* * Functions defined in this file that may be exported in the future for use @@ -205,14 +230,9 @@ 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. @@ -231,30 +251,52 @@ static Tcl_SetFromAnyProc PanicOnSetVarName; static const Tcl_ObjType localVarNameType = { "localVarName", - FreeLocalVarName, DupLocalVarName, PanicOnUpdateVarName, PanicOnSetVarName + FreeLocalVarName, DupLocalVarName, NULL, NULL }; -static const Tcl_ObjType tclParsedVarNameType = { +#define LocalSetIntRep(objPtr, index, namePtr) \ + do { \ + Tcl_ObjIntRep ir; \ + Tcl_Obj *ptr = (namePtr); \ + if (ptr) {Tcl_IncrRefCount(ptr);} \ + ir.twoPtrValue.ptr1 = ptr; \ + ir.twoPtrValue.ptr2 = INT2PTR(index); \ + Tcl_StoreIntRep((objPtr), &localVarNameType, &ir); \ + } while (0) + +#define LocalGetIntRep(objPtr, index, name) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = TclFetchIntRep((objPtr), &localVarNameType); \ + (name) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + (index) = irPtr ? PTR2INT(irPtr->twoPtrValue.ptr2) : -1; \ + } while (0) + +static const Tcl_ObjType parsedVarNameType = { "parsedVarName", - FreeParsedVarName, DupParsedVarName, UpdateParsedVarName, PanicOnSetVarName + FreeParsedVarName, DupParsedVarName, NULL, NULL }; -/* - * 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 -}; +#define ParsedSetIntRep(objPtr, arrayPtr, elem) \ + do { \ + Tcl_ObjIntRep ir; \ + Tcl_Obj *ptr1 = (arrayPtr); \ + Tcl_Obj *ptr2 = (elem); \ + if (ptr1) {Tcl_IncrRefCount(ptr1);} \ + if (ptr2) {Tcl_IncrRefCount(ptr2);} \ + ir.twoPtrValue.ptr1 = ptr1; \ + ir.twoPtrValue.ptr2 = ptr2; \ + Tcl_StoreIntRep((objPtr), &parsedVarNameType, &ir); \ + } while (0) + +#define ParsedGetIntRep(objPtr, parsed, array, elem) \ + do { \ + const Tcl_ObjIntRep *irPtr; \ + irPtr = TclFetchIntRep((objPtr), &parsedVarNameType); \ + (parsed) = (irPtr != NULL); \ + (array) = irPtr ? irPtr->twoPtrValue.ptr1 : NULL; \ + (elem) = irPtr ? irPtr->twoPtrValue.ptr2 : NULL; \ + } while (0) Var * TclVarHashCreateVar( @@ -340,7 +382,8 @@ CleanupVar( { if (TclIsVarUndefined(varPtr) && TclIsVarInHash(varPtr) && !TclIsVarTraced(varPtr) - && (VarHashRefCount(varPtr) == !TclIsVarDeadHash(varPtr))) { + && (VarHashRefCount(varPtr) == (unsigned) + !TclIsVarDeadHash(varPtr))) { if (VarHashRefCount(varPtr) == 0) { ckfree(varPtr); } else { @@ -349,7 +392,8 @@ CleanupVar( } if (arrayPtr != NULL && TclIsVarUndefined(arrayPtr) && TclIsVarInHash(arrayPtr) && !TclIsVarTraced(arrayPtr) && - (VarHashRefCount(arrayPtr) == !TclIsVarDeadHash(arrayPtr))) { + (VarHashRefCount(arrayPtr) == (unsigned) + !TclIsVarDeadHash(arrayPtr))) { if (VarHashRefCount(arrayPtr) == 0) { ckfree(arrayPtr); } else { @@ -477,9 +521,8 @@ TclLookupVar( * * Side effects: * New hashtable entries may be created if createPart1 or createPart2 - * are 1. The object part1Ptr is converted to one of localVarNameType, - * tclNsVarNameType or tclParsedVarNameType and caches as much of the - * lookup as it can. + * are 1. The object part1Ptr is converted to one of localVarNameType + * or parsedVarNameType and caches as much of the lookup as it can. * When createPart1 is 1, callers must IncrRefCount part1Ptr if they * plan to DecrRefCount it. * @@ -561,24 +604,20 @@ 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 *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; + int index, parsed = 0; + + int localIndex; + Tcl_Obj *namePtr, *arrayPtr, *elem; - if (typePtr == &localVarNameType) { - int localIndex; + *arrayPtrPtr = NULL; - localVarNameTypeHandling: - localIndex = PTR2INT(part1Ptr->internalRep.twoPtrValue.ptr2); + restart: + LocalGetIntRep(part1Ptr, localIndex, namePtr); + if (localIndex >= 0) { if (HasLocalVars(varFramePtr) && !(flags & (TCL_GLOBAL_ONLY | TCL_NAMESPACE_ONLY)) && (localIndex < varFramePtr->numCompiledLocals)) { @@ -586,8 +625,7 @@ TclObjLookupVarEx( * Use the cached index if the names coincide. */ - Tcl_Obj *namePtr = part1Ptr->internalRep.twoPtrValue.ptr1; - Tcl_Obj *checkNamePtr = localName(iPtr->varFramePtr, localIndex); + Tcl_Obj *checkNamePtr = localName(varFramePtr, localIndex); if ((!namePtr && (checkNamePtr == part1Ptr)) || (namePtr && (checkNamePtr == namePtr))) { @@ -599,12 +637,11 @@ TclObjLookupVarEx( } /* - * If part1Ptr is a tclParsedVarNameType, separate it into the pre-parsed - * parts. + * If part1Ptr is a parsedVarNameType, retrieve the pre-parsed parts. */ - if (typePtr == &tclParsedVarNameType) { - if (part1Ptr->internalRep.twoPtrValue.ptr1 != NULL) { + ParsedGetIntRep(part1Ptr, parsed, arrayPtr, elem); + if (parsed && arrayPtr) { if (part2Ptr != NULL) { /* * ERROR: part1Ptr is already an array element, cannot specify @@ -618,33 +655,23 @@ TclObjLookupVarEx( } return NULL; } - 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) { - goto localVarNameTypeHandling; - } - } - parsed = 1; + part2Ptr = elem; + part1Ptr = arrayPtr; + goto restart; } - part1 = TclGetStringFromObj(part1Ptr, &len1); - if (!parsed && len1 && (*(part1 + len1 - 1) == ')')) { + if (!parsed) { /* * part1Ptr is possibly an unparsed array element. */ - register int i; + int len; + const char *part1 = TclGetStringFromObj(part1Ptr, &len); + + if ((len > 1) && (part1[len - 1] == ')')) { + const char *part2 = strchr(part1, '('); - len2 = -1; - for (i = 0; i < len1; i++) { - if (*(part1 + i) == '(') { + if (part2) { if (part2Ptr != NULL) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, msg, @@ -655,49 +682,13 @@ TclObjLookupVarEx( return NULL; } - /* - * part1Ptr points to an array element; first copy the element - * name to a new string part2. - */ - - 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); - } - - /* - * 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); + arrayPtr = Tcl_NewStringObj(part1, (part2 - part1)); + part2Ptr = Tcl_NewStringObj(part2 + 1, + len - (part2 - part1) - 2); - objPtr->internalRep.twoPtrValue.ptr1 = part1Ptr; - objPtr->internalRep.twoPtrValue.ptr2 = (void *) part2; + ParsedSetIntRep(part1Ptr, arrayPtr, part2Ptr); - typePtr = part1Ptr->typePtr; - part1 = TclGetString(part1Ptr); - break; + part1Ptr = arrayPtr; } } } @@ -708,8 +699,6 @@ TclObjLookupVarEx( * the cached types if possible. */ - TclFreeIntRep(part1Ptr); - varPtr = TclLookupSimpleVar(interp, part1Ptr, flags, createPart1, &errMsg, &index); if (varPtr == NULL) { @@ -718,9 +707,6 @@ TclObjLookupVarEx( Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", TclGetString(part1Ptr), NULL); } - if (newPart2) { - Tcl_DecrRefCount(part2Ptr); - } return NULL; } @@ -732,28 +718,46 @@ TclObjLookupVarEx( /* * An indexed local variable. */ - Tcl_Obj *cachedNamePtr = localName(iPtr->varFramePtr, index); - - part1Ptr->typePtr = &localVarNameType; - if (part1Ptr != cachedNamePtr) { - part1Ptr->internalRep.twoPtrValue.ptr1 = cachedNamePtr; - Tcl_IncrRefCount(cachedNamePtr); - if (cachedNamePtr->typePtr != &localVarNameType - || cachedNamePtr->internalRep.twoPtrValue.ptr1 != NULL) { - TclFreeIntRep(cachedNamePtr); - } + + Tcl_Obj *cachedNamePtr = localName(varFramePtr, index); + + if (part1Ptr == cachedNamePtr) { + LocalSetIntRep(part1Ptr, index, NULL); } else { - part1Ptr->internalRep.twoPtrValue.ptr1 = NULL; + /* + * [80304238ac] Trickiness here. We will store and incr the + * refcount on cachedNamePtr. Trouble is that it's possible + * (see test var-22.1) for cachedNamePtr to have an intrep + * that contains a stored and refcounted part1Ptr. This + * would be a reference cycle which leads to a memory leak. + * + * The solution here is to wipe away all intrep(s) in + * cachedNamePtr and leave it as string only. This is + * radical and destructive, so a better idea would be welcome. + */ + + /* + * Firstly set cached local var reference (avoid free before set, + * see [45b9faf103f2]) + */ + LocalSetIntRep(part1Ptr, index, cachedNamePtr); + + /* Then wipe it */ + TclFreeIntRep(cachedNamePtr); + + /* + * Now go ahead and convert it the the "localVarName" type, + * since we suspect at least some use of the value as a + * varname and we want to resolve it quickly. + */ + LocalSetIntRep(cachedNamePtr, index, NULL); } - part1Ptr->internalRep.twoPtrValue.ptr2 = INT2PTR(index); } else { /* * At least mark part1Ptr as already parsed. */ - part1Ptr->typePtr = &tclParsedVarNameType; - part1Ptr->internalRep.twoPtrValue.ptr1 = NULL; - part1Ptr->internalRep.twoPtrValue.ptr2 = NULL; + ParsedSetIntRep(part1Ptr, NULL, NULL); } donePart1: @@ -769,9 +773,6 @@ TclObjLookupVarEx( *arrayPtrPtr = varPtr; varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr, flags, msg, createPart1, createPart2, varPtr, -1); - if (newPart2) { - Tcl_DecrRefCount(part2Ptr); - } } return varPtr; } @@ -938,38 +939,41 @@ TclLookupSimpleVar( if (varPtr == NULL) { Tcl_Obj *tailPtr; - if (create) { /* Var wasn't found so create it. */ - TclGetNamespaceForQualName(interp, varName, cxtNsPtr, - flags, &varNsPtr, &dummy1Ptr, &dummy2Ptr, &tail); - if (varNsPtr == NULL) { - *errMsgPtr = badNamespace; - return NULL; - } else if (tail == NULL) { - *errMsgPtr = missingName; - return NULL; - } - if (tail != varName) { - tailPtr = Tcl_NewStringObj(tail, -1); - } else { - tailPtr = varNamePtr; - } - varPtr = VarHashCreateVar(&varNsPtr->varTable, tailPtr, - &isNew); - if (lookGlobal) { - /* - * The variable was created starting from the global - * namespace: a global reference is returned even if it - * wasn't explicitly requested. - */ - - *indexPtr = -1; - } else { - *indexPtr = -2; - } - } else { /* Var wasn't found and not to create it. */ + if (!create) { /* Var wasn't found and not to create it. */ *errMsgPtr = noSuchVar; return NULL; } + + /* + * Var wasn't found so create it. + */ + + TclGetNamespaceForQualName(interp, varName, cxtNsPtr, flags, + &varNsPtr, &dummy1Ptr, &dummy2Ptr, &tail); + if (varNsPtr == NULL) { + *errMsgPtr = badNamespace; + return NULL; + } else if (tail == NULL) { + *errMsgPtr = missingName; + return NULL; + } + if (tail != varName) { + tailPtr = Tcl_NewStringObj(tail, -1); + } else { + tailPtr = varNamePtr; + } + varPtr = VarHashCreateVar(&varNsPtr->varTable, tailPtr, &isNew); + if (lookGlobal) { + /* + * The variable was created starting from the global + * namespace: a global reference is returned even if it wasn't + * explicitly requested. + */ + + *indexPtr = -1; + } else { + *indexPtr = -2; + } } } else { /* Local var: look in frame varFramePtr. */ int localCt = varFramePtr->numCompiledLocals; @@ -1075,8 +1079,6 @@ TclLookupArrayElement( { int isNew; Var *varPtr; - TclVarHashTable *tablePtr; - Namespace *nsPtr; /* * We're dealing with an array element. Make sure the variable is an array @@ -1109,16 +1111,7 @@ TclLookupArrayElement( return NULL; } - TclSetVarArray(arrayPtr); - tablePtr = ckalloc(sizeof(TclVarHashTable)); - arrayPtr->value.tablePtr = tablePtr; - - if (TclIsVarInHash(arrayPtr) && TclGetVarNsPtr(arrayPtr)) { - nsPtr = TclGetVarNsPtr(arrayPtr); - } else { - nsPtr = NULL; - } - TclInitVarHashTable(arrayPtr->value.tablePtr, nsPtr); + TclInitArrayVar(arrayPtr); } else if (!TclIsVarArray(arrayPtr)) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, arrayNamePtr, elNamePtr, msg, needArray, @@ -1174,6 +1167,7 @@ TclLookupArrayElement( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_GetVar const char * Tcl_GetVar( @@ -1194,6 +1188,7 @@ Tcl_GetVar( } return TclGetString(resultPtr); } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -1466,6 +1461,28 @@ TclPtrGetVarIdx( return varPtr->value.objPtr; } + /* + * Return the array default value if any. + */ + + if (arrayPtr && TclIsVarArray(arrayPtr) && TclGetArrayDefault(arrayPtr)) { + return TclGetArrayDefault(arrayPtr); + } + if (TclIsVarArrayElement(varPtr) && !arrayPtr) { + /* + * UGLY! Peek inside the implementation of things. This lets us get + * the default of an array even when we've been [upvar]ed to just an + * element of the array. + */ + + ArrayVarHashTable *avhtPtr = (ArrayVarHashTable *) + ((VarInHash *) varPtr)->entry.tablePtr; + + if (avhtPtr->defaultObj) { + return avhtPtr->defaultObj; + } + } + if (flags & TCL_LEAVE_ERR_MSG) { if (TclIsVarUndefined(varPtr) && arrayPtr && !TclIsVarUndefined(arrayPtr)) { @@ -1563,6 +1580,7 @@ Tcl_SetObjCmd( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_SetVar const char * Tcl_SetVar( @@ -1575,18 +1593,15 @@ Tcl_SetVar( * TCL_APPEND_VALUE, TCL_LIST_ELEMENT, * TCL_LEAVE_ERR_MSG. */ { - Tcl_Obj *varValuePtr, *varNamePtr = Tcl_NewStringObj(varName, -1); - - Tcl_IncrRefCount(varNamePtr); - varValuePtr = Tcl_ObjSetVar2(interp, varNamePtr, NULL, + Tcl_Obj *varValuePtr = Tcl_SetVar2Ex(interp, varName, NULL, Tcl_NewStringObj(newValue, -1), flags); - Tcl_DecrRefCount(varNamePtr); if (varValuePtr == NULL) { return NULL; } return TclGetString(varValuePtr); } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -1828,6 +1843,130 @@ TclPtrSetVar( /* *---------------------------------------------------------------------- * + * ListAppendInVar, StringAppendInVar -- + * + * Support functions for TclPtrSetVarIdx that implement various types of + * appending operations. + * + * Results: + * ListAppendInVar returns a Tcl result code (from the core list append + * operation). StringAppendInVar has no return value. + * + * Side effects: + * The variable or element of the array is updated. This may make the + * variable/element exist. Reference counts of values may be updated. + * + *---------------------------------------------------------------------- + */ + +static inline int +ListAppendInVar( + Tcl_Interp *interp, + Var *varPtr, + Var *arrayPtr, + Tcl_Obj *oldValuePtr, + Tcl_Obj *newValuePtr) +{ + if (oldValuePtr == NULL) { + /* + * No previous value. Check for defaults if there's an array we can + * ask this of. + */ + + if (arrayPtr) { + Tcl_Obj *defValuePtr = TclGetArrayDefault(arrayPtr); + + if (defValuePtr) { + oldValuePtr = Tcl_DuplicateObj(defValuePtr); + } + } + + if (oldValuePtr == NULL) { + /* + * No default. [lappend] semantics say this is like being an empty + * string. + */ + + TclNewObj(oldValuePtr); + } + varPtr->value.objPtr = oldValuePtr; + Tcl_IncrRefCount(oldValuePtr); /* Since var is referenced. */ + } else if (Tcl_IsShared(oldValuePtr)) { + varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); + TclDecrRefCount(oldValuePtr); + oldValuePtr = varPtr->value.objPtr; + Tcl_IncrRefCount(oldValuePtr); /* Since var is referenced. */ + } + + return Tcl_ListObjAppendElement(interp, oldValuePtr, newValuePtr); +} + +static inline void +StringAppendInVar( + Var *varPtr, + Var *arrayPtr, + Tcl_Obj *oldValuePtr, + Tcl_Obj *newValuePtr) +{ + /* + * If there was no previous value, either we use the array's default (if + * this is an array with a default at all) or we treat this as a simple + * set. + */ + + if (oldValuePtr == NULL) { + if (arrayPtr) { + Tcl_Obj *defValuePtr = TclGetArrayDefault(arrayPtr); + + if (defValuePtr) { + /* + * This is *almost* the same as the shared path below, except + * that the original value reference in defValuePtr is not + * decremented. + */ + + Tcl_Obj *valuePtr = Tcl_DuplicateObj(defValuePtr); + + varPtr->value.objPtr = valuePtr; + TclContinuationsCopy(valuePtr, defValuePtr); + Tcl_IncrRefCount(valuePtr); + Tcl_AppendObjToObj(valuePtr, newValuePtr); + if (newValuePtr->refCount == 0) { + Tcl_DecrRefCount(newValuePtr); + } + return; + } + } + varPtr->value.objPtr = newValuePtr; + Tcl_IncrRefCount(newValuePtr); + return; + } + + /* + * We append newValuePtr's bytes but don't change its ref count. Unless + * the reference is shared, when we have to duplicate in order to be safe + * to modify at all. + */ + + if (Tcl_IsShared(oldValuePtr)) { /* Append to copy. */ + varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); + + TclContinuationsCopy(varPtr->value.objPtr, oldValuePtr); + + TclDecrRefCount(oldValuePtr); + oldValuePtr = varPtr->value.objPtr; + Tcl_IncrRefCount(oldValuePtr); /* Since var is ref */ + } + + Tcl_AppendObjToObj(oldValuePtr, newValuePtr); + if (newValuePtr->refCount == 0) { + Tcl_DecrRefCount(newValuePtr); + } +} + +/* + *---------------------------------------------------------------------- + * * TclPtrSetVarIdx -- * * This function is the same as Tcl_SetVar2Ex above, except that it @@ -1940,44 +2079,13 @@ TclPtrSetVarIdx( } if (flags & (TCL_APPEND_VALUE|TCL_LIST_ELEMENT)) { if (flags & TCL_LIST_ELEMENT) { /* Append list element. */ - if (oldValuePtr == NULL) { - TclNewObj(oldValuePtr); - varPtr->value.objPtr = oldValuePtr; - Tcl_IncrRefCount(oldValuePtr); /* Since var is referenced. */ - } else if (Tcl_IsShared(oldValuePtr)) { - varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); - TclDecrRefCount(oldValuePtr); - oldValuePtr = varPtr->value.objPtr; - Tcl_IncrRefCount(oldValuePtr); /* Since var is referenced. */ - } - result = Tcl_ListObjAppendElement(interp, oldValuePtr, + result = ListAppendInVar(interp, varPtr, arrayPtr, oldValuePtr, newValuePtr); if (result != TCL_OK) { goto earlyError; } } else { /* Append string. */ - /* - * We append newValuePtr's bytes but don't change its ref count. - */ - - if (oldValuePtr == NULL) { - varPtr->value.objPtr = newValuePtr; - Tcl_IncrRefCount(newValuePtr); - } else { - if (Tcl_IsShared(oldValuePtr)) { /* Append to copy. */ - varPtr->value.objPtr = Tcl_DuplicateObj(oldValuePtr); - - TclContinuationsCopy(varPtr->value.objPtr, oldValuePtr); - - TclDecrRefCount(oldValuePtr); - oldValuePtr = varPtr->value.objPtr; - Tcl_IncrRefCount(oldValuePtr); /* Since var is ref */ - } - Tcl_AppendObjToObj(oldValuePtr, newValuePtr); - if (newValuePtr->refCount == 0) { - Tcl_DecrRefCount(newValuePtr); - } - } + StringAppendInVar(varPtr, arrayPtr, oldValuePtr, newValuePtr); } } else if (newValuePtr != oldValuePtr) { /* @@ -2232,7 +2340,6 @@ TclPtrIncrObjVarIdx( } else { /* Unshared - can Incr in place */ if (TCL_OK == TclIncrObj(interp, varValuePtr, incrPtr)) { - /* * This seems dumb to write the incremeted value into the var * after we just adjusted the value in place, but the spec for @@ -2268,6 +2375,7 @@ TclPtrIncrObjVarIdx( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_UnsetVar int Tcl_UnsetVar( @@ -2296,6 +2404,7 @@ Tcl_UnsetVar( Tcl_DecrRefCount(varNamePtr); return result; } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -2972,6 +3081,310 @@ Tcl_LappendObjCmd( /* *---------------------------------------------------------------------- * + * ArrayForObjCmd, ArrayForNRCmd, ArrayForLoopCallback, ArrayObjNext -- + * + * These functions implement the "array for" Tcl command. + * array for {k v} a {} + * The array for command iterates over the array, setting the the + * specified loop variables, and executing the body each iteration. + * + * ArrayForObjCmd() is the standard wrapper around ArrayForNRCmd(). + * + * ArrayForNRCmd() sets up the ArraySearch structure, sets arrayNamePtr + * inside the structure and calls VarHashFirstEntry to start the hash + * iteration. + * + * ArrayForNRCmd() does not execute the body or set the loop variables, + * it only initializes the iterator. + * + * ArrayForLoopCallback() iterates over the entire array, executing the + * body each time. + * + *---------------------------------------------------------------------- + */ + +static int +ArrayObjNext( + Tcl_Interp *interp, + Tcl_Obj *arrayNameObj, /* array */ + Var *varPtr, /* array */ + ArraySearch *searchPtr, + Tcl_Obj **keyPtrPtr, /* Pointer to a variable to have the key + * written into, or NULL. */ + Tcl_Obj **valuePtrPtr) /* Pointer to a variable to have the + * value written into, or NULL.*/ +{ + Tcl_Obj *keyObj; + Tcl_Obj *valueObj = NULL; + int gotValue; + int donerc; + + donerc = TCL_BREAK; + + if ((varPtr->flags & VAR_SEARCH_ACTIVE) != VAR_SEARCH_ACTIVE) { + donerc = TCL_ERROR; + return donerc; + } + + gotValue = 0; + while (1) { + Tcl_HashEntry *hPtr = searchPtr->nextEntry; + + if (hPtr != NULL) { + searchPtr->nextEntry = NULL; + } else { + hPtr = Tcl_NextHashEntry(&searchPtr->search); + if (hPtr == NULL) { + gotValue = 0; + break; + } + } + varPtr = VarHashGetValue(hPtr); + if (!TclIsVarUndefined(varPtr)) { + gotValue = 1; + break; + } + } + + if (!gotValue) { + return donerc; + } + + donerc = TCL_CONTINUE; + + keyObj = VarHashGetKey(varPtr); + *keyPtrPtr = keyObj; + valueObj = Tcl_ObjGetVar2(interp, arrayNameObj, keyObj, + TCL_LEAVE_ERR_MSG); + *valuePtrPtr = valueObj; + + return donerc; +} + +static int +ArrayForObjCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + return Tcl_NRCallObjProc(interp, ArrayForNRCmd, dummy, objc, objv); +} + +static int +ArrayForNRCmd( + ClientData dummy, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const *objv) +{ + Tcl_Obj *varListObj, *arrayNameObj, *scriptObj; + ArraySearch *searchPtr = NULL; + Var *varPtr; + int isArray, numVars; + + /* + * array for {k v} a body + */ + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "{key value} arrayName script"); + return TCL_ERROR; + } + + /* + * Parse arguments. + */ + + if (Tcl_ListObjLength(interp, objv[1], &numVars) != TCL_OK) { + return TCL_ERROR; + } + + if (numVars != 2) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "must have two variable names", -1)); + Tcl_SetErrorCode(interp, "TCL", "SYNTAX", "array", "for", NULL); + return TCL_ERROR; + } + + arrayNameObj = objv[2]; + + if (TCL_ERROR == LocateArray(interp, arrayNameObj, &varPtr, &isArray)) { + return TCL_ERROR; + } + + if (!isArray) { + return NotArrayError(interp, arrayNameObj); + } + + /* + * Make a new array search, put it on the stack. + */ + + searchPtr = ckalloc(sizeof(ArraySearch)); + ArrayPopulateSearch(interp, arrayNameObj, varPtr, searchPtr); + + /* + * Make sure that these objects (which we need throughout the body of the + * loop) don't vanish. + */ + + varListObj = TclListObjCopy(NULL, objv[1]); + scriptObj = objv[3]; + Tcl_IncrRefCount(scriptObj); + + /* + * Run the script. + */ + + TclNRAddCallback(interp, ArrayForLoopCallback, searchPtr, varListObj, + arrayNameObj, scriptObj); + return TCL_OK; +} + +static int +ArrayForLoopCallback( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *) interp; + ArraySearch *searchPtr = data[0]; + Tcl_Obj *varListObj = data[1]; + Tcl_Obj *arrayNameObj = data[2]; + Tcl_Obj *scriptObj = data[3]; + Tcl_Obj **varv; + Tcl_Obj *keyObj, *valueObj; + Var *varPtr; + Var *arrayPtr; + int done, varc; + + /* + * Process the result from the previous execution of the script body. + */ + + done = TCL_ERROR; + + if (result == TCL_CONTINUE) { + result = TCL_OK; + } else if (result != TCL_OK) { + if (result == TCL_BREAK) { + Tcl_ResetResult(interp); + result = TCL_OK; + } else if (result == TCL_ERROR) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"array for\" body line %d)", + Tcl_GetErrorLine(interp))); + } + goto arrayfordone; + } + + /* + * Get the next mapping from the array. + */ + + keyObj = NULL; + valueObj = NULL; + varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, /*flags*/ 0, + /*msg*/ 0, /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); + if (varPtr == NULL) { + done = TCL_ERROR; + } else { + done = ArrayObjNext(interp, arrayNameObj, varPtr, searchPtr, &keyObj, + &valueObj); + } + + result = TCL_OK; + if (done != TCL_CONTINUE) { + Tcl_ResetResult(interp); + if (done == TCL_ERROR) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "array changed during iteration", -1)); + Tcl_SetErrorCode(interp, "TCL", "READ", "array", "for", NULL); + varPtr->flags |= TCL_LEAVE_ERR_MSG; + result = done; + } + goto arrayfordone; + } + + Tcl_ListObjGetElements(NULL, varListObj, &varc, &varv); + if (Tcl_ObjSetVar2(interp, varv[0], NULL, keyObj, + TCL_LEAVE_ERR_MSG) == NULL) { + result = TCL_ERROR; + goto arrayfordone; + } + if (valueObj != NULL) { + if (Tcl_ObjSetVar2(interp, varv[1], NULL, valueObj, + TCL_LEAVE_ERR_MSG) == NULL) { + result = TCL_ERROR; + goto arrayfordone; + } + } + + /* + * Run the script. + */ + + TclNRAddCallback(interp, ArrayForLoopCallback, searchPtr, varListObj, + arrayNameObj, scriptObj); + return TclNREvalObjEx(interp, scriptObj, 0, iPtr->cmdFramePtr, 3); + + /* + * For unwinding everything once the iterating is done. + */ + + arrayfordone: + if (done != TCL_ERROR) { + /* + * If the search was terminated by an array change, the + * VAR_SEARCH_ACTIVE flag will no longer be set. + */ + + ArrayDoneSearch(iPtr, varPtr, searchPtr); + Tcl_DecrRefCount(searchPtr->name); + ckfree(searchPtr); + } + + TclDecrRefCount(varListObj); + TclDecrRefCount(scriptObj); + return result; +} + +/* + * ArrayPopulateSearch + */ + +static void +ArrayPopulateSearch( + Tcl_Interp *interp, + Tcl_Obj *arrayNameObj, + Var *varPtr, + ArraySearch *searchPtr) +{ + Interp *iPtr = (Interp *) interp; + Tcl_HashEntry *hPtr; + int isNew; + + hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, varPtr, &isNew); + if (isNew) { + searchPtr->id = 1; + varPtr->flags |= VAR_SEARCH_ACTIVE; + searchPtr->nextPtr = NULL; + } else { + searchPtr->id = ((ArraySearch *) Tcl_GetHashValue(hPtr))->id + 1; + searchPtr->nextPtr = Tcl_GetHashValue(hPtr); + } + searchPtr->varPtr = varPtr; + searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr, + &searchPtr->search); + Tcl_SetHashValue(hPtr, searchPtr); + searchPtr->name = Tcl_ObjPrintf("s-%d-%s", searchPtr->id, + TclGetString(arrayNameObj)); + Tcl_IncrRefCount(searchPtr->name); +} +/* + *---------------------------------------------------------------------- + * * ArrayStartSearchCmd -- * * This object-based function is invoked to process the "array @@ -2988,6 +3401,7 @@ Tcl_LappendObjCmd( */ /* ARGSUSED */ + static int ArrayStartSearchCmd( ClientData clientData, @@ -2995,12 +3409,9 @@ ArrayStartSearchCmd( int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *)interp; Var *varPtr; - Tcl_HashEntry *hPtr; - int isNew, isArray; + int isArray; ArraySearch *searchPtr; - const char *varName; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName"); @@ -3019,24 +3430,54 @@ ArrayStartSearchCmd( * Make a new array search with a free name. */ - varName = TclGetString(objv[1]); searchPtr = ckalloc(sizeof(ArraySearch)); - hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, varPtr, &isNew); - if (isNew) { - searchPtr->id = 1; - varPtr->flags |= VAR_SEARCH_ACTIVE; - searchPtr->nextPtr = NULL; + ArrayPopulateSearch(interp, objv[1], varPtr, searchPtr); + Tcl_SetObjResult(interp, searchPtr->name); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * ArrayDoneSearch -- + * + * Removes the search from the hash of active searches. + * + *---------------------------------------------------------------------- + */ +static void +ArrayDoneSearch( + Interp *iPtr, + Var *varPtr, + ArraySearch *searchPtr) +{ + Tcl_HashEntry *hPtr; + ArraySearch *prevPtr; + + /* + * Unhook the search from the list of searches associated with the + * variable. + */ + + hPtr = Tcl_FindHashEntry(&iPtr->varSearches, varPtr); + if (hPtr == NULL) { + return; + } + if (searchPtr == Tcl_GetHashValue(hPtr)) { + if (searchPtr->nextPtr) { + Tcl_SetHashValue(hPtr, searchPtr->nextPtr); + } else { + varPtr->flags &= ~VAR_SEARCH_ACTIVE; + Tcl_DeleteHashEntry(hPtr); + } } else { - searchPtr->id = ((ArraySearch *) Tcl_GetHashValue(hPtr))->id + 1; - searchPtr->nextPtr = Tcl_GetHashValue(hPtr); + for (prevPtr=Tcl_GetHashValue(hPtr) ;; prevPtr=prevPtr->nextPtr) { + if (prevPtr->nextPtr == searchPtr) { + prevPtr->nextPtr = searchPtr->nextPtr; + break; + } + } } - searchPtr->varPtr = varPtr; - searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr, - &searchPtr->search); - Tcl_SetHashValue(hPtr, searchPtr); - Tcl_SetObjResult(interp, - Tcl_ObjPrintf("s-%d-%s", searchPtr->id, varName)); - return TCL_OK; } /* @@ -3064,7 +3505,7 @@ ArrayAnyMoreCmd( int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *)interp; + Interp *iPtr = (Interp *) interp; Var *varPtr; Tcl_Obj *varNameObj, *searchObj; int gotValue, isArray; @@ -3224,11 +3665,10 @@ ArrayDoneSearchCmd( int objc, Tcl_Obj *const objv[]) { - Interp *iPtr = (Interp *)interp; + Interp *iPtr = (Interp *) interp; Var *varPtr; - Tcl_HashEntry *hPtr; Tcl_Obj *varNameObj, *searchObj; - ArraySearch *searchPtr, *prevPtr; + ArraySearch *searchPtr; int isArray; if (objc != 3) { @@ -3255,27 +3695,8 @@ ArrayDoneSearchCmd( return TCL_ERROR; } - /* - * Unhook the search from the list of searches associated with the - * variable. - */ - - hPtr = Tcl_FindHashEntry(&iPtr->varSearches, varPtr); - if (searchPtr == Tcl_GetHashValue(hPtr)) { - if (searchPtr->nextPtr) { - Tcl_SetHashValue(hPtr, searchPtr->nextPtr); - } else { - varPtr->flags &= ~VAR_SEARCH_ACTIVE; - Tcl_DeleteHashEntry(hPtr); - } - } else { - for (prevPtr=Tcl_GetHashValue(hPtr) ;; prevPtr=prevPtr->nextPtr) { - if (prevPtr->nextPtr == searchPtr) { - prevPtr->nextPtr = searchPtr->nextPtr; - break; - } - } - } + ArrayDoneSearch(iPtr, varPtr, searchPtr); + Tcl_DecrRefCount(searchPtr->name); ckfree(searchPtr); return TCL_OK; } @@ -3708,7 +4129,7 @@ ArraySetCmd( */ arrayElemObj = objv[2]; - if (arrayElemObj->typePtr == &tclDictType && arrayElemObj->bytes == NULL) { + if (TclHasIntRep(arrayElemObj, &tclDictType) && arrayElemObj->bytes == NULL) { Tcl_Obj *keyPtr, *valuePtr; Tcl_DictSearch search; int done; @@ -3786,7 +4207,8 @@ ArraySetCmd( if ((elemVarPtr == NULL) || (TclPtrSetVarIdx(interp, elemVarPtr, varPtr, arrayNameObj, - elemPtrs[i],elemPtrs[i+1],TCL_LEAVE_ERR_MSG,-1) == NULL)){ + elemPtrs[i], elemPtrs[i+1], TCL_LEAVE_ERR_MSG, + -1) == NULL)) { result = TCL_ERROR; break; } @@ -3820,9 +4242,7 @@ ArraySetCmd( return TCL_ERROR; } } - TclSetVarArray(varPtr); - varPtr->value.tablePtr = ckalloc(sizeof(TclVarHashTable)); - TclInitVarHashTable(varPtr->value.tablePtr, TclGetVarNsPtr(varPtr)); + TclInitArrayVar(varPtr); return TCL_OK; } @@ -4102,8 +4522,10 @@ TclInitArrayCmd( { static const EnsembleImplMap arrayImplMap[] = { {"anymore", ArrayAnyMoreCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, + {"default", ArrayDefaultCmd, TclCompileBasic2Or3ArgCmd, NULL, NULL, 0}, {"donesearch", ArrayDoneSearchCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, {"exists", ArrayExistsCmd, TclCompileArrayExistsCmd, NULL, NULL, 0}, + {"for", ArrayForObjCmd, TclCompileBasic3ArgCmd, ArrayForNRCmd, NULL, 0}, {"get", ArrayGetCmd, TclCompileBasic1Or2ArgCmd, NULL, NULL, 0}, {"names", ArrayNamesCmd, TclCompileBasic1To3ArgCmd, NULL, NULL, 0}, {"nextelement", ArrayNextElementCmd, TclCompileBasic2ArgCmd, NULL, NULL, 0}, @@ -4128,7 +4550,7 @@ TclInitArrayCmd( * * Results: * A standard Tcl completion code. If an error occurs then an error - * message is left in iPtr->result. + * message is left in interp. * * Side effects: * The variable given by myName is linked to the variable in framePtr @@ -4222,7 +4644,7 @@ ObjMakeUpvar( * * Results: * A standard Tcl completion code. If an error occurs then an error - * message is left in iPtr->result. + * message is left in interp. * * Side effects: * The variable given by myName is linked to the variable in framePtr @@ -4413,6 +4835,7 @@ TclPtrObjMakeUpvarIdx( *---------------------------------------------------------------------- */ +#ifndef TCL_NO_DEPRECATED #undef Tcl_UpVar int Tcl_UpVar( @@ -4446,6 +4869,7 @@ Tcl_UpVar( Tcl_DecrRefCount(localNamePtr); return result; } +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -4901,75 +5325,6 @@ 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 @@ -4980,10 +5335,6 @@ SetArraySearchObj( * 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. - * *---------------------------------------------------------------------- */ @@ -4999,65 +5350,43 @@ ParseSearchId( * name. */ { Interp *iPtr = (Interp *) interp; - register const char *string; - register size_t offset; - int id; ArraySearch *searchPtr; - 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. - */ + const char *handle = TclGetString(handleObj); + char *end; 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->id == id) { + if (searchPtr->name == handleObj) { 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_SetObjResult(interp, Tcl_ObjPrintf( - "couldn't find search \"%s\"", string)); - badLookup: - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", string, NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARRAYSEARCH", handle, NULL); return NULL; } @@ -5092,6 +5421,7 @@ DeleteSearches( for (searchPtr = Tcl_GetHashValue(sPtr); searchPtr != NULL; searchPtr = nextPtr) { nextPtr = searchPtr->nextPtr; + Tcl_DecrRefCount(searchPtr->name); ckfree(searchPtr); } arrayVarPtr->flags &= ~VAR_SEARCH_ACTIVE; @@ -5383,8 +5713,7 @@ DeleteArray( TclClearVarNamespaceVar(elPtr); } - VarHashDeleteTable(varPtr->value.tablePtr); - ckfree(varPtr->value.tablePtr); + DeleteArrayVar(varPtr); } /* @@ -5462,28 +5791,6 @@ 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: @@ -5496,12 +5803,15 @@ static void FreeLocalVarName( Tcl_Obj *objPtr) { - Tcl_Obj *namePtr = objPtr->internalRep.twoPtrValue.ptr1; + int index; + Tcl_Obj *namePtr; + LocalGetIntRep(objPtr, index, namePtr); + + index++; /* Compiler warning bait. */ if (namePtr) { Tcl_DecrRefCount(namePtr); } - objPtr->typePtr = NULL; } static void @@ -5509,17 +5819,14 @@ DupLocalVarName( Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { - Tcl_Obj *namePtr = srcPtr->internalRep.twoPtrValue.ptr1; + int index; + Tcl_Obj *namePtr; + LocalGetIntRep(srcPtr, index, namePtr); if (!namePtr) { namePtr = srcPtr; } - dupPtr->internalRep.twoPtrValue.ptr1 = namePtr; - Tcl_IncrRefCount(namePtr); - - dupPtr->internalRep.twoPtrValue.ptr2 = - srcPtr->internalRep.twoPtrValue.ptr2; - dupPtr->typePtr = &localVarNameType; + LocalSetIntRep(dupPtr, index, namePtr); } /* @@ -5535,14 +5842,16 @@ static void FreeParsedVarName( Tcl_Obj *objPtr) { - register Tcl_Obj *arrayPtr = objPtr->internalRep.twoPtrValue.ptr1; - register char *elem = objPtr->internalRep.twoPtrValue.ptr2; + register Tcl_Obj *arrayPtr, *elem; + int parsed; + ParsedGetIntRep(objPtr, parsed, arrayPtr, elem); + + parsed++; /* Silence compiler. */ if (arrayPtr != NULL) { TclDecrRefCount(arrayPtr); - ckfree(elem); + TclDecrRefCount(elem); } - objPtr->typePtr = NULL; } static void @@ -5550,58 +5859,13 @@ DupParsedVarName( Tcl_Obj *srcPtr, Tcl_Obj *dupPtr) { - register Tcl_Obj *arrayPtr = srcPtr->internalRep.twoPtrValue.ptr1; - register char *elem = srcPtr->internalRep.twoPtrValue.ptr2; - char *elemCopy; - unsigned elemLen; - - if (arrayPtr != NULL) { - Tcl_IncrRefCount(arrayPtr); - 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? - */ + register Tcl_Obj *arrayPtr, *elem; + int parsed; - 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; + ParsedGetIntRep(srcPtr, parsed, arrayPtr, elem); - memcpy(p, part1, (unsigned) len1); - p += len1; - *p++ = '('; - memcpy(p, part2, (unsigned) len2); - p += len2; - *p++ = ')'; - *p = '\0'; + parsed++; /* Silence compiler. */ + ParsedSetIntRep(dupPtr, arrayPtr, elem); } /* @@ -5930,7 +6194,7 @@ TclInfoVarsCmd( */ if ((nsPtr != globalNsPtr) && !specificNsInPattern) { - varPtr = VarHashFirstVar(&globalNsPtr->varTable,&search); + varPtr = VarHashFirstVar(&globalNsPtr->varTable, &search); while (varPtr) { if (!TclIsVarUndefined(varPtr) || TclIsVarNamespaceVar(varPtr)) { @@ -6226,25 +6490,50 @@ AppendLocals( } if (iPtr->varFramePtr->isProcCallFrame & FRAME_IS_METHOD) { - CallContext *contextPtr = iPtr->varFramePtr->clientData; - Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr; + Method *mPtr = (Method *) + Tcl_ObjectContextMethod(iPtr->varFramePtr->clientData); + PrivateVariableMapping *privatePtr; if (mPtr->declaringObjectPtr) { - FOREACH(objNamePtr, mPtr->declaringObjectPtr->variables) { + Object *oPtr = mPtr->declaringObjectPtr; + + FOREACH(objNamePtr, oPtr->variables) { Tcl_CreateHashEntry(&addedTable, objNamePtr, &added); if (added && (!pattern || Tcl_StringMatch(TclGetString(objNamePtr), pattern))) { Tcl_ListObjAppendElement(interp, listPtr, objNamePtr); } } + FOREACH_STRUCT(privatePtr, oPtr->privateVariables) { + Tcl_CreateHashEntry(&addedTable, privatePtr->variableObj, + &added); + if (added && (!pattern || + Tcl_StringMatch(TclGetString(privatePtr->variableObj), + pattern))) { + Tcl_ListObjAppendElement(interp, listPtr, + privatePtr->variableObj); + } + } } else { - FOREACH(objNamePtr, mPtr->declaringClassPtr->variables) { + Class *clsPtr = mPtr->declaringClassPtr; + + FOREACH(objNamePtr, clsPtr->variables) { Tcl_CreateHashEntry(&addedTable, objNamePtr, &added); if (added && (!pattern || Tcl_StringMatch(TclGetString(objNamePtr), pattern))) { Tcl_ListObjAppendElement(interp, listPtr, objNamePtr); } } + FOREACH_STRUCT(privatePtr, clsPtr->privateVariables) { + Tcl_CreateHashEntry(&addedTable, privatePtr->variableObj, + &added); + if (added && (!pattern || + Tcl_StringMatch(TclGetString(privatePtr->variableObj), + pattern))) { + Tcl_ListObjAppendElement(interp, listPtr, + privatePtr->variableObj); + } + } } } Tcl_DeleteHashTable(&addedTable); @@ -6317,9 +6606,9 @@ CompareVarKeys( /* * If the object pointers are the same then they match. * OPT: this comparison was moved to the caller - - if (objPtr1 == objPtr2) return 1; - */ + * + * if (objPtr1 == objPtr2) return 1; + */ /* * Don't use Tcl_GetStringFromObj as it would prevent l1 and l2 being in a @@ -6338,6 +6627,264 @@ CompareVarKeys( return ((l1 == l2) && !memcmp(p1, p2, l1)); } +/*---------------------------------------------------------------------- + * + * ArrayDefaultCmd -- + * + * This function implements the 'array default' Tcl command. + * Refer to the user documentation for details on what it does. + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + + /* ARGSUSED */ +static int +ArrayDefaultCmd( + ClientData clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + static const char *const options[] = { + "get", "set", "exists", "unset", NULL + }; + enum options { OPT_GET, OPT_SET, OPT_EXISTS, OPT_UNSET }; + Tcl_Obj *arrayNameObj, *defaultValueObj; + Var *varPtr, *arrayPtr; + int isArray, option; + + /* + * Parse arguments. + */ + + if (objc != 3 && objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "option arrayName ?value?"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", + 0, &option) != TCL_OK) { + return TCL_ERROR; + } + + arrayNameObj = objv[2]; + + if (TCL_ERROR == LocateArray(interp, arrayNameObj, &varPtr, &isArray)) { + return TCL_ERROR; + } + + switch (option) { + case OPT_GET: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); + return TCL_ERROR; + } + if (!varPtr || TclIsVarUndefined(varPtr) || !isArray) { + return NotArrayError(interp, arrayNameObj); + } + + defaultValueObj = TclGetArrayDefault(varPtr); + if (!defaultValueObj) { + /* Array default must exist. */ + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "array has no default value", -1)); + Tcl_SetErrorCode(interp, "TCL", "READ", "ARRAY", "DEFAULT", NULL); + return TCL_ERROR; + } + Tcl_SetObjResult(interp, defaultValueObj); + return TCL_OK; + + case OPT_SET: + if (objc != 4) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName value"); + return TCL_ERROR; + } + + /* + * Attempt to create array if needed. + */ + varPtr = TclObjLookupVarEx(interp, arrayNameObj, NULL, + /*flags*/ TCL_LEAVE_ERR_MSG, /*msg*/ "array default set", + /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); + if (varPtr == NULL) { + return TCL_ERROR; + } + if (arrayPtr) { + /* + * Not a valid array name. + */ + + CleanupVar(varPtr, arrayPtr); + TclObjVarErrMsg(interp, arrayNameObj, NULL, "array default set", + needArray, -1); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARNAME", + TclGetString(arrayNameObj), NULL); + return TCL_ERROR; + } + if (!TclIsVarArray(varPtr) && !TclIsVarUndefined(varPtr)) { + /* + * Not an array. + */ + + TclObjVarErrMsg(interp, arrayNameObj, NULL, "array default set", + needArray, -1); + Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL); + return TCL_ERROR; + } + + if (!TclIsVarArray(varPtr)) { + TclInitArrayVar(varPtr); + } + defaultValueObj = objv[3]; + SetArrayDefault(varPtr, defaultValueObj); + return TCL_OK; + + case OPT_EXISTS: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); + return TCL_ERROR; + } + + /* + * Undefined variables (whether or not they have storage allocated) do + * not have defaults, and this is not an error case. + */ + + if (!varPtr || TclIsVarUndefined(varPtr)) { + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(0)); + } else if (!isArray) { + return NotArrayError(interp, arrayNameObj); + } else { + defaultValueObj = TclGetArrayDefault(varPtr); + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(!!defaultValueObj)); + } + return TCL_OK; + + case OPT_UNSET: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); + return TCL_ERROR; + } + + if (varPtr && !TclIsVarUndefined(varPtr)) { + if (!isArray) { + return NotArrayError(interp, arrayNameObj); + } + SetArrayDefault(varPtr, NULL); + } + return TCL_OK; + } + + /* Unreached */ + return TCL_ERROR; +} + +/* + * Initialize array variable. + */ + +void +TclInitArrayVar( + Var *arrayPtr) +{ + ArrayVarHashTable *tablePtr = ckalloc(sizeof(ArrayVarHashTable)); + + /* + * Mark the variable as an array. + */ + + TclSetVarArray(arrayPtr); + + /* + * Regular TclVarHashTable initialization. + */ + + arrayPtr->value.tablePtr = (TclVarHashTable *) tablePtr; + TclInitVarHashTable(arrayPtr->value.tablePtr, TclGetVarNsPtr(arrayPtr)); + + /* + * Default value initialization. + */ + + tablePtr->defaultObj = NULL; +} + +/* + * Cleanup array variable. + */ + +static void +DeleteArrayVar( + Var *arrayPtr) +{ + ArrayVarHashTable *tablePtr = (ArrayVarHashTable *) + arrayPtr->value.tablePtr; + + /* + * Default value cleanup. + */ + + SetArrayDefault(arrayPtr, NULL); + + /* + * Regular TclVarHashTable cleanup. + */ + + VarHashDeleteTable(arrayPtr->value.tablePtr); + ckfree(tablePtr); +} + +/* + * Get array default value if any. + */ + +Tcl_Obj * +TclGetArrayDefault( + Var *arrayPtr) +{ + ArrayVarHashTable *tablePtr = (ArrayVarHashTable *) + arrayPtr->value.tablePtr; + + return tablePtr->defaultObj; +} + +/* + * Set/replace/unset array default value. + */ + +static void +SetArrayDefault( + Var *arrayPtr, + Tcl_Obj *defaultObj) +{ + ArrayVarHashTable *tablePtr = (ArrayVarHashTable *) + arrayPtr->value.tablePtr; + + /* + * Increment/decrement refcount twice to ensure that the object is shared, + * so that it doesn't get modified accidentally by the folling code: + * + * array default set v 1 + * lappend v(a) 2; # returns a new object {1 2} + * set v(b); # returns the original default object "1" + */ + + if (tablePtr->defaultObj) { + Tcl_DecrRefCount(tablePtr->defaultObj); + Tcl_DecrRefCount(tablePtr->defaultObj); + } + tablePtr->defaultObj = defaultObj; + if (tablePtr->defaultObj) { + Tcl_IncrRefCount(tablePtr->defaultObj); + Tcl_IncrRefCount(tablePtr->defaultObj); + } +} + /* * Local Variables: * mode: c diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c new file mode 100644 index 0000000..6a568fe --- /dev/null +++ b/generic/tclZipfs.c @@ -0,0 +1,5047 @@ +/* + * tclZipfs.c -- + * + * Implementation of the ZIP filesystem used in TIP 430 + * Adapted from the implentation for AndroWish. + * + * Copyright (c) 2016-2017 Sean Woods <yoda@etoyoc.com> + * Copyright (c) 2013-2015 Christian Werner <chw@ch-werner.de> + * + * See the file "license.terms" for information on usage and redistribution of + * this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * This file is distributed in two ways: + * generic/tclZipfs.c file in the TIP430-enabled Tcl cores. + * compat/tclZipfs.c file in the tclconfig (TEA) file system, for pre-tip430 + * projects. + */ + +#include "tclInt.h" +#include "tclFileSystem.h" + +#ifndef _WIN32 +#include <sys/mman.h> +#endif /* _WIN32*/ + +#ifndef MAP_FILE +#define MAP_FILE 0 +#endif /* !MAP_FILE */ + +#ifdef HAVE_ZLIB +#include "zlib.h" +#include "crypt.h" + +#ifdef CFG_RUNTIME_DLLFILE + +/* +** We are compiling as part of the core. +** TIP430 style zipfs prefix +*/ + +#define ZIPFS_VOLUME "//zipfs:/" +#define ZIPFS_VOLUME_LEN 9 +#define ZIPFS_APP_MOUNT "//zipfs:/app" +#define ZIPFS_ZIP_MOUNT "//zipfs:/lib/tcl" + +#else /* !CFG_RUNTIME_DLLFILE */ + +/* +** We are compiling from the /compat folder of tclconfig +** Pre TIP430 style zipfs prefix +** //zipfs:/ doesn't work straight out of the box on either windows or Unix +** without other changes made to tip 430 +*/ + +#define ZIPFS_VOLUME "zipfs:/" +#define ZIPFS_VOLUME_LEN 7 +#define ZIPFS_APP_MOUNT "zipfs:/app" +#define ZIPFS_ZIP_MOUNT "zipfs:/lib/tcl" + +#endif /* CFG_RUNTIME_DLLFILE */ + +/* + * Various constants and offsets found in ZIP archive files + */ + +#define ZIP_SIG_LEN 4 + +/* + * Local header of ZIP archive member (at very beginning of each member). + */ + +#define ZIP_LOCAL_HEADER_SIG 0x04034b50 +#define ZIP_LOCAL_HEADER_LEN 30 +#define ZIP_LOCAL_SIG_OFFS 0 +#define ZIP_LOCAL_VERSION_OFFS 4 +#define ZIP_LOCAL_FLAGS_OFFS 6 +#define ZIP_LOCAL_COMPMETH_OFFS 8 +#define ZIP_LOCAL_MTIME_OFFS 10 +#define ZIP_LOCAL_MDATE_OFFS 12 +#define ZIP_LOCAL_CRC32_OFFS 14 +#define ZIP_LOCAL_COMPLEN_OFFS 18 +#define ZIP_LOCAL_UNCOMPLEN_OFFS 22 +#define ZIP_LOCAL_PATHLEN_OFFS 26 +#define ZIP_LOCAL_EXTRALEN_OFFS 28 + +/* + * Central header of ZIP archive member at end of ZIP file. + */ + +#define ZIP_CENTRAL_HEADER_SIG 0x02014b50 +#define ZIP_CENTRAL_HEADER_LEN 46 +#define ZIP_CENTRAL_SIG_OFFS 0 +#define ZIP_CENTRAL_VERSIONMADE_OFFS 4 +#define ZIP_CENTRAL_VERSION_OFFS 6 +#define ZIP_CENTRAL_FLAGS_OFFS 8 +#define ZIP_CENTRAL_COMPMETH_OFFS 10 +#define ZIP_CENTRAL_MTIME_OFFS 12 +#define ZIP_CENTRAL_MDATE_OFFS 14 +#define ZIP_CENTRAL_CRC32_OFFS 16 +#define ZIP_CENTRAL_COMPLEN_OFFS 20 +#define ZIP_CENTRAL_UNCOMPLEN_OFFS 24 +#define ZIP_CENTRAL_PATHLEN_OFFS 28 +#define ZIP_CENTRAL_EXTRALEN_OFFS 30 +#define ZIP_CENTRAL_FCOMMENTLEN_OFFS 32 +#define ZIP_CENTRAL_DISKFILE_OFFS 34 +#define ZIP_CENTRAL_IATTR_OFFS 36 +#define ZIP_CENTRAL_EATTR_OFFS 38 +#define ZIP_CENTRAL_LOCALHDR_OFFS 42 + +/* + * Central end signature at very end of ZIP file. + */ + +#define ZIP_CENTRAL_END_SIG 0x06054b50 +#define ZIP_CENTRAL_END_LEN 22 +#define ZIP_CENTRAL_END_SIG_OFFS 0 +#define ZIP_CENTRAL_DISKNO_OFFS 4 +#define ZIP_CENTRAL_DISKDIR_OFFS 6 +#define ZIP_CENTRAL_ENTS_OFFS 8 +#define ZIP_CENTRAL_TOTALENTS_OFFS 10 +#define ZIP_CENTRAL_DIRSIZE_OFFS 12 +#define ZIP_CENTRAL_DIRSTART_OFFS 16 +#define ZIP_CENTRAL_COMMENTLEN_OFFS 20 + +#define ZIP_MIN_VERSION 20 +#define ZIP_COMPMETH_STORED 0 +#define ZIP_COMPMETH_DEFLATED 8 + +#define ZIP_PASSWORD_END_SIG 0x5a5a4b50 + +#define DEFAULT_WRITE_MAX_SIZE (2 * 1024 * 1024) + +/* + * Macros to report errors only if an interp is present. + */ + +#define ZIPFS_ERROR(interp,errstr) \ + do { \ + if (interp) { \ + Tcl_SetObjResult(interp, Tcl_NewStringObj(errstr, -1)); \ + } \ + } while (0) +#define ZIPFS_POSIX_ERROR(interp,errstr) \ + do { \ + if (interp) { \ + Tcl_SetObjResult(interp, Tcl_ObjPrintf( \ + "%s: %s", errstr, Tcl_PosixError(interp))); \ + } \ + } while (0) + +/* + * Macros to read and write 16 and 32 bit integers from/to ZIP archives. + */ + +#define ZipReadInt(p) \ + ((p)[0] | ((p)[1] << 8) | ((p)[2] << 16) | ((p)[3] << 24)) +#define ZipReadShort(p) \ + ((p)[0] | ((p)[1] << 8)) + +#define ZipWriteInt(p, v) \ + do { \ + (p)[0] = (v) & 0xff; \ + (p)[1] = ((v) >> 8) & 0xff; \ + (p)[2] = ((v) >> 16) & 0xff; \ + (p)[3] = ((v) >> 24) & 0xff; \ + } while (0) +#define ZipWriteShort(p, v) \ + do { \ + (p)[0] = (v) & 0xff; \ + (p)[1] = ((v) >> 8) & 0xff; \ + } while (0) + +/* + * Windows drive letters. + */ + +#ifdef _WIN32 +static const char drvletters[] = + "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ"; +#endif /* _WIN32 */ + +/* + * Mutex to protect localtime(3) when no reentrant version available. + */ + +#if !defined(_WIN32) && !defined(HAVE_LOCALTIME_R) && TCL_THREADS +TCL_DECLARE_MUTEX(localtimeMutex) +#endif /* !_WIN32 && !HAVE_LOCALTIME_R && TCL_THREADS */ + +/* + * In-core description of mounted ZIP archive file. + */ + +typedef struct ZipFile { + char *name; /* Archive name */ + size_t nameLength; /* Length of archive name */ + char isMemBuffer; /* When true, not a file but a memory buffer */ + Tcl_Channel chan; /* Channel handle or NULL */ + unsigned char *data; /* Memory mapped or malloc'ed file */ + size_t length; /* Length of memory mapped file */ + void *ptrToFree; /* Non-NULL if malloc'ed file */ + size_t numFiles; /* Number of files in archive */ + size_t baseOffset; /* Archive start */ + size_t passOffset; /* Password start */ + size_t directoryOffset; /* Archive directory start */ + unsigned char passBuf[264]; /* Password buffer */ + size_t numOpen; /* Number of open files on archive */ + struct ZipEntry *entries; /* List of files in archive */ + struct ZipEntry *topEnts; /* List of top-level dirs in archive */ + char *mountPoint; /* Mount point name */ + size_t mountPointLen; /* Length of mount point name */ +#ifdef _WIN32 + HANDLE mountHandle; /* Handle used for direct file access. */ +#endif /* _WIN32 */ +} ZipFile; + +/* + * In-core description of file contained in mounted ZIP archive. + */ + +typedef struct ZipEntry { + char *name; /* The full pathname of the virtual file */ + ZipFile *zipFilePtr; /* The ZIP file holding this virtual file */ + Tcl_WideInt offset; /* Data offset into memory mapped ZIP file */ + int numBytes; /* Uncompressed size of the virtual file */ + int numCompressedBytes; /* Compressed size of the virtual file */ + int compressMethod; /* Compress method */ + int isDirectory; /* Set to 1 if directory, or -1 if root */ + int depth; /* Number of slashes in path. */ + int crc32; /* CRC-32 */ + int timestamp; /* Modification time */ + int isEncrypted; /* True if data is encrypted */ + unsigned char *data; /* File data if written */ + struct ZipEntry *next; /* Next file in the same archive */ + struct ZipEntry *tnext; /* Next top-level dir in archive */ +} ZipEntry; + +/* + * File channel for file contained in mounted ZIP archive. + */ + +typedef struct ZipChannel { + ZipFile *zipFilePtr; /* The ZIP file holding this channel */ + ZipEntry *zipEntryPtr; /* Pointer back to virtual file */ + size_t maxWrite; /* Maximum size for write */ + size_t numBytes; /* Number of bytes of uncompressed data */ + size_t numRead; /* Position of next byte to be read from the + * channel */ + unsigned char *ubuf; /* Pointer to the uncompressed data */ + int iscompr; /* True if data is compressed */ + int isDirectory; /* Set to 1 if directory, or -1 if root */ + int isEncrypted; /* True if data is encrypted */ + int isWriting; /* True if open for writing */ + unsigned long keys[3]; /* Key for decryption */ +} ZipChannel; + +/* + * Global variables. + * + * Most are kept in single ZipFS struct. When build with threading support + * this struct is protected by the ZipFSMutex (see below). + * + * The "fileHash" component is the process wide global table of all known ZIP + * archive members in all mounted ZIP archives. + * + * The "zipHash" components is the process wide global table of all mounted + * ZIP archive files. + */ + +static struct { + int initialized; /* True when initialized */ + int lock; /* RW lock, see below */ + int waiters; /* RW lock, see below */ + int wrmax; /* Maximum write size of a file */ + int idCount; /* Counter for channel names */ + Tcl_HashTable fileHash; /* File name to ZipEntry mapping */ + Tcl_HashTable zipHash; /* Mount to ZipFile mapping */ +} ZipFS = { + 0, 0, 0, DEFAULT_WRITE_MAX_SIZE, 0, +}; + +/* + * For password rotation. + */ + +static const char pwrot[16] = + "\x00\x80\x40\xC0\x20\xA0\x60\xE0" + "\x10\x90\x50\xD0\x30\xB0\x70\xF0"; + +/* + * Table to compute CRC32. + */ +#ifdef Z_U4 + typedef Z_U4 z_crc_t; +#else + typedef unsigned long z_crc_t; +#endif + +static const z_crc_t crc32tab[256] = { + 0x00000000, 0x77073096, 0xee0e612c, 0x990951ba, 0x076dc419, + 0x706af48f, 0xe963a535, 0x9e6495a3, 0x0edb8832, 0x79dcb8a4, + 0xe0d5e91e, 0x97d2d988, 0x09b64c2b, 0x7eb17cbd, 0xe7b82d07, + 0x90bf1d91, 0x1db71064, 0x6ab020f2, 0xf3b97148, 0x84be41de, + 0x1adad47d, 0x6ddde4eb, 0xf4d4b551, 0x83d385c7, 0x136c9856, + 0x646ba8c0, 0xfd62f97a, 0x8a65c9ec, 0x14015c4f, 0x63066cd9, + 0xfa0f3d63, 0x8d080df5, 0x3b6e20c8, 0x4c69105e, 0xd56041e4, + 0xa2677172, 0x3c03e4d1, 0x4b04d447, 0xd20d85fd, 0xa50ab56b, + 0x35b5a8fa, 0x42b2986c, 0xdbbbc9d6, 0xacbcf940, 0x32d86ce3, + 0x45df5c75, 0xdcd60dcf, 0xabd13d59, 0x26d930ac, 0x51de003a, + 0xc8d75180, 0xbfd06116, 0x21b4f4b5, 0x56b3c423, 0xcfba9599, + 0xb8bda50f, 0x2802b89e, 0x5f058808, 0xc60cd9b2, 0xb10be924, + 0x2f6f7c87, 0x58684c11, 0xc1611dab, 0xb6662d3d, 0x76dc4190, + 0x01db7106, 0x98d220bc, 0xefd5102a, 0x71b18589, 0x06b6b51f, + 0x9fbfe4a5, 0xe8b8d433, 0x7807c9a2, 0x0f00f934, 0x9609a88e, + 0xe10e9818, 0x7f6a0dbb, 0x086d3d2d, 0x91646c97, 0xe6635c01, + 0x6b6b51f4, 0x1c6c6162, 0x856530d8, 0xf262004e, 0x6c0695ed, + 0x1b01a57b, 0x8208f4c1, 0xf50fc457, 0x65b0d9c6, 0x12b7e950, + 0x8bbeb8ea, 0xfcb9887c, 0x62dd1ddf, 0x15da2d49, 0x8cd37cf3, + 0xfbd44c65, 0x4db26158, 0x3ab551ce, 0xa3bc0074, 0xd4bb30e2, + 0x4adfa541, 0x3dd895d7, 0xa4d1c46d, 0xd3d6f4fb, 0x4369e96a, + 0x346ed9fc, 0xad678846, 0xda60b8d0, 0x44042d73, 0x33031de5, + 0xaa0a4c5f, 0xdd0d7cc9, 0x5005713c, 0x270241aa, 0xbe0b1010, + 0xc90c2086, 0x5768b525, 0x206f85b3, 0xb966d409, 0xce61e49f, + 0x5edef90e, 0x29d9c998, 0xb0d09822, 0xc7d7a8b4, 0x59b33d17, + 0x2eb40d81, 0xb7bd5c3b, 0xc0ba6cad, 0xedb88320, 0x9abfb3b6, + 0x03b6e20c, 0x74b1d29a, 0xead54739, 0x9dd277af, 0x04db2615, + 0x73dc1683, 0xe3630b12, 0x94643b84, 0x0d6d6a3e, 0x7a6a5aa8, + 0xe40ecf0b, 0x9309ff9d, 0x0a00ae27, 0x7d079eb1, 0xf00f9344, + 0x8708a3d2, 0x1e01f268, 0x6906c2fe, 0xf762575d, 0x806567cb, + 0x196c3671, 0x6e6b06e7, 0xfed41b76, 0x89d32be0, 0x10da7a5a, + 0x67dd4acc, 0xf9b9df6f, 0x8ebeeff9, 0x17b7be43, 0x60b08ed5, + 0xd6d6a3e8, 0xa1d1937e, 0x38d8c2c4, 0x4fdff252, 0xd1bb67f1, + 0xa6bc5767, 0x3fb506dd, 0x48b2364b, 0xd80d2bda, 0xaf0a1b4c, + 0x36034af6, 0x41047a60, 0xdf60efc3, 0xa867df55, 0x316e8eef, + 0x4669be79, 0xcb61b38c, 0xbc66831a, 0x256fd2a0, 0x5268e236, + 0xcc0c7795, 0xbb0b4703, 0x220216b9, 0x5505262f, 0xc5ba3bbe, + 0xb2bd0b28, 0x2bb45a92, 0x5cb36a04, 0xc2d7ffa7, 0xb5d0cf31, + 0x2cd99e8b, 0x5bdeae1d, 0x9b64c2b0, 0xec63f226, 0x756aa39c, + 0x026d930a, 0x9c0906a9, 0xeb0e363f, 0x72076785, 0x05005713, + 0x95bf4a82, 0xe2b87a14, 0x7bb12bae, 0x0cb61b38, 0x92d28e9b, + 0xe5d5be0d, 0x7cdcefb7, 0x0bdbdf21, 0x86d3d2d4, 0xf1d4e242, + 0x68ddb3f8, 0x1fda836e, 0x81be16cd, 0xf6b9265b, 0x6fb077e1, + 0x18b74777, 0x88085ae6, 0xff0f6a70, 0x66063bca, 0x11010b5c, + 0x8f659eff, 0xf862ae69, 0x616bffd3, 0x166ccf45, 0xa00ae278, + 0xd70dd2ee, 0x4e048354, 0x3903b3c2, 0xa7672661, 0xd06016f7, + 0x4969474d, 0x3e6e77db, 0xaed16a4a, 0xd9d65adc, 0x40df0b66, + 0x37d83bf0, 0xa9bcae53, 0xdebb9ec5, 0x47b2cf7f, 0x30b5ffe9, + 0xbdbdf21c, 0xcabac28a, 0x53b39330, 0x24b4a3a6, 0xbad03605, + 0xcdd70693, 0x54de5729, 0x23d967bf, 0xb3667a2e, 0xc4614ab8, + 0x5d681b02, 0x2a6f2b94, 0xb40bbe37, 0xc30c8ea1, 0x5a05df1b, + 0x2d02ef8d, +}; + +static const char *zipfs_literal_tcl_library = NULL; + +/* Function prototypes */ + +static inline int DescribeMounted(Tcl_Interp *interp, + const char *mountPoint); +static inline int ListMountPoints(Tcl_Interp *interp); +static int ZipfsAppHookFindTclInit(const char *archive); +static int ZipFSPathInFilesystemProc(Tcl_Obj *pathPtr, + void **clientDataPtr); +static Tcl_Obj * ZipFSFilesystemPathTypeProc(Tcl_Obj *pathPtr); +static Tcl_Obj * ZipFSFilesystemSeparatorProc(Tcl_Obj *pathPtr); +static int ZipFSStatProc(Tcl_Obj *pathPtr, Tcl_StatBuf *buf); +static int ZipFSAccessProc(Tcl_Obj *pathPtr, int mode); +static Tcl_Channel ZipFSOpenFileChannelProc(Tcl_Interp *interp, + Tcl_Obj *pathPtr, int mode, int permissions); +static int ZipFSMatchInDirectoryProc(Tcl_Interp *interp, + Tcl_Obj *result, Tcl_Obj *pathPtr, + const char *pattern, Tcl_GlobTypeData *types); +static Tcl_Obj * ZipFSListVolumesProc(void); +static const char *const *ZipFSFileAttrStringsProc(Tcl_Obj *pathPtr, + Tcl_Obj **objPtrRef); +static int ZipFSFileAttrsGetProc(Tcl_Interp *interp, int index, + Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); +static int ZipFSFileAttrsSetProc(Tcl_Interp *interp, int index, + Tcl_Obj *pathPtr, Tcl_Obj *objPtr); +static int ZipFSLoadFile(Tcl_Interp *interp, Tcl_Obj *path, + Tcl_LoadHandle *loadHandle, + Tcl_FSUnloadFileProc **unloadProcPtr, int flags); +static void ZipfsExitHandler(ClientData clientData); +static void ZipfsSetup(void); +static int ZipChannelClose(void *instanceData, + Tcl_Interp *interp); +static int ZipChannelGetFile(void *instanceData, + int direction, void **handlePtr); +static int ZipChannelRead(void *instanceData, char *buf, + int toRead, int *errloc); +static int ZipChannelSeek(void *instanceData, long offset, + int mode, int *errloc); +static void ZipChannelWatchChannel(void *instanceData, + int mask); +static int ZipChannelWrite(void *instanceData, + const char *buf, int toWrite, int *errloc); + +/* + * Define the ZIP filesystem dispatch table. + */ + +MODULE_SCOPE const Tcl_Filesystem zipfsFilesystem; + +const Tcl_Filesystem zipfsFilesystem = { + "zipfs", + sizeof(Tcl_Filesystem), + TCL_FILESYSTEM_VERSION_2, + ZipFSPathInFilesystemProc, + NULL, /* dupInternalRepProc */ + NULL, /* freeInternalRepProc */ + NULL, /* internalToNormalizedProc */ + NULL, /* createInternalRepProc */ + NULL, /* normalizePathProc */ + ZipFSFilesystemPathTypeProc, + ZipFSFilesystemSeparatorProc, + ZipFSStatProc, + ZipFSAccessProc, + ZipFSOpenFileChannelProc, + ZipFSMatchInDirectoryProc, + NULL, /* utimeProc */ + NULL, /* linkProc */ + ZipFSListVolumesProc, + ZipFSFileAttrStringsProc, + ZipFSFileAttrsGetProc, + ZipFSFileAttrsSetProc, + NULL, /* createDirectoryProc */ + NULL, /* removeDirectoryProc */ + NULL, /* deleteFileProc */ + NULL, /* copyFileProc */ + NULL, /* renameFileProc */ + NULL, /* copyDirectoryProc */ + NULL, /* lstatProc */ + (Tcl_FSLoadFileProc *) ZipFSLoadFile, + NULL, /* getCwdProc */ + NULL, /* chdirProc */ +}; + +/* + * The channel type/driver definition used for ZIP archive members. + */ + +static Tcl_ChannelType ZipChannelType = { + "zip", /* Type name. */ + TCL_CHANNEL_VERSION_5, + ZipChannelClose, /* Close channel, clean instance data */ + ZipChannelRead, /* Handle read request */ + ZipChannelWrite, /* Handle write request */ + ZipChannelSeek, /* Move location of access point, NULL'able */ + NULL, /* Set options, NULL'able */ + NULL, /* Get options, NULL'able */ + ZipChannelWatchChannel, /* Initialize notifier */ + ZipChannelGetFile, /* Get OS handle from the channel */ + NULL, /* 2nd version of close channel, NULL'able */ + NULL, /* Set blocking mode for raw channel, NULL'able */ + NULL, /* Function to flush channel, NULL'able */ + NULL, /* Function to handle event, NULL'able */ + NULL, /* Wide seek function, NULL'able */ + NULL, /* Thread action function, NULL'able */ + NULL, /* Truncate function, NULL'able */ +}; + +/* + * Miscellaneous constants. + */ + +#define ERROR_LENGTH ((size_t) -1) + +/* + *------------------------------------------------------------------------- + * + * ReadLock, WriteLock, Unlock -- + * + * POSIX like rwlock functions to support multiple readers and single + * writer on internal structs. + * + * Limitations: + * - a read lock cannot be promoted to a write lock + * - a write lock may not be nested + * + *------------------------------------------------------------------------- + */ + +TCL_DECLARE_MUTEX(ZipFSMutex) + +#if TCL_THREADS + +static Tcl_Condition ZipFSCond; + +static void +ReadLock(void) +{ + Tcl_MutexLock(&ZipFSMutex); + while (ZipFS.lock < 0) { + ZipFS.waiters++; + Tcl_ConditionWait(&ZipFSCond, &ZipFSMutex, NULL); + ZipFS.waiters--; + } + ZipFS.lock++; + Tcl_MutexUnlock(&ZipFSMutex); +} + +static void +WriteLock(void) +{ + Tcl_MutexLock(&ZipFSMutex); + while (ZipFS.lock != 0) { + ZipFS.waiters++; + Tcl_ConditionWait(&ZipFSCond, &ZipFSMutex, NULL); + ZipFS.waiters--; + } + ZipFS.lock = -1; + Tcl_MutexUnlock(&ZipFSMutex); +} + +static void +Unlock(void) +{ + Tcl_MutexLock(&ZipFSMutex); + if (ZipFS.lock > 0) { + --ZipFS.lock; + } else if (ZipFS.lock < 0) { + ZipFS.lock = 0; + } + if ((ZipFS.lock == 0) && (ZipFS.waiters > 0)) { + Tcl_ConditionNotify(&ZipFSCond); + } + Tcl_MutexUnlock(&ZipFSMutex); +} + +#else /* !TCL_THREADS */ +#define ReadLock() do {} while (0) +#define WriteLock() do {} while (0) +#define Unlock() do {} while (0) +#endif /* TCL_THREADS */ + +/* + *------------------------------------------------------------------------- + * + * DosTimeDate, ToDosTime, ToDosDate -- + * + * Functions to perform conversions between DOS time stamps and POSIX + * time_t. + * + *------------------------------------------------------------------------- + */ + +static time_t +DosTimeDate( + int dosDate, + int dosTime) +{ + struct tm tm; + time_t ret; + + memset(&tm, 0, sizeof(tm)); + tm.tm_isdst = -1; /* let mktime() deal with DST */ + tm.tm_year = ((dosDate & 0xfe00) >> 9) + 80; + tm.tm_mon = ((dosDate & 0x1e0) >> 5) - 1; + tm.tm_mday = dosDate & 0x1f; + tm.tm_hour = (dosTime & 0xf800) >> 11; + tm.tm_min = (dosTime & 0x7e0) >> 5; + tm.tm_sec = (dosTime & 0x1f) << 1; + ret = mktime(&tm); + if (ret == (time_t) -1) { + /* fallback to 1980-01-01T00:00:00+00:00 (DOS epoch) */ + ret = (time_t) 315532800; + } + return ret; +} + +static int +ToDosTime( + time_t when) +{ + struct tm *tmp, tm; + +#if !TCL_THREADS || defined(_WIN32) + /* Not threaded, or on Win32 which uses thread local storage */ + tmp = localtime(&when); + tm = *tmp; +#elif defined(HAVE_LOCALTIME_R) + /* Threaded, have reentrant API */ + tmp = &tm; + localtime_r(&when, tmp); +#else /* TCL_THREADS && !_WIN32 && !HAVE_LOCALTIME_R */ + /* Only using a mutex is safe. */ + Tcl_MutexLock(&localtimeMutex); + tmp = localtime(&when); + tm = *tmp; + Tcl_MutexUnlock(&localtimeMutex); +#endif + return (tm.tm_hour << 11) | (tm.tm_min << 5) | (tm.tm_sec >> 1); +} + +static int +ToDosDate( + time_t when) +{ + struct tm *tmp, tm; + +#if !TCL_THREADS || defined(_WIN32) + /* Not threaded, or on Win32 which uses thread local storage */ + tmp = localtime(&when); + tm = *tmp; +#elif /* TCL_THREADS && !_WIN32 && */ defined(HAVE_LOCALTIME_R) + /* Threaded, have reentrant API */ + tmp = &tm; + localtime_r(&when, tmp); +#else /* TCL_THREADS && !_WIN32 && !HAVE_LOCALTIME_R */ + /* Only using a mutex is safe. */ + Tcl_MutexLock(&localtimeMutex); + tmp = localtime(&when); + tm = *tmp; + Tcl_MutexUnlock(&localtimeMutex); +#endif + return ((tm.tm_year - 80) << 9) | ((tm.tm_mon + 1) << 5) | tm.tm_mday; +} + +/* + *------------------------------------------------------------------------- + * + * CountSlashes -- + * + * This function counts the number of slashes in a pathname string. + * + * Results: + * Number of slashes found in string. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +CountSlashes( + const char *string) +{ + int count = 0; + const char *p = string; + + while (*p != '\0') { + if (*p == '/') { + count++; + } + p++; + } + return count; +} + +/* + *------------------------------------------------------------------------- + * + * CanonicalPath -- + * + * This function computes the canonical path from a directory and file + * name components into the specified Tcl_DString. + * + * Results: + * Returns the pointer to the canonical path contained in the specified + * Tcl_DString. + * + * Side effects: + * Modifies the specified Tcl_DString. + * + *------------------------------------------------------------------------- + */ + +static char * +CanonicalPath( + const char *root, + const char *tail, + Tcl_DString *dsPtr, + int inZipfs) +{ + char *path; + int i, j, c, isUNC = 0, isVfs = 0, n = 0; + int haveZipfsPath = 1; + +#ifdef _WIN32 + if (tail[0] != '\0' && strchr(drvletters, tail[0]) && tail[1] == ':') { + tail += 2; + haveZipfsPath = 0; + } + /* UNC style path */ + if (tail[0] == '\\') { + root = ""; + ++tail; + haveZipfsPath = 0; + } + if (tail[0] == '\\') { + root = "/"; + ++tail; + haveZipfsPath = 0; + } +#endif /* _WIN32 */ + + if (haveZipfsPath) { + /* UNC style path */ + if (root && strncmp(root, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN) == 0) { + isVfs = 1; + } else if (tail && + strncmp(tail, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN) == 0) { + isVfs = 2; + } + if (isVfs != 1 && (root[0] == '/') && (root[1] == '/')) { + isUNC = 1; + } + } + + if (isVfs != 2) { + if (tail[0] == '/') { + if (isVfs != 1) { + root = ""; + } + ++tail; + isUNC = 0; + } + if (tail[0] == '/') { + if (isVfs != 1) { + root = "/"; + } + ++tail; + isUNC = 1; + } + } + i = strlen(root); + j = strlen(tail); + + switch (isVfs) { + case 1: + if (i > ZIPFS_VOLUME_LEN) { + Tcl_DStringSetLength(dsPtr, i + j + 1); + path = Tcl_DStringValue(dsPtr); + memcpy(path, root, i); + path[i++] = '/'; + memcpy(path + i, tail, j); + } else { + Tcl_DStringSetLength(dsPtr, i + j); + path = Tcl_DStringValue(dsPtr); + memcpy(path, root, i); + memcpy(path + i, tail, j); + } + break; + case 2: + Tcl_DStringSetLength(dsPtr, j); + path = Tcl_DStringValue(dsPtr); + memcpy(path, tail, j); + break; + default: + if (inZipfs) { + Tcl_DStringSetLength(dsPtr, i + j + ZIPFS_VOLUME_LEN); + path = Tcl_DStringValue(dsPtr); + memcpy(path, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN); + memcpy(path + ZIPFS_VOLUME_LEN + i , tail, j); + } else { + Tcl_DStringSetLength(dsPtr, i + j + 1); + path = Tcl_DStringValue(dsPtr); + memcpy(path, root, i); + path[i++] = '/'; + memcpy(path + i, tail, j); + } + break; + } + +#ifdef _WIN32 + for (i = 0; path[i] != '\0'; i++) { + if (path[i] == '\\') { + path[i] = '/'; + } + } +#endif /* _WIN32 */ + + if (inZipfs) { + n = ZIPFS_VOLUME_LEN; + } else { + n = 0; + } + + for (i = j = n; (c = path[i]) != '\0'; i++) { + if (c == '/') { + int c2 = path[i + 1]; + + if (c2 == '\0' || c2 == '/') { + continue; + } + if (c2 == '.') { + int c3 = path[i + 2]; + + if ((c3 == '/') || (c3 == '\0')) { + i++; + continue; + } + if ((c3 == '.') + && ((path[i + 3] == '/') || (path[i + 3] == '\0'))) { + i += 2; + while ((j > 0) && (path[j - 1] != '/')) { + j--; + } + if (j > isUNC) { + --j; + while ((j > 1 + isUNC) && (path[j - 2] == '/')) { + j--; + } + } + continue; + } + } + } + path[j++] = c; + } + if (j == 0) { + path[j++] = '/'; + } + path[j] = 0; + Tcl_DStringSetLength(dsPtr, j); + return Tcl_DStringValue(dsPtr); +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSLookup -- + * + * This function returns the ZIP entry struct corresponding to the ZIP + * archive member of the given file name. Caller must hold the right + * lock. + * + * Results: + * Returns the pointer to ZIP entry struct or NULL if the the given file + * name could not be found in the global list of ZIP archive members. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static ZipEntry * +ZipFSLookup( + char *filename) +{ + Tcl_HashEntry *hPtr; + ZipEntry *z = NULL; + + hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, filename); + if (hPtr) { + z = Tcl_GetHashValue(hPtr); + } + return z; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSLookupMount -- + * + * This function returns an indication if the given file name corresponds + * to a mounted ZIP archive file. + * + * Results: + * Returns true, if the given file name is a mounted ZIP archive file. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +#ifdef NEVER_USED +static int +ZipFSLookupMount( + char *filename) +{ + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + + for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr; + hPtr = Tcl_NextHashEntry(&search)) { + ZipFile *zf = Tcl_GetHashValue(hPtr); + + if (strcmp(zf->mountPoint, filename) == 0) { + return 1; + } + } + return 0; +} +#endif /* NEVER_USED */ + +/* + *------------------------------------------------------------------------- + * + * ZipFSCloseArchive -- + * + * This function closes a mounted ZIP archive file. + * + * Results: + * None. + * + * Side effects: + * A memory mapped ZIP archive is unmapped, allocated memory is released. + * The ZipFile pointer is *NOT* deallocated by this function. + * + *------------------------------------------------------------------------- + */ + +static void +ZipFSCloseArchive( + Tcl_Interp *interp, /* Current interpreter. */ + ZipFile *zf) +{ + if (zf->nameLength) { + ckfree(zf->name); + } + if (zf->isMemBuffer) { + /* Pointer to memory */ + if (zf->ptrToFree) { + ckfree(zf->ptrToFree); + zf->ptrToFree = NULL; + } + zf->data = NULL; + return; + } + +#ifdef _WIN32 + if (zf->data && !zf->ptrToFree) { + UnmapViewOfFile(zf->data); + zf->data = NULL; + } + if (zf->mountHandle != INVALID_HANDLE_VALUE) { + CloseHandle(zf->mountHandle); + } +#else /* !_WIN32 */ + if ((zf->data != MAP_FAILED) && !zf->ptrToFree) { + munmap(zf->data, zf->length); + zf->data = MAP_FAILED; + } +#endif /* _WIN32 */ + + if (zf->ptrToFree) { + ckfree(zf->ptrToFree); + zf->ptrToFree = NULL; + } + if (zf->chan) { + Tcl_Close(interp, zf->chan); + zf->chan = NULL; + } +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSFindTOC -- + * + * This function takes a memory mapped zip file and indexes the contents. + * When "needZip" is zero an embedded ZIP archive in an executable file + * is accepted. + * + * Results: + * TCL_OK on success, TCL_ERROR otherwise with an error message placed + * into the given "interp" if it is not NULL. + * + * Side effects: + * The given ZipFile struct is filled with information about the ZIP + * archive file. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSFindTOC( + Tcl_Interp *interp, /* Current interpreter. NULLable. */ + int needZip, + ZipFile *zf) +{ + size_t i; + unsigned char *p, *q; + + p = zf->data + zf->length - ZIP_CENTRAL_END_LEN; + while (p >= zf->data) { + if (*p == (ZIP_CENTRAL_END_SIG & 0xFF)) { + if (ZipReadInt(p) == ZIP_CENTRAL_END_SIG) { + break; + } + p -= ZIP_SIG_LEN; + } else { + --p; + } + } + if (p < zf->data) { + if (!needZip) { + zf->baseOffset = zf->passOffset = zf->length; + return TCL_OK; + } + ZIPFS_ERROR(interp, "wrong end signature"); + if (interp) { + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "END_SIG", NULL); + } + goto error; + } + zf->numFiles = ZipReadShort(p + ZIP_CENTRAL_ENTS_OFFS); + if (zf->numFiles == 0) { + if (!needZip) { + zf->baseOffset = zf->passOffset = zf->length; + return TCL_OK; + } + ZIPFS_ERROR(interp, "empty archive"); + if (interp) { + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "EMPTY", NULL); + } + goto error; + } + q = zf->data + ZipReadInt(p + ZIP_CENTRAL_DIRSTART_OFFS); + p -= ZipReadInt(p + ZIP_CENTRAL_DIRSIZE_OFFS); + if ((p < zf->data) || (p > zf->data + zf->length) + || (q < zf->data) || (q > zf->data + zf->length)) { + if (!needZip) { + zf->baseOffset = zf->passOffset = zf->length; + return TCL_OK; + } + ZIPFS_ERROR(interp, "archive directory not found"); + if (interp) { + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_DIR", NULL); + } + goto error; + } + zf->baseOffset = zf->passOffset = p - q; + zf->directoryOffset = p - zf->data; + q = p; + for (i = 0; i < zf->numFiles; i++) { + int pathlen, comlen, extra; + + if (q + ZIP_CENTRAL_HEADER_LEN > zf->data + zf->length) { + ZIPFS_ERROR(interp, "wrong header length"); + if (interp) { + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "HDR_LEN", NULL); + } + goto error; + } + if (ZipReadInt(q) != ZIP_CENTRAL_HEADER_SIG) { + ZIPFS_ERROR(interp, "wrong header signature"); + if (interp) { + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "HDR_SIG", NULL); + } + goto error; + } + pathlen = ZipReadShort(q + ZIP_CENTRAL_PATHLEN_OFFS); + comlen = ZipReadShort(q + ZIP_CENTRAL_FCOMMENTLEN_OFFS); + extra = ZipReadShort(q + ZIP_CENTRAL_EXTRALEN_OFFS); + q += pathlen + comlen + extra + ZIP_CENTRAL_HEADER_LEN; + } + q = zf->data + zf->baseOffset; + if ((zf->baseOffset >= 6) && (ZipReadInt(q - 4) == ZIP_PASSWORD_END_SIG)) { + i = q[-5]; + if (q - 5 - i > zf->data) { + zf->passBuf[0] = i; + memcpy(zf->passBuf + 1, q - 5 - i, i); + zf->passOffset -= i ? (5 + i) : 0; + } + } + return TCL_OK; + + error: + ZipFSCloseArchive(interp, zf); + return TCL_ERROR; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSOpenArchive -- + * + * This function opens a ZIP archive file for reading. An attempt is made + * to memory map that file. Otherwise it is read into an allocated memory + * buffer. The ZIP archive header is verified and must be valid for the + * function to succeed. When "needZip" is zero an embedded ZIP archive in + * an executable file is accepted. + * + * Results: + * TCL_OK on success, TCL_ERROR otherwise with an error message placed + * into the given "interp" if it is not NULL. + * + * Side effects: + * ZIP archive is memory mapped or read into allocated memory, the given + * ZipFile struct is filled with information about the ZIP archive file. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSOpenArchive( + Tcl_Interp *interp, /* Current interpreter. NULLable. */ + const char *zipname, /* Path to ZIP file to open. */ + int needZip, + ZipFile *zf) +{ + size_t i; + void *handle; + + zf->nameLength = 0; + zf->isMemBuffer = 0; +#ifdef _WIN32 + zf->data = NULL; + zf->mountHandle = INVALID_HANDLE_VALUE; +#else /* !_WIN32 */ + zf->data = MAP_FAILED; +#endif /* _WIN32 */ + zf->length = 0; + zf->numFiles = 0; + zf->baseOffset = zf->passOffset = 0; + zf->ptrToFree = NULL; + zf->passBuf[0] = 0; + zf->chan = Tcl_OpenFileChannel(interp, zipname, "rb", 0); + if (!zf->chan) { + return TCL_ERROR; + } + if (Tcl_GetChannelHandle(zf->chan, TCL_READABLE, &handle) != TCL_OK) { + zf->length = Tcl_Seek(zf->chan, 0, SEEK_END); + if (zf->length == ERROR_LENGTH) { + ZIPFS_POSIX_ERROR(interp, "seek error"); + goto error; + } + if ((zf->length - ZIP_CENTRAL_END_LEN) + > (64 * 1024 * 1024 - ZIP_CENTRAL_END_LEN)) { + ZIPFS_ERROR(interp, "illegal file size"); + if (interp) { + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "FILE_SIZE", NULL); + } + goto error; + } + if (Tcl_Seek(zf->chan, 0, SEEK_SET) == -1) { + ZIPFS_POSIX_ERROR(interp, "seek error"); + goto error; + } + zf->ptrToFree = zf->data = attemptckalloc(zf->length); + if (!zf->ptrToFree) { + ZIPFS_ERROR(interp, "out of memory"); + if (interp) { + Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); + } + goto error; + } + i = Tcl_Read(zf->chan, (char *) zf->data, zf->length); + if (i != zf->length) { + ZIPFS_POSIX_ERROR(interp, "file read error"); + goto error; + } + Tcl_Close(interp, zf->chan); + zf->chan = NULL; + } else { +#ifdef _WIN32 + int readSuccessful; +# ifdef _WIN64 + i = GetFileSizeEx((HANDLE) handle, (PLARGE_INTEGER) &zf->length); + readSuccessful = (i != 0); +# else /* !_WIN64 */ + zf->length = GetFileSize((HANDLE) handle, 0); + readSuccessful = (zf->length != (size_t) INVALID_FILE_SIZE); +# endif /* _WIN64 */ + if (!readSuccessful || (zf->length < ZIP_CENTRAL_END_LEN)) { + ZIPFS_POSIX_ERROR(interp, "invalid file size"); + goto error; + } + zf->mountHandle = CreateFileMapping((HANDLE) handle, 0, PAGE_READONLY, + 0, zf->length, 0); + if (zf->mountHandle == INVALID_HANDLE_VALUE) { + ZIPFS_POSIX_ERROR(interp, "file mapping failed"); + goto error; + } + zf->data = MapViewOfFile(zf->mountHandle, FILE_MAP_READ, 0, 0, + zf->length); + if (!zf->data) { + ZIPFS_POSIX_ERROR(interp, "file mapping failed"); + goto error; + } +#else /* !_WIN32 */ + zf->length = lseek(PTR2INT(handle), 0, SEEK_END); + if (zf->length == ERROR_LENGTH || zf->length < ZIP_CENTRAL_END_LEN) { + ZIPFS_POSIX_ERROR(interp, "invalid file size"); + goto error; + } + lseek(PTR2INT(handle), 0, SEEK_SET); + zf->data = (unsigned char *) mmap(0, zf->length, PROT_READ, + MAP_FILE | MAP_PRIVATE, PTR2INT(handle), 0); + if (zf->data == MAP_FAILED) { + ZIPFS_POSIX_ERROR(interp, "file mapping failed"); + goto error; + } +#endif /* _WIN32 */ + } + return ZipFSFindTOC(interp, needZip, zf); + + error: + ZipFSCloseArchive(interp, zf); + return TCL_ERROR; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSRootNode -- + * + * This function generates the root node for a ZIPFS filesystem. + * + * Results: + * TCL_OK on success, TCL_ERROR otherwise with an error message placed + * into the given "interp" if it is not NULL. + * + * Side effects: + * ... + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSCatalogFilesystem( + Tcl_Interp *interp, /* Current interpreter. NULLable. */ + ZipFile *zf0, + const char *mountPoint, /* Mount point path. */ + const char *passwd, /* Password for opening the ZIP, or NULL if + * the ZIP is unprotected. */ + const char *zipname) /* Path to ZIP file to build a catalog of. */ +{ + int pwlen, isNew; + size_t i; + ZipFile *zf; + ZipEntry *z; + Tcl_HashEntry *hPtr; + Tcl_DString ds, dsm, fpBuf; + unsigned char *q; + + /* + * Basic verification of the password for sanity. + */ + + pwlen = 0; + if (passwd) { + pwlen = strlen(passwd); + if ((pwlen > 255) || strchr(passwd, 0xff)) { + if (interp) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("illegal password", -1)); + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_PASS", NULL); + } + return TCL_ERROR; + } + } + + WriteLock(); + + /* + * Mount point sometimes is a relative or otherwise denormalized path. + * But an absolute name is needed as mount point here. + */ + + Tcl_DStringInit(&ds); + Tcl_DStringInit(&dsm); + if (strcmp(mountPoint, "/") == 0) { + mountPoint = ""; + } else { + mountPoint = CanonicalPath("", mountPoint, &dsm, 1); + } + hPtr = Tcl_CreateHashEntry(&ZipFS.zipHash, mountPoint, &isNew); + if (!isNew) { + if (interp) { + zf = Tcl_GetHashValue(hPtr); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s is already mounted on %s", zf->name, mountPoint)); + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "MOUNTED", NULL); + } + Unlock(); + ZipFSCloseArchive(interp, zf0); + return TCL_ERROR; + } + zf = attemptckalloc(sizeof(ZipFile) + strlen(mountPoint) + 1); + if (!zf) { + if (interp) { + Tcl_AppendResult(interp, "out of memory", (char *) NULL); + Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); + } + Unlock(); + ZipFSCloseArchive(interp, zf0); + return TCL_ERROR; + } + Unlock(); + + *zf = *zf0; + zf->mountPoint = Tcl_GetHashKey(&ZipFS.zipHash, hPtr); + Tcl_CreateExitHandler(ZipfsExitHandler, (ClientData)zf); + zf->mountPointLen = strlen(zf->mountPoint); + zf->nameLength = strlen(zipname); + zf->name = ckalloc(zf->nameLength + 1); + memcpy(zf->name, zipname, zf->nameLength + 1); + zf->entries = NULL; + zf->topEnts = NULL; + zf->numOpen = 0; + Tcl_SetHashValue(hPtr, zf); + if ((zf->passBuf[0] == 0) && pwlen) { + int k = 0; + + zf->passBuf[k++] = pwlen; + for (i = pwlen; i-- > 0 ;) { + zf->passBuf[k++] = (passwd[i] & 0x0f) + | pwrot[(passwd[i] >> 4) & 0x0f]; + } + zf->passBuf[k] = '\0'; + } + if (mountPoint[0] != '\0') { + hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, mountPoint, &isNew); + if (isNew) { + z = ckalloc(sizeof(ZipEntry)); + Tcl_SetHashValue(hPtr, z); + + z->tnext = NULL; + z->depth = CountSlashes(mountPoint); + z->zipFilePtr = zf; + z->isDirectory = (zf->baseOffset == 0) ? 1 : -1; /* root marker */ + z->isEncrypted = 0; + z->offset = zf->baseOffset; + z->crc32 = 0; + z->timestamp = 0; + z->numBytes = z->numCompressedBytes = 0; + z->compressMethod = ZIP_COMPMETH_STORED; + z->data = NULL; + z->name = Tcl_GetHashKey(&ZipFS.fileHash, hPtr); + z->next = zf->entries; + zf->entries = z; + } + } + q = zf->data + zf->directoryOffset; + Tcl_DStringInit(&fpBuf); + for (i = 0; i < zf->numFiles; i++) { + int extra, isdir = 0, dosTime, dosDate, nbcompr; + size_t offs, pathlen, comlen; + unsigned char *lq, *gq = NULL; + char *fullpath, *path; + + pathlen = ZipReadShort(q + ZIP_CENTRAL_PATHLEN_OFFS); + comlen = ZipReadShort(q + ZIP_CENTRAL_FCOMMENTLEN_OFFS); + extra = ZipReadShort(q + ZIP_CENTRAL_EXTRALEN_OFFS); + Tcl_DStringSetLength(&ds, 0); + Tcl_DStringAppend(&ds, (char *) q + ZIP_CENTRAL_HEADER_LEN, pathlen); + path = Tcl_DStringValue(&ds); + if ((pathlen > 0) && (path[pathlen - 1] == '/')) { + Tcl_DStringSetLength(&ds, pathlen - 1); + path = Tcl_DStringValue(&ds); + isdir = 1; + } + if ((strcmp(path, ".") == 0) || (strcmp(path, "..") == 0)) { + goto nextent; + } + lq = zf->data + zf->baseOffset + + ZipReadInt(q + ZIP_CENTRAL_LOCALHDR_OFFS); + if ((lq < zf->data) || (lq > zf->data + zf->length)) { + goto nextent; + } + nbcompr = ZipReadInt(lq + ZIP_LOCAL_COMPLEN_OFFS); + if (!isdir && (nbcompr == 0) + && (ZipReadInt(lq + ZIP_LOCAL_UNCOMPLEN_OFFS) == 0) + && (ZipReadInt(lq + ZIP_LOCAL_CRC32_OFFS) == 0)) { + gq = q; + nbcompr = ZipReadInt(gq + ZIP_CENTRAL_COMPLEN_OFFS); + } + offs = (lq - zf->data) + + ZIP_LOCAL_HEADER_LEN + + ZipReadShort(lq + ZIP_LOCAL_PATHLEN_OFFS) + + ZipReadShort(lq + ZIP_LOCAL_EXTRALEN_OFFS); + if (offs + nbcompr > zf->length) { + goto nextent; + } + if (!isdir && (mountPoint[0] == '\0') && !CountSlashes(path)) { +#ifdef ANDROID + /* + * When mounting the ZIP archive on the root directory try to + * remap top level regular files of the archive to + * /assets/.root/... since this directory should not be in a valid + * APK due to the leading dot in the file name component. This + * trick should make the files AndroidManifest.xml, + * resources.arsc, and classes.dex visible to Tcl. + */ + Tcl_DString ds2; + + Tcl_DStringInit(&ds2); + Tcl_DStringAppend(&ds2, "assets/.root/", -1); + Tcl_DStringAppend(&ds2, path, -1); + hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, Tcl_DStringValue(&ds2)); + if (hPtr) { + /* should not happen but skip it anyway */ + Tcl_DStringFree(&ds2); + goto nextent; + } + Tcl_DStringSetLength(&ds, 0); + Tcl_DStringAppend(&ds, Tcl_DStringValue(&ds2), + Tcl_DStringLength(&ds2)); + path = Tcl_DStringValue(&ds); + Tcl_DStringFree(&ds2); +#else /* !ANDROID */ + /* + * Regular files skipped when mounting on root. + */ + goto nextent; +#endif /* ANDROID */ + } + Tcl_DStringSetLength(&fpBuf, 0); + fullpath = CanonicalPath(mountPoint, path, &fpBuf, 1); + z = ckalloc(sizeof(ZipEntry)); + z->name = NULL; + z->tnext = NULL; + z->depth = CountSlashes(fullpath); + z->zipFilePtr = zf; + z->isDirectory = isdir; + z->isEncrypted = (ZipReadShort(lq + ZIP_LOCAL_FLAGS_OFFS) & 1) + && (nbcompr > 12); + z->offset = offs; + if (gq) { + z->crc32 = ZipReadInt(gq + ZIP_CENTRAL_CRC32_OFFS); + dosDate = ZipReadShort(gq + ZIP_CENTRAL_MDATE_OFFS); + dosTime = ZipReadShort(gq + ZIP_CENTRAL_MTIME_OFFS); + z->timestamp = DosTimeDate(dosDate, dosTime); + z->numBytes = ZipReadInt(gq + ZIP_CENTRAL_UNCOMPLEN_OFFS); + z->compressMethod = ZipReadShort(gq + ZIP_CENTRAL_COMPMETH_OFFS); + } else { + z->crc32 = ZipReadInt(lq + ZIP_LOCAL_CRC32_OFFS); + dosDate = ZipReadShort(lq + ZIP_LOCAL_MDATE_OFFS); + dosTime = ZipReadShort(lq + ZIP_LOCAL_MTIME_OFFS); + z->timestamp = DosTimeDate(dosDate, dosTime); + z->numBytes = ZipReadInt(lq + ZIP_LOCAL_UNCOMPLEN_OFFS); + z->compressMethod = ZipReadShort(lq + ZIP_LOCAL_COMPMETH_OFFS); + } + z->numCompressedBytes = nbcompr; + z->data = NULL; + hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, fullpath, &isNew); + if (!isNew) { + /* should not happen but skip it anyway */ + ckfree(z); + } else { + Tcl_SetHashValue(hPtr, z); + z->name = Tcl_GetHashKey(&ZipFS.fileHash, hPtr); + z->next = zf->entries; + zf->entries = z; + if (isdir && (mountPoint[0] == '\0') && (z->depth == 1)) { + z->tnext = zf->topEnts; + zf->topEnts = z; + } + if (!z->isDirectory && (z->depth > 1)) { + char *dir, *end; + ZipEntry *zd; + + Tcl_DStringSetLength(&ds, strlen(z->name) + 8); + Tcl_DStringSetLength(&ds, 0); + Tcl_DStringAppend(&ds, z->name, -1); + dir = Tcl_DStringValue(&ds); + for (end = strrchr(dir, '/'); end && (end != dir); + end = strrchr(dir, '/')) { + Tcl_DStringSetLength(&ds, end - dir); + hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, dir, &isNew); + if (!isNew) { + break; + } + zd = ckalloc(sizeof(ZipEntry)); + zd->name = NULL; + zd->tnext = NULL; + zd->depth = CountSlashes(dir); + zd->zipFilePtr = zf; + zd->isDirectory = 1; + zd->isEncrypted = 0; + zd->offset = z->offset; + zd->crc32 = 0; + zd->timestamp = z->timestamp; + zd->numBytes = zd->numCompressedBytes = 0; + zd->compressMethod = ZIP_COMPMETH_STORED; + zd->data = NULL; + Tcl_SetHashValue(hPtr, zd); + zd->name = Tcl_GetHashKey(&ZipFS.fileHash, hPtr); + zd->next = zf->entries; + zf->entries = zd; + if ((mountPoint[0] == '\0') && (zd->depth == 1)) { + zd->tnext = zf->topEnts; + zf->topEnts = zd; + } + } + } + } + nextent: + q += pathlen + comlen + extra + ZIP_CENTRAL_HEADER_LEN; + } + Tcl_DStringFree(&fpBuf); + Tcl_DStringFree(&ds); + Tcl_FSMountsChanged(NULL); + Unlock(); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * ZipfsSetup -- + * + * Common initialisation code. ZipFS.initialized must *not* be set prior + * to the call. + * + *------------------------------------------------------------------------- + */ + +static void +ZipfsSetup(void) +{ +#if TCL_THREADS + static const Tcl_Time t = { 0, 0 }; + + /* + * Inflate condition variable. + */ + + Tcl_MutexLock(&ZipFSMutex); + Tcl_ConditionWait(&ZipFSCond, &ZipFSMutex, &t); + Tcl_MutexUnlock(&ZipFSMutex); +#endif /* TCL_THREADS */ + + Tcl_FSRegister(NULL, &zipfsFilesystem); + Tcl_InitHashTable(&ZipFS.fileHash, TCL_STRING_KEYS); + Tcl_InitHashTable(&ZipFS.zipHash, TCL_STRING_KEYS); + ZipFS.idCount = 1; + ZipFS.wrmax = DEFAULT_WRITE_MAX_SIZE; + ZipFS.initialized = 1; +} + +/* + *------------------------------------------------------------------------- + * + * ListMountPoints -- + * + * This procedure lists the mount points and what's mounted there, or + * reports whether there are any mounts (if there's no interpreter). The + * read lock must be held by the caller. + * + * Results: + * A standard Tcl result. TCL_OK (or TCL_BREAK if no mounts and no + * interpreter). + * + * Side effects: + * Interpreter result may be updated. + * + *------------------------------------------------------------------------- + */ + +static inline int +ListMountPoints( + Tcl_Interp *interp) +{ + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + ZipFile *zf; + + for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr; + hPtr = Tcl_NextHashEntry(&search)) { + if (!interp) { + return TCL_OK; + } + zf = Tcl_GetHashValue(hPtr); + Tcl_AppendElement(interp, zf->mountPoint); + Tcl_AppendElement(interp, zf->name); + } + return (interp ? TCL_OK : TCL_BREAK); +} + +/* + *------------------------------------------------------------------------- + * + * DescribeMounted -- + * + * This procedure describes what is mounted at the given the mount point. + * The interpreter result is not updated if there is nothing mounted at + * the given point. The read lock must be held by the caller. + * + * Results: + * A standard Tcl result. TCL_OK (or TCL_BREAK if nothing mounted there + * and no interpreter). + * + * Side effects: + * Interpreter result may be updated. + * + *------------------------------------------------------------------------- + */ + +static inline int +DescribeMounted( + Tcl_Interp *interp, + const char *mountPoint) +{ + Tcl_HashEntry *hPtr; + ZipFile *zf; + + if (interp) { + hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, mountPoint); + if (hPtr) { + zf = Tcl_GetHashValue(hPtr); + Tcl_SetObjResult(interp, Tcl_NewStringObj(zf->name, -1)); + return TCL_OK; + } + } + return (interp ? TCL_OK : TCL_BREAK); +} + +/* + *------------------------------------------------------------------------- + * + * TclZipfs_Mount -- + * + * This procedure is invoked to mount a given ZIP archive file on a given + * mountpoint with optional ZIP password. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * A ZIP archive file is read, analyzed and mounted, resources are + * allocated. + * + *------------------------------------------------------------------------- + */ + +int +TclZipfs_Mount( + Tcl_Interp *interp, /* Current interpreter. NULLable. */ + const char *mountPoint, /* Mount point path. */ + const char *zipname, /* Path to ZIP file to mount. */ + const char *passwd) /* Password for opening the ZIP, or NULL if + * the ZIP is unprotected. */ +{ + ZipFile *zf; + + ReadLock(); + if (!ZipFS.initialized) { + ZipfsSetup(); + } + + /* + * No mount point, so list all mount points and what is mounted there. + */ + + if (!mountPoint) { + int ret = ListMountPoints(interp); + Unlock(); + return ret; + } + + /* + * Mount point but no file, so describe what is mounted at that mount + * point. + */ + + if (!zipname) { + DescribeMounted(interp, mountPoint); + Unlock(); + return TCL_OK; + } + Unlock(); + + /* + * Have both a mount point and a file (name) to mount there. + */ + + if (passwd) { + if ((strlen(passwd) > 255) || strchr(passwd, 0xff)) { + if (interp) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("illegal password", -1)); + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_PASS", NULL); + } + return TCL_ERROR; + } + } + zf = attemptckalloc(sizeof(ZipFile) + strlen(mountPoint) + 1); + if (!zf) { + if (interp) { + Tcl_AppendResult(interp, "out of memory", (char *) NULL); + Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); + } + return TCL_ERROR; + } + if (ZipFSOpenArchive(interp, zipname, 1, zf) != TCL_OK) { + ckfree(zf); + return TCL_ERROR; + } + if (ZipFSCatalogFilesystem(interp, zf, mountPoint, passwd, zipname) + != TCL_OK) { + ckfree(zf); + return TCL_ERROR; + } + ckfree(zf); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * TclZipfs_MountBuffer -- + * + * This procedure is invoked to mount a given ZIP archive file on a given + * mountpoint with optional ZIP password. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * A ZIP archive file is read, analyzed and mounted, resources are + * allocated. + * + *------------------------------------------------------------------------- + */ + +int +TclZipfs_MountBuffer( + Tcl_Interp *interp, /* Current interpreter. NULLable. */ + const char *mountPoint, /* Mount point path. */ + unsigned char *data, + size_t datalen, + int copy) +{ + ZipFile *zf; + int result; + + ReadLock(); + if (!ZipFS.initialized) { + ZipfsSetup(); + } + + /* + * No mount point, so list all mount points and what is mounted there. + */ + + if (!mountPoint) { + int ret = ListMountPoints(interp); + Unlock(); + return ret; + } + + /* + * Mount point but no data, so describe what is mounted at that mount + * point. + */ + + if (!data) { + DescribeMounted(interp, mountPoint); + Unlock(); + return TCL_OK; + } + Unlock(); + + /* + * Have both a mount point and data to mount there. + */ + + zf = attemptckalloc(sizeof(ZipFile) + strlen(mountPoint) + 1); + if (!zf) { + if (interp) { + Tcl_AppendResult(interp, "out of memory", (char *) NULL); + Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); + } + return TCL_ERROR; + } + zf->isMemBuffer = 1; + zf->length = datalen; + if (copy) { + zf->data = attemptckalloc(datalen); + if (!zf->data) { + if (interp) { + Tcl_AppendResult(interp, "out of memory", (char *) NULL); + Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); + } + return TCL_ERROR; + } + memcpy(zf->data, data, datalen); + zf->ptrToFree = zf->data; + } else { + zf->data = data; + zf->ptrToFree = NULL; + } + zf->passBuf[0] = 0; /* stop valgrind cries */ + if (ZipFSFindTOC(interp, 0, zf) != TCL_OK) { + return TCL_ERROR; + } + result = ZipFSCatalogFilesystem(interp, zf, mountPoint, NULL, + "Memory Buffer"); + ckfree(zf); + return result; +} + +/* + *------------------------------------------------------------------------- + * + * TclZipfs_Unmount -- + * + * This procedure is invoked to unmount a given ZIP archive. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * A mounted ZIP archive file is unmounted, resources are free'd. + * + *------------------------------------------------------------------------- + */ + +int +TclZipfs_Unmount( + Tcl_Interp *interp, /* Current interpreter. NULLable. */ + const char *mountPoint) /* Mount point path. */ +{ + ZipFile *zf; + ZipEntry *z, *znext; + Tcl_HashEntry *hPtr; + Tcl_DString dsm; + int ret = TCL_OK, unmounted = 0; + + WriteLock(); + if (!ZipFS.initialized) { + goto done; + } + + /* + * Mount point sometimes is a relative or otherwise denormalized path. + * But an absolute name is needed as mount point here. + */ + + Tcl_DStringInit(&dsm); + mountPoint = CanonicalPath("", mountPoint, &dsm, 1); + + hPtr = Tcl_FindHashEntry(&ZipFS.zipHash, mountPoint); + /* don't report no-such-mount as an error */ + if (!hPtr) { + goto done; + } + + zf = Tcl_GetHashValue(hPtr); + if (zf->numOpen > 0) { + ZIPFS_ERROR(interp, "filesystem is busy"); + ret = TCL_ERROR; + goto done; + } + Tcl_DeleteHashEntry(hPtr); + for (z = zf->entries; z; z = znext) { + znext = z->next; + hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, z->name); + if (hPtr) { + Tcl_DeleteHashEntry(hPtr); + } + if (z->data) { + ckfree(z->data); + } + ckfree(z); + } + ZipFSCloseArchive(interp, zf); + Tcl_DeleteExitHandler(ZipfsExitHandler, (ClientData)zf); + ckfree(zf); + unmounted = 1; + done: + Unlock(); + if (unmounted) { + Tcl_FSMountsChanged(NULL); + } + return ret; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSMountObjCmd -- + * + * This procedure is invoked to process the [zipfs mount] command. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * A ZIP archive file is mounted, resources are allocated. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSMountObjCmd( + void *clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + if (objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, + "?mountpoint? ?zipfile? ?password?"); + return TCL_ERROR; + } + + return TclZipfs_Mount(interp, (objc > 1) ? Tcl_GetString(objv[1]) : NULL, + (objc > 2) ? Tcl_GetString(objv[2]) : NULL, + (objc > 3) ? Tcl_GetString(objv[3]) : NULL); +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSMountBufferObjCmd -- + * + * This procedure is invoked to process the [zipfs mount_data] command. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * A ZIP archive file is mounted, resources are allocated. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSMountBufferObjCmd( + void *clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + const char *mountPoint; /* Mount point path. */ + unsigned char *data; + int length; + + if (objc > 3) { + Tcl_WrongNumArgs(interp, 1, objv, "?mountpoint? ?data?"); + return TCL_ERROR; + } + if (objc < 2) { + int ret; + + ReadLock(); + ret = ListMountPoints(interp); + Unlock(); + return ret; + } + + mountPoint = Tcl_GetString(objv[1]); + if (objc < 3) { + ReadLock(); + DescribeMounted(interp, mountPoint); + Unlock(); + return TCL_OK; + } + + data = Tcl_GetByteArrayFromObj(objv[2], &length); + return TclZipfs_MountBuffer(interp, mountPoint, data, length, 1); +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSRootObjCmd -- + * + * This procedure is invoked to process the [zipfs root] command. It + * returns the root that all zipfs file systems are mounted under. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSRootObjCmd( + void *clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_SetObjResult(interp, Tcl_NewStringObj(ZIPFS_VOLUME, -1)); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSUnmountObjCmd -- + * + * This procedure is invoked to process the [zipfs unmount] command. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * A mounted ZIP archive file is unmounted, resources are free'd. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSUnmountObjCmd( + void *clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "zipfile"); + return TCL_ERROR; + } + return TclZipfs_Unmount(interp, Tcl_GetString(objv[1])); +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSMkKeyObjCmd -- + * + * This procedure is invoked to process the [zipfs mkkey] command. It + * produces a rotated password to be embedded into an image file. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSMkKeyObjCmd( + void *clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int len, i = 0; + char *pw, passBuf[264]; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "password"); + return TCL_ERROR; + } + pw = Tcl_GetString(objv[1]); + len = strlen(pw); + if (len == 0) { + return TCL_OK; + } + if ((len > 255) || strchr(pw, 0xff)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("illegal password", -1)); + return TCL_ERROR; + } + while (len > 0) { + int ch = pw[len - 1]; + + passBuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; + i++; + len--; + } + passBuf[i] = i; + ++i; + passBuf[i++] = (char) ZIP_PASSWORD_END_SIG; + passBuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 8); + passBuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 16); + passBuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 24); + passBuf[i] = '\0'; + Tcl_AppendResult(interp, passBuf, (char *) NULL); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * ZipAddFile -- + * + * This procedure is used by ZipFSMkZipOrImgCmd() to add a single file to + * the output ZIP archive file being written. A ZipEntry struct about the + * input file is added to the given fileHash table for later creation of + * the central ZIP directory. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * Input file is read and (compressed and) written to the output ZIP + * archive file. + * + *------------------------------------------------------------------------- + */ + +static int +ZipAddFile( + Tcl_Interp *interp, /* Current interpreter. */ + const char *path, + const char *name, + Tcl_Channel out, + const char *passwd, /* Password for encoding the file, or NULL if + * the file is to be unprotected. */ + char *buf, + int bufsize, + Tcl_HashTable *fileHash) +{ + Tcl_Channel in; + Tcl_HashEntry *hPtr; + ZipEntry *z; + z_stream stream; + const char *zpath; + int crc, flush, zpathlen; + size_t nbyte, nbytecompr, len, olen, align = 0; + Tcl_WideInt pos[3]; + int mtime = 0, isNew, compMeth; + unsigned long keys[3], keys0[3]; + char obuf[4096]; + + /* + * Trim leading '/' characters. If this results in an empty string, we've + * nothing to do. + */ + + zpath = name; + while (zpath && zpath[0] == '/') { + zpath++; + } + if (!zpath || (zpath[0] == '\0')) { + return TCL_OK; + } + + zpathlen = strlen(zpath); + if (zpathlen + ZIP_CENTRAL_HEADER_LEN > bufsize) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "path too long for \"%s\"", path)); + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "PATH_LEN", NULL); + return TCL_ERROR; + } + in = Tcl_OpenFileChannel(interp, path, "rb", 0); + if (!in) { +#ifdef _WIN32 + /* hopefully a directory */ + if (strcmp("permission denied", Tcl_PosixError(interp)) == 0) { + Tcl_Close(interp, in); + return TCL_OK; + } +#endif /* _WIN32 */ + Tcl_Close(interp, in); + return TCL_ERROR; + } else { + Tcl_Obj *pathObj = Tcl_NewStringObj(path, -1); + Tcl_StatBuf statBuf; + + Tcl_IncrRefCount(pathObj); + if (Tcl_FSStat(pathObj, &statBuf) != -1) { + mtime = statBuf.st_mtime; + } + Tcl_DecrRefCount(pathObj); + } + Tcl_ResetResult(interp); + crc = 0; + nbyte = nbytecompr = 0; + while (1) { + len = Tcl_Read(in, buf, bufsize); + if (len == ERROR_LENGTH) { + if (nbyte == 0 && errno == EISDIR) { + Tcl_Close(interp, in); + return TCL_OK; + } + Tcl_SetObjResult(interp, Tcl_ObjPrintf("read error on \"%s\": %s", + path, Tcl_PosixError(interp))); + Tcl_Close(interp, in); + return TCL_ERROR; + } + if (len == 0) { + break; + } + crc = crc32(crc, (unsigned char *) buf, len); + nbyte += len; + } + if (Tcl_Seek(in, 0, SEEK_SET) == -1) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf("seek error on \"%s\": %s", + path, Tcl_PosixError(interp))); + Tcl_Close(interp, in); + return TCL_ERROR; + } + pos[0] = Tcl_Tell(out); + memset(buf, '\0', ZIP_LOCAL_HEADER_LEN); + memcpy(buf + ZIP_LOCAL_HEADER_LEN, zpath, zpathlen); + len = zpathlen + ZIP_LOCAL_HEADER_LEN; + if ((size_t) Tcl_Write(out, buf, len) != len) { + wrerr: + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "write error on %s: %s", path, Tcl_PosixError(interp))); + Tcl_Close(interp, in); + return TCL_ERROR; + } + if ((len + pos[0]) & 3) { + unsigned char abuf[8]; + + /* + * Align payload to next 4-byte boundary using a dummy extra entry + * similar to the zipalign tool from Android's SDK. + */ + + align = 4 + ((len + pos[0]) & 3); + ZipWriteShort(abuf, 0xffff); + ZipWriteShort(abuf + 2, align - 4); + ZipWriteInt(abuf + 4, 0x03020100); + if ((size_t) Tcl_Write(out, (const char *) abuf, align) != align) { + goto wrerr; + } + } + if (passwd) { + int i, ch, tmp; + unsigned char kvbuf[24]; + Tcl_Obj *ret; + + init_keys(passwd, keys, crc32tab); + for (i = 0; i < 12 - 2; i++) { + double r; + + if (Tcl_EvalEx(interp, "::tcl::mathfunc::rand", -1, 0) != TCL_OK) { + Tcl_Obj *eiPtr = Tcl_ObjPrintf( + "\n (evaluating PRNG step %d for password encoding)", + i); + + Tcl_AppendObjToErrorInfo(interp, eiPtr); + Tcl_Close(interp, in); + return TCL_ERROR; + } + ret = Tcl_GetObjResult(interp); + if (Tcl_GetDoubleFromObj(interp, ret, &r) != TCL_OK) { + Tcl_Obj *eiPtr = Tcl_ObjPrintf( + "\n (evaluating PRNG step %d for password encoding)", + i); + + Tcl_AppendObjToErrorInfo(interp, eiPtr); + Tcl_Close(interp, in); + return TCL_ERROR; + } + ch = (int) (r * 256); + kvbuf[i + 12] = (unsigned char) zencode(keys, crc32tab, ch, tmp); + } + Tcl_ResetResult(interp); + init_keys(passwd, keys, crc32tab); + for (i = 0; i < 12 - 2; i++) { + kvbuf[i] = (unsigned char) + zencode(keys, crc32tab, kvbuf[i + 12], tmp); + } + kvbuf[i++] = (unsigned char) zencode(keys, crc32tab, crc >> 16, tmp); + kvbuf[i++] = (unsigned char) zencode(keys, crc32tab, crc >> 24, tmp); + len = Tcl_Write(out, (char *) kvbuf, 12); + memset(kvbuf, 0, 24); + if (len != 12) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "write error on %s: %s", path, Tcl_PosixError(interp))); + Tcl_Close(interp, in); + return TCL_ERROR; + } + memcpy(keys0, keys, sizeof(keys0)); + nbytecompr += 12; + } + Tcl_Flush(out); + pos[2] = Tcl_Tell(out); + compMeth = ZIP_COMPMETH_DEFLATED; + memset(&stream, 0, sizeof(z_stream)); + stream.zalloc = Z_NULL; + stream.zfree = Z_NULL; + stream.opaque = Z_NULL; + if (deflateInit2(&stream, 9, Z_DEFLATED, -15, 8, + Z_DEFAULT_STRATEGY) != Z_OK) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "compression init error on \"%s\"", path)); + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "DEFLATE_INIT", NULL); + Tcl_Close(interp, in); + return TCL_ERROR; + } + do { + len = Tcl_Read(in, buf, bufsize); + if (len == ERROR_LENGTH) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "read error on %s: %s", path, Tcl_PosixError(interp))); + deflateEnd(&stream); + Tcl_Close(interp, in); + return TCL_ERROR; + } + stream.avail_in = len; + stream.next_in = (unsigned char *) buf; + flush = Tcl_Eof(in) ? Z_FINISH : Z_NO_FLUSH; + do { + stream.avail_out = sizeof(obuf); + stream.next_out = (unsigned char *) obuf; + len = deflate(&stream, flush); + if (len == (size_t) Z_STREAM_ERROR) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "deflate error on %s", path)); + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "DEFLATE", NULL); + deflateEnd(&stream); + Tcl_Close(interp, in); + return TCL_ERROR; + } + olen = sizeof(obuf) - stream.avail_out; + if (passwd) { + size_t i; + int tmp; + + for (i = 0; i < olen; i++) { + obuf[i] = (char) zencode(keys, crc32tab, obuf[i], tmp); + } + } + if (olen && ((size_t) Tcl_Write(out, obuf, olen) != olen)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "write error: %s", Tcl_PosixError(interp))); + deflateEnd(&stream); + Tcl_Close(interp, in); + return TCL_ERROR; + } + nbytecompr += olen; + } while (stream.avail_out == 0); + } while (flush != Z_FINISH); + deflateEnd(&stream); + Tcl_Flush(out); + pos[1] = Tcl_Tell(out); + if (nbyte - nbytecompr <= 0) { + /* + * Compressed file larger than input, write it again uncompressed. + */ + if (Tcl_Seek(in, 0, SEEK_SET) != 0) { + goto seekErr; + } + if (Tcl_Seek(out, pos[2], SEEK_SET) != pos[2]) { + seekErr: + Tcl_Close(interp, in); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "seek error: %s", Tcl_PosixError(interp))); + return TCL_ERROR; + } + nbytecompr = (passwd ? 12 : 0); + while (1) { + len = Tcl_Read(in, buf, bufsize); + if (len == ERROR_LENGTH) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "read error on \"%s\": %s", + path, Tcl_PosixError(interp))); + Tcl_Close(interp, in); + return TCL_ERROR; + } else if (len == 0) { + break; + } + if (passwd) { + size_t i; + int tmp; + + for (i = 0; i < len; i++) { + buf[i] = (char) zencode(keys0, crc32tab, buf[i], tmp); + } + } + if ((size_t) Tcl_Write(out, buf, len) != len) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "write error: %s", Tcl_PosixError(interp))); + Tcl_Close(interp, in); + return TCL_ERROR; + } + nbytecompr += len; + } + compMeth = ZIP_COMPMETH_STORED; + Tcl_Flush(out); + pos[1] = Tcl_Tell(out); + Tcl_TruncateChannel(out, pos[1]); + } + Tcl_Close(interp, in); + + hPtr = Tcl_CreateHashEntry(fileHash, zpath, &isNew); + if (!isNew) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "non-unique path name \"%s\"", path)); + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "DUPLICATE_PATH", NULL); + return TCL_ERROR; + } + + z = ckalloc(sizeof(ZipEntry)); + Tcl_SetHashValue(hPtr, z); + z->name = NULL; + z->tnext = NULL; + z->depth = 0; + z->zipFilePtr = NULL; + z->isDirectory = 0; + z->isEncrypted = (passwd ? 1 : 0); + z->offset = pos[0]; + z->crc32 = crc; + z->timestamp = mtime; + z->numBytes = nbyte; + z->numCompressedBytes = nbytecompr; + z->compressMethod = compMeth; + z->data = NULL; + z->name = Tcl_GetHashKey(fileHash, hPtr); + z->next = NULL; + + /* + * Write final local header information. + */ + ZipWriteInt(buf + ZIP_LOCAL_SIG_OFFS, ZIP_LOCAL_HEADER_SIG); + ZipWriteShort(buf + ZIP_LOCAL_VERSION_OFFS, ZIP_MIN_VERSION); + ZipWriteShort(buf + ZIP_LOCAL_FLAGS_OFFS, z->isEncrypted); + ZipWriteShort(buf + ZIP_LOCAL_COMPMETH_OFFS, z->compressMethod); + ZipWriteShort(buf + ZIP_LOCAL_MTIME_OFFS, ToDosTime(z->timestamp)); + ZipWriteShort(buf + ZIP_LOCAL_MDATE_OFFS, ToDosDate(z->timestamp)); + ZipWriteInt(buf + ZIP_LOCAL_CRC32_OFFS, z->crc32); + ZipWriteInt(buf + ZIP_LOCAL_COMPLEN_OFFS, z->numCompressedBytes); + ZipWriteInt(buf + ZIP_LOCAL_UNCOMPLEN_OFFS, z->numBytes); + ZipWriteShort(buf + ZIP_LOCAL_PATHLEN_OFFS, zpathlen); + ZipWriteShort(buf + ZIP_LOCAL_EXTRALEN_OFFS, align); + if (Tcl_Seek(out, pos[0], SEEK_SET) != pos[0]) { + Tcl_DeleteHashEntry(hPtr); + ckfree(z); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "seek error: %s", Tcl_PosixError(interp))); + return TCL_ERROR; + } + if (Tcl_Write(out, buf, ZIP_LOCAL_HEADER_LEN) != ZIP_LOCAL_HEADER_LEN) { + Tcl_DeleteHashEntry(hPtr); + ckfree(z); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "write error: %s", Tcl_PosixError(interp))); + return TCL_ERROR; + } + Tcl_Flush(out); + if (Tcl_Seek(out, pos[1], SEEK_SET) != pos[1]) { + Tcl_DeleteHashEntry(hPtr); + ckfree(z); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "seek error: %s", Tcl_PosixError(interp))); + return TCL_ERROR; + } + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSMkZipOrImgObjCmd -- + * + * This procedure is creates a new ZIP archive file or image file given + * output filename, input directory of files to be archived, optional + * password, and optional image to be prepended to the output ZIP archive + * file. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * A new ZIP archive file or image file is written. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSMkZipOrImgObjCmd( + Tcl_Interp *interp, /* Current interpreter. */ + int isImg, + int isList, + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + Tcl_Channel out; + int pwlen = 0, count, ret = TCL_ERROR, lobjc; + size_t len, slen = 0, i = 0; + Tcl_WideInt pos[3]; + Tcl_Obj **lobjv, *list = NULL; + ZipEntry *z; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + Tcl_HashTable fileHash; + char *strip = NULL, *pw = NULL, passBuf[264], buf[4096]; + + /* + * Caller has verified that the number of arguments is correct. + */ + + passBuf[0] = 0; + if (objc > (isList ? 3 : 4)) { + pw = Tcl_GetString(objv[isList ? 3 : 4]); + pwlen = strlen(pw); + if ((pwlen > 255) || strchr(pw, 0xff)) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("illegal password", -1)); + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_PASS", NULL); + return TCL_ERROR; + } + } + if (isList) { + list = objv[2]; + Tcl_IncrRefCount(list); + } else { + Tcl_Obj *cmd[3]; + + cmd[1] = Tcl_NewStringObj("::tcl::zipfs::find", -1); + cmd[2] = objv[2]; + cmd[0] = Tcl_NewListObj(2, cmd + 1); + Tcl_IncrRefCount(cmd[0]); + if (Tcl_EvalObjEx(interp, cmd[0], TCL_EVAL_DIRECT) != TCL_OK) { + Tcl_DecrRefCount(cmd[0]); + return TCL_ERROR; + } + Tcl_DecrRefCount(cmd[0]); + list = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(list); + } + if (Tcl_ListObjGetElements(interp, list, &lobjc, &lobjv) != TCL_OK) { + Tcl_DecrRefCount(list); + return TCL_ERROR; + } + if (isList && (lobjc % 2)) { + Tcl_DecrRefCount(list); + Tcl_SetObjResult(interp, + Tcl_NewStringObj("need even number of elements", -1)); + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "LIST_LENGTH", NULL); + return TCL_ERROR; + } + if (lobjc == 0) { + Tcl_DecrRefCount(list); + Tcl_SetObjResult(interp, Tcl_NewStringObj("empty archive", -1)); + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "EMPTY", NULL); + return TCL_ERROR; + } + out = Tcl_OpenFileChannel(interp, Tcl_GetString(objv[1]), "wb", 0755); + if (out == NULL) { + Tcl_DecrRefCount(list); + return TCL_ERROR; + } + if (pwlen <= 0) { + pw = NULL; + pwlen = 0; + } + if (isImg) { + ZipFile *zf, zf0; + int isMounted = 0; + const char *imgName; + + if (isList) { + imgName = (objc > 4) ? Tcl_GetString(objv[4]) : + Tcl_GetNameOfExecutable(); + } else { + imgName = (objc > 5) ? Tcl_GetString(objv[5]) : + Tcl_GetNameOfExecutable(); + } + if (pwlen) { + i = 0; + for (len = pwlen; len-- > 0;) { + int ch = pw[len]; + + passBuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; + i++; + } + passBuf[i] = i; + ++i; + passBuf[i++] = (char) ZIP_PASSWORD_END_SIG; + passBuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 8); + passBuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 16); + passBuf[i++] = (char) (ZIP_PASSWORD_END_SIG >> 24); + passBuf[i] = '\0'; + } + + /* + * Check for mounted image. + */ + + WriteLock(); + for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr; + hPtr = Tcl_NextHashEntry(&search)) { + zf = Tcl_GetHashValue(hPtr); + if (strcmp(zf->name, imgName) == 0) { + isMounted = 1; + zf->numOpen++; + break; + } + } + Unlock(); + if (!isMounted) { + zf = &zf0; + } + if (isMounted || ZipFSOpenArchive(interp, imgName, 0, zf) == TCL_OK) { + if ((size_t) Tcl_Write(out, (char *) zf->data, + zf->passOffset) != zf->passOffset) { + memset(passBuf, 0, sizeof(passBuf)); + Tcl_DecrRefCount(list); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "write error: %s", Tcl_PosixError(interp))); + Tcl_Close(interp, out); + if (zf == &zf0) { + ZipFSCloseArchive(interp, zf); + } else { + WriteLock(); + zf->numOpen--; + Unlock(); + } + return TCL_ERROR; + } + if (zf == &zf0) { + ZipFSCloseArchive(interp, zf); + } else { + WriteLock(); + zf->numOpen--; + Unlock(); + } + } else { + size_t k; + int m, n; + Tcl_Channel in; + const char *errMsg = "seek error"; + + /* + * Fall back to read it as plain file which hopefully is a static + * tclsh or wish binary with proper zipfs infrastructure built in. + */ + + Tcl_ResetResult(interp); + in = Tcl_OpenFileChannel(interp, imgName, "rb", 0644); + if (!in) { + memset(passBuf, 0, sizeof(passBuf)); + Tcl_DecrRefCount(list); + Tcl_Close(interp, out); + return TCL_ERROR; + } + i = Tcl_Seek(in, 0, SEEK_END); + if (i == ERROR_LENGTH) { + cperr: + memset(passBuf, 0, sizeof(passBuf)); + Tcl_DecrRefCount(list); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "%s: %s", errMsg, Tcl_PosixError(interp))); + Tcl_Close(interp, out); + Tcl_Close(interp, in); + return TCL_ERROR; + } + Tcl_Seek(in, 0, SEEK_SET); + for (k = 0; k < i; k += m) { + m = i - k; + if (m > (int) sizeof(buf)) { + m = (int) sizeof(buf); + } + n = Tcl_Read(in, buf, m); + if (n == -1) { + errMsg = "read error"; + goto cperr; + } else if (n == 0) { + break; + } + m = Tcl_Write(out, buf, n); + if (m != n) { + errMsg = "write error"; + goto cperr; + } + } + Tcl_Close(interp, in); + } + len = strlen(passBuf); + if (len > 0) { + i = Tcl_Write(out, passBuf, len); + if (i != len) { + Tcl_DecrRefCount(list); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "write error: %s", Tcl_PosixError(interp))); + Tcl_Close(interp, out); + return TCL_ERROR; + } + } + memset(passBuf, 0, sizeof(passBuf)); + Tcl_Flush(out); + } + Tcl_InitHashTable(&fileHash, TCL_STRING_KEYS); + pos[0] = Tcl_Tell(out); + if (!isList && (objc > 3)) { + strip = Tcl_GetString(objv[3]); + slen = strlen(strip); + } + for (i = 0; i < (size_t) lobjc; i += (isList ? 2 : 1)) { + const char *path, *name; + + path = Tcl_GetString(lobjv[i]); + if (isList) { + name = Tcl_GetString(lobjv[i + 1]); + } else { + name = path; + if (slen > 0) { + len = strlen(name); + if ((len <= slen) || (strncmp(strip, name, slen) != 0)) { + continue; + } + name += slen; + } + } + while (name[0] == '/') { + ++name; + } + if (name[0] == '\0') { + continue; + } + if (ZipAddFile(interp, path, name, out, pw, buf, sizeof(buf), + &fileHash) != TCL_OK) { + goto done; + } + } + pos[1] = Tcl_Tell(out); + count = 0; + for (i = 0; i < (size_t) lobjc; i += (isList ? 2 : 1)) { + const char *path, *name; + + path = Tcl_GetString(lobjv[i]); + if (isList) { + name = Tcl_GetString(lobjv[i + 1]); + } else { + name = path; + if (slen > 0) { + len = strlen(name); + if ((len <= slen) || (strncmp(strip, name, slen) != 0)) { + continue; + } + name += slen; + } + } + while (name[0] == '/') { + ++name; + } + if (name[0] == '\0') { + continue; + } + hPtr = Tcl_FindHashEntry(&fileHash, name); + if (!hPtr) { + continue; + } + z = Tcl_GetHashValue(hPtr); + len = strlen(z->name); + ZipWriteInt(buf + ZIP_CENTRAL_SIG_OFFS, ZIP_CENTRAL_HEADER_SIG); + ZipWriteShort(buf + ZIP_CENTRAL_VERSIONMADE_OFFS, ZIP_MIN_VERSION); + ZipWriteShort(buf + ZIP_CENTRAL_VERSION_OFFS, ZIP_MIN_VERSION); + ZipWriteShort(buf + ZIP_CENTRAL_FLAGS_OFFS, z->isEncrypted); + ZipWriteShort(buf + ZIP_CENTRAL_COMPMETH_OFFS, z->compressMethod); + ZipWriteShort(buf + ZIP_CENTRAL_MTIME_OFFS, ToDosTime(z->timestamp)); + ZipWriteShort(buf + ZIP_CENTRAL_MDATE_OFFS, ToDosDate(z->timestamp)); + ZipWriteInt(buf + ZIP_CENTRAL_CRC32_OFFS, z->crc32); + ZipWriteInt(buf + ZIP_CENTRAL_COMPLEN_OFFS, z->numCompressedBytes); + ZipWriteInt(buf + ZIP_CENTRAL_UNCOMPLEN_OFFS, z->numBytes); + ZipWriteShort(buf + ZIP_CENTRAL_PATHLEN_OFFS, len); + ZipWriteShort(buf + ZIP_CENTRAL_EXTRALEN_OFFS, 0); + ZipWriteShort(buf + ZIP_CENTRAL_FCOMMENTLEN_OFFS, 0); + ZipWriteShort(buf + ZIP_CENTRAL_DISKFILE_OFFS, 0); + ZipWriteShort(buf + ZIP_CENTRAL_IATTR_OFFS, 0); + ZipWriteInt(buf + ZIP_CENTRAL_EATTR_OFFS, 0); + ZipWriteInt(buf + ZIP_CENTRAL_LOCALHDR_OFFS, z->offset - pos[0]); + if ((Tcl_Write(out, buf, + ZIP_CENTRAL_HEADER_LEN) != ZIP_CENTRAL_HEADER_LEN) + || ((size_t) Tcl_Write(out, z->name, len) != len)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "write error: %s", Tcl_PosixError(interp))); + goto done; + } + count++; + } + Tcl_Flush(out); + pos[2] = Tcl_Tell(out); + ZipWriteInt(buf + ZIP_CENTRAL_END_SIG_OFFS, ZIP_CENTRAL_END_SIG); + ZipWriteShort(buf + ZIP_CENTRAL_DISKNO_OFFS, 0); + ZipWriteShort(buf + ZIP_CENTRAL_DISKDIR_OFFS, 0); + ZipWriteShort(buf + ZIP_CENTRAL_ENTS_OFFS, count); + ZipWriteShort(buf + ZIP_CENTRAL_TOTALENTS_OFFS, count); + ZipWriteInt(buf + ZIP_CENTRAL_DIRSIZE_OFFS, pos[2] - pos[1]); + ZipWriteInt(buf + ZIP_CENTRAL_DIRSTART_OFFS, pos[1] - pos[0]); + ZipWriteShort(buf + ZIP_CENTRAL_COMMENTLEN_OFFS, 0); + if (Tcl_Write(out, buf, ZIP_CENTRAL_END_LEN) != ZIP_CENTRAL_END_LEN) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "write error: %s", Tcl_PosixError(interp))); + goto done; + } + Tcl_Flush(out); + ret = TCL_OK; + + done: + if (ret == TCL_OK) { + ret = Tcl_Close(interp, out); + } else { + Tcl_Close(interp, out); + } + Tcl_DecrRefCount(list); + for (hPtr = Tcl_FirstHashEntry(&fileHash, &search); hPtr; + hPtr = Tcl_NextHashEntry(&search)) { + z = Tcl_GetHashValue(hPtr); + ckfree(z); + Tcl_DeleteHashEntry(hPtr); + } + Tcl_DeleteHashTable(&fileHash); + return ret; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSMkZipObjCmd, ZipFSLMkZipObjCmd -- + * + * These procedures are invoked to process the [zipfs mkzip] and [zipfs + * lmkzip] commands. See description of ZipFSMkZipOrImgCmd(). + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See description of ZipFSMkZipOrImgCmd(). + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSMkZipObjCmd( + void *clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + if (objc < 3 || objc > 5) { + Tcl_WrongNumArgs(interp, 1, objv, "outfile indir ?strip? ?password?"); + return TCL_ERROR; + } + if (Tcl_IsSafe(interp)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "operation not permitted in a safe interpreter", -1)); + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "SAFE_INTERP", NULL); + return TCL_ERROR; + } + return ZipFSMkZipOrImgObjCmd(interp, 0, 0, objc, objv); +} + +static int +ZipFSLMkZipObjCmd( + void *clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + if (objc < 3 || objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, "outfile inlist ?password?"); + return TCL_ERROR; + } + if (Tcl_IsSafe(interp)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "operation not permitted in a safe interpreter", -1)); + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "SAFE_INTERP", NULL); + return TCL_ERROR; + } + return ZipFSMkZipOrImgObjCmd(interp, 0, 1, objc, objv); +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSMkImgObjCmd, ZipFSLMkImgObjCmd -- + * + * These procedures are invoked to process the [zipfs mkimg] and [zipfs + * lmkimg] commands. See description of ZipFSMkZipOrImgCmd(). + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See description of ZipFSMkZipOrImgCmd(). + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSMkImgObjCmd( + void *clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + if (objc < 3 || objc > 6) { + Tcl_WrongNumArgs(interp, 1, objv, + "outfile indir ?strip? ?password? ?infile?"); + return TCL_ERROR; + } + if (Tcl_IsSafe(interp)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "operation not permitted in a safe interpreter", -1)); + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "SAFE_INTERP", NULL); + return TCL_ERROR; + } + return ZipFSMkZipOrImgObjCmd(interp, 1, 0, objc, objv); +} + +static int +ZipFSLMkImgObjCmd( + void *clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + if (objc < 3 || objc > 5) { + Tcl_WrongNumArgs(interp, 1, objv, "outfile inlist ?password infile?"); + return TCL_ERROR; + } + if (Tcl_IsSafe(interp)) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "operation not permitted in a safe interpreter", -1)); + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "SAFE_INTERP", NULL); + return TCL_ERROR; + } + return ZipFSMkZipOrImgObjCmd(interp, 1, 1, objc, objv); +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSCanonicalObjCmd -- + * + * This procedure is invoked to process the [zipfs canonical] command. + * It returns the canonical name for a file within zipfs + * + * Results: + * Always TCL_OK provided the right number of arguments are supplied. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSCanonicalObjCmd( + void *clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + char *mntpoint = NULL; + char *filename = NULL; + char *result; + Tcl_DString dPath; + + if (objc < 2 || objc > 4) { + Tcl_WrongNumArgs(interp, 1, objv, "?mountpoint? filename ?inZipfs?"); + return TCL_ERROR; + } + Tcl_DStringInit(&dPath); + if (objc == 2) { + filename = Tcl_GetString(objv[1]); + result = CanonicalPath("", filename, &dPath, 1); + } else if (objc == 3) { + mntpoint = Tcl_GetString(objv[1]); + filename = Tcl_GetString(objv[2]); + result = CanonicalPath(mntpoint, filename, &dPath, 1); + } else { + int zipfs = 0; + + if (Tcl_GetBooleanFromObj(interp, objv[3], &zipfs)) { + return TCL_ERROR; + } + mntpoint = Tcl_GetString(objv[1]); + filename = Tcl_GetString(objv[2]); + result = CanonicalPath(mntpoint, filename, &dPath, zipfs); + } + Tcl_SetObjResult(interp, Tcl_NewStringObj(result, -1)); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSExistsObjCmd -- + * + * This procedure is invoked to process the [zipfs exists] command. It + * tests for the existence of a file in the ZIP filesystem and places a + * boolean into the interp's result. + * + * Results: + * Always TCL_OK provided the right number of arguments are supplied. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSExistsObjCmd( + void *clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + char *filename; + int exists; + Tcl_DString ds; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "filename"); + return TCL_ERROR; + } + + /* + * Prepend ZIPFS_VOLUME to filename, eliding the final / + */ + + filename = Tcl_GetString(objv[1]); + Tcl_DStringInit(&ds); + Tcl_DStringAppend(&ds, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN - 1); + Tcl_DStringAppend(&ds, filename, -1); + filename = Tcl_DStringValue(&ds); + + ReadLock(); + exists = ZipFSLookup(filename) != NULL; + Unlock(); + + Tcl_SetObjResult(interp, Tcl_NewBooleanObj(exists)); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSInfoObjCmd -- + * + * This procedure is invoked to process the [zipfs info] command. On + * success, it returns a Tcl list made up of name of ZIP archive file, + * size uncompressed, size compressed, and archive offset of a file in + * the ZIP filesystem. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSInfoObjCmd( + void *clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + char *filename; + ZipEntry *z; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "filename"); + return TCL_ERROR; + } + filename = Tcl_GetString(objv[1]); + ReadLock(); + z = ZipFSLookup(filename); + if (z) { + Tcl_Obj *result = Tcl_GetObjResult(interp); + + Tcl_ListObjAppendElement(interp, result, + Tcl_NewStringObj(z->zipFilePtr->name, -1)); + Tcl_ListObjAppendElement(interp, result, + Tcl_NewWideIntObj(z->numBytes)); + Tcl_ListObjAppendElement(interp, result, + Tcl_NewWideIntObj(z->numCompressedBytes)); + Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(z->offset)); + } + Unlock(); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSListObjCmd -- + * + * This procedure is invoked to process the [zipfs list] command. On + * success, it returns a Tcl list of files of the ZIP filesystem which + * match a search pattern (glob or regexp). + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSListObjCmd( + void *clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + char *pattern = NULL; + Tcl_RegExp regexp = NULL; + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + Tcl_Obj *result = Tcl_GetObjResult(interp); + + if (objc > 3) { + Tcl_WrongNumArgs(interp, 1, objv, "?(-glob|-regexp)? ?pattern?"); + return TCL_ERROR; + } + if (objc == 3) { + int n; + char *what = Tcl_GetStringFromObj(objv[1], &n); + + if ((n >= 2) && (strncmp(what, "-glob", n) == 0)) { + pattern = Tcl_GetString(objv[2]); + } else if ((n >= 2) && (strncmp(what, "-regexp", n) == 0)) { + regexp = Tcl_RegExpCompile(interp, Tcl_GetString(objv[2])); + if (!regexp) { + return TCL_ERROR; + } + } else { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown option \"%s\"", what)); + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_OPT", NULL); + return TCL_ERROR; + } + } else if (objc == 2) { + pattern = Tcl_GetString(objv[1]); + } + ReadLock(); + if (pattern) { + for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); + hPtr != NULL; hPtr = Tcl_NextHashEntry(&search)) { + ZipEntry *z = Tcl_GetHashValue(hPtr); + + if (Tcl_StringMatch(z->name, pattern)) { + Tcl_ListObjAppendElement(interp, result, + Tcl_NewStringObj(z->name, -1)); + } + } + } else if (regexp) { + for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); + hPtr; hPtr = Tcl_NextHashEntry(&search)) { + ZipEntry *z = Tcl_GetHashValue(hPtr); + + if (Tcl_RegExpExec(interp, regexp, z->name, z->name)) { + Tcl_ListObjAppendElement(interp, result, + Tcl_NewStringObj(z->name, -1)); + } + } + } else { + for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); + hPtr; hPtr = Tcl_NextHashEntry(&search)) { + ZipEntry *z = Tcl_GetHashValue(hPtr); + + Tcl_ListObjAppendElement(interp, result, + Tcl_NewStringObj(z->name, -1)); + } + } + Unlock(); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * TclZipfs_TclLibrary -- + * + * This procedure gets (and possibly finds) the root that Tcl's library + * files are mounted under. + * + * Results: + * A Tcl object holding the location (with zero refcount), or NULL if no + * Tcl library can be found. + * + * Side effects: + * May initialise the cache of where such library files are to be found. + * This cache is never cleared. + * + *------------------------------------------------------------------------- + */ + +#ifdef _WIN32 +#define LIBRARY_SIZE 64 +#endif /* _WIN32 */ + +Tcl_Obj * +TclZipfs_TclLibrary(void) +{ + Tcl_Obj *vfsInitScript; + int found; +#ifdef _WIN32 + HMODULE hModule; + WCHAR wName[MAX_PATH + LIBRARY_SIZE]; + char dllName[(MAX_PATH + LIBRARY_SIZE) * TCL_UTF_MAX]; +#endif /* _WIN32 */ + + /* + * Use the cached value if that has been set; we don't want to repeat the + * searching and mounting. + */ + + if (zipfs_literal_tcl_library) { + return Tcl_NewStringObj(zipfs_literal_tcl_library, -1); + } + + /* + * Look for the library file system within the executable. + */ + + vfsInitScript = Tcl_NewStringObj(ZIPFS_APP_MOUNT "/tcl_library/init.tcl", + -1); + Tcl_IncrRefCount(vfsInitScript); + found = Tcl_FSAccess(vfsInitScript, F_OK); + Tcl_DecrRefCount(vfsInitScript); + if (found == TCL_OK) { + zipfs_literal_tcl_library = ZIPFS_APP_MOUNT "/tcl_library"; + return Tcl_NewStringObj(zipfs_literal_tcl_library, -1); + } + + /* + * Look for the library file system within the DLL/shared library. Note + * that we must mount the zip file and dll before releasing to search. + */ + +#if defined(_WIN32) + hModule = TclWinGetTclInstance(); + GetModuleFileNameW(hModule, wName, MAX_PATH); + WideCharToMultiByte(CP_UTF8, 0, wName, -1, dllName, sizeof(dllName), NULL, NULL); + + if (ZipfsAppHookFindTclInit(dllName) == TCL_OK) { + return Tcl_NewStringObj(zipfs_literal_tcl_library, -1); + } +#elif /* !_WIN32 && */ defined(CFG_RUNTIME_DLLFILE) + if (ZipfsAppHookFindTclInit( + CFG_RUNTIME_LIBDIR "/" CFG_RUNTIME_DLLFILE) == TCL_OK) { + return Tcl_NewStringObj(zipfs_literal_tcl_library, -1); + } +#endif /* _WIN32 || CFG_RUNTIME_DLLFILE */ + + /* + * If we're configured to know about a ZIP archive we should use, do that. + */ + +#ifdef CFG_RUNTIME_ZIPFILE + if (ZipfsAppHookFindTclInit( + CFG_RUNTIME_LIBDIR "/" CFG_RUNTIME_ZIPFILE) == TCL_OK) { + return Tcl_NewStringObj(zipfs_literal_tcl_library, -1); + } + if (ZipfsAppHookFindTclInit( + CFG_RUNTIME_SCRDIR "/" CFG_RUNTIME_ZIPFILE) == TCL_OK) { + return Tcl_NewStringObj(zipfs_literal_tcl_library, -1); + } + if (ZipfsAppHookFindTclInit(CFG_RUNTIME_ZIPFILE) == TCL_OK) { + return Tcl_NewStringObj(zipfs_literal_tcl_library, -1); + } +#endif /* CFG_RUNTIME_ZIPFILE */ + + /* + * If anything set the cache (but subsequently failed) go with that + * anyway. + */ + + if (zipfs_literal_tcl_library) { + return Tcl_NewStringObj(zipfs_literal_tcl_library, -1); + } + return NULL; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSTclLibraryObjCmd -- + * + * This procedure is invoked to process the + * [::tcl::zipfs::tcl_library_init] command, usually called during the + * execution of Tcl's interpreter startup. It returns the root that Tcl's + * library files are mounted under. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * May initialise the cache of where such library files are to be found. + * This cache is never cleared. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSTclLibraryObjCmd( + void *clientData, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + if (!Tcl_IsSafe(interp)) { + Tcl_Obj *pResult = TclZipfs_TclLibrary(); + + if (!pResult) { + pResult = Tcl_NewObj(); + } + Tcl_SetObjResult(interp, pResult); + } + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * ZipChannelClose -- + * + * This function is called to close a channel. + * + * Results: + * Always TCL_OK. + * + * Side effects: + * Resources are free'd. + * + *------------------------------------------------------------------------- + */ + +static int +ZipChannelClose( + void *instanceData, + Tcl_Interp *interp) /* Current interpreter. */ +{ + ZipChannel *info = instanceData; + + if (info->iscompr && info->ubuf) { + ckfree(info->ubuf); + info->ubuf = NULL; + } + if (info->isEncrypted) { + info->isEncrypted = 0; + memset(info->keys, 0, sizeof(info->keys)); + } + if (info->isWriting) { + ZipEntry *z = info->zipEntryPtr; + unsigned char *newdata = attemptckrealloc(info->ubuf, info->numRead); + + if (newdata) { + if (z->data) { + ckfree(z->data); + } + z->data = newdata; + z->numBytes = z->numCompressedBytes = info->numBytes; + z->compressMethod = ZIP_COMPMETH_STORED; + z->timestamp = time(NULL); + z->isDirectory = 0; + z->isEncrypted = 0; + z->offset = 0; + z->crc32 = 0; + } else { + ckfree(info->ubuf); + } + } + WriteLock(); + info->zipFilePtr->numOpen--; + Unlock(); + ckfree(info); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * ZipChannelRead -- + * + * This function is called to read data from channel. + * + * Results: + * Number of bytes read or -1 on error with error number set. + * + * Side effects: + * Data is read and file pointer is advanced. + * + *------------------------------------------------------------------------- + */ + +static int +ZipChannelRead( + void *instanceData, + char *buf, + int toRead, + int *errloc) +{ + ZipChannel *info = (ZipChannel *) instanceData; + unsigned long nextpos; + + if (info->isDirectory < 0) { + /* + * Special case: when executable combined with ZIP archive file read + * data in front of ZIP, i.e. the executable itself. + */ + + nextpos = info->numRead + toRead; + if (nextpos > info->zipFilePtr->baseOffset) { + toRead = info->zipFilePtr->baseOffset - info->numRead; + nextpos = info->zipFilePtr->baseOffset; + } + if (toRead == 0) { + return 0; + } + memcpy(buf, info->zipFilePtr->data, toRead); + info->numRead = nextpos; + *errloc = 0; + return toRead; + } + if (info->isDirectory) { + *errloc = EISDIR; + return -1; + } + nextpos = info->numRead + toRead; + if (nextpos > info->numBytes) { + toRead = info->numBytes - info->numRead; + nextpos = info->numBytes; + } + if (toRead == 0) { + return 0; + } + if (info->isEncrypted) { + int i; + + for (i = 0; i < toRead; i++) { + int ch = info->ubuf[i + info->numRead]; + + buf[i] = zdecode(info->keys, crc32tab, ch); + } + } else { + memcpy(buf, info->ubuf + info->numRead, toRead); + } + info->numRead = nextpos; + *errloc = 0; + return toRead; +} + +/* + *------------------------------------------------------------------------- + * + * ZipChannelWrite -- + * + * This function is called to write data into channel. + * + * Results: + * Number of bytes written or -1 on error with error number set. + * + * Side effects: + * Data is written and file pointer is advanced. + * + *------------------------------------------------------------------------- + */ + +static int +ZipChannelWrite( + void *instanceData, + const char *buf, + int toWrite, + int *errloc) +{ + ZipChannel *info = (ZipChannel *) instanceData; + unsigned long nextpos; + + if (!info->isWriting) { + *errloc = EINVAL; + return -1; + } + nextpos = info->numRead + toWrite; + if (nextpos > info->maxWrite) { + toWrite = info->maxWrite - info->numRead; + nextpos = info->maxWrite; + } + if (toWrite == 0) { + return 0; + } + memcpy(info->ubuf + info->numRead, buf, toWrite); + info->numRead = nextpos; + if (info->numRead > info->numBytes) { + info->numBytes = info->numRead; + } + *errloc = 0; + return toWrite; +} + +/* + *------------------------------------------------------------------------- + * + * ZipChannelSeek -- + * + * This function is called to position file pointer of channel. + * + * Results: + * New file position or -1 on error with error number set. + * + * Side effects: + * File pointer is repositioned according to offset and mode. + * + *------------------------------------------------------------------------- + */ + +static int +ZipChannelSeek( + void *instanceData, + long offset, + int mode, + int *errloc) +{ + ZipChannel *info = (ZipChannel *) instanceData; + unsigned long end; + + if (!info->isWriting && (info->isDirectory < 0)) { + /* + * Special case: when executable combined with ZIP archive file, seek + * within front of ZIP, i.e. the executable itself. + */ + end = info->zipFilePtr->baseOffset; + } else if (info->isDirectory) { + *errloc = EINVAL; + return -1; + } else { + end = info->numBytes; + } + switch (mode) { + case SEEK_CUR: + offset += info->numRead; + break; + case SEEK_END: + offset += end; + break; + case SEEK_SET: + break; + default: + *errloc = EINVAL; + return -1; + } + if (offset < 0) { + *errloc = EINVAL; + return -1; + } + if (info->isWriting) { + if ((unsigned long) offset > info->maxWrite) { + *errloc = EINVAL; + return -1; + } + if ((unsigned long) offset > info->numBytes) { + info->numBytes = offset; + } + } else if ((unsigned long) offset > end) { + *errloc = EINVAL; + return -1; + } + info->numRead = (unsigned long) offset; + return info->numRead; +} + +/* + *------------------------------------------------------------------------- + * + * ZipChannelWatchChannel -- + * + * This function is called for event notifications on channel. Does + * nothing. + * + * Results: + * None. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static void +ZipChannelWatchChannel( + void *instanceData, + int mask) +{ + return; +} + +/* + *------------------------------------------------------------------------- + * + * ZipChannelGetFile -- + * + * This function is called to retrieve OS handle for channel. + * + * Results: + * Always TCL_ERROR since there's never an OS handle for a file within a + * ZIP archive. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +ZipChannelGetFile( + void *instanceData, + int direction, + void **handlePtr) +{ + return TCL_ERROR; +} + +/* + *------------------------------------------------------------------------- + * + * ZipChannelOpen -- + * + * This function opens a Tcl_Channel on a file from a mounted ZIP archive + * according to given open mode. + * + * Results: + * Tcl_Channel on success, or NULL on error. + * + * Side effects: + * Memory is allocated, the file from the ZIP archive is uncompressed. + * + *------------------------------------------------------------------------- + */ + +static Tcl_Channel +ZipChannelOpen( + Tcl_Interp *interp, /* Current interpreter. */ + char *filename, + int mode, + int permissions) +{ + ZipEntry *z; + ZipChannel *info; + int i, ch, trunc, wr, flags = 0; + char cname[128]; + + if ((mode & O_APPEND) + || ((ZipFS.wrmax <= 0) && (mode & (O_WRONLY | O_RDWR)))) { + if (interp) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("unsupported open mode", -1)); + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "BAD_MODE", NULL); + } + return NULL; + } + WriteLock(); + z = ZipFSLookup(filename); + if (!z) { + Tcl_SetErrno(ENOENT); + if (interp) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "file not found \"%s\": %s", filename, + Tcl_PosixError(interp))); + } + goto error; + } + trunc = (mode & O_TRUNC) != 0; + wr = (mode & (O_WRONLY | O_RDWR)) != 0; + if ((z->compressMethod != ZIP_COMPMETH_STORED) + && (z->compressMethod != ZIP_COMPMETH_DEFLATED)) { + ZIPFS_ERROR(interp, "unsupported compression method"); + if (interp) { + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "COMP_METHOD", NULL); + } + goto error; + } + if (wr && z->isDirectory) { + ZIPFS_ERROR(interp, "unsupported file type"); + if (interp) { + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "FILE_TYPE", NULL); + } + goto error; + } + if (!trunc) { + flags |= TCL_READABLE; + if (z->isEncrypted && (z->zipFilePtr->passBuf[0] == 0)) { + ZIPFS_ERROR(interp, "decryption failed"); + if (interp) { + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "DECRYPT", NULL); + } + goto error; + } else if (wr && !z->data && (z->numBytes > ZipFS.wrmax)) { + ZIPFS_ERROR(interp, "file too large"); + if (interp) { + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "FILE_SIZE", NULL); + } + goto error; + } + } else { + flags = TCL_WRITABLE; + } + info = attemptckalloc(sizeof(ZipChannel)); + if (!info) { + ZIPFS_ERROR(interp, "out of memory"); + if (interp) { + Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); + } + goto error; + } + info->zipFilePtr = z->zipFilePtr; + info->zipEntryPtr = z; + info->numRead = 0; + if (wr) { + flags |= TCL_WRITABLE; + info->isWriting = 1; + info->isDirectory = 0; + info->maxWrite = ZipFS.wrmax; + info->iscompr = 0; + info->isEncrypted = 0; + info->ubuf = attemptckalloc(info->maxWrite); + if (!info->ubuf) { + merror0: + if (info->ubuf) { + ckfree(info->ubuf); + } + ckfree(info); + ZIPFS_ERROR(interp, "out of memory"); + if (interp) { + Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); + } + goto error; + } + memset(info->ubuf, 0, info->maxWrite); + if (trunc) { + info->numBytes = 0; + } else if (z->data) { + unsigned int j = z->numBytes; + + if (j > info->maxWrite) { + j = info->maxWrite; + } + memcpy(info->ubuf, z->data, j); + info->numBytes = j; + } else { + unsigned char *zbuf = z->zipFilePtr->data + z->offset; + + if (z->isEncrypted) { + int len = z->zipFilePtr->passBuf[0] & 0xFF; + char passBuf[260]; + + for (i = 0; i < len; i++) { + ch = z->zipFilePtr->passBuf[len - i]; + passBuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; + } + passBuf[i] = '\0'; + init_keys(passBuf, info->keys, crc32tab); + memset(passBuf, 0, sizeof(passBuf)); + for (i = 0; i < 12; i++) { + ch = info->ubuf[i]; + zdecode(info->keys, crc32tab, ch); + } + zbuf += i; + } + if (z->compressMethod == ZIP_COMPMETH_DEFLATED) { + z_stream stream; + int err; + unsigned char *cbuf = NULL; + + memset(&stream, 0, sizeof(z_stream)); + stream.zalloc = Z_NULL; + stream.zfree = Z_NULL; + stream.opaque = Z_NULL; + stream.avail_in = z->numCompressedBytes; + if (z->isEncrypted) { + unsigned int j; + + stream.avail_in -= 12; + cbuf = attemptckalloc(stream.avail_in); + if (!cbuf) { + goto merror0; + } + for (j = 0; j < stream.avail_in; j++) { + ch = info->ubuf[j]; + cbuf[j] = zdecode(info->keys, crc32tab, ch); + } + stream.next_in = cbuf; + } else { + stream.next_in = zbuf; + } + stream.next_out = info->ubuf; + stream.avail_out = info->maxWrite; + if (inflateInit2(&stream, -15) != Z_OK) { + goto cerror0; + } + err = inflate(&stream, Z_SYNC_FLUSH); + inflateEnd(&stream); + if ((err == Z_STREAM_END) + || ((err == Z_OK) && (stream.avail_in == 0))) { + if (cbuf) { + memset(info->keys, 0, sizeof(info->keys)); + ckfree(cbuf); + } + goto wrapchan; + } + cerror0: + if (cbuf) { + memset(info->keys, 0, sizeof(info->keys)); + ckfree(cbuf); + } + if (info->ubuf) { + ckfree(info->ubuf); + } + ckfree(info); + ZIPFS_ERROR(interp, "decompression error"); + if (interp) { + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "CORRUPT", NULL); + } + goto error; + } else if (z->isEncrypted) { + for (i = 0; i < z->numBytes - 12; i++) { + ch = zbuf[i]; + info->ubuf[i] = zdecode(info->keys, crc32tab, ch); + } + } else { + memcpy(info->ubuf, zbuf, z->numBytes); + } + memset(info->keys, 0, sizeof(info->keys)); + goto wrapchan; + } + } else if (z->data) { + flags |= TCL_READABLE; + info->isWriting = 0; + info->iscompr = 0; + info->isDirectory = 0; + info->isEncrypted = 0; + info->numBytes = z->numBytes; + info->maxWrite = 0; + info->ubuf = z->data; + } else { + flags |= TCL_READABLE; + info->isWriting = 0; + info->iscompr = (z->compressMethod == ZIP_COMPMETH_DEFLATED); + info->ubuf = z->zipFilePtr->data + z->offset; + info->isDirectory = z->isDirectory; + info->isEncrypted = z->isEncrypted; + info->numBytes = z->numBytes; + info->maxWrite = 0; + if (info->isEncrypted) { + int len = z->zipFilePtr->passBuf[0] & 0xFF; + char passBuf[260]; + + for (i = 0; i < len; i++) { + ch = z->zipFilePtr->passBuf[len - i]; + passBuf[i] = (ch & 0x0f) | pwrot[(ch >> 4) & 0x0f]; + } + passBuf[i] = '\0'; + init_keys(passBuf, info->keys, crc32tab); + memset(passBuf, 0, sizeof(passBuf)); + for (i = 0; i < 12; i++) { + ch = info->ubuf[i]; + zdecode(info->keys, crc32tab, ch); + } + info->ubuf += i; + } + if (info->iscompr) { + z_stream stream; + int err; + unsigned char *ubuf = NULL; + unsigned int j; + + memset(&stream, 0, sizeof(z_stream)); + stream.zalloc = Z_NULL; + stream.zfree = Z_NULL; + stream.opaque = Z_NULL; + stream.avail_in = z->numCompressedBytes; + if (info->isEncrypted) { + stream.avail_in -= 12; + ubuf = attemptckalloc(stream.avail_in); + if (!ubuf) { + info->ubuf = NULL; + goto merror; + } + for (j = 0; j < stream.avail_in; j++) { + ch = info->ubuf[j]; + ubuf[j] = zdecode(info->keys, crc32tab, ch); + } + stream.next_in = ubuf; + } else { + stream.next_in = info->ubuf; + } + stream.next_out = info->ubuf = attemptckalloc(info->numBytes); + if (!info->ubuf) { + merror: + if (ubuf) { + info->isEncrypted = 0; + memset(info->keys, 0, sizeof(info->keys)); + ckfree(ubuf); + } + ckfree(info); + if (interp) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("out of memory", -1)); + Tcl_SetErrorCode(interp, "TCL", "MALLOC", NULL); + } + goto error; + } + stream.avail_out = info->numBytes; + if (inflateInit2(&stream, -15) != Z_OK) { + goto cerror; + } + err = inflate(&stream, Z_SYNC_FLUSH); + inflateEnd(&stream); + if ((err == Z_STREAM_END) + || ((err == Z_OK) && (stream.avail_in == 0))) { + if (ubuf) { + info->isEncrypted = 0; + memset(info->keys, 0, sizeof(info->keys)); + ckfree(ubuf); + } + goto wrapchan; + } + cerror: + if (ubuf) { + info->isEncrypted = 0; + memset(info->keys, 0, sizeof(info->keys)); + ckfree(ubuf); + } + if (info->ubuf) { + ckfree(info->ubuf); + } + ckfree(info); + ZIPFS_ERROR(interp, "decompression error"); + if (interp) { + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "CORRUPT", NULL); + } + goto error; + } else if (info->isEncrypted) { + unsigned char *ubuf = NULL; + unsigned int j, len; + + /* + * Decode encrypted but uncompressed file, since we support + * Tcl_Seek() on it, and it can be randomly accessed later. + */ + + len = z->numCompressedBytes - 12; + ubuf = (unsigned char *) attemptckalloc(len); + if (ubuf == NULL) { + ckfree((char *) info); + if (interp != NULL) { + Tcl_SetObjResult(interp, + Tcl_NewStringObj("out of memory", -1)); + } + goto error; + } + for (j = 0; j < len; j++) { + ch = info->ubuf[j]; + ubuf[j] = zdecode(info->keys, crc32tab, ch); + } + info->ubuf = ubuf; + info->isEncrypted = 0; + } + } + + wrapchan: + sprintf(cname, "zipfs_%" TCL_LL_MODIFIER "x_%d", z->offset, + ZipFS.idCount++); + z->zipFilePtr->numOpen++; + Unlock(); + return Tcl_CreateChannel(&ZipChannelType, cname, info, flags); + + error: + Unlock(); + return NULL; +} + +/* + *------------------------------------------------------------------------- + * + * ZipEntryStat -- + * + * This function implements the ZIP filesystem specific version of the + * library version of stat. + * + * Results: + * See stat documentation. + * + * Side effects: + * See stat documentation. + * + *------------------------------------------------------------------------- + */ + +static int +ZipEntryStat( + char *path, + Tcl_StatBuf *buf) +{ + ZipEntry *z; + int ret = -1; + + ReadLock(); + z = ZipFSLookup(path); + if (z) { + memset(buf, 0, sizeof(Tcl_StatBuf)); + if (z->isDirectory) { + buf->st_mode = S_IFDIR | 0555; + } else { + buf->st_mode = S_IFREG | 0555; + } + buf->st_size = z->numBytes; + buf->st_mtime = z->timestamp; + buf->st_ctime = z->timestamp; + buf->st_atime = z->timestamp; + ret = 0; + } + Unlock(); + return ret; +} + +/* + *------------------------------------------------------------------------- + * + * ZipEntryAccess -- + * + * This function implements the ZIP filesystem specific version of the + * library version of access. + * + * Results: + * See access documentation. + * + * Side effects: + * See access documentation. + * + *------------------------------------------------------------------------- + */ + +static int +ZipEntryAccess( + char *path, + int mode) +{ + ZipEntry *z; + + if (mode & 3) { + return -1; + } + ReadLock(); + z = ZipFSLookup(path); + Unlock(); + return (z ? 0 : -1); +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSOpenFileChannelProc -- + * + * Results: + * + * Side effects: + * + *------------------------------------------------------------------------- + */ + +static Tcl_Channel +ZipFSOpenFileChannelProc( + Tcl_Interp *interp, /* Current interpreter. */ + Tcl_Obj *pathPtr, + int mode, + int permissions) +{ + int len; + + pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); + if (!pathPtr) { + return NULL; + } + return ZipChannelOpen(interp, Tcl_GetStringFromObj(pathPtr, &len), mode, + permissions); +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSStatProc -- + * + * This function implements the ZIP filesystem specific version of the + * library version of stat. + * + * Results: + * See stat documentation. + * + * Side effects: + * See stat documentation. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSStatProc( + Tcl_Obj *pathPtr, + Tcl_StatBuf *buf) +{ + int len; + + pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); + if (!pathPtr) { + return -1; + } + return ZipEntryStat(Tcl_GetStringFromObj(pathPtr, &len), buf); +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSAccessProc -- + * + * This function implements the ZIP filesystem specific version of the + * library version of access. + * + * Results: + * See access documentation. + * + * Side effects: + * See access documentation. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSAccessProc( + Tcl_Obj *pathPtr, + int mode) +{ + int len; + + pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); + if (!pathPtr) { + return -1; + } + return ZipEntryAccess(Tcl_GetStringFromObj(pathPtr, &len), mode); +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSFilesystemSeparatorProc -- + * + * This function returns the separator to be used for a given path. The + * object returned should have a refCount of zero + * + * Results: + * A Tcl object, with a refCount of zero. If the caller needs to retain a + * reference to the object, it should call Tcl_IncrRefCount, and should + * otherwise free the object. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static Tcl_Obj * +ZipFSFilesystemSeparatorProc( + Tcl_Obj *pathPtr) +{ + return Tcl_NewStringObj("/", -1); +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSMatchInDirectoryProc -- + * + * This routine is used by the globbing code to search a directory for + * all files which match a given pattern. + * + * Results: + * The return value is a standard Tcl result indicating whether an error + * occurred in globbing. Errors are left in interp, good results are + * lappend'ed to resultPtr (which must be a valid object). + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSMatchInDirectoryProc( + Tcl_Interp *interp, /* Current interpreter. */ + Tcl_Obj *result, + Tcl_Obj *pathPtr, + const char *pattern, + Tcl_GlobTypeData *types) +{ + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + Tcl_Obj *normPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); + int scnt, l, dirOnly = -1, prefixLen, strip = 0; + size_t len; + char *pat, *prefix, *path; + Tcl_DString dsPref; + + if (!normPathPtr) { + return -1; + } + if (types) { + dirOnly = (types->type & TCL_GLOB_TYPE_DIR) == TCL_GLOB_TYPE_DIR; + } + + /* + * The prefix that gets prepended to results. + */ + + prefix = Tcl_GetStringFromObj(pathPtr, &prefixLen); + + /* + * The (normalized) path we're searching. + */ + + path = Tcl_GetString(normPathPtr); + len = normPathPtr->length; + + Tcl_DStringInit(&dsPref); + Tcl_DStringAppend(&dsPref, prefix, prefixLen); + + if (strcmp(prefix, path) == 0) { + prefix = NULL; + } else { + strip = len + 1; + } + if (prefix) { + Tcl_DStringAppend(&dsPref, "/", 1); + prefixLen++; + prefix = Tcl_DStringValue(&dsPref); + } + ReadLock(); + if (types && (types->type == TCL_GLOB_TYPE_MOUNT)) { + l = CountSlashes(path); + if (path[len - 1] == '/') { + len--; + } else { + l++; + } + if (!pattern || (pattern[0] == '\0')) { + pattern = "*"; + } + for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr; + hPtr = Tcl_NextHashEntry(&search)) { + ZipFile *zf = Tcl_GetHashValue(hPtr); + + if (zf->mountPointLen == 0) { + ZipEntry *z; + + for (z = zf->topEnts; z; z = z->tnext) { + size_t lenz = strlen(z->name); + + if ((lenz > len + 1) && (strncmp(z->name, path, len) == 0) + && (z->name[len] == '/') + && (CountSlashes(z->name) == l) + && Tcl_StringCaseMatch(z->name + len + 1, pattern, + 0)) { + if (prefix) { + Tcl_DStringAppend(&dsPref, z->name, lenz); + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(Tcl_DStringValue(&dsPref), + Tcl_DStringLength(&dsPref))); + Tcl_DStringSetLength(&dsPref, prefixLen); + } else { + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(z->name, lenz)); + } + } + } + } else if ((zf->mountPointLen > len + 1) + && (strncmp(zf->mountPoint, path, len) == 0) + && (zf->mountPoint[len] == '/') + && (CountSlashes(zf->mountPoint) == l) + && Tcl_StringCaseMatch(zf->mountPoint + len + 1, + pattern, 0)) { + if (prefix) { + Tcl_DStringAppend(&dsPref, zf->mountPoint, + zf->mountPointLen); + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(Tcl_DStringValue(&dsPref), + Tcl_DStringLength(&dsPref))); + Tcl_DStringSetLength(&dsPref, prefixLen); + } else { + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(zf->mountPoint, + zf->mountPointLen)); + } + } + } + goto end; + } + + if (!pattern || (pattern[0] == '\0')) { + hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, path); + if (hPtr) { + ZipEntry *z = Tcl_GetHashValue(hPtr); + + if ((dirOnly < 0) || (!dirOnly && !z->isDirectory) + || (dirOnly && z->isDirectory)) { + if (prefix) { + Tcl_DStringAppend(&dsPref, z->name, -1); + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(Tcl_DStringValue(&dsPref), + Tcl_DStringLength(&dsPref))); + Tcl_DStringSetLength(&dsPref, prefixLen); + } else { + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(z->name, -1)); + } + } + } + goto end; + } + + l = strlen(pattern); + pat = ckalloc(len + l + 2); + memcpy(pat, path, len); + while ((len > 1) && (pat[len - 1] == '/')) { + --len; + } + if ((len > 1) || (pat[0] != '/')) { + pat[len] = '/'; + ++len; + } + memcpy(pat + len, pattern, l + 1); + scnt = CountSlashes(pat); + for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); + hPtr; hPtr = Tcl_NextHashEntry(&search)) { + ZipEntry *z = Tcl_GetHashValue(hPtr); + + if ((dirOnly >= 0) && ((dirOnly && !z->isDirectory) + || (!dirOnly && z->isDirectory))) { + continue; + } + if ((z->depth == scnt) && Tcl_StringCaseMatch(z->name, pat, 0)) { + if (prefix) { + Tcl_DStringAppend(&dsPref, z->name + strip, -1); + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(Tcl_DStringValue(&dsPref), + Tcl_DStringLength(&dsPref))); + Tcl_DStringSetLength(&dsPref, prefixLen); + } else { + Tcl_ListObjAppendElement(NULL, result, + Tcl_NewStringObj(z->name + strip, -1)); + } + } + } + ckfree(pat); + + end: + Unlock(); + Tcl_DStringFree(&dsPref); + return TCL_OK; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSPathInFilesystemProc -- + * + * This function determines if the given path object is in the ZIP + * filesystem. + * + * Results: + * TCL_OK when the path object is in the ZIP filesystem, -1 otherwise. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSPathInFilesystemProc( + Tcl_Obj *pathPtr, + void **clientDataPtr) +{ + Tcl_HashEntry *hPtr; + Tcl_HashSearch search; + int ret = -1; + size_t len; + char *path; + + pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); + if (!pathPtr) { + return -1; + } + + path = Tcl_GetString(pathPtr); + if (strncmp(path, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN) != 0) { + return -1; + } + + len = pathPtr->length; + + ReadLock(); + hPtr = Tcl_FindHashEntry(&ZipFS.fileHash, path); + if (hPtr) { + ret = TCL_OK; + goto endloop; + } + + for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr; + hPtr = Tcl_NextHashEntry(&search)) { + ZipFile *zf = Tcl_GetHashValue(hPtr); + + if (zf->mountPointLen == 0) { + ZipEntry *z; + + for (z = zf->topEnts; z != NULL; z = z->tnext) { + size_t lenz = strlen(z->name); + + if ((len >= lenz) && (strncmp(path, z->name, lenz) == 0)) { + ret = TCL_OK; + goto endloop; + } + } + } else if ((len >= zf->mountPointLen) && + (strncmp(path, zf->mountPoint, zf->mountPointLen) == 0)) { + ret = TCL_OK; + break; + } + } + + endloop: + Unlock(); + return ret; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSListVolumesProc -- + * + * Lists the currently mounted ZIP filesystem volumes. + * + * Results: + * The list of volumes. + * + * Side effects: + * None + * + *------------------------------------------------------------------------- + */ + +static Tcl_Obj * +ZipFSListVolumesProc(void) +{ + return Tcl_NewStringObj(ZIPFS_VOLUME, -1); +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSFileAttrStringsProc -- + * + * This function implements the ZIP filesystem dependent 'file + * attributes' subcommand, for listing the set of possible attribute + * strings. + * + * Results: + * An array of strings + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static const char *const * +ZipFSFileAttrStringsProc( + Tcl_Obj *pathPtr, + Tcl_Obj **objPtrRef) +{ + static const char *const attrs[] = { + "-uncompsize", + "-compsize", + "-offset", + "-mount", + "-archive", + "-permissions", + NULL, + }; + return attrs; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSFileAttrsGetProc -- + * + * This function implements the ZIP filesystem specific 'file attributes' + * subcommand, for 'get' operations. + * + * Results: + * Standard Tcl return code. The object placed in objPtrRef (if TCL_OK + * was returned) is likely to have a refCount of zero. Either way we must + * either store it somewhere (e.g. the Tcl result), or Incr/Decr its + * refCount to ensure it is properly freed. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSFileAttrsGetProc( + Tcl_Interp *interp, /* Current interpreter. */ + int index, + Tcl_Obj *pathPtr, + Tcl_Obj **objPtrRef) +{ + int len, ret = TCL_OK; + char *path; + ZipEntry *z; + + pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); + if (!pathPtr) { + return -1; + } + path = Tcl_GetStringFromObj(pathPtr, &len); + ReadLock(); + z = ZipFSLookup(path); + if (!z) { + Tcl_SetErrno(ENOENT); + ZIPFS_POSIX_ERROR(interp, "file not found"); + ret = TCL_ERROR; + goto done; + } + switch (index) { + case 0: + *objPtrRef = Tcl_NewWideIntObj(z->numBytes); + break; + case 1: + *objPtrRef = Tcl_NewWideIntObj(z->numCompressedBytes); + break; + case 2: + *objPtrRef = Tcl_NewWideIntObj(z->offset); + break; + case 3: + *objPtrRef = Tcl_NewStringObj(z->zipFilePtr->mountPoint, + z->zipFilePtr->mountPointLen); + break; + case 4: + *objPtrRef = Tcl_NewStringObj(z->zipFilePtr->name, -1); + break; + case 5: + *objPtrRef = Tcl_NewStringObj("0o555", -1); + break; + default: + ZIPFS_ERROR(interp, "unknown attribute"); + ret = TCL_ERROR; + } + + done: + Unlock(); + return ret; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSFileAttrsSetProc -- + * + * This function implements the ZIP filesystem specific 'file attributes' + * subcommand, for 'set' operations. + * + * Results: + * Standard Tcl return code. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSFileAttrsSetProc( + Tcl_Interp *interp, /* Current interpreter. */ + int index, + Tcl_Obj *pathPtr, + Tcl_Obj *objPtr) +{ + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("unsupported operation", -1)); + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "UNSUPPORTED_OP", NULL); + } + return TCL_ERROR; +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSFilesystemPathTypeProc -- + * + * Results: + * + * Side effects: + * + *------------------------------------------------------------------------- + */ + +static Tcl_Obj * +ZipFSFilesystemPathTypeProc( + Tcl_Obj *pathPtr) +{ + return Tcl_NewStringObj("zip", -1); +} + +/* + *------------------------------------------------------------------------- + * + * ZipFSLoadFile -- + * + * This functions deals with loading native object code. If the given + * path object refers to a file within the ZIP filesystem, an approriate + * error code is returned to delegate loading to the caller (by copying + * the file to temp store and loading from there). As fallback when the + * file refers to the ZIP file system but is not present, it is looked up + * relative to the executable and loaded from there when available. + * + * Results: + * TCL_OK on success, TCL_ERROR otherwise with error message left. + * + * Side effects: + * Loads native code into the process address space. + * + *------------------------------------------------------------------------- + */ + +static int +ZipFSLoadFile( + Tcl_Interp *interp, /* Current interpreter. */ + Tcl_Obj *path, + Tcl_LoadHandle *loadHandle, + Tcl_FSUnloadFileProc **unloadProcPtr, + int flags) +{ + Tcl_FSLoadFileProc2 *loadFileProc; +#ifdef ANDROID + /* + * Force loadFileProc to native implementation since the package manager + * already extracted the shared libraries from the APK at install time. + */ + + loadFileProc = (Tcl_FSLoadFileProc2 *) tclNativeFilesystem.loadFileProc; + if (loadFileProc) { + return loadFileProc(interp, path, loadHandle, unloadProcPtr, flags); + } + Tcl_SetErrno(ENOENT); + ZIPFS_ERROR(interp, Tcl_PosixError(interp)); + return TCL_ERROR; +#else /* !ANDROID */ + Tcl_Obj *altPath = NULL; + int ret = TCL_ERROR; + Tcl_Obj *objs[2] = { NULL, NULL }; + + if (Tcl_FSAccess(path, R_OK) == 0) { + /* + * EXDEV should trigger loading by copying to temp store. + */ + + Tcl_SetErrno(EXDEV); + ZIPFS_ERROR(interp, Tcl_PosixError(interp)); + return ret; + } + + objs[1] = TclPathPart(interp, path, TCL_PATH_DIRNAME); + if (objs[1] && (ZipFSAccessProc(objs[1], R_OK) == 0)) { + const char *execName = Tcl_GetNameOfExecutable(); + + /* + * Shared object is not in ZIP but its path prefix is, thus try to + * load from directory where the executable came from. + */ + + TclDecrRefCount(objs[1]); + objs[1] = TclPathPart(interp, path, TCL_PATH_TAIL); + + /* + * Get directory name of executable manually to deal with cases where + * [file dirname [info nameofexecutable]] is equal to [info + * nameofexecutable] due to VFS effects. + */ + + if (execName) { + const char *p = strrchr(execName, '/'); + + if (p > execName + 1) { + --p; + objs[0] = Tcl_NewStringObj(execName, p - execName); + } + } + if (!objs[0]) { + objs[0] = TclPathPart(interp, TclGetObjNameOfExecutable(), + TCL_PATH_DIRNAME); + } + if (objs[0]) { + altPath = TclJoinPath(2, objs, 0); + if (altPath) { + Tcl_IncrRefCount(altPath); + if (Tcl_FSAccess(altPath, R_OK) == 0) { + path = altPath; + } + } + } + } + if (objs[0]) { + Tcl_DecrRefCount(objs[0]); + } + if (objs[1]) { + Tcl_DecrRefCount(objs[1]); + } + + loadFileProc = (Tcl_FSLoadFileProc2 *) tclNativeFilesystem.loadFileProc; + if (loadFileProc) { + ret = loadFileProc(interp, path, loadHandle, unloadProcPtr, flags); + } else { + Tcl_SetErrno(ENOENT); + ZIPFS_ERROR(interp, Tcl_PosixError(interp)); + } + if (altPath) { + Tcl_DecrRefCount(altPath); + } + return ret; +#endif /* ANDROID */ +} + +#endif /* HAVE_ZLIB */ + +/* + *------------------------------------------------------------------------- + * + * TclZipfs_Init -- + * + * Perform per interpreter initialization of this module. + * + * Results: + * The return value is a standard Tcl result. + * + * Side effects: + * Initializes this module if not already initialized, and adds module + * related commands to the given interpreter. + * + *------------------------------------------------------------------------- + */ + +MODULE_SCOPE int +TclZipfs_Init( + Tcl_Interp *interp) /* Current interpreter. */ +{ +#ifdef HAVE_ZLIB + static const EnsembleImplMap initMap[] = { + {"mkimg", ZipFSMkImgObjCmd, NULL, NULL, NULL, 1}, + {"mkzip", ZipFSMkZipObjCmd, NULL, NULL, NULL, 1}, + {"lmkimg", ZipFSLMkImgObjCmd, NULL, NULL, NULL, 1}, + {"lmkzip", ZipFSLMkZipObjCmd, NULL, NULL, NULL, 1}, + /* The 4 entries above are not available in safe interpreters */ + {"mount", ZipFSMountObjCmd, NULL, NULL, NULL, 1}, + {"mount_data", ZipFSMountBufferObjCmd, NULL, NULL, NULL, 1}, + {"unmount", ZipFSUnmountObjCmd, NULL, NULL, NULL, 1}, + {"mkkey", ZipFSMkKeyObjCmd, NULL, NULL, NULL, 1}, + {"exists", ZipFSExistsObjCmd, NULL, NULL, NULL, 0}, + {"info", ZipFSInfoObjCmd, NULL, NULL, NULL, 0}, + {"list", ZipFSListObjCmd, NULL, NULL, NULL, 0}, + {"canonical", ZipFSCanonicalObjCmd, NULL, NULL, NULL, 0}, + {"root", ZipFSRootObjCmd, NULL, NULL, NULL, 0}, + {NULL, NULL, NULL, NULL, NULL, 0} + }; + static const char findproc[] = + "namespace eval ::tcl::zipfs {}\n" + "proc ::tcl::zipfs::Find dir {\n" + " set result {}\n" + " if {[catch {glob -directory $dir -nocomplain * .*} list]} {\n" + " return $result\n" + " }\n" + " foreach file $list {\n" + " if {[file tail $file] in {. ..}} {\n" + " continue\n" + " }\n" + " lappend result $file {*}[Find $file]\n" + " }\n" + " return $result\n" + "}\n" + "proc ::tcl::zipfs::find {directoryName} {\n" + " return [lsort [Find $directoryName]]\n" + "}\n"; + + /* + * One-time initialization. + */ + + WriteLock(); + if (!ZipFS.initialized) { + ZipfsSetup(); + } + Unlock(); + + if (interp) { + Tcl_Command ensemble; + Tcl_Obj *mapObj; + + Tcl_EvalEx(interp, findproc, -1, TCL_EVAL_GLOBAL); + Tcl_LinkVar(interp, "::tcl::zipfs::wrmax", (char *) &ZipFS.wrmax, + TCL_LINK_INT); + ensemble = TclMakeEnsemble(interp, "zipfs", + Tcl_IsSafe(interp) ? (initMap + 4) : initMap); + + /* + * Add the [zipfs find] subcommand. + */ + + Tcl_GetEnsembleMappingDict(NULL, ensemble, &mapObj); + Tcl_DictObjPut(NULL, mapObj, Tcl_NewStringObj("find", -1), + Tcl_NewStringObj("::tcl::zipfs::find", -1)); + Tcl_CreateObjCommand(interp, "::tcl::zipfs::tcl_library_init", + ZipFSTclLibraryObjCmd, NULL, NULL); + Tcl_PkgProvide(interp, "zipfs", "2.0"); + } + return TCL_OK; +#else /* !HAVE_ZLIB */ + ZIPFS_ERROR(interp, "no zlib available"); + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_ZLIB", NULL); + return TCL_ERROR; +#endif /* HAVE_ZLIB */ +} + +static int +ZipfsAppHookFindTclInit( + const char *archive) +{ + Tcl_Obj *vfsInitScript; + int found; + + if (zipfs_literal_tcl_library) { + return TCL_ERROR; + } + if (TclZipfs_Mount(NULL, ZIPFS_ZIP_MOUNT, archive, NULL)) { + /* Either the file doesn't exist or it is not a zip archive */ + return TCL_ERROR; + } + + TclNewLiteralStringObj(vfsInitScript, ZIPFS_ZIP_MOUNT "/init.tcl"); + Tcl_IncrRefCount(vfsInitScript); + found = Tcl_FSAccess(vfsInitScript, F_OK); + Tcl_DecrRefCount(vfsInitScript); + if (found == 0) { + zipfs_literal_tcl_library = ZIPFS_ZIP_MOUNT; + return TCL_OK; + } + + TclNewLiteralStringObj(vfsInitScript, + ZIPFS_ZIP_MOUNT "/tcl_library/init.tcl"); + Tcl_IncrRefCount(vfsInitScript); + found = Tcl_FSAccess(vfsInitScript, F_OK); + Tcl_DecrRefCount(vfsInitScript); + if (found == 0) { + zipfs_literal_tcl_library = ZIPFS_ZIP_MOUNT "/tcl_library"; + return TCL_OK; + } + + return TCL_ERROR; +} + +static void +ZipfsExitHandler( + ClientData clientData) +{ + ZipFile *zf = (ZipFile *)clientData; + + if (TCL_OK != TclZipfs_Unmount(NULL, zf->mountPoint)) { + Tcl_Panic("tried to unmount busy filesystem"); + } +} + +/* + *------------------------------------------------------------------------- + * + * TclZipfs_AppHook -- + * + * Performs the argument munging for the shell + * + *------------------------------------------------------------------------- + */ + +int +TclZipfs_AppHook( + int *argcPtr, /* Pointer to argc */ +#ifdef _WIN32 + WCHAR +#else /* !_WIN32 */ + char +#endif /* _WIN32 */ + ***argvPtr) /* Pointer to argv */ +{ + char *archive; + + Tcl_FindExecutable((*argvPtr)[0]); + archive = (char *) Tcl_GetNameOfExecutable(); + TclZipfs_Init(NULL); + + /* + * Look for init.tcl in one of the locations mounted later in this + * function. + */ + + if (!TclZipfs_Mount(NULL, ZIPFS_APP_MOUNT, archive, NULL)) { + int found; + Tcl_Obj *vfsInitScript; + + TclNewLiteralStringObj(vfsInitScript, ZIPFS_APP_MOUNT "/main.tcl"); + Tcl_IncrRefCount(vfsInitScript); + if (Tcl_FSAccess(vfsInitScript, F_OK) == 0) { + /* + * Startup script should be set before calling Tcl_AppInit + */ + + Tcl_SetStartupScript(vfsInitScript, NULL); + } else { + Tcl_DecrRefCount(vfsInitScript); + } + + /* + * Set Tcl Encodings + */ + + if (!zipfs_literal_tcl_library) { + TclNewLiteralStringObj(vfsInitScript, + ZIPFS_APP_MOUNT "/tcl_library/init.tcl"); + Tcl_IncrRefCount(vfsInitScript); + found = Tcl_FSAccess(vfsInitScript, F_OK); + Tcl_DecrRefCount(vfsInitScript); + if (found == TCL_OK) { + zipfs_literal_tcl_library = ZIPFS_APP_MOUNT "/tcl_library"; + return TCL_OK; + } + } +#ifdef SUPPORT_BUILTIN_ZIP_INSTALL + } else if (*argcPtr > 1) { + /* + * If the first argument is "install", run the supplied installer + * script. + */ + +#ifdef _WIN32 + Tcl_DString ds; + + archive = Tcl_WinTCharToUtf((*argvPtr)[1], -1, &ds); +#else /* !_WIN32 */ + archive = (*argvPtr)[1]; +#endif /* _WIN32 */ + if (strcmp(archive, "install") == 0) { + Tcl_Obj *vfsInitScript; + + /* + * Run this now to ensure the file is present by the time Tcl_Main + * wants it. + */ + + TclZipfs_TclLibrary(); + TclNewLiteralStringObj(vfsInitScript, + ZIPFS_ZIP_MOUNT "/tcl_library/install.tcl"); + Tcl_IncrRefCount(vfsInitScript); + if (Tcl_FSAccess(vfsInitScript, F_OK) == 0) { + Tcl_SetStartupScript(vfsInitScript, NULL); + } + return TCL_OK; + } else if (!TclZipfs_Mount(NULL, ZIPFS_APP_MOUNT, archive, NULL)) { + int found; + Tcl_Obj *vfsInitScript; + + TclNewLiteralStringObj(vfsInitScript, ZIPFS_APP_MOUNT "/main.tcl"); + Tcl_IncrRefCount(vfsInitScript); + if (Tcl_FSAccess(vfsInitScript, F_OK) == 0) { + /* + * Startup script should be set before calling Tcl_AppInit + */ + + Tcl_SetStartupScript(vfsInitScript, NULL); + } else { + Tcl_DecrRefCount(vfsInitScript); + } + /* Set Tcl Encodings */ + TclNewLiteralStringObj(vfsInitScript, + ZIPFS_APP_MOUNT "/tcl_library/init.tcl"); + Tcl_IncrRefCount(vfsInitScript); + found = Tcl_FSAccess(vfsInitScript, F_OK); + Tcl_DecrRefCount(vfsInitScript); + if (found == TCL_OK) { + zipfs_literal_tcl_library = ZIPFS_APP_MOUNT "/tcl_library"; + return TCL_OK; + } + } +#ifdef _WIN32 + Tcl_DStringFree(&ds); +#endif /* _WIN32 */ +#endif /* SUPPORT_BUILTIN_ZIP_INSTALL */ + } + return TCL_OK; +} + +#ifndef HAVE_ZLIB + +/* + *------------------------------------------------------------------------- + * + * TclZipfs_Mount, TclZipfs_MountBuffer, TclZipfs_Unmount -- + * + * Dummy version when no ZLIB support available. + * + *------------------------------------------------------------------------- + */ + +int +TclZipfs_Mount( + Tcl_Interp *interp, /* Current interpreter. */ + const char *mountPoint, /* Mount point path. */ + const char *zipname, /* Path to ZIP file to mount. */ + const char *passwd) /* Password for opening the ZIP, or NULL if + * the ZIP is unprotected. */ +{ + ZIPFS_ERROR(interp, "no zlib available"); + if (interp) { + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_ZLIB", NULL); + } + return TCL_ERROR; +} + +int +TclZipfs_MountBuffer( + Tcl_Interp *interp, /* Current interpreter. NULLable. */ + const char *mountPoint, /* Mount point path. */ + unsigned char *data, + size_t datalen, + int copy) +{ + ZIPFS_ERROR(interp, "no zlib available"); + if (interp) { + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_ZLIB", NULL); + } + return TCL_ERROR; +} + +int +TclZipfs_Unmount( + Tcl_Interp *interp, /* Current interpreter. */ + const char *mountPoint) /* Mount point path. */ +{ + ZIPFS_ERROR(interp, "no zlib available"); + if (interp) { + Tcl_SetErrorCode(interp, "TCL", "ZIPFS", "NO_ZLIB", NULL); + } + return TCL_ERROR; +} +#endif /* !HAVE_ZLIB */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ diff --git a/generic/tclZlib.c b/generic/tclZlib.c index aed38c3..8dbe807 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -117,7 +117,7 @@ typedef struct { z_stream outStream; /* Structure used by zlib for compression of * output. */ char *inBuffer, *outBuffer; /* Working buffers. */ - int inAllocated, outAllocated; + size_t inAllocated, outAllocated; /* Sizes of working buffers. */ GzipHeader inHeader; /* Header read from input stream, when * decompressing a gzip stream. */ @@ -196,7 +196,7 @@ static void ZlibStreamCleanup(ZlibStreamHandle *zshPtr); static int ZlibStreamSubcmd(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); static inline void ZlibTransformEventTimerKill(ZlibChannelData *cd); -static void ZlibTransformTimerRun(ClientData clientData); +static void ZlibTransformTimerRun(void *clientData); /* * Type of zlib-based compressing and decompressing channels. @@ -422,6 +422,7 @@ GenerateHeader( { Tcl_Obj *value; int len, result = TCL_ERROR; + Tcl_WideInt wideValue = 0; const char *valueStr; Tcl_Encoding latin1enc; static const char *const types[] = { @@ -440,7 +441,7 @@ GenerateHeader( if (GetValue(interp, dictObj, "comment", &value) != TCL_OK) { goto error; } else if (value != NULL) { - valueStr = Tcl_GetStringFromObj(value, &len); + valueStr = TclGetStringFromObj(value, &len); Tcl_UtfToExternal(NULL, latin1enc, valueStr, len, 0, NULL, headerPtr->nativeCommentBuf, MAX_COMMENT_LEN-1, NULL, &len, NULL); @@ -461,7 +462,7 @@ GenerateHeader( if (GetValue(interp, dictObj, "filename", &value) != TCL_OK) { goto error; } else if (value != NULL) { - valueStr = Tcl_GetStringFromObj(value, &len); + valueStr = TclGetStringFromObj(value, &len); Tcl_UtfToExternal(NULL, latin1enc, valueStr, len, 0, NULL, headerPtr->nativeFilenameBuf, MAXPATHLEN-1, NULL, &len, NULL); headerPtr->nativeFilenameBuf[len] = '\0'; @@ -485,10 +486,11 @@ GenerateHeader( if (GetValue(interp, dictObj, "time", &value) != TCL_OK) { goto error; - } else if (value != NULL && Tcl_GetLongFromObj(interp, value, - (long *) &headerPtr->header.time) != TCL_OK) { + } else if (value != NULL && Tcl_GetWideIntFromObj(interp, value, + &wideValue) != TCL_OK) { goto error; } + headerPtr->header.time = wideValue; if (GetValue(interp, dictObj, "type", &value) != TCL_OK) { goto error; @@ -565,10 +567,10 @@ ExtractHeader( SetValue(dictObj, "filename", TclDStringToObj(&tmp)); } if (headerPtr->os != 255) { - SetValue(dictObj, "os", Tcl_NewIntObj(headerPtr->os)); + SetValue(dictObj, "os", Tcl_NewWideIntObj(headerPtr->os)); } if (headerPtr->time != 0 /* magic - no time */) { - SetValue(dictObj, "time", Tcl_NewLongObj((long) headerPtr->time)); + SetValue(dictObj, "time", Tcl_NewWideIntObj(headerPtr->time)); } if (headerPtr->text != Z_UNKNOWN) { SetValue(dictObj, "type", @@ -593,7 +595,7 @@ SetInflateDictionary( int length; unsigned char *bytes = Tcl_GetByteArrayFromObj(compDictObj, &length); - return inflateSetDictionary(strm, bytes, (unsigned) length); + return inflateSetDictionary(strm, bytes, length); } return Z_OK; } @@ -607,7 +609,7 @@ SetDeflateDictionary( int length; unsigned char *bytes = Tcl_GetByteArrayFromObj(compDictObj, &length); - return deflateSetDictionary(strm, bytes, (unsigned) length); + return deflateSetDictionary(strm, bytes, length); } return Z_OK; } @@ -623,7 +625,7 @@ Deflate( int e; strm->next_out = (Bytef *) bufferPtr; - strm->avail_out = (unsigned) bufferSize; + strm->avail_out = bufferSize; e = deflate(strm, flush); if (writtenPtr != NULL) { *writtenPtr = bufferSize - strm->avail_out; @@ -882,7 +884,7 @@ Tcl_ZlibStreamInit( static void ZlibStreamCmdDelete( - ClientData cd) + void *cd) { ZlibStreamHandle *zshPtr = cd; @@ -1515,7 +1517,7 @@ Tcl_ZlibStreamGet( Tcl_ListObjIndex(NULL, zshPtr->outData, 0, &itemObj); itemPtr = Tcl_GetByteArrayFromObj(itemObj, &itemLen); if (itemLen-zshPtr->outPos >= count-dataPos) { - unsigned len = count - dataPos; + size_t len = count - dataPos; memcpy(dataPtr + dataPos, itemPtr + zshPtr->outPos, len); zshPtr->outPos += len; @@ -1524,7 +1526,7 @@ Tcl_ZlibStreamGet( zshPtr->outPos = 0; } } else { - unsigned len = itemLen - zshPtr->outPos; + size_t len = itemLen - zshPtr->outPos; memcpy(dataPtr + dataPos, itemPtr + zshPtr->outPos, len); dataPos += len; @@ -1858,7 +1860,7 @@ Tcl_ZlibInflate( if (headerPtr != NULL) { ExtractHeader(&header, gzipHeaderDictObj); SetValue(gzipHeaderDictObj, "size", - Tcl_NewLongObj((long) stream.total_out)); + Tcl_NewWideIntObj(stream.total_out)); ckfree(nameBuf); ckfree(commentBuf); } @@ -1894,7 +1896,7 @@ Tcl_ZlibCRC32( int len) { /* Nothing much to do, just wrap the crc32(). */ - return crc32(crc, (Bytef *) buf, (unsigned) len); + return crc32(crc, (Bytef *) buf, len); } unsigned int @@ -1903,7 +1905,7 @@ Tcl_ZlibAdler32( const unsigned char *buf, int len) { - return adler32(adler, (Bytef *) buf, (unsigned) len); + return adler32(adler, (Bytef *) buf, len); } /* @@ -1918,7 +1920,7 @@ Tcl_ZlibAdler32( static int ZlibCmd( - ClientData notUsed, + void *notUsed, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -2514,7 +2516,7 @@ ZlibPushSubcmd( static int ZlibStreamCmd( - ClientData cd, + void *cd, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -2617,7 +2619,7 @@ ZlibStreamCmd( Tcl_WrongNumArgs(interp, 2, objv, NULL); return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewIntObj(Tcl_ZlibStreamEof(zstream))); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_ZlibStreamEof(zstream))); return TCL_OK; case zs_checksum: /* $strm checksum */ if (objc != 2) { @@ -2640,7 +2642,7 @@ ZlibStreamCmd( static int ZlibStreamAddCmd( - ClientData cd, + void *cd, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -2764,7 +2766,7 @@ ZlibStreamAddCmd( static int ZlibStreamPutCmd( - ClientData cd, + void *cd, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -2853,7 +2855,7 @@ ZlibStreamPutCmd( static int ZlibStreamHeaderCmd( - ClientData cd, + void *cd, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -2892,7 +2894,7 @@ ZlibStreamHeaderCmd( static int ZlibTransformClose( - ClientData instanceData, + void *instanceData, Tcl_Interp *interp) { ZlibChannelData *cd = instanceData; @@ -2931,7 +2933,7 @@ ZlibTransformClose( result = TCL_ERROR; break; } - if (written && Tcl_WriteRaw(cd->parent, cd->outBuffer, written) < 0) { + if (written && Tcl_WriteRaw(cd->parent, cd->outBuffer, written) == TCL_IO_FAILURE) { /* TODO: is this the right way to do errors on close? * Note: when close is called from FinalizeIOSubsystem then * interp may be NULL */ @@ -2983,7 +2985,7 @@ ZlibTransformClose( static int ZlibTransformInput( - ClientData instanceData, + void *instanceData, char *buf, int toRead, int *errorCodePtr) @@ -3097,7 +3099,7 @@ ZlibTransformInput( static int ZlibTransformOutput( - ClientData instanceData, + void *instanceData, const char *buf, int toWrite, int *errorCodePtr) @@ -3130,7 +3132,7 @@ ZlibTransformOutput( break; } - if (Tcl_WriteRaw(cd->parent, cd->outBuffer, produced) < 0) { + if (Tcl_WriteRaw(cd->parent, cd->outBuffer, produced) == TCL_IO_FAILURE) { *errorCodePtr = Tcl_GetErrno(); return -1; } @@ -3186,7 +3188,7 @@ ZlibTransformFlush( * Write the bytes we've received to the next layer. */ - if (len > 0 && Tcl_WriteRaw(cd->parent, cd->outBuffer, len) < 0) { + if (len > 0 && Tcl_WriteRaw(cd->parent, cd->outBuffer, len) == TCL_IO_FAILURE) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "problem flushing channel: %s", Tcl_PosixError(interp))); @@ -3218,7 +3220,7 @@ ZlibTransformFlush( static int ZlibTransformSetOption( /* not used */ - ClientData instanceData, + void *instanceData, Tcl_Interp *interp, const char *optionName, const char *value) @@ -3331,7 +3333,7 @@ ZlibTransformSetOption( /* not used */ static int ZlibTransformGetOption( - ClientData instanceData, + void *instanceData, Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr) @@ -3387,7 +3389,7 @@ ZlibTransformGetOption( } else { if (cd->compDictObj) { int len; - const char *str = Tcl_GetStringFromObj(cd->compDictObj, &len); + const char *str = TclGetStringFromObj(cd->compDictObj, &len); Tcl_DStringAppend(dsPtr, str, len); } @@ -3451,7 +3453,7 @@ ZlibTransformGetOption( static void ZlibTransformWatch( - ClientData instanceData, + void *instanceData, int mask) { ZlibChannelData *cd = instanceData; @@ -3474,7 +3476,7 @@ ZlibTransformWatch( static int ZlibTransformEventHandler( - ClientData instanceData, + void *instanceData, int interestMask) { ZlibChannelData *cd = instanceData; @@ -3495,7 +3497,7 @@ ZlibTransformEventTimerKill( static void ZlibTransformTimerRun( - ClientData clientData) + void *clientData) { ZlibChannelData *cd = clientData; @@ -3516,9 +3518,9 @@ ZlibTransformTimerRun( static int ZlibTransformGetHandle( - ClientData instanceData, + void *instanceData, int direction, - ClientData *handlePtr) + void **handlePtr) { ZlibChannelData *cd = instanceData; @@ -3537,7 +3539,7 @@ ZlibTransformGetHandle( static int ZlibTransformBlockMode( - ClientData instanceData, + void *instanceData, int mode) { ZlibChannelData *cd = instanceData; @@ -3909,6 +3911,12 @@ TclZlibInit( Tcl_RegisterConfig(interp, "zlib", cfg, "iso8859-1"); /* + * Allow command type introspection to do something sensible with streams. + */ + + TclRegisterCommandTypeName(ZlibStreamCmd, "zlibStream"); + + /* * Formally provide the package as a Tcl built-in. */ |