diff options
Diffstat (limited to 'generic')
121 files changed, 15944 insertions, 12976 deletions
diff --git a/generic/regc_cvec.c b/generic/regc_cvec.c index dc699cf..3b4f1e4 100644 --- a/generic/regc_cvec.c +++ b/generic/regc_cvec.c @@ -36,14 +36,14 @@ /* - newcvec - allocate a new cvec - ^ static struct cvec *newcvec(size_t, size_t); + ^ static struct cvec *newcvec(int, int); */ static struct cvec * newcvec( - size_t nchrs, /* to hold this many chrs... */ - size_t nranges) /* ... and this many ranges... */ + int nchrs, /* to hold this many chrs... */ + int nranges) /* ... and this many ranges... */ { - size_t nc = nchrs + nranges*2; + size_t nc = (size_t)nchrs + (size_t)nranges*2; size_t n = sizeof(struct cvec) + nc*sizeof(chr); struct cvec *cv = (struct cvec *) MALLOC(n); @@ -108,8 +108,8 @@ addrange( static struct cvec * getcvec( struct vars *v, /* context */ - size_t nchrs, /* to hold this many chrs... */ - size_t nranges) /* ... and this many ranges... */ + int nchrs, /* to hold this many chrs... */ + int nranges) /* ... and this many ranges... */ { if ((v->cv != NULL) && (nchrs <= v->cv->chrspace) && (nranges <= v->cv->rangespace)) { diff --git a/generic/regc_lex.c b/generic/regc_lex.c index bf936ca..28ae821 100644 --- a/generic/regc_lex.c +++ b/generic/regc_lex.c @@ -889,7 +889,7 @@ lexescape( * Ugly heuristic (first test is "exactly 1 digit?") */ - if (v->now - save == 0 || ((int) c > 0 && (size_t)c <= v->nsubexp)) { + if (v->now - save == 0 || ((int) c > 0 && (int)c <= v->nsubexp)) { NOTE(REG_UBACKREF); RETV(BACKREF, (chr)c); } diff --git a/generic/regc_nfa.c b/generic/regc_nfa.c index 5357571..71bcb09 100644 --- a/generic/regc_nfa.c +++ b/generic/regc_nfa.c @@ -108,7 +108,7 @@ freenfa( } nfa->slast = NULL; - nfa->nstates = FREESTATE; + nfa->nstates = -1; nfa->pre = NULL; nfa->post = NULL; FREE(nfa); @@ -143,7 +143,7 @@ newstate( s->noas = 0; } - assert(nfa->nstates != FREESTATE); + assert(nfa->nstates >= 0); s->no = nfa->nstates++; s->flag = 0; if (nfa->states == NULL) { @@ -2494,7 +2494,7 @@ clonesuccessorstates( struct arc * refarc, char *curdonemap, char *outerdonemap, - size_t nstates) + int nstates) { char *donemap; struct arc *a; @@ -2691,7 +2691,7 @@ cleanup( { struct state *s; struct state *nexts; - size_t n; + int n; /* * Clear out unreachable or dead-end states. Use pre to mark reachable, @@ -2847,7 +2847,7 @@ compact( ca = cnfa->arcs; for (s = nfa->states; s != NULL; s = s->next) { - assert(s->no < nstates); + assert((size_t) s->no < nstates); cnfa->stflags[s->no] = 0; cnfa->states[s->no] = ca; first = ca; @@ -2951,10 +2951,10 @@ dumpnfa( { #ifdef REG_DEBUG struct state *s; - size_t nstates = 0; - size_t narcs = 0; + int nstates = 0; + int narcs = 0; - fprintf(f, "pre %" TCL_Z_MODIFIER "u, post %" TCL_Z_MODIFIER "u", nfa->pre->no, nfa->post->no); + fprintf(f, "pre %d, post %d", nfa->pre->no, nfa->post->no); if (nfa->bos[0] != COLORLESS) { fprintf(f, ", bos [%ld]", (long) nfa->bos[0]); } @@ -2973,7 +2973,7 @@ dumpnfa( nstates++; narcs += s->nouts; } - fprintf(f, "total of %" TCL_Z_MODIFIER "u states, %" TCL_Z_MODIFIER "u arcs\n", nstates, narcs); + fprintf(f, "total of %d states, %d arcs\n", nstates, narcs); if (nfa->parent == NULL) { dumpcolors(nfa->cm, f); } @@ -3000,7 +3000,7 @@ dumpstate( { struct arc *a; - fprintf(f, "%" TCL_Z_MODIFIER "u%s%c", s->no, (s->tmp != NULL) ? "T" : "", + fprintf(f, "%d%s%c", s->no, (s->tmp != NULL) ? "T" : "", (s->flag) ? s->flag : '.'); if (s->prev != NULL && s->prev->next != s) { fprintf(f, "\tstate chain bad\n"); @@ -3013,7 +3013,7 @@ dumpstate( fflush(f); for (a = s->ins; a != NULL; a = a->inchain) { if (a->to != s) { - fprintf(f, "\tlink from %" TCL_Z_MODIFIER "u to %" TCL_Z_MODIFIER "u on %" TCL_Z_MODIFIER "u's in-chain\n", + fprintf(f, "\tlink from %d to %d on %d's in-chain\n", a->from->no, a->to->no, s->no); } } @@ -3091,7 +3091,7 @@ dumparc( break; } if (a->from != s) { - fprintf(f, "?%" TCL_Z_MODIFIER "u?", a->from->no); + fprintf(f, "?%d?", a->from->no); } for (ab = &a->from->oas; ab != NULL; ab = ab->next) { for (aa = &ab->a[0]; aa < &ab->a[ABSIZE]; aa++) { @@ -3111,7 +3111,7 @@ dumparc( fprintf(f, "NULL"); return; } - fprintf(f, "%" TCL_Z_MODIFIER "u", a->to->no); + fprintf(f, "%d", a->to->no); for (aa = a->to->ins; aa != NULL; aa = aa->inchain) { if (aa == a) { break; /* NOTE BREAK OUT */ @@ -3137,9 +3137,9 @@ dumpcnfa( FILE *f) { #ifdef REG_DEBUG - size_t st; + int st; - fprintf(f, "pre %" TCL_Z_MODIFIER "u, post %" TCL_Z_MODIFIER "u", cnfa->pre, cnfa->post); + fprintf(f, "pre %d, post %d", cnfa->pre, cnfa->post); if (cnfa->bos[0] != COLORLESS) { fprintf(f, ", bos [%ld]", (long) cnfa->bos[0]); } @@ -3182,15 +3182,15 @@ dumpcstate( FILE *f) { struct carc *ca; - size_t pos; + int pos; fprintf(f, "%d%s", st, (cnfa->stflags[st] & CNFA_NOPROGRESS) ? ":" : "."); pos = 1; for (ca = cnfa->states[st]; ca->co != COLORLESS; ca++) { if (ca->co < cnfa->ncolors) { - fprintf(f, "\t[%d]->%" TCL_Z_MODIFIER "u", ca->co, ca->to); + fprintf(f, "\t[%ld]->%d", (long) ca->co, ca->to); } else { - fprintf(f, "\t:%d:->%" TCL_Z_MODIFIER "u", ca->co - cnfa->ncolors, ca->to); + fprintf(f, "\t:%ld:->%d", (long) (ca->co - cnfa->ncolors), ca->to); } if (pos == 5) { fprintf(f, "\n"); diff --git a/generic/regcomp.c b/generic/regcomp.c index 012e37c..983cd7a 100644 --- a/generic/regcomp.c +++ b/generic/regcomp.c @@ -39,7 +39,7 @@ /* automatically gathered by fwd; do not hand-edit */ /* === regcomp.c === */ int compile(regex_t *, const chr *, size_t, int); -static void moresubs(struct vars *, size_t); +static void moresubs(struct vars *, int); static int freev(struct vars *, int); static void makesearch(struct vars *, struct nfa *); static struct subre *parse(struct vars *, int, int, struct state *, struct state *); @@ -156,7 +156,7 @@ static void fixconstraintloops(struct nfa *, FILE *); static int findconstraintloop(struct nfa *, struct state *); static void breakconstraintloop(struct nfa *, struct state *); static void clonesuccessorstates(struct nfa *, struct state *, struct state *, - struct state *, struct arc *, char *, char *, size_t); + struct state *, struct arc *, char *, char *, int); static void cleanup(struct nfa *); static void markreachable(struct nfa *, struct state *, struct state *, struct state *); static void markcanreach(struct nfa *, struct state *, struct state *, struct state *); @@ -179,8 +179,8 @@ static void dumpcstate(int, struct cnfa *, FILE *); static struct cvec *clearcvec(struct cvec *); static void addchr(struct cvec *, pchr); static void addrange(struct cvec *, pchr, pchr); -static struct cvec *newcvec(size_t, size_t); -static struct cvec *getcvec(struct vars *, size_t, size_t); +static struct cvec *newcvec(int, int); +static struct cvec *getcvec(struct vars *, int, int); static void freecvec(struct cvec *); /* === regc_locale.c === */ static celt element(struct vars *, const chr *, const chr *); @@ -205,11 +205,11 @@ struct vars { int cflags; /* copy of compile flags */ int lasttype; /* type of previous token */ int nexttype; /* type of next token */ - size_t nextvalue; /* value (if any) of next token */ + int nextvalue; /* value (if any) of next token */ int lexcon; /* lexical context type (see lex.c) */ - size_t nsubexp; /* subexpression count */ + 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 */ @@ -222,7 +222,7 @@ struct vars { struct cvec *cv; /* interface cvec */ struct cvec *cv2; /* utility cvec */ struct subre *lacons; /* lookahead-constraint vector */ - size_t nlacons; /* size of lacons */ + int nlacons; /* size of lacons */ size_t spaceused; /* approx. space used for compilation */ }; @@ -287,7 +287,7 @@ compile( { AllocVars(v); struct guts *g; - size_t i, j; + int i, j; FILE *debug = (flags®_PROGRESS) ? stdout : NULL; #define CNOERR() { if (ISERR()) return freev(v, v->err); } @@ -338,6 +338,7 @@ compile( v->spaceused = 0; re->re_magic = REMAGIC; re->re_info = 0; /* bits get set during parse */ + re->re_csize = sizeof(chr); re->re_guts = NULL; re->re_fns = (void*)(&functions); @@ -410,7 +411,7 @@ compile( assert(v->nlacons == 0 || v->lacons != NULL); for (i = 1; i < v->nlacons; i++) { if (debug != NULL) { - fprintf(debug, "\n\n\n========= LA%" TCL_Z_MODIFIER "u ==========\n", i); + fprintf(debug, "\n\n\n========= LA%d ==========\n", i); } nfanode(v, &v->lacons[i], debug); } @@ -466,15 +467,15 @@ compile( /* - moresubs - enlarge subRE vector - ^ static void moresubs(struct vars *, size_t); + ^ static void moresubs(struct vars *, int); */ static void moresubs( struct vars *v, - size_t wanted) /* want enough room for this one */ + int wanted) /* want enough room for this one */ { struct subre **p; - size_t n; + int n; assert(wanted > 0 && wanted >= v->nsubs); n = wanted * 3 / 2 + 1; @@ -794,7 +795,7 @@ parseqatom( struct subre *t; int cap; /* capturing parens? */ int pos; /* positive lookahead? */ - size_t subno; /* capturing-parens or backref number */ + int subno; /* capturing-parens or backref number */ int atomtype; int qprefer; /* quantifier short/long preference */ int f; @@ -2047,7 +2048,7 @@ dump( { #ifdef REG_DEBUG struct guts *g; - size_t i; + int i; if (re->re_magic != REMAGIC) { fprintf(f, "bad magic number (0x%x not 0x%x)\n", @@ -2064,8 +2065,8 @@ dump( } fprintf(f, "\n\n\n========= DUMP ==========\n"); - fprintf(f, "nsub %" TCL_Z_MODIFIER "u, info 0%lo, ntree %" TCL_Z_MODIFIER "u\n", - re->re_nsub, re->re_info, g->ntree); + fprintf(f, "nsub %d, info 0%lo, csize %d, ntree %d\n", + (int) re->re_nsub, re->re_info, re->re_csize, g->ntree); dumpcolors(&g->cmap, f); if (!NULLCNFA(g->search)) { @@ -2073,7 +2074,7 @@ dump( dumpcnfa(&g->search, f); } for (i = 1; i < g->nlacons; i++) { - fprintf(f, "\nla%" TCL_Z_MODIFIER "u (%s):\n", i, + fprintf(f, "\nla%d (%s):\n", i, (g->lacons[i].subno) ? "positive" : "negative"); dumpcnfa(&g->lacons[i].cnfa, f); } @@ -2145,7 +2146,7 @@ stdump( fprintf(f, "}"); } if (nfapresent) { - fprintf(f, " %" TCL_Z_MODIFIER "u-%" TCL_Z_MODIFIER "u", t->begin->no, t->end->no); + fprintf(f, " %d-%d", t->begin->no, t->end->no); } if (t->left != NULL) { fprintf(f, " L:%s", stid(t->left, idbuf, sizeof(idbuf))); diff --git a/generic/regcustom.h b/generic/regcustom.h index e5d7f12..56bf571 100644 --- a/generic/regcustom.h +++ b/generic/regcustom.h @@ -36,9 +36,9 @@ * Overrides for regguts.h definitions, if any. */ -#define MALLOC(n) Tcl_AttemptAlloc(n) -#define FREE(p) Tcl_Free(p) -#define REALLOC(p,n) Tcl_AttemptRealloc(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 @@ -56,6 +56,9 @@ #ifdef __REG_WIDE_EXEC #undef __REG_WIDE_EXEC #endif +#ifdef __REG_REGOFF_T +#undef __REG_REGOFF_T +#endif #ifdef __REG_NOFRONT #undef __REG_NOFRONT #endif @@ -64,6 +67,7 @@ #endif /* Interface types */ #define __REG_WIDE_T Tcl_UniChar +#define __REG_REGOFF_T long /* Not really right, but good enough... */ /* Names and declarations */ #define __REG_WIDE_COMPILE TclReComp #define __REG_WIDE_EXEC TclReExec diff --git a/generic/rege_dfa.c b/generic/rege_dfa.c index 5d49aa5..eddfea2 100644 --- a/generic/rege_dfa.c +++ b/generic/rege_dfa.c @@ -47,7 +47,7 @@ longest( color co; struct sset *css, *ss; chr *post; - size_t i; + int i; struct colormap *cm = d->cm; /* @@ -292,7 +292,7 @@ lastCold( { struct sset *ss; chr *nopr = d->lastnopr; - size_t i; + int i; if (nopr == NULL) { nopr = v->start; @@ -319,7 +319,7 @@ newDFA( { struct dfa *d; size_t nss = cnfa->nstates * 2; - size_t wordsper = (cnfa->nstates + UBITS - 1) / UBITS; + int wordsper = (cnfa->nstates + UBITS - 1) / UBITS; struct smalldfa *smallwas = sml; assert(cnfa != NULL && cnfa->nstates != 0); @@ -442,7 +442,7 @@ initialize( chr *const start) { struct sset *ss; - size_t i; + int i; /* * Is previous one still there? @@ -492,8 +492,7 @@ miss( unsigned h; struct carc *ca; struct sset *p; - size_t i; - int isPost, noProgress, gotState, doLAConstraints, sawLAConstraints; + int i, isPost, noProgress, gotState, doLAConstraints, sawLAConstraints; /* * For convenience, we can be called even if it might not be a miss. @@ -527,7 +526,7 @@ miss( if (!(cnfa->stflags[ca->to] & CNFA_NOPROGRESS)) { noProgress = 0; } - FDEBUG(("%" TCL_Z_MODIFIER "u -> %" TCL_Z_MODIFIER "u\n", i, ca->to)); + FDEBUG(("%d -> %d\n", i, ca->to)); } } } @@ -557,7 +556,7 @@ miss( if (!(cnfa->stflags[ca->to] & CNFA_NOPROGRESS)) { noProgress = 0; } - FDEBUG(("%" TCL_Z_MODIFIER "u :> %" TCL_Z_MODIFIER"u\n", i, ca->to)); + FDEBUG(("%d :> %d\n", i, ca->to)); } } } @@ -616,7 +615,7 @@ checkLAConstraint( chr *const cp, const pcolor co) /* "color" of the lookahead constraint */ { - size_t n; + int n; struct subre *sub; struct dfa *d; struct smalldfa sd; @@ -624,7 +623,7 @@ checkLAConstraint( n = co - pcnfa->ncolors; assert(n < v->g->nlacons && v->g->lacons != NULL); - FDEBUG(("=== testing lacon %" TCL_Z_MODIFIER "u\n", n)); + FDEBUG(("=== testing lacon %d\n", n)); sub = &v->g->lacons[n]; d = newDFA(v, &sub->cnfa, &v->g->cmap, &sd); if (d == NULL) { @@ -633,7 +632,7 @@ checkLAConstraint( } end = longest(v, d, cp, v->stop, NULL); freeDFA(d); - FDEBUG(("=== lacon %" TCL_Z_MODIFIER "u match %d\n", n, (end != NULL))); + FDEBUG(("=== lacon %d match %d\n", n, (end != NULL))); return (sub->subno) ? (end != NULL) : (end == NULL); } @@ -739,21 +738,21 @@ pickNextSS( */ if (d->nssused < d->nssets) { - size_t j = d->nssused; + i = d->nssused; d->nssused++; - ss = &d->ssets[j]; - FDEBUG(("new c%" TCL_Z_MODIFIER "u\n", j)); + ss = &d->ssets[i]; + FDEBUG(("new c%d\n", i)); /* * Set up innards. */ - ss->states = &d->statesarea[j * d->wordsper]; + ss->states = &d->statesarea[i * d->wordsper]; ss->flags = 0; ss->ins.ss = NULL; ss->ins.co = WHITE; /* give it some value */ - ss->outs = &d->outsarea[j * d->ncolors]; - ss->inchain = &d->incarea[j * d->ncolors]; + ss->outs = &d->outsarea[i * d->ncolors]; + ss->inchain = &d->incarea[i * d->ncolors]; for (i = 0; i < d->ncolors; i++) { ss->outs[i] = NULL; ss->inchain[i].ss = NULL; @@ -765,7 +764,7 @@ pickNextSS( * Look for oldest, or old enough anyway. */ - if ((size_t)(cp - start) > d->nssets*2/3) { /* oldest 33% are expendable */ + if (cp - start > d->nssets*2/3) { /* oldest 33% are expendable */ ancient = cp - d->nssets*2/3; } else { ancient = start; @@ -774,7 +773,7 @@ pickNextSS( if ((ss->lastseen == NULL || ss->lastseen < ancient) && !(ss->flags&LOCKED)) { d->search = ss + 1; - FDEBUG(("replacing c%" TCL_Z_MODIFIER "u\n", (size_t)(ss - d->ssets))); + FDEBUG(("replacing c%d\n", (int) (ss - d->ssets))); return ss; } } @@ -782,7 +781,7 @@ pickNextSS( if ((ss->lastseen == NULL || ss->lastseen < ancient) && !(ss->flags&LOCKED)) { d->search = ss + 1; - FDEBUG(("replacing c%" TCL_Z_MODIFIER "u\n", (size_t)(ss - d->ssets))); + FDEBUG(("replacing c%d\n", (int) (ss - d->ssets))); return ss; } } diff --git a/generic/regerror.c b/generic/regerror.c index 5caab8a..775c640 100644 --- a/generic/regerror.c +++ b/generic/regerror.c @@ -86,7 +86,7 @@ regerror( if (r->code >= 0) { msg = r->name; } else { /* Unknown; tell him the number */ - snprintf(convbuf, sizeof(convbuf), "REG_%u", icode); + snprintf(convbuf, sizeof(convbuf), "REG_%u", (unsigned)icode); msg = convbuf; } break; diff --git a/generic/regex.h b/generic/regex.h index 72f7037..dba3ab4 100644 --- a/generic/regex.h +++ b/generic/regex.h @@ -89,6 +89,9 @@ extern "C" { #ifdef __REG_WIDE_EXEC #undef __REG_WIDE_EXEC #endif +#ifdef __REG_REGOFF_T +#undef __REG_REGOFF_T +#endif #ifdef __REG_NOFRONT #undef __REG_NOFRONT #endif @@ -97,6 +100,7 @@ extern "C" { #endif /* interface types */ #define __REG_WIDE_T Tcl_UniChar +#define __REG_REGOFF_T long /* not really right, but good enough... */ /* names and declarations */ #define __REG_WIDE_COMPILE TclReComp #define __REG_WIDE_EXEC TclReExec @@ -111,14 +115,25 @@ extern "C" { */ /* + * regoff_t has to be large enough to hold either off_t or ssize_t, and must + * be signed; it's only a guess that long is suitable, so we offer + * <sys/types.h> an override. + */ +#ifdef __REG_REGOFF_T +typedef __REG_REGOFF_T regoff_t; +#else +typedef long regoff_t; +#endif + +/* * other interface types */ /* the biggie, a compiled RE (or rather, a front end to same) */ typedef struct { int re_magic; /* magic number */ - long re_info; /* information about RE */ size_t re_nsub; /* number of subexpressions */ + long re_info; /* information about RE */ #define REG_UBACKREF 000001 #define REG_ULOOKAHEAD 000002 #define REG_UBOUNDS 000004 @@ -133,6 +148,7 @@ typedef struct { #define REG_UEMPTYMATCH 004000 #define REG_UIMPOSSIBLE 010000 #define REG_USHORTEST 020000 + int re_csize; /* sizeof(character) */ char *re_endp; /* backward compatibility kludge */ /* the rest is opaque pointers to hidden innards */ void *re_guts; @@ -141,8 +157,8 @@ typedef struct { /* result reporting (may acquire more fields later) */ typedef struct { - size_t rm_so; /* start of substring */ - size_t rm_eo; /* end of substring */ + regoff_t rm_so; /* start of substring */ + regoff_t rm_eo; /* end of substring */ } regmatch_t; /* supplementary control and reporting */ diff --git a/generic/regexec.c b/generic/regexec.c index 7b84f0f..7ef048e 100644 --- a/generic/regexec.c +++ b/generic/regexec.c @@ -57,12 +57,11 @@ struct sset { /* state set */ }; struct dfa { - size_t nssets; /* size of cache */ - size_t nssused; /* how many entries occupied yet */ - size_t nstates; /* number of states */ - size_t wordsper; /* length of state-set bitvectors */ + int nssets; /* size of cache */ + int nssused; /* how many entries occupied yet */ + int nstates; /* number of states */ int ncolors; /* length of outarc and inchain vectors */ - int cptsmalloced; /* were the areas individually malloced? */ + int wordsper; /* length of state-set bitvectors */ struct sset *ssets; /* state-set cache */ unsigned *statesarea; /* bitvector storage */ unsigned *work; /* pointer to work area within statesarea */ @@ -73,6 +72,7 @@ struct dfa { chr *lastpost; /* location of last cache-flushed success */ chr *lastnopr; /* location of last cache-flushed NOPROGRESS */ struct sset *search; /* replacement-search-pointer memory */ + int cptsmalloced; /* were the areas individually malloced? */ char *mallocarea; /* self, or malloced area, or NULL */ }; @@ -186,6 +186,10 @@ exec( FreeVars(v); return REG_INVARG; } + if (re->re_csize != sizeof(chr)) { + FreeVars(v); + return REG_MIXED; + } /* * Setup. @@ -550,8 +554,8 @@ zapallsubs( size_t i; for (i = n-1; i > 0; i--) { - p[i].rm_so = FREESTATE; - p[i].rm_eo = FREESTATE; + p[i].rm_so = -1; + p[i].rm_eo = -1; } } @@ -565,11 +569,11 @@ zaptreesubs( struct subre *const t) { if (t->op == '(') { - size_t n = t->subno; + int n = t->subno; assert(n > 0); - if (n < v->nmatch) { - v->pmatch[n].rm_so = FREESTATE; - v->pmatch[n].rm_eo = FREESTATE; + if ((size_t) n < v->nmatch) { + v->pmatch[n].rm_so = -1; + v->pmatch[n].rm_eo = -1; } } @@ -889,7 +893,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 == FREESTATE) { + 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 e135874..62ab889 100644 --- a/generic/regguts.h +++ b/generic/regguts.h @@ -203,11 +203,11 @@ struct colormap { /* Representation of a set of characters. */ struct cvec { - size_t nchrs; /* number of chrs */ - size_t chrspace; /* number of chrs possible */ + int nchrs; /* number of chrs */ + int chrspace; /* number of chrs possible */ chr *chrs; /* pointer to vector of chrs */ - size_t nranges; /* number of ranges (chr pairs) */ - size_t rangespace; /* number of chrs possible */ + int nranges; /* number of ranges (chr pairs) */ + int rangespace; /* number of chrs possible */ chr *ranges; /* pointer to vector of chr pairs */ }; @@ -242,19 +242,19 @@ struct arcbatch { /* for bulk allocation of arcs */ }; struct state { - size_t no; -#define FREESTATE ((size_t)-1) + int no; +#define FREESTATE (-1) char flag; /* marks special states */ - size_t nins; /* number of inarcs */ + int nins; /* number of inarcs */ struct arc *ins; /* chain of inarcs */ - size_t nouts; /* number of outarcs */ + int nouts; /* number of outarcs */ struct arc *outs; /* chain of outarcs */ struct arc *free; /* chain of free arcs */ struct state *tmp; /* temporary for traversal algorithms */ struct state *next; /* chain for traversing all */ struct state *prev; /* back chain */ struct arcbatch oas; /* first arcbatch, avoid malloc in easy case */ - size_t noas; /* number of arcs used in first arcbatch */ + int noas; /* number of arcs used in first arcbatch */ }; struct nfa { @@ -262,7 +262,7 @@ struct nfa { struct state *init; /* initial state */ struct state *final; /* final state */ struct state *post; /* postfinal state */ - size_t nstates; /* for numbering states */ + int nstates; /* for numbering states */ struct state *states; /* state-chain header */ struct state *slast; /* tail of the chain */ struct state *free; /* free list */ @@ -290,16 +290,16 @@ struct nfa { struct carc { color co; /* COLORLESS is list terminator */ - size_t to; /* next-state number */ + int to; /* next-state number */ }; struct cnfa { - size_t nstates; /* number of states */ + int nstates; /* number of states */ int ncolors; /* number of colors */ int flags; #define HASLACONS 01 /* uses lookahead constraints */ - size_t pre; /* setup state number */ - size_t post; /* teardown state number */ + int pre; /* setup state number */ + int post; /* teardown state number */ color bos[2]; /* colors, if any, assigned to BOS and BOL */ color eos[2]; /* colors, if any, assigned to EOS and EOL */ char *stflags; /* vector of per-state flags bytes */ @@ -396,11 +396,11 @@ struct guts { size_t nsub; /* copy of re_nsub */ struct subre *tree; struct cnfa search; /* for fast preliminary search */ - size_t ntree; /* number of subre's, plus one */ + int ntree; /* number of subre's, plus one */ struct colormap cmap; int (*compare) (const chr *, const chr *, size_t); struct subre *lacons; /* lookahead-constraint vector */ - size_t nlacons; /* size of lacons */ + int nlacons; /* size of lacons */ }; /* diff --git a/generic/tcl.decls b/generic/tcl.decls index 14472e7..238c45e 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -40,22 +40,22 @@ declare 2 { TCL_NORETURN void Tcl_Panic(const char *format, ...) } declare 3 { - void *Tcl_Alloc(TCL_HASH_TYPE size) + char *Tcl_Alloc(TCL_HASH_TYPE size) } declare 4 { - void Tcl_Free(void *ptr) + void Tcl_Free(char *ptr) } declare 5 { - void *Tcl_Realloc(void *ptr, TCL_HASH_TYPE size) + char *Tcl_Realloc(char *ptr, TCL_HASH_TYPE size) } declare 6 { - void *Tcl_DbCkalloc(TCL_HASH_TYPE size, const char *file, int line) + char *Tcl_DbCkalloc(TCL_HASH_TYPE size, const char *file, int line) } declare 7 { - void Tcl_DbCkfree(void *ptr, const char *file, int line) + void Tcl_DbCkfree(char *ptr, const char *file, int line) } declare 8 { - void *Tcl_DbCkrealloc(void *ptr, TCL_HASH_TYPE size, + char *Tcl_DbCkrealloc(char *ptr, TCL_HASH_TYPE size, const char *file, int line) } @@ -63,11 +63,11 @@ declare 8 { # but they are part of the old generic interface, so we include them here for # compatibility reasons. -declare 9 { +declare 9 unix { void Tcl_CreateFileHandler(int fd, int mask, Tcl_FileProc *proc, void *clientData) } -declare 10 { +declare 10 unix { void Tcl_DeleteFileHandler(int fd) } declare 11 { @@ -104,6 +104,9 @@ declare 20 { declare 21 { int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file, int line) } +declare 22 {deprecated {No longer in use, changed to macro}} { + Tcl_Obj *Tcl_DbNewBooleanObj(int intValue, const char *file, int line) +} declare 23 { Tcl_Obj *Tcl_DbNewByteArrayObj(const unsigned char *bytes, Tcl_Size numBytes, const char *file, int line) @@ -116,6 +119,9 @@ declare 25 { Tcl_Obj *Tcl_DbNewListObj(Tcl_Size objc, Tcl_Obj *const *objv, const char *file, int line) } +declare 26 {deprecated {No longer in use, changed to macro}} { + Tcl_Obj *Tcl_DbNewLongObj(long longValue, const char *file, int line) +} declare 27 { Tcl_Obj *Tcl_DbNewObj(const char *file, int line) } @@ -147,6 +153,10 @@ declare 35 { int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr) } +declare 36 {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) +} declare 37 { int Tcl_GetInt(Tcl_Interp *interp, const char *src, int *intPtr) } @@ -157,10 +167,10 @@ declare 39 { int Tcl_GetLongFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr) } declare 40 { - const Tcl_ObjType *Tcl_GetObjType(const char *typeName) + CONST86 Tcl_ObjType *Tcl_GetObjType(const char *typeName) } declare 41 { - char *TclGetStringFromObj(Tcl_Obj *objPtr, void *lengthPtr) + char *Tcl_GetStringFromObj(Tcl_Obj *objPtr, Tcl_Size *lengthPtr) } declare 42 { void Tcl_InvalidateStringRep(Tcl_Obj *objPtr) @@ -174,36 +184,48 @@ declare 44 { Tcl_Obj *objPtr) } declare 45 { - int TclListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr, - void *objcPtr, Tcl_Obj ***objvPtr) + int Tcl_ListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr, + Tcl_Size *objcPtr, Tcl_Obj ***objvPtr) } declare 46 { int Tcl_ListObjIndex(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size index, Tcl_Obj **objPtrPtr) } declare 47 { - int TclListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr, - void *lengthPtr) + int Tcl_ListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr, + Tcl_Size *lengthPtr) } declare 48 { int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size first, Tcl_Size count, Tcl_Size objc, Tcl_Obj *const objv[]) } +declare 49 {deprecated {No longer in use, changed to macro}} { + Tcl_Obj *Tcl_NewBooleanObj(int intValue) +} declare 50 { Tcl_Obj *Tcl_NewByteArrayObj(const unsigned char *bytes, Tcl_Size numBytes) } declare 51 { Tcl_Obj *Tcl_NewDoubleObj(double doubleValue) } +declare 52 {deprecated {No longer in use, changed to macro}} { + Tcl_Obj *Tcl_NewIntObj(int intValue) +} declare 53 { Tcl_Obj *Tcl_NewListObj(Tcl_Size objc, Tcl_Obj *const objv[]) } +declare 54 {deprecated {No longer in use, changed to macro}} { + Tcl_Obj *Tcl_NewLongObj(long longValue) +} declare 55 { Tcl_Obj *Tcl_NewObj(void) } declare 56 { Tcl_Obj *Tcl_NewStringObj(const char *bytes, Tcl_Size length) } +declare 57 {deprecated {No longer in use, changed to macro}} { + void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int intValue) +} declare 58 { unsigned char *Tcl_SetByteArrayLength(Tcl_Obj *objPtr, Tcl_Size numBytes) } @@ -214,15 +236,28 @@ declare 59 { declare 60 { void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue) } +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, Tcl_Size objc, Tcl_Obj *const objv[]) } +declare 63 {deprecated {No longer in use, changed to macro}} { + void Tcl_SetLongObj(Tcl_Obj *objPtr, long longValue) +} declare 64 { void Tcl_SetObjLength(Tcl_Obj *objPtr, Tcl_Size length) } declare 65 { void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, Tcl_Size length) } +declare 66 {deprecated {No longer in use, changed to macro}} { + void Tcl_AddErrorInfo(Tcl_Interp *interp, const char *message) +} +declare 67 {deprecated {No longer in use, changed to macro}} { + void Tcl_AddObjErrorInfo(Tcl_Interp *interp, const char *message, + Tcl_Size length) +} declare 68 { void Tcl_AllowExceptions(Tcl_Interp *interp) } @@ -248,6 +283,12 @@ declare 74 { declare 75 { int Tcl_AsyncReady(void) } +declare 76 {deprecated {No longer in use, changed to macro}} { + void Tcl_BackgroundError(Tcl_Interp *interp) +} +declare 77 {deprecated {Use Tcl_UtfBackslash}} { + char Tcl_Backslash(const char *src, int *readPtr) +} declare 78 { int Tcl_BadChannelOption(Tcl_Interp *interp, const char *optionName, const char *optionList) @@ -313,6 +354,11 @@ declare 93 { declare 94 { Tcl_Interp *Tcl_CreateInterp(void) } +declare 95 {deprecated {}} { + void Tcl_CreateMathFunc(Tcl_Interp *interp, const char *name, + int numArgs, Tcl_ValueType *argTypes, + Tcl_MathProc *proc, void *clientData) +} declare 96 { Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp, const char *cmdName, @@ -422,9 +468,15 @@ declare 127 { declare 128 { const char *Tcl_ErrnoMsg(int err) } +declare 129 { + int Tcl_Eval(Tcl_Interp *interp, const char *script) +} declare 130 { int Tcl_EvalFile(Tcl_Interp *interp, const char *fileName) } +declare 131 {deprecated {No longer in use, changed to macro}} { + int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr) +} declare 132 { void Tcl_EventuallyFree(void *clientData, Tcl_FreeProc *freeProc) } @@ -463,6 +515,9 @@ declare 142 { declare 143 { void Tcl_Finalize(void) } +declare 144 {nostub {Don't use this function in a stub-enabled extension}} { + const char *Tcl_FindExecutable(const char *argv0) +} declare 145 { Tcl_HashEntry *Tcl_FirstHashEntry(Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr) @@ -470,8 +525,16 @@ declare 145 { declare 146 { int Tcl_Flush(Tcl_Channel chan) } +declare 147 {deprecated {see TIP #559. Use Tcl_ResetResult}} { + void Tcl_FreeResult(Tcl_Interp *interp) +} +declare 148 {deprecated {Use Tcl_GetAliasObj}} { + int Tcl_GetAlias(Tcl_Interp *interp, const char *childCmd, + Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, + int *argcPtr, const char ***argvPtr) +} declare 149 { - int TclGetAliasObj(Tcl_Interp *interp, const char *childCmd, + int Tcl_GetAliasObj(Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objvPtr) } @@ -504,7 +567,7 @@ declare 157 { const char *optionName, Tcl_DString *dsPtr) } declare 158 { - const Tcl_ChannelType *Tcl_GetChannelType(Tcl_Channel chan) + CONST86 Tcl_ChannelType *Tcl_GetChannelType(Tcl_Channel chan) } declare 159 { int Tcl_GetCommandInfo(Tcl_Interp *interp, const char *cmdName, @@ -536,7 +599,7 @@ declare 166 { # Tcl_GetOpenFile is only available on unix, but it is a part of the old # generic interface, so we include it here for compatibility reasons. -declare 167 { +declare 167 unix { int Tcl_GetOpenFile(Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, void **filePtr) } @@ -560,10 +623,23 @@ declare 172 { declare 173 { Tcl_Channel Tcl_GetStdChannel(int type) } +declare 174 { + const char *Tcl_GetStringResult(Tcl_Interp *interp) +} +declare 175 {deprecated {No longer in use, changed to macro}} { + const char *Tcl_GetVar(Tcl_Interp *interp, const char *varName, + int flags) +} declare 176 { 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 {deprecated {No longer in use, changed to macro}} { + int Tcl_GlobalEvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr) +} declare 179 { int Tcl_HideCommand(Tcl_Interp *interp, const char *cmdName, const char *hiddenCmdToken) @@ -604,6 +680,9 @@ declare 187 { declare 189 { Tcl_Channel Tcl_MakeFileChannel(void *handle, int mode) } +declare 190 {deprecated {}} { + int Tcl_MakeSafe(Tcl_Interp *interp) +} declare 191 { Tcl_Channel Tcl_MakeTcpClientChannel(void *tcpSocket) } @@ -702,6 +781,9 @@ declare 218 { declare 219 { Tcl_Size Tcl_ScanCountedElement(const char *src, Tcl_Size length, int *flagPtr) } +declare 220 {deprecated {}} { + int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode) +} declare 221 { int Tcl_ServiceAll(void) } @@ -732,9 +814,16 @@ declare 228 { declare 229 { void Tcl_SetMaxBlockTime(const Tcl_Time *timePtr) } +declare 230 {nostub {Don't use this function in a stub-enabled extension}} { + const char *Tcl_SetPanicProc(Tcl_PanicProc *panicProc) +} declare 231 { Tcl_Size Tcl_SetRecursionLimit(Tcl_Interp *interp, Tcl_Size depth) } +declare 232 { + void Tcl_SetResult(Tcl_Interp *interp, char *result, + Tcl_FreeProc *freeProc) +} declare 233 { int Tcl_SetServiceMode(int mode) } @@ -747,6 +836,10 @@ declare 235 { declare 236 { void Tcl_SetStdChannel(Tcl_Channel channel, int type) } +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 { const char *Tcl_SetVar2(Tcl_Interp *interp, const char *part1, const char *part2, const char *newValue, int flags) @@ -761,12 +854,26 @@ declare 241 { void Tcl_SourceRCFile(Tcl_Interp *interp) } declare 242 { - int TclSplitList(Tcl_Interp *interp, const char *listStr, void *argcPtr, + int Tcl_SplitList(Tcl_Interp *interp, const char *listStr, Tcl_Size *argcPtr, const char ***argvPtr) } # Obsolete, use Tcl_FSSplitPath declare 243 { - void TclSplitPath(const char *path, void *argcPtr, const char ***argvPtr) + void Tcl_SplitPath(const char *path, Tcl_Size *argcPtr, const char ***argvPtr) +} +declare 244 {nostub {Don't use this function in a stub-enabled extension}} { + void Tcl_StaticLibrary(Tcl_Interp *interp, const char *prefix, + Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *safeInitProc) +} +declare 245 {deprecated {No longer in use, changed to macro}} { + int Tcl_StringMatch(const char *str, const char *pattern) +} +declare 246 {deprecated {}} { + int Tcl_TellOld(Tcl_Channel chan) +} +declare 247 {deprecated {No longer in use, changed to macro}} { + int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, int flags, + Tcl_VarTraceProc *proc, void *clientData) } declare 248 { int Tcl_TraceVar2(Tcl_Interp *interp, const char *part1, const char *part2, @@ -785,10 +892,17 @@ declare 251 { declare 252 { int Tcl_UnregisterChannel(Tcl_Interp *interp, Tcl_Channel chan) } +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 {deprecated {No longer in use, changed to macro}} { + void Tcl_UntraceVar(Tcl_Interp *interp, const char *varName, int flags, + Tcl_VarTraceProc *proc, void *clientData) +} declare 256 { void Tcl_UntraceVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, @@ -797,6 +911,10 @@ declare 256 { declare 257 { void Tcl_UpdateLinkedVar(Tcl_Interp *interp, const char *varName) } +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) +} declare 259 { int Tcl_UpVar2(Tcl_Interp *interp, const char *frameName, const char *part1, const char *part2, const char *localName, int flags) @@ -804,6 +922,10 @@ declare 259 { declare 260 { int Tcl_VarEval(Tcl_Interp *interp, ...) } +declare 261 {deprecated {No longer in use, changed to macro}} { + void *Tcl_VarTraceInfo(Tcl_Interp *interp, const char *varName, + int flags, Tcl_VarTraceProc *procPtr, void *prevClientData) +} declare 262 { void *Tcl_VarTraceInfo2(Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *procPtr, @@ -822,6 +944,12 @@ declare 265 { declare 266 { void Tcl_ValidateAllMemory(const char *file, int line) } +declare 267 {deprecated {see TIP #422}} { + void Tcl_AppendResultVA(Tcl_Interp *interp, va_list argList) +} +declare 268 {deprecated {see TIP #422}} { + void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, va_list argList) +} declare 269 { char *Tcl_HashStats(Tcl_HashTable *tablePtr) } @@ -829,14 +957,36 @@ declare 270 { const char *Tcl_ParseVar(Tcl_Interp *interp, const char *start, const char **termPtr) } +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 { const char *Tcl_PkgPresentEx(Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr) } +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 {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 {deprecated {see TIP #422}} { + void Tcl_SetErrorCodeVA(Tcl_Interp *interp, va_list argList) +} +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 {deprecated {see TIP #422}} { + TCL_NORETURN void Tcl_PanicVA(const char *format, va_list argList) +} declare 279 { void Tcl_GetVersion(int *major, int *minor, int *patchLevel, int *type) } @@ -875,11 +1025,9 @@ declare 284 { void Tcl_SetMainLoop(Tcl_MainLoopProc *proc) } -declare 285 { - int Tcl_GetAliasObj(Tcl_Interp *interp, const char *childCmd, - Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, - Tcl_Size *objcPtr, Tcl_Obj ***objvPtr) -} +# Reserved for future use (8.0.x vs. 8.1) +# declare 285 { +# } # Added in 8.1: @@ -895,6 +1043,9 @@ declare 288 { declare 289 { void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc, void *clientData) } +declare 290 {deprecated {Use Tcl_DiscardInterpState}} { + void Tcl_DiscardResult(Tcl_SavedResult *statePtr) +} declare 291 { int Tcl_EvalEx(Tcl_Interp *interp, const char *script, Tcl_Size numBytes, int flags) @@ -969,12 +1120,18 @@ declare 311 { const Tcl_Time *timePtr) } declare 312 { - Tcl_Size TclNumUtfChars(const char *src, Tcl_Size length) + Tcl_Size Tcl_NumUtfChars(const char *src, Tcl_Size length) } declare 313 { Tcl_Size Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, Tcl_Size charsToRead, int appendFlag) } +declare 314 {deprecated {Use Tcl_RestoreInterpState}} { + void Tcl_RestoreResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr) +} +declare 315 {deprecated {Use Tcl_SaveInterpState}} { + void Tcl_SaveResult(Tcl_Interp *interp, Tcl_SavedResult *statePtr) +} declare 316 { int Tcl_SetSystemEncoding(Tcl_Interp *interp, const char *name) } @@ -1005,7 +1162,7 @@ declare 324 { Tcl_Size Tcl_UniCharToUtf(int ch, char *buf) } declare 325 { - const char *TclUtfAtIndex(const char *src, Tcl_Size index) + const char *Tcl_UtfAtIndex(const char *src, Tcl_Size index) } declare 326 { int TclUtfCharComplete(const char *src, Tcl_Size length) @@ -1056,6 +1213,12 @@ declare 339 { declare 340 { char *Tcl_GetString(Tcl_Obj *objPtr) } +declare 341 {deprecated {Use Tcl_GetEncodingSearchPath}} { + const char *Tcl_GetDefaultEncodingDir(void) +} +declare 342 {deprecated {Use Tcl_SetEncodingSearchPath}} { + void Tcl_SetDefaultEncodingDir(const char *path) +} declare 343 { void Tcl_AlertNotifier(void *clientData) } @@ -1086,6 +1249,10 @@ declare 351 { declare 352 { Tcl_Size Tcl_Char16Len(const unsigned short *uniStr) } +declare 353 {deprecated {Use Tcl_UtfNcmp}} { + int Tcl_UniCharNcmp(const unsigned short *ucs, const unsigned short *uct, + unsigned long numChars) +} declare 354 { char *Tcl_Char16ToUtfDString(const unsigned short *uniStr, Tcl_Size uniLength, Tcl_DString *dsPtr) @@ -1098,6 +1265,10 @@ declare 356 { Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj, int flags) } +declare 357 {deprecated {Use Tcl_EvalTokensStandard}} { + Tcl_Obj *Tcl_EvalTokens(Tcl_Interp *interp, Tcl_Token *tokenPtr, + Tcl_Size count) +} declare 358 { void Tcl_FreeParse(Tcl_Parse *parsePtr) } @@ -1142,10 +1313,10 @@ declare 368 { int Tcl_Stat(const char *path, struct stat *bufPtr) } declare 369 { - int TclUtfNcmp(const char *s1, const char *s2, size_t n) + int Tcl_UtfNcmp(const char *s1, const char *s2, unsigned long n) } declare 370 { - int TclUtfNcasecmp(const char *s1, const char *s2, size_t n) + int Tcl_UtfNcasecmp(const char *s1, const char *s2, unsigned long n) } declare 371 { int Tcl_StringCaseMatch(const char *str, const char *pattern, int nocase) @@ -1170,23 +1341,26 @@ declare 377 { void Tcl_RegExpGetInfo(Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr) } declare 378 { - Tcl_Obj *Tcl_NewUnicodeObj(const Tcl_UniChar *unicode, Tcl_Size numChars) + Tcl_Obj *Tcl_NewUnicodeObj(const unsigned short *unicode, Tcl_Size numChars) } declare 379 { - void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, + void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, const unsigned short *unicode, Tcl_Size numChars) } declare 380 { - Tcl_Size TclGetCharLength(Tcl_Obj *objPtr) + Tcl_Size Tcl_GetCharLength(Tcl_Obj *objPtr) } declare 381 { - int TclGetUniChar(Tcl_Obj *objPtr, Tcl_Size index) + int Tcl_GetUniChar(Tcl_Obj *objPtr, Tcl_Size index) +} +declare 382 {deprecated {No longer in use, changed to macro}} { + unsigned short *Tcl_GetUnicode(Tcl_Obj *objPtr) } declare 383 { - Tcl_Obj *TclGetRange(Tcl_Obj *objPtr, Tcl_Size first, Tcl_Size last) + Tcl_Obj *Tcl_GetRange(Tcl_Obj *objPtr, Tcl_Size first, Tcl_Size last) } declare 384 { - void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, + void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, const unsigned short *unicode, Tcl_Size length) } declare 385 { @@ -1244,6 +1418,10 @@ declare 400 { Tcl_DriverBlockModeProc *Tcl_ChannelBlockModeProc( const Tcl_ChannelType *chanTypePtr) } +declare 401 {deprecated {Use Tcl_ChannelClose2Proc}} { + Tcl_DriverCloseProc *Tcl_ChannelCloseProc( + const Tcl_ChannelType *chanTypePtr) +} declare 402 { Tcl_DriverClose2Proc *Tcl_ChannelClose2Proc( const Tcl_ChannelType *chanTypePtr) @@ -1256,6 +1434,10 @@ declare 404 { Tcl_DriverOutputProc *Tcl_ChannelOutputProc( const Tcl_ChannelType *chanTypePtr) } +declare 405 {deprecated {Use Tcl_ChannelWideSeekProc}} { + Tcl_DriverSeekProc *Tcl_ChannelSeekProc( + const Tcl_ChannelType *chanTypePtr) +} declare 406 { Tcl_DriverSetOptionProc *Tcl_ChannelSetOptionProc( const Tcl_ChannelType *chanTypePtr) @@ -1303,6 +1485,21 @@ declare 417 { declare 418 { int Tcl_IsChannelExisting(const char *channelName) } +declare 419 {deprecated {Use Tcl_UtfNcasecmp}} { + int Tcl_UniCharNcasecmp(const unsigned short *ucs, const unsigned short *uct, + unsigned long numChars) +} +declare 420 {deprecated {Use Tcl_StringCaseMatch}} { + int Tcl_UniCharCaseMatch(const unsigned short *uniStr, + const unsigned short *uniPattern, int nocase) +} +declare 421 {deprecated {}} { + Tcl_HashEntry *Tcl_FindHashEntry(Tcl_HashTable *tablePtr, const void *key) +} +declare 422 {deprecated {}} { + Tcl_HashEntry *Tcl_CreateHashEntry(Tcl_HashTable *tablePtr, + const void *key, int *newPtr) +} declare 423 { void Tcl_InitCustomHashTable(Tcl_HashTable *tablePtr, int keyType, const Tcl_HashKeyType *typePtr) @@ -1324,16 +1521,16 @@ declare 427 { int flags, Tcl_CommandTraceProc *proc, void *clientData) } declare 428 { - void *Tcl_AttemptAlloc(TCL_HASH_TYPE size) + char *Tcl_AttemptAlloc(TCL_HASH_TYPE size) } declare 429 { - void *Tcl_AttemptDbCkalloc(TCL_HASH_TYPE size, const char *file, int line) + char *Tcl_AttemptDbCkalloc(TCL_HASH_TYPE size, const char *file, int line) } declare 430 { - void *Tcl_AttemptRealloc(void *ptr, TCL_HASH_TYPE size) + char *Tcl_AttemptRealloc(char *ptr, TCL_HASH_TYPE size) } declare 431 { - void *Tcl_AttemptDbCkrealloc(void *ptr, TCL_HASH_TYPE size, + char *Tcl_AttemptDbCkrealloc(char *ptr, TCL_HASH_TYPE size, const char *file, int line) } declare 432 { @@ -1347,7 +1544,17 @@ declare 433 { # introduced in 8.4a3 declare 434 { - Tcl_UniChar *TclGetUnicodeFromObj(Tcl_Obj *objPtr, void *lengthPtr) + unsigned short *Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, Tcl_Size *lengthPtr) +} + +# TIP#15 (math function introspection) dkf +declare 435 {deprecated {}} { + int Tcl_GetMathFuncInfo(Tcl_Interp *interp, const char *name, + int *numArgsPtr, Tcl_ValueType **argTypesPtr, + Tcl_MathProc **procPtr, void **clientDataPtr) +} +declare 436 {deprecated {}} { + Tcl_Obj *Tcl_ListMathFuncs(Tcl_Interp *interp, const char *pattern) } # TIP#36 (better access to 'subst') dkf @@ -1410,7 +1617,7 @@ declare 452 { int index, Tcl_Obj *pathPtr, Tcl_Obj *objPtr) } declare 453 { - const char *const *Tcl_FSFileAttrStrings(Tcl_Obj *pathPtr, + const char *CONST86 *Tcl_FSFileAttrStrings(Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef) } declare 454 { @@ -1436,7 +1643,7 @@ declare 460 { Tcl_Obj *Tcl_FSJoinPath(Tcl_Obj *listObj, Tcl_Size elements) } declare 461 { - Tcl_Obj *TclFSSplitPath(Tcl_Obj *pathPtr, void *lenPtr) + Tcl_Obj *Tcl_FSSplitPath(Tcl_Obj *pathPtr, Tcl_Size *lenPtr) } declare 462 { int Tcl_FSEqualPaths(Tcl_Obj *firstPtr, Tcl_Obj *secondPtr) @@ -1488,7 +1695,7 @@ declare 476 { Tcl_Obj *pathPtr) } declare 477 { - const Tcl_Filesystem *Tcl_FSGetFileSystemForPath(Tcl_Obj *pathPtr) + CONST86 Tcl_Filesystem *Tcl_FSGetFileSystemForPath(Tcl_Obj *pathPtr) } declare 478 { Tcl_PathType Tcl_FSGetPathType(Tcl_Obj *pathPtr) @@ -1575,7 +1782,7 @@ declare 496 { Tcl_Obj *keyPtr) } declare 497 { - int TclDictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, void *sizePtr) + int Tcl_DictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Size *sizePtr) } declare 498 { int Tcl_DictObjFirst(Tcl_Interp *interp, Tcl_Obj *dictPtr, @@ -1663,6 +1870,11 @@ declare 518 { const char *encodingName) } +# TIP#121 (exit handler) dkf for Joe Mistachkin +declare 519 {nostub {Don't use this function in a stub-enabled extension}} { + Tcl_ExitProc *Tcl_SetExitProc(Tcl_ExitProc *proc) +} + # TIP#143 (resource limits) dkf declare 520 { void Tcl_LimitAddHandler(Tcl_Interp *interp, int type, @@ -1998,8 +2210,8 @@ declare 603 { # TIP#265 (option parser) dkf for Sam Bromley declare 604 { - int TclParseArgsObjv(Tcl_Interp *interp, const Tcl_ArgvInfo *argTable, - void *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv) + int Tcl_ParseArgsObjv(Tcl_Interp *interp, const Tcl_ArgvInfo *argTable, + Tcl_Size *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv) } # TIP#336 (manipulate the error line) dgp @@ -2196,28 +2408,10 @@ declare 648 { # TIP #568 declare 649 { - unsigned char *TclGetBytesFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - void *numBytesPtr) -} -declare 650 { unsigned char *Tcl_GetBytesFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Size *numBytesPtr) } -# TIP #481 -declare 651 { - char *Tcl_GetStringFromObj(Tcl_Obj *objPtr, Tcl_Size *lengthPtr) -} -declare 652 { - Tcl_UniChar *Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, Tcl_Size *lengthPtr) -} - -# TIP 660 -declare 653 { - int Tcl_GetSizeIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, - Tcl_Size *sizePtr) -} - # TIP #575 declare 654 { int Tcl_UtfCharComplete(const char *src, Tcl_Size length) @@ -2246,51 +2440,24 @@ declare 660 { int Tcl_AsyncMarkFromSignal(Tcl_AsyncHandler async, int sigNumber) } -# TIP #616 -declare 661 { - int Tcl_ListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr, - Tcl_Size *objcPtr, Tcl_Obj ***objvPtr) -} -declare 662 { - int Tcl_ListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr, - Tcl_Size *lengthPtr) -} -declare 663 { - int Tcl_DictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Size *sizePtr) -} -declare 664 { - int Tcl_SplitList(Tcl_Interp *interp, const char *listStr, Tcl_Size *argcPtr, - const char ***argvPtr) -} -declare 665 { - void Tcl_SplitPath(const char *path, Tcl_Size *argcPtr, const char ***argvPtr) -} -declare 666 { - Tcl_Obj *Tcl_FSSplitPath(Tcl_Obj *pathPtr, Tcl_Size *lenPtr) -} -declare 667 { - int Tcl_ParseArgsObjv(Tcl_Interp *interp, const Tcl_ArgvInfo *argTable, - Tcl_Size *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv) -} - # TIP #617 declare 668 { Tcl_Size Tcl_UniCharLen(const int *uniStr) } declare 669 { - Tcl_Size Tcl_NumUtfChars(const char *src, Tcl_Size length) + Tcl_Size TclNumUtfChars(const char *src, Tcl_Size length) } declare 670 { - Tcl_Size Tcl_GetCharLength(Tcl_Obj *objPtr) + Tcl_Size TclGetCharLength(Tcl_Obj *objPtr) } declare 671 { - const char *Tcl_UtfAtIndex(const char *src, Tcl_Size index) + const char *TclUtfAtIndex(const char *src, Tcl_Size index) } declare 672 { - Tcl_Obj *Tcl_GetRange(Tcl_Obj *objPtr, Tcl_Size first, Tcl_Size last) + Tcl_Obj *TclGetRange(Tcl_Obj *objPtr, Tcl_Size first, Tcl_Size last) } declare 673 { - int Tcl_GetUniChar(Tcl_Obj *objPtr, Tcl_Size index) + int TclGetUniChar(Tcl_Obj *objPtr, Tcl_Size index) } declare 674 { @@ -2301,28 +2468,6 @@ declare 675 { int Tcl_GetBoolFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, char *charPtr) } -declare 676 { - Tcl_Command Tcl_CreateObjCommand2(Tcl_Interp *interp, - const char *cmdName, - Tcl_ObjCmdProc2 *proc2, void *clientData, - Tcl_CmdDeleteProc *deleteProc) -} -declare 677 { - Tcl_Trace Tcl_CreateObjTrace2(Tcl_Interp *interp, Tcl_Size level, int flags, - Tcl_CmdObjTraceProc2 *objProc2, void *clientData, - Tcl_CmdObjTraceDeleteProc *delProc) -} -declare 678 { - Tcl_Command Tcl_NRCreateCommand2(Tcl_Interp *interp, - const char *cmdName, Tcl_ObjCmdProc2 *proc, - Tcl_ObjCmdProc2 *nreProc2, void *clientData, - Tcl_CmdDeleteProc *deleteProc) -} -declare 679 { - int Tcl_NRCallObjProc2(Tcl_Interp *interp, Tcl_ObjCmdProc2 *objProc2, - void *clientData, Tcl_Size objc, Tcl_Obj *const objv[]) -} - # TIP #638. declare 680 { int Tcl_GetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, @@ -2355,10 +2500,10 @@ declare 685 { } declare 686 { - int Tcl_UtfNcmp(const char *s1, const char *s2, size_t n) + int TclUtfNcmp(const char *s1, const char *s2, size_t n) } declare 687 { - int Tcl_UtfNcasecmp(const char *s1, const char *s2, size_t n) + int TclUtfNcasecmp(const char *s1, const char *s2, size_t n) } # TIP #648 @@ -2389,18 +2534,32 @@ interface tclPlat ################################ # Mac OS X specific functions -declare 1 { +declare 0 macosx { + int Tcl_MacOSXOpenBundleResources(Tcl_Interp *interp, + const char *bundleName, int hasResourceFile, + Tcl_Size maxPathLen, char *libraryPath) +} +declare 1 macosx { int Tcl_MacOSXOpenVersionedBundleResources(Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, int hasResourceFile, Tcl_Size maxPathLen, char *libraryPath) } -declare 2 { +declare 2 macosx { void Tcl_MacOSXNotifierAddRunLoopMode(const void *runLoopMode) } ################################ # Windows specific functions -declare 3 { + +# Added in Tcl 8.1 + +declare 0 win { + TCHAR *Tcl_WinUtfToTChar(const char *str, int len, Tcl_DString *dsPtr) +} +declare 1 win { + char *Tcl_WinTCharToUtf(const TCHAR *str, int len, Tcl_DString *dsPtr) +} +declare 3 win { void Tcl_WinConvertError(unsigned errCode) } @@ -2409,6 +2568,9 @@ declare 3 { # Public functions that are not accessible via the stubs table. export { + TCL_NORETURN void Tcl_Main(Tcl_Size argc, char **argv, Tcl_AppInitProc *appInitProc) +} +export { TCL_NORETURN void Tcl_MainEx(Tcl_Size argc, char **argv, Tcl_AppInitProc *appInitProc, Tcl_Interp *interp) } diff --git a/generic/tcl.h b/generic/tcl.h index e40e8a9..7afd119 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -48,18 +48,34 @@ extern "C" { */ #if !defined(TCL_MAJOR_VERSION) -# define TCL_MAJOR_VERSION 9 +# define TCL_MAJOR_VERSION 8 #endif -#if TCL_MAJOR_VERSION == 9 -# define TCL_MINOR_VERSION 0 -# define TCL_RELEASE_LEVEL TCL_BETA_RELEASE -# define TCL_RELEASE_SERIAL 2 +#if TCL_MAJOR_VERSION != 8 +# error "This header-file is for Tcl 8 only" +#endif +#define TCL_MINOR_VERSION 7 +#define TCL_RELEASE_LEVEL TCL_BETA_RELEASE +#define TCL_RELEASE_SERIAL 1 -# define TCL_VERSION "9.0" -# define TCL_PATCH_LEVEL "9.0b2" -#endif /* TCL_MAJOR_VERSION */ +#define TCL_VERSION "8.7" +#define TCL_PATCH_LEVEL "8.7b1" -#if defined(RC_INVOKED) +#if !defined(TCL_NO_DEPRECATED) || defined(RC_INVOKED) +/* + *---------------------------------------------------------------------------- + * The following definitions set up the proper options for Windows compilers. + * We use this method because there is no autoconf equivalent. + */ + +#ifdef _WIN32 +# ifndef __WIN32__ +# define __WIN32__ +# endif +# ifndef WIN32 +# define WIN32 +# endif +#endif + /* * Utility macros: STRINGIFY takes an argument and wraps it in "" (double * quotation marks), JOIN joins two arguments. @@ -73,7 +89,11 @@ extern "C" { # define JOIN(a,b) JOIN1(a,b) # define JOIN1(a,b) a##b #endif -#endif /* RC_INVOKED */ + +#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 @@ -105,6 +125,23 @@ extern "C" { #include <stdio.h> #include <stddef.h> +/* + *---------------------------------------------------------------------------- + * Support for functions with a variable number of arguments. + * + * The following TCL_VARARGS* macros are to support old extensions + * written for older versions of Tcl where the macros permitted + * support for the varargs.h system as well as stdarg.h . + * + * New code should just directly be written to use stdarg.h conventions. + */ + +#include <stdarg.h> +#ifndef TCL_NO_DEPRECATED +# 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 /* !TCL_NO_DEPRECATED */ #if defined(__GNUC__) && (__GNUC__ > 2) # if defined(_WIN32) && defined(__USE_MINGW_ANSI_STDIO) && __USE_MINGW_ANSI_STDIO # define TCL_FORMAT_PRINTF(a,b) __attribute__ ((__format__ (__MINGW_PRINTF_FORMAT, a, b))) @@ -113,7 +150,11 @@ extern "C" { # endif # define TCL_NORETURN __attribute__ ((noreturn)) # define TCL_NOINLINE __attribute__ ((noinline)) -# define TCL_NORETURN1 __attribute__ ((noreturn)) +# if defined(BUILD_tcl) || defined(BUILD_tk) +# define TCL_NORETURN1 __attribute__ ((noreturn)) +# else +# define TCL_NORETURN1 /* nothing */ +# endif #else # define TCL_FORMAT_PRINTF(a,b) # if defined(_MSC_VER) @@ -208,7 +249,33 @@ extern "C" { # endif #endif -#if !defined(CONST86) && !defined(TCL_NO_DEPRECATED) +/* + * The following _ANSI_ARGS_ macro is to support old extensions + * written for older versions of Tcl where it permitted support + * for compilers written in the pre-prototype era of C. + * + * New code should use prototypes. + */ + +#ifndef TCL_NO_DEPRECATED +# undef _ANSI_ARGS_ +# define _ANSI_ARGS_(x) x + +/* + * Definitions that allow this header file to be used either with or without + * ANSI C features. + */ + +#ifndef INLINE +# define INLINE +#endif +#ifndef CONST +# define CONST const +#endif + +#endif /* !TCL_NO_DEPRECATED */ + +#ifndef CONST86 # define CONST86 const #endif @@ -227,6 +294,33 @@ extern "C" { #endif /* + *---------------------------------------------------------------------------- + * The following code is copied from winnt.h. If we don't replicate it here, + * then <windows.h> can't be included after tcl.h, since tcl.h also defines + * VOID. This block is skipped under Cygwin and Mingw. + */ + +#ifndef TCL_NO_DEPRECATED +#if defined(_WIN32) +#ifndef VOID +#define VOID void +typedef char CHAR; +typedef short SHORT; +typedef long LONG; +#endif +#endif /* _WIN32 */ + +/* + * Macro to use instead of "void" for arguments that must have type "void *" + * in ANSI C; maps them to type "char *" in non-ANSI systems. + */ + +#ifndef __VXWORKS__ +# define VOID void +#endif +#endif /* !TCL_NO_DEPRECATED */ + +/* * Miscellaneous declarations. */ @@ -327,7 +421,7 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; # define TCL_SIZE_MODIFIER "" #else typedef ptrdiff_t Tcl_Size; -# define TCL_SIZE_MAX ((Tcl_Size)(((size_t)-1)>>1)) +# define TCL_SIZE_MAX ((ptrdiff_t)(((size_t)-1)>>1)) # define TCL_SIZE_MODIFIER TCL_T_MODIFIER #endif /* TCL_MAJOR_VERSION */ @@ -355,6 +449,10 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; struct {long tv_sec;} st_mtim; struct {long tv_sec;} st_ctim; } Tcl_StatBuf; +#elif defined(HAVE_STRUCT_STAT64) && !defined(__APPLE__) \ + && (!defined(_FILE_OFFSET_BITS) || _FILE_OFFSET_BITS != 64) \ + && (!defined(_TIME_BITS) || _TIME_BITS != 64) + typedef struct stat64 Tcl_StatBuf; #else typedef struct stat Tcl_StatBuf; #endif @@ -362,9 +460,35 @@ typedef unsigned TCL_WIDE_INT_TYPE Tcl_WideUInt; /* *---------------------------------------------------------------------------- * Data structures defined opaquely in this module. The definitions below just - * provide dummy types. + * provide dummy types. A few fields are made visible in Tcl_Interp + * structures, namely those used for returning a string result from commands. + * Direct access to the result field is discouraged in Tcl 8.0. The + * interpreter result is either an object or a string, and the two values are + * kept consistent unless some C code sets interp->result directly. + * Programmers should use either the function Tcl_GetObjResult() or + * Tcl_GetStringResult() to read the interpreter's result. See the SetResult + * man page for details. + * + * Note: any change to the Tcl_Interp definition below must be mirrored in the + * "real" definition in tclInt.h. + * + * Note: Tcl_ObjCmdProc functions do not directly set result and freeProc. + * Instead, they set a Tcl_Obj member in the "real" structure that can be + * accessed with Tcl_GetObjResult() and Tcl_SetObjResult(). */ +typedef struct Tcl_Interp +#ifndef TCL_NO_DEPRECATED +{ + /* TIP #330: Strongly discourage extensions from using the string + * result. */ + char *resultDontUse; /* Don't use in extensions! */ + void (*freeProcDontUse) (char *); /* Don't use in extensions! */ + int errorLineDontUse; /* Don't use in extensions! */ +} +#endif /* !TCL_NO_DEPRECATED */ +Tcl_Interp; + typedef struct Tcl_AsyncHandler_ *Tcl_AsyncHandler; typedef struct Tcl_Channel_ *Tcl_Channel; typedef struct Tcl_ChannelTypeVersion_ *Tcl_ChannelTypeVersion; @@ -374,7 +498,6 @@ typedef struct Tcl_Dict_ *Tcl_Dict; typedef struct Tcl_EncodingState_ *Tcl_EncodingState; typedef struct Tcl_Encoding_ *Tcl_Encoding; typedef struct Tcl_Event Tcl_Event; -typedef struct Tcl_Interp Tcl_Interp; typedef struct Tcl_InterpState_ *Tcl_InterpState; typedef struct Tcl_LoadHandle_ *Tcl_LoadHandle; typedef struct Tcl_Mutex_ *Tcl_Mutex; @@ -522,6 +645,10 @@ typedef struct stat *Tcl_OldStat_; #define TCL_BREAK 3 #define TCL_CONTINUE 4 +#ifndef TCL_NO_DEPRECATED +#define TCL_RESULT_SIZE 200 +#endif + /* *---------------------------------------------------------------------------- * Flags to control what substitutions are performed by Tcl_SubstObj(): @@ -533,6 +660,27 @@ typedef struct stat *Tcl_OldStat_; #define TCL_SUBST_ALL 007 /* + * Argument descriptors for math function callbacks in expressions: + */ + +#ifndef TCL_NO_DEPRECATED +typedef enum { + TCL_INT, TCL_DOUBLE, TCL_EITHER, TCL_WIDE_INT +} Tcl_ValueType; + +typedef struct Tcl_Value { + Tcl_ValueType type; /* Indicates intValue or doubleValue is valid, + * or both. */ + long intValue; /* Integer 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 * reference to Tcl_Obj is encountered in the function types declared below. */ @@ -558,6 +706,7 @@ typedef void (Tcl_CmdTraceProc) (void *clientData, Tcl_Interp *interp, typedef int (Tcl_CmdObjTraceProc) (void *clientData, Tcl_Interp *interp, int level, const char *command, Tcl_Command commandInfo, int objc, struct Tcl_Obj *const *objv); +#define Tcl_CmdObjTraceProc2 Tcl_CmdObjTraceProc typedef void (Tcl_CmdObjTraceDeleteProc) (void *clientData); typedef void (Tcl_DupInternalRepProc) (struct Tcl_Obj *srcPtr, struct Tcl_Obj *dupPtr); @@ -573,28 +722,16 @@ typedef void (Tcl_ExitProc) (void *clientData); typedef void (Tcl_FileProc) (void *clientData, int mask); typedef void (Tcl_FileFreeProc) (void *clientData); typedef void (Tcl_FreeInternalRepProc) (struct Tcl_Obj *objPtr); +typedef void (Tcl_FreeProc) (char *blockPtr); typedef void (Tcl_IdleProc) (void *clientData); typedef void (Tcl_InterpDeleteProc) (void *clientData, Tcl_Interp *interp); +typedef int (Tcl_MathProc) (void *clientData, Tcl_Interp *interp, + Tcl_Value *args, Tcl_Value *resultPtr); typedef void (Tcl_NamespaceDeleteProc) (void *clientData); typedef int (Tcl_ObjCmdProc) (void *clientData, Tcl_Interp *interp, int objc, struct Tcl_Obj *const *objv); -#if TCL_MAJOR_VERSION > 8 -typedef int (Tcl_ObjCmdProc2) (void *clientData, Tcl_Interp *interp, - Tcl_Size objc, struct Tcl_Obj *const *objv); -typedef int (Tcl_CmdObjTraceProc2) (void *clientData, Tcl_Interp *interp, - Tcl_Size level, const char *command, Tcl_Command commandInfo, Tcl_Size objc, - struct Tcl_Obj *const *objv); -typedef void (Tcl_FreeProc) (void *blockPtr); -#define Tcl_ExitProc Tcl_FreeProc -#define Tcl_FileFreeProc Tcl_FreeProc -#define Tcl_FileFreeProc Tcl_FreeProc -#define Tcl_EncodingFreeProc Tcl_FreeProc -#else #define Tcl_ObjCmdProc2 Tcl_ObjCmdProc -#define Tcl_CmdObjTraceProc2 Tcl_CmdObjTraceProc -typedef void (Tcl_FreeProc) (char *blockPtr); -#endif typedef int (Tcl_LibraryInitProc) (Tcl_Interp *interp); typedef int (Tcl_LibraryUnloadProc) (Tcl_Interp *interp, int flags); typedef void (Tcl_PanicProc) (const char *format, ...); @@ -616,28 +753,6 @@ typedef void *(Tcl_InitNotifierProc) (void); typedef void (Tcl_FinalizeNotifierProc) (void *clientData); typedef void (Tcl_MainLoopProc) (void); -/* Abstract List functions */ -typedef Tcl_Size (Tcl_ObjTypeLengthProc) (struct Tcl_Obj *listPtr); -typedef int (Tcl_ObjTypeIndexProc) (Tcl_Interp *interp, struct Tcl_Obj *listPtr, - Tcl_Size index, struct Tcl_Obj** elemObj); -typedef int (Tcl_ObjTypeSliceProc) (Tcl_Interp *interp, struct Tcl_Obj *listPtr, - Tcl_Size fromIdx, Tcl_Size toIdx, - struct Tcl_Obj **newObjPtr); -typedef int (Tcl_ObjTypeReverseProc) (Tcl_Interp *interp, struct Tcl_Obj *listPtr, - struct Tcl_Obj **newObjPtr); -typedef int (Tcl_ObjTypeGetElements) (Tcl_Interp *interp, struct Tcl_Obj *listPtr, - Tcl_Size *objcptr, struct Tcl_Obj ***objvptr); -typedef struct Tcl_Obj* (Tcl_ObjTypeSetElement) (Tcl_Interp *interp, struct Tcl_Obj *listPtr, - Tcl_Size indexCount, - struct Tcl_Obj *const indexArray[], - struct Tcl_Obj *valueObj); -typedef int (Tcl_ObjTypeReplaceProc) (Tcl_Interp *interp, struct Tcl_Obj *listObj, - Tcl_Size first, Tcl_Size numToDelete, - Tcl_Size numToInsert, - struct Tcl_Obj *const insertObjs[]); -typedef int (Tcl_ObjTypeInOperatorProc) (Tcl_Interp *interp, struct Tcl_Obj *valueObj, - struct Tcl_Obj *listObj, int *boolResult); - #ifndef TCL_NO_DEPRECATED # define Tcl_PackageInitProc Tcl_LibraryInitProc # define Tcl_PackageUnloadProc Tcl_LibraryUnloadProc @@ -666,40 +781,10 @@ typedef struct Tcl_ObjType { /* Called to convert the object's internal rep * to this type. Frees the internal rep of the * old type. Returns TCL_ERROR on failure. */ -#if TCL_MAJOR_VERSION > 8 - size_t version; - - /* List emulation functions - ObjType Version 1 */ - Tcl_ObjTypeLengthProc *lengthProc; /* Return the [llength] of the - ** AbstractList */ - Tcl_ObjTypeIndexProc *indexProc; /* Return a value (Tcl_Obj) for - ** [lindex $al $index] */ - Tcl_ObjTypeSliceProc *sliceProc; /* Return an AbstractList for - ** [lrange $al $start $end] */ - Tcl_ObjTypeReverseProc *reverseProc; /* Return an AbstractList for - ** [lreverse $al] */ - Tcl_ObjTypeGetElements *getElementsProc; /* Return an objv[] of all elements in - ** the list */ - Tcl_ObjTypeSetElement *setElementProc; /* Replace the element at the indicie - ** with the given valueObj. */ - Tcl_ObjTypeReplaceProc *replaceProc; /* Replace subset with subset */ - Tcl_ObjTypeInOperatorProc *inOperProc; /* "in" and "ni" expr list - ** operation Determine if the given - ** string value matches an element in - ** the list */ -#endif } Tcl_ObjType; - -#if TCL_MAJOR_VERSION > 8 -# define TCL_OBJTYPE_V0 0, \ - 0,0,0,0,0,0,0,0 /* Pre-Tcl 9 */ -# define TCL_OBJTYPE_V1(a) offsetof(Tcl_ObjType, indexProc), \ - a,0,0,0,0,0,0,0 /* Tcl 9 Version 1 */ -# define TCL_OBJTYPE_V2(a,b,c,d,e,f,g,h) sizeof(Tcl_ObjType), \ - a,b,c,d,e,f,g,h /* Tcl 9 - AbstractLists */ -#else -# define TCL_OBJTYPE_V0 /* just empty */ -#endif +#define TCL_OBJTYPE_V0 /* just empty */ +#define TCL_OBJTYPE_V1(a) /* just empty */ +#define TCL_OBJTYPE_V2(a,b,c,d,e,f,g,h) /* just empty */ /* * The following structure stores an internal representation (internalrep) for @@ -737,7 +822,7 @@ typedef struct Tcl_Obj { * must be followed by a null byte (i.e., at * offset length) but may also contain * embedded null characters. The array's - * storage is allocated by Tcl_Alloc. NULL means + * storage is allocated by ckalloc. NULL means * the string rep is invalid and must be * regenerated from the internal rep. Clients * should use Tcl_GetStringFromObj or @@ -755,6 +840,25 @@ typedef struct Tcl_Obj { /* *---------------------------------------------------------------------------- + * The following structure contains the state needed by Tcl_SaveResult. No-one + * outside of Tcl should access any of these fields. This structure is + * typically allocated on the stack. + */ + +#ifndef TCL_NO_DEPRECATED +typedef struct Tcl_SavedResult { + char *result; + Tcl_FreeProc *freeProc; + Tcl_Obj *objResultPtr; + char *appendResult; + int appendAvl; + int appendUsed; + char resultSpace[200+1]; +} Tcl_SavedResult; +#endif + +/* + *---------------------------------------------------------------------------- * The following definitions support Tcl's namespace facility. Note: the first * five fields must match exactly the fields in a Namespace structure (see * tclInt.h). @@ -833,7 +937,7 @@ typedef struct Tcl_CallFrame { * then calls the other function. */ -typedef struct { +typedef struct Tcl_CmdInfo { int isNativeObjectProc; /* 1 if objProc was registered by a call to * Tcl_CreateObjCommand; 2 if objProc was registered by * a call to Tcl_CreateObjCommand2; 0 otherwise. @@ -852,8 +956,8 @@ typedef struct { * change a command's namespace; use * TclRenameCommand or Tcl_Eval (of 'rename') * to do that. */ - Tcl_ObjCmdProc2 *objProc2; /* Command's object2-based function. */ - void *objClientData2; /* ClientData for object2 proc. */ + Tcl_ObjCmdProc2 *objProc2; /* Not used in Tcl 8.7. */ + void *objClientData2; /* Not used in Tcl 8.7. */ } Tcl_CmdInfo; /* @@ -867,8 +971,8 @@ typedef struct { typedef struct Tcl_DString { char *string; /* Points to beginning of string: either * staticSpace below or a malloced array. */ - Tcl_Size length; /* Number of bytes in string excluding - * terminating nul */ + Tcl_Size length; /* Number of non-NULL characters in the + * string. */ Tcl_Size spaceAvl; /* Total number of bytes available for the * string and its terminating NULL char. */ char staticSpace[TCL_DSTRING_STATIC_SIZE]; @@ -878,6 +982,9 @@ typedef struct Tcl_DString { #define Tcl_DStringLength(dsPtr) ((dsPtr)->length) #define Tcl_DStringValue(dsPtr) ((dsPtr)->string) +#ifndef TCL_NO_DEPRECATED +# define Tcl_DStringTrunc Tcl_DStringSetLength +#endif /* * Definitions for the maximum number of digits of precision that may be @@ -938,7 +1045,7 @@ typedef struct Tcl_DString { /* * Flags that may be passed to Tcl_UniCharToUtf. - * TCL_COMBINE Combine surrogates + * TCL_COMBINE Combine surrogates (default in Tcl 8.x) */ #if TCL_MAJOR_VERSION > 8 @@ -999,8 +1106,16 @@ typedef struct Tcl_DString { #define TCL_TRACE_UNSETS 0x40 #define TCL_TRACE_DESTROYED 0x80 +#ifndef TCL_NO_DEPRECATED +#define TCL_INTERP_DESTROYED 0x100 +#endif + #define TCL_LEAVE_ERR_MSG 0x200 #define TCL_TRACE_ARRAY 0x800 +#ifndef TCL_NO_DEPRECATED +/* Required to support old variable/vdelete/vinfo traces. */ +#define TCL_TRACE_OLD_STYLE 0x1000 +#endif /* Indicate the semantics of the result of a trace. */ #define TCL_TRACE_RESULT_DYNAMIC 0x8000 #define TCL_TRACE_RESULT_OBJECT 0x10000 @@ -1023,6 +1138,17 @@ typedef struct Tcl_DString { #define TCL_ALLOW_INLINE_COMPILATION 0x20000 /* + * The TCL_PARSE_PART1 flag is deprecated and has no effect. The part1 is now + * always parsed whenever the part2 is NULL. (This is to avoid a common error + * when converting code to use the new object based APIs and forgetting to + * give the flag) + */ + +#ifndef TCL_NO_DEPRECATED +# define TCL_PARSE_PART1 0x400 +#endif + +/* * Types for linked variables: */ @@ -1036,8 +1162,13 @@ typedef struct Tcl_DString { #define TCL_LINK_SHORT 8 #define TCL_LINK_USHORT 9 #define TCL_LINK_UINT 10 +#if defined(TCL_WIDE_INT_IS_LONG) || defined(_WIN32) || defined(__CYGWIN__) #define TCL_LINK_LONG ((sizeof(long) != sizeof(int)) ? TCL_LINK_WIDE_INT : TCL_LINK_INT) #define TCL_LINK_ULONG ((sizeof(long) != sizeof(int)) ? TCL_LINK_WIDE_UINT : TCL_LINK_UINT) +#else +#define TCL_LINK_LONG 11 +#define TCL_LINK_ULONG 12 +#endif #define TCL_LINK_FLOAT 13 #define TCL_LINK_WIDE_UINT 14 #define TCL_LINK_CHARS 15 @@ -1076,7 +1207,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. */ - size_t hash; /* Hash value. */ + void *hash; /* Hash value, stored as pointer to ensure + * that the offsets of the fields in this + * structure are not changed. */ void *clientData; /* Application stores something here with * Tcl_SetHashValue. */ union { /* Key has one of these forms: */ @@ -1305,20 +1438,12 @@ typedef enum { */ typedef struct Tcl_Time { -#if TCL_MAJOR_VERSION > 8 - long long sec; /* Seconds. */ -#else long sec; /* Seconds. */ -#endif -#if defined(_CYGWIN_) && TCL_MAJOR_VERSION > 8 - int usec; /* Microseconds. */ -#else long usec; /* Microseconds. */ -#endif } Tcl_Time; -typedef void (Tcl_SetTimerProc) (const Tcl_Time *timePtr); -typedef int (Tcl_WaitForEventProc) (const Tcl_Time *timePtr); +typedef void (Tcl_SetTimerProc) (CONST86 Tcl_Time *timePtr); +typedef int (Tcl_WaitForEventProc) (CONST86 Tcl_Time *timePtr); /* * TIP #233 (Virtualized Time) @@ -1364,13 +1489,19 @@ typedef void (Tcl_ScaleTimeProc) (Tcl_Time *timebuf, void *clientData); #if TCL_MAJOR_VERSION > 8 # define TCL_CLOSE2PROC NULL #else -# define TCL_CLOSE2PROC ((void *) 1) +# define TCL_CLOSE2PROC ((Tcl_DriverCloseProc *)(void *)(size_t)1) #endif /* * Channel version tag. This was introduced in 8.3.2/8.4. */ +#ifndef TCL_NO_DEPRECATED +#define TCL_CHANNEL_VERSION_1 ((Tcl_ChannelTypeVersion) 0x1) +#define TCL_CHANNEL_VERSION_2 ((Tcl_ChannelTypeVersion) 0x2) +#define TCL_CHANNEL_VERSION_3 ((Tcl_ChannelTypeVersion) 0x3) +#define TCL_CHANNEL_VERSION_4 ((Tcl_ChannelTypeVersion) 0x4) +#endif #define TCL_CHANNEL_VERSION_5 ((Tcl_ChannelTypeVersion) 0x5) /* @@ -1385,14 +1516,16 @@ typedef void (Tcl_ScaleTimeProc) (Tcl_Time *timebuf, void *clientData); */ typedef int (Tcl_DriverBlockModeProc) (void *instanceData, int mode); -typedef void Tcl_DriverCloseProc; +typedef int (Tcl_DriverCloseProc) (void *instanceData, + Tcl_Interp *interp); typedef int (Tcl_DriverClose2Proc) (void *instanceData, Tcl_Interp *interp, int flags); typedef int (Tcl_DriverInputProc) (void *instanceData, char *buf, int toRead, int *errorCodePtr); typedef int (Tcl_DriverOutputProc) (void *instanceData, const char *buf, int toWrite, int *errorCodePtr); -typedef void Tcl_DriverSeekProc; +typedef int (Tcl_DriverSeekProc) (void *instanceData, long offset, + int mode, int *errorCodePtr); typedef int (Tcl_DriverSetOptionProc) (void *instanceData, Tcl_Interp *interp, const char *optionName, const char *value); @@ -1435,12 +1568,17 @@ typedef struct Tcl_ChannelType { * type. */ Tcl_ChannelTypeVersion version; /* Version of the channel type. */ - void *closeProc; /* Not used any more. */ + Tcl_DriverCloseProc *closeProc; + /* Function to call to close the channel, or + * NULL or TCL_CLOSE2PROC if the close2Proc should be + * used instead. */ Tcl_DriverInputProc *inputProc; /* Function to call for input on channel. */ Tcl_DriverOutputProc *outputProc; /* Function to call for output on channel. */ - void *seekProc; /* Not used any more. */ + Tcl_DriverSeekProc *seekProc; + /* Function to call to seek on the channel. + * May be NULL. */ Tcl_DriverSetOptionProc *setOptionProc; /* Set an option on a channel. */ Tcl_DriverGetOptionProc *getOptionProc; @@ -1458,6 +1596,9 @@ typedef struct Tcl_ChannelType { Tcl_DriverBlockModeProc *blockModeProc; /* Set blocking mode for the raw channel. May * be NULL. */ + /* + * Only valid in TCL_CHANNEL_VERSION_2 channels or later. + */ Tcl_DriverFlushProc *flushProc; /* Function to call to flush a channel. May be * NULL. */ @@ -1465,15 +1606,26 @@ typedef struct Tcl_ChannelType { /* Function to call to handle a channel event. * This will be passed up the stacked channel * chain. */ + /* + * Only valid in TCL_CHANNEL_VERSION_3 channels or later. + */ Tcl_DriverWideSeekProc *wideSeekProc; /* Function to call to seek on the channel * which can handle 64-bit offsets. May be * NULL, and must be NULL if seekProc is * NULL. */ + /* + * Only valid in TCL_CHANNEL_VERSION_4 channels or later. + * TIP #218, Channel Thread Actions. + */ Tcl_DriverThreadActionProc *threadActionProc; /* Function to call to notify the driver of * thread specific activity for a channel. May * be NULL. */ + /* + * Only valid in TCL_CHANNEL_VERSION_5 channels or later. + * TIP #208, File Truncation. + */ Tcl_DriverTruncateProc *truncateProc; /* Function to call to truncate the underlying * file to a particular length. May be NULL if @@ -1569,7 +1721,7 @@ typedef int (Tcl_FSNormalizePathProc) (Tcl_Interp *interp, Tcl_Obj *pathPtr, int nextCheckpoint); typedef int (Tcl_FSFileAttrsGetProc) (Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); -typedef const char *const * (Tcl_FSFileAttrStringsProc) (Tcl_Obj *pathPtr, +typedef const char *CONST86 * (Tcl_FSFileAttrStringsProc) (Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); typedef int (Tcl_FSFileAttrsSetProc) (Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj *objPtr); @@ -1581,7 +1733,7 @@ typedef int (Tcl_FSPathInFilesystemProc) (Tcl_Obj *pathPtr, void **clientDataPtr); typedef Tcl_Obj * (Tcl_FSFilesystemPathTypeProc) (Tcl_Obj *pathPtr); typedef Tcl_Obj * (Tcl_FSFilesystemSeparatorProc) (Tcl_Obj *pathPtr); -#define Tcl_FSFreeInternalRepProc Tcl_FreeProc +typedef void (Tcl_FSFreeInternalRepProc) (void *clientData); typedef void *(Tcl_FSDupInternalRepProc) (void *clientData); typedef Tcl_Obj * (Tcl_FSInternalToNormalizedProc) (void *clientData); typedef void *(Tcl_FSCreateInternalRepProc) (Tcl_Obj *pathPtr); @@ -1964,7 +2116,7 @@ typedef struct Tcl_EncodingType { Tcl_EncodingConvertProc *fromUtfProc; /* Function to convert from UTF-8 into * external encoding. */ - Tcl_FreeProc *freeProc; + Tcl_EncodingFreeProc *freeProc; /* If non-NULL, function to call when this * encoding is deleted. */ void *clientData; /* Arbitrary value associated with encoding @@ -1996,7 +2148,14 @@ typedef struct Tcl_EncodingType { * reset to an initial state. If the source * buffer contains the entire input stream to be * converted, this flag should be set. - * TCL_ENCODING_STOPONERROR - Not used any more. + * TCL_ENCODING_STOPONERROR - If set, the converter returns immediately upon + * encountering an invalid byte sequence or a + * source character that has no mapping in the + * target encoding. If clear, the converter + * substitutes the problematic character(s) with + * one or more "close" characters in the + * destination buffer and then continues to + * convert the source. Only for Tcl 8.x. * TCL_ENCODING_NO_TERMINATE - If set, Tcl_ExternalToUtf does not append a * terminating NUL byte. Since it does not need * an extra byte for a terminating NUL, it fills @@ -2021,11 +2180,7 @@ typedef struct Tcl_EncodingType { #define TCL_ENCODING_START 0x01 #define TCL_ENCODING_END 0x02 -#if TCL_MAJOR_VERSION > 8 -# define TCL_ENCODING_STOPONERROR 0x0 /* Not used any more */ -#else -# define TCL_ENCODING_STOPONERROR 0x04 -#endif +#define TCL_ENCODING_STOPONERROR 0x04 #define TCL_ENCODING_NO_TERMINATE 0x08 #define TCL_ENCODING_CHAR_LIMIT 0x10 /* Internal use bits, do not define bits in this space. See above comment */ @@ -2058,10 +2213,13 @@ typedef struct Tcl_EncodingType { * TCL_CONVERT_SYNTAX - The source stream contained an invalid * character sequence. This may occur if the * input stream has been damaged or if the input - * encoding method was misidentified. + * encoding method was misidentified. This error + * is reported only if TCL_ENCODING_STOPONERROR + * was specified. * TCL_CONVERT_UNKNOWN - The source string contained a character that * could not be represented in the target - * encoding. + * encoding. This error is reported only if + * TCL_ENCODING_STOPONERROR was specified. */ #define TCL_CONVERT_MULTIBYTE (-1) @@ -2072,13 +2230,12 @@ typedef struct Tcl_EncodingType { /* * The maximum number of bytes that are necessary to represent a single * Unicode character in UTF-8. The valid values are 3 and 4. If > 3, - * then Tcl_UniChar must be 4-bytes in size (UCS-4) (the default). If == 3, - * then Tcl_UniChar must be 2-bytes in size (UTF-16). Since Tcl 9.0, UCS-4 - * mode is the default and recommended mode. + * then Tcl_UniChar must be 4-bytes in size (UCS-4) (the default for the + * Tcl core). If == 3, then Tcl_UniChar must be 2-bytes in size (UTF-16). */ #ifndef TCL_UTF_MAX -# if TCL_MAJOR_VERSION > 8 +# ifdef BUILD_tcl # define TCL_UTF_MAX 4 # else # define TCL_UTF_MAX 3 @@ -2131,11 +2288,7 @@ typedef struct Tcl_Config { */ typedef void (Tcl_LimitHandlerProc) (void *clientData, Tcl_Interp *interp); -#if TCL_MAJOR_VERSION > 8 -#define Tcl_LimitHandlerDeleteProc Tcl_FreeProc -#else typedef void (Tcl_LimitHandlerDeleteProc) (void *clientData); -#endif #if 0 /* @@ -2309,8 +2462,6 @@ const char * Tcl_InitStubs(Tcl_Interp *interp, const char *version, int exact, int magic); const char * TclTomMathInitializeStubs(Tcl_Interp *interp, const char *version, int epoch, int revision); -const char * TclInitStubTable(const char *version); -void * TclStubCall(void *arg); #if defined(_WIN32) TCL_NORETURN void Tcl_ConsolePanic(const char *format, ...); #else @@ -2318,41 +2469,21 @@ void * TclStubCall(void *arg); #endif #ifdef USE_TCL_STUBS -#if TCL_MAJOR_VERSION < 9 # if TCL_UTF_MAX < 4 # define Tcl_InitStubs(interp, version, exact) \ (Tcl_InitStubs)(interp, version, \ - (exact)|(TCL_MAJOR_VERSION<<8)|(0xFF<<16), \ - TCL_STUB_MAGIC) -# else -# define Tcl_InitStubs(interp, version, exact) \ - (Tcl_InitStubs)(interp, "8.7.0", \ - (exact)|(TCL_MAJOR_VERSION<<8)|(0xFF<<16), \ - TCL_STUB_MAGIC) -# endif -#elif 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 +# else # define Tcl_InitStubs(interp, version, exact) \ - (Tcl_InitStubs)(interp, (((exact)&1) ? (version) : "9.0b2"), \ + (Tcl_InitStubs)(interp, TCL_PATCH_LEVEL, \ (exact)|(TCL_MAJOR_VERSION<<8)|(TCL_MINOR_VERSION<<16), \ TCL_STUB_MAGIC) -#endif +# endif #else -#if TCL_MAJOR_VERSION < 9 -# error "Please define -DUSE_TCL_STUBS" -#elif 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 /* @@ -2361,65 +2492,22 @@ void * TclStubCall(void *arg); */ #define Tcl_Main(argc, argv, proc) Tcl_MainEx(argc, argv, proc, \ - ((Tcl_SetPanicProc(Tcl_ConsolePanic), Tcl_CreateInterp()))) + ((Tcl_SetPanicProc(Tcl_ConsolePanic), Tcl_CreateInterp)())) EXTERN TCL_NORETURN void Tcl_MainEx(Tcl_Size argc, char **argv, Tcl_AppInitProc *appInitProc, Tcl_Interp *interp); EXTERN const char * Tcl_PkgInitStubsCheck(Tcl_Interp *interp, const char *version, int exact); EXTERN const char * Tcl_InitSubsystems(void); EXTERN void Tcl_GetMemoryInfo(Tcl_DString *dsPtr); -EXTERN const char * Tcl_FindExecutable(const char *argv0); EXTERN const char * Tcl_SetPreInitScript(const char *string); -EXTERN const char * Tcl_SetPanicProc( - Tcl_PanicProc *panicProc); -EXTERN void Tcl_StaticLibrary(Tcl_Interp *interp, - const char *prefix, - Tcl_LibraryInitProc *initProc, - Tcl_LibraryInitProc *safeInitProc); #ifndef TCL_NO_DEPRECATED # define Tcl_StaticPackage Tcl_StaticLibrary #endif -EXTERN Tcl_ExitProc *Tcl_SetExitProc(Tcl_ExitProc *proc); #ifdef _WIN32 EXTERN const char *TclZipfs_AppHook(int *argc, wchar_t ***argv); #else EXTERN const char *TclZipfs_AppHook(int *argc, char ***argv); #endif -#if defined(_WIN32) && defined(UNICODE) -#ifndef USE_TCL_STUBS -# define Tcl_FindExecutable(arg) ((Tcl_FindExecutable)((const char *)(arg))) -#endif -# define Tcl_MainEx Tcl_MainExW - EXTERN TCL_NORETURN void Tcl_MainExW(Tcl_Size argc, wchar_t **argv, - Tcl_AppInitProc *appInitProc, Tcl_Interp *interp); -#endif -#if defined(USE_TCL_STUBS) && (TCL_MAJOR_VERSION > 8) -#define Tcl_SetPanicProc(panicProc) \ - TclInitStubTable(((const char *(*)(Tcl_PanicProc *))TclStubCall((void *)panicProc))(panicProc)) -#define Tcl_InitSubsystems() \ - TclInitStubTable(((const char *(*)(void))TclStubCall((void *)1))()) -#define Tcl_FindExecutable(argv0) \ - TclInitStubTable(((const char *(*)(const char *))TclStubCall((void *)2))(argv0)) -#define TclZipfs_AppHook(argcp, argvp) \ - TclInitStubTable(((const char *(*)(int *, void *))TclStubCall((void *)3))(argcp, argvp)) -#define Tcl_MainExW(argc, argv, appInitProc, interp) \ - (void)((const char *(*)(Tcl_Size, const void *, Tcl_AppInitProc *, Tcl_Interp *)) \ - TclStubCall((void *)4))(argc, argv, appInitProc, interp) -#if !defined(_WIN32) || !defined(UNICODE) -#define Tcl_MainEx(argc, argv, appInitProc, interp) \ - (void)((const char *(*)(Tcl_Size, const void *, Tcl_AppInitProc *, Tcl_Interp *)) \ - TclStubCall((void *)5))(argc, argv, appInitProc, interp) -#endif -#define Tcl_StaticLibrary(interp, pkgName, initProc, safeInitProc) \ - (void)((const char *(*)(Tcl_Interp *, const char *, Tcl_LibraryInitProc *, Tcl_LibraryInitProc *)) \ - TclStubCall((void *)6))(interp, pkgName, initProc, safeInitProc) -#define Tcl_SetExitProc(proc) \ - ((Tcl_ExitProc *(*)(Tcl_ExitProc *))TclStubCall((void *)7))(proc) -#define Tcl_GetMemoryInfo(dsPtr) \ - (void)((const char *(*)(Tcl_DString *))TclStubCall((void *)8))(dsPtr) -#define Tcl_SetPreInitScript(string) \ - ((const char *(*)(const char *))TclStubCall((void *)9))(string) -#endif /* *---------------------------------------------------------------------------- @@ -2444,26 +2532,25 @@ EXTERN const char *TclZipfs_AppHook(int *argc, char ***argv); /* *---------------------------------------------------------------------------- - * The following declarations map ckalloc and ckfree to Tcl_Alloc and - * Tcl_Free for use in Tcl-8.x-compatible extensions. - */ - -#ifndef BUILD_tcl -# define ckalloc Tcl_Alloc -# define attemptckalloc Tcl_AttemptAlloc -# ifdef _MSC_VER - /* Silence invalid C4090 warnings */ -# define ckfree(a) Tcl_Free((void *)(a)) -# define ckrealloc(a,b) Tcl_Realloc((void *)(a),(b)) -# define attemptckrealloc(a,b) Tcl_AttemptRealloc((void *)(a),(b)) -# else -# define ckfree Tcl_Free -# define ckrealloc Tcl_Realloc -# define attemptckrealloc Tcl_AttemptRealloc -# endif -#endif + * The following declarations either map ckalloc and ckfree to malloc and + * free, or they map them to functions with all sorts of debugging hooks + * defined in tclCkalloc.c. + */ + +#ifdef TCL_MEM_DEBUG -#ifndef TCL_MEM_DEBUG +# define ckalloc(x) \ + ((void *) Tcl_DbCkalloc((unsigned)(x), __FILE__, __LINE__)) +# define ckfree(x) \ + Tcl_DbCkfree((char *)(x), __FILE__, __LINE__) +# define ckrealloc(x,y) \ + ((void *) Tcl_DbCkrealloc((char *)(x), (unsigned)(y), __FILE__, __LINE__)) +# define attemptckalloc(x) \ + ((void *) Tcl_AttemptDbCkalloc((unsigned)(x), __FILE__, __LINE__)) +# define attemptckrealloc(x,y) \ + ((void *) Tcl_AttemptDbCkrealloc((char *)(x), (unsigned)(y), __FILE__, __LINE__)) + +#else /* !TCL_MEM_DEBUG */ /* * If we are not using the debugging allocator, we should call the Tcl_Alloc, @@ -2471,6 +2558,16 @@ EXTERN const char *TclZipfs_AppHook(int *argc, char ***argv); * memory allocator both inside and outside of the Tcl library. */ +# define ckalloc(x) \ + ((void *) Tcl_Alloc((unsigned)(x))) +# define ckfree(x) \ + Tcl_Free((char *)(x)) +# define ckrealloc(x,y) \ + ((void *) Tcl_Realloc((char *)(x), (unsigned)(y))) +# define attemptckalloc(x) \ + ((void *) Tcl_AttemptAlloc((unsigned)(x))) +# define attemptckrealloc(x,y) \ + ((void *) Tcl_AttemptRealloc((char *)(x), (unsigned)(y))) # undef Tcl_InitMemory # define Tcl_InitMemory(x) # undef Tcl_DumpActiveMemory @@ -2490,29 +2587,10 @@ EXTERN const char *TclZipfs_AppHook(int *argc, char ***argv); # undef Tcl_IsShared # define Tcl_IsShared(objPtr) \ Tcl_DbIsShared(objPtr, __FILE__, __LINE__) -/* - * Free the Obj by effectively doing: - * - * Tcl_IncrRefCount(objPtr); - * Tcl_DecrRefCount(objPtr); - * - * This will free the obj if there are no references to the obj. - */ -# define Tcl_BounceRefCount(objPtr) \ - TclBounceRefCount(objPtr, __FILE__, __LINE__) - -static inline void TclBounceRefCount(Tcl_Obj* objPtr, const char* fn, int line) -{ - if (objPtr) { - if ((objPtr)->refCount == 0) { - Tcl_DbDecrRefCount(objPtr, fn, line); - } - } -} #else # undef Tcl_IncrRefCount # define Tcl_IncrRefCount(objPtr) \ - ((void)++(objPtr)->refCount) + ++(objPtr)->refCount /* * Use do/while0 idiom for optimum correctness without compiler warnings. * https://wiki.c2.com/?TrivialDoWhileLoop @@ -2528,24 +2606,6 @@ static inline void TclBounceRefCount(Tcl_Obj* objPtr, const char* fn, int line) # undef Tcl_IsShared # define Tcl_IsShared(objPtr) \ ((objPtr)->refCount > 1) - -/* - * Declare that obj will no longer be used or referenced. - * This will release the obj if there is no referece count, - * otherwise let it be. - */ -# define Tcl_BounceRefCount(objPtr) \ - TclBounceRefCount(objPtr); - -static inline void TclBounceRefCount(Tcl_Obj* objPtr) -{ - if (objPtr) { - if ((objPtr)->refCount == 0) { - Tcl_DecrRefCount(objPtr); - } - } -} - #endif /* @@ -2606,6 +2666,38 @@ static inline void TclBounceRefCount(Tcl_Obj* objPtr) #define Tcl_CreateHashEntry(tablePtr, key, newPtr) \ (*((tablePtr)->createProc))(tablePtr, (const char *)(key), newPtr) +/* + *---------------------------------------------------------------------------- + * Deprecated Tcl functions: + */ + +#ifndef TCL_NO_DEPRECATED +/* + * These function have been renamed. The old names are deprecated, but we + * define these macros for backwards compatibility. + */ + +# define Tcl_Ckalloc Tcl_Alloc +# define Tcl_Ckfree Tcl_Free +# define Tcl_Ckrealloc Tcl_Realloc +# define Tcl_Return Tcl_SetResult +# define Tcl_TildeSubst Tcl_TranslateFileName +#if !defined(__APPLE__) /* On OSX, there is a conflict with "mach/mach.h" */ +# define panic Tcl_Panic +#endif +# define panicVA Tcl_PanicVA + +/* + *---------------------------------------------------------------------------- + * Convenience declaration of Tcl_AppInit for backwards compatibility. This + * function is not *implemented* by the tcl library, so the storage class is + * neither DLLEXPORT nor DLLIMPORT. + */ + +extern Tcl_AppInitProc Tcl_AppInit; + +#endif /* !TCL_NO_DEPRECATED */ + #endif /* RC_INVOKED */ /* diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c index 3c4fac3..800b0ae 100644 --- a/generic/tclAlloc.c +++ b/generic/tclAlloc.c @@ -251,11 +251,11 @@ TclFinalizeAllocSubsystem(void) void * TclpAlloc( - size_t numBytes) /* Number of bytes to allocate. */ + unsigned int numBytes) /* Number of bytes to allocate. */ { union overhead *overPtr; size_t bucket; - size_t amount; + unsigned amount; struct block *bigBlockPtr = NULL; if (!allocInit) { @@ -274,8 +274,8 @@ TclpAlloc( if (numBytes >= MAXMALLOC - OVERHEAD) { if (numBytes <= UINT_MAX - OVERHEAD -sizeof(struct block)) { - bigBlockPtr = TclpSysAlloc( - sizeof(struct block) + OVERHEAD + numBytes); + bigBlockPtr = (struct block *) TclpSysAlloc( + sizeof(struct block) + OVERHEAD + numBytes, 0); } if (bigBlockPtr == NULL) { Tcl_MutexUnlock(allocMutexPtr); @@ -304,7 +304,7 @@ TclpAlloc( #endif Tcl_MutexUnlock(allocMutexPtr); - return (void *)(overPtr+1); + return (char *)(overPtr+1); } /* @@ -405,7 +405,8 @@ MoreCore( numBlocks = amount / size; ASSERT(numBlocks*size == amount); - blockPtr = TclpSysAlloc(sizeof(struct block) + amount); + blockPtr = (struct block *) TclpSysAlloc( + (sizeof(struct block) + amount), 1); /* no more room! */ if (blockPtr == NULL) { return; @@ -511,7 +512,7 @@ TclpFree( void * TclpRealloc( void *oldPtr, /* Pointer to alloc'ed block. */ - size_t numBytes) /* New size of memory. */ + unsigned int numBytes) /* New size of memory. */ { int i; union overhead *overPtr; @@ -691,10 +692,9 @@ mstats( *---------------------------------------------------------------------- */ -#undef TclpAlloc void * TclpAlloc( - size_t numBytes) /* Number of bytes to allocate. */ + unsigned int numBytes) /* Number of bytes to allocate. */ { return malloc(numBytes); } @@ -715,7 +715,6 @@ TclpAlloc( *---------------------------------------------------------------------- */ -#undef TclpFree void TclpFree( void *oldPtr) /* Pointer to memory to free. */ @@ -743,7 +742,7 @@ TclpFree( void * TclpRealloc( void *oldPtr, /* Pointer to alloced block. */ - size_t numBytes) /* New size of memory. */ + unsigned int numBytes) /* New size of memory. */ { return realloc(oldPtr, numBytes); } diff --git a/generic/tclArithSeries.c b/generic/tclArithSeries.c index fd1014c..7a41518 100755 --- a/generic/tclArithSeries.c +++ b/generic/tclArithSeries.c @@ -46,77 +46,43 @@ * Note that the len can in theory be always computed by start,end,step * but it's faster to cache it inside the internal representation. */ - typedef struct { Tcl_Size len; Tcl_Obj **elements; int isDouble; -} ArithSeries; - -typedef struct { - ArithSeries base; Tcl_WideInt start; Tcl_WideInt end; Tcl_WideInt step; -} ArithSeriesInt; - +} ArithSeries; typedef struct { - ArithSeries base; + Tcl_Size len; + Tcl_Obj **elements; + int isDouble; double start; double end; double step; - unsigned precision; /* Number of decimal places to render. */ + int precision; } ArithSeriesDbl; -/* Forward declarations. */ - -static int TclArithSeriesObjIndex(TCL_UNUSED(Tcl_Interp *), - Tcl_Obj *arithSeriesObj, Tcl_Size index, - Tcl_Obj **elemObj); -static Tcl_Size ArithSeriesObjLength(Tcl_Obj *arithSeriesObj); -static int TclArithSeriesObjRange(Tcl_Interp *interp, - Tcl_Obj *arithSeriesObj, Tcl_Size fromIdx, - Tcl_Size toIdx, Tcl_Obj **newObjPtr); -static int TclArithSeriesObjReverse(Tcl_Interp *interp, - Tcl_Obj *arithSeriesObj, Tcl_Obj **newObjPtr); -static int TclArithSeriesGetElements(Tcl_Interp *interp, - Tcl_Obj *objPtr, Tcl_Size *objcPtr, - Tcl_Obj ***objvPtr); -static void DupArithSeriesInternalRep(Tcl_Obj *srcPtr, - Tcl_Obj *copyPtr); -static void FreeArithSeriesInternalRep(Tcl_Obj *arithSeriesObjPtr); -static void UpdateStringOfArithSeries(Tcl_Obj *arithSeriesObjPtr); -static int SetArithSeriesFromAny(Tcl_Interp *interp, - Tcl_Obj *objPtr); -static int ArithSeriesInOperation(Tcl_Interp *interp, - Tcl_Obj *valueObj, Tcl_Obj *arithSeriesObj, - int *boolResult); -static int TclArithSeriesObjStep(Tcl_Obj *arithSeriesObj, - Tcl_Obj **stepObj); - -/* ------------------------ ArithSeries object type -------------------------- */ - -static const Tcl_ObjType arithSeriesType = { +/* -------------------------- ArithSeries object ---------------------------- */ + +static void DupArithSeriesInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); +static void FreeArithSeriesInternalRep(Tcl_Obj *arithSeriesObjPtr); +static void UpdateStringOfArithSeries(Tcl_Obj *arithSeriesObjPtr); +static int SetArithSeriesFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); +Tcl_Size TclArithSeriesObjLength(Tcl_Obj *arithSeriesObj); + +const Tcl_ObjType tclArithSeriesType = { "arithseries", /* name */ FreeArithSeriesInternalRep, /* freeIntRepProc */ DupArithSeriesInternalRep, /* dupIntRepProc */ UpdateStringOfArithSeries, /* updateStringProc */ - SetArithSeriesFromAny, /* setFromAnyProc */ - TCL_OBJTYPE_V2( - ArithSeriesObjLength, - TclArithSeriesObjIndex, - TclArithSeriesObjRange, - TclArithSeriesObjReverse, - TclArithSeriesGetElements, - NULL, // SetElement - NULL, // Replace - ArithSeriesInOperation) // "in" operator + SetArithSeriesFromAny /* setFromAnyProc */ }; - + /* * Helper functions * - * - power10 -- Fast version of pow(10, (int) n) for common cases. * - ArithRound -- Round doubles to the number of significant fractional * digits * - ArithSeriesIndexDbl -- base list indexing operation for doubles @@ -127,31 +93,10 @@ static const Tcl_ObjType arithSeriesType = { * - maxPrecision -- Using the values provide, determine the longest percision * in the arithSeries */ - -static inline double -power10( - unsigned n) -{ - static const double powers[] = { - 1, 10, 100, 1000, 1e4, 1e5, 1e6, 1e7, 1e8, 1e9, 1e10, 1e11, 1e12, - 1e13, 1e14, 1e15, 1e16, 1e17, 1e18, 1e19, 1e20 - }; - - if (n < sizeof(powers) / sizeof(*powers)) { - return powers[n]; - } else { - // Not an expected case. Doesn't need to be so fast - return pow(10, n); - } -} - static inline double -ArithRound( - double d, - unsigned n) -{ - double scalefactor = power10(n); - return round(d * scalefactor) / scalefactor; +ArithRound(double d, unsigned int n) { + double scalefactor = pow(10, n); + return round(d*scalefactor)/scalefactor; } static inline double @@ -159,14 +104,13 @@ ArithSeriesIndexDbl( ArithSeries *arithSeriesRepPtr, Tcl_WideInt index) { + ArithSeriesDbl *dblRepPtr = (ArithSeriesDbl*)arithSeriesRepPtr; if (arithSeriesRepPtr->isDouble) { - ArithSeriesDbl *dblRepPtr = (ArithSeriesDbl *) arithSeriesRepPtr; double d = dblRepPtr->start + (index * dblRepPtr->step); - - return ArithRound(d, dblRepPtr->precision); + unsigned n = (dblRepPtr->precision > 0 ? dblRepPtr->precision : 0); + return ArithRound(d, n); } else { - ArithSeriesInt *intRepPtr = (ArithSeriesInt *) arithSeriesRepPtr; - return (double)(intRepPtr->start + (index * intRepPtr->step)); + return (double)(arithSeriesRepPtr->start + (index * arithSeriesRepPtr->step)); } } @@ -175,57 +119,50 @@ ArithSeriesIndexInt( ArithSeries *arithSeriesRepPtr, Tcl_WideInt index) { + ArithSeriesDbl *dblRepPtr = (ArithSeriesDbl*)arithSeriesRepPtr; if (arithSeriesRepPtr->isDouble) { - ArithSeriesDbl *dblRepPtr = (ArithSeriesDbl *) arithSeriesRepPtr; - return (Tcl_WideInt) (dblRepPtr->start + (index * dblRepPtr->step)); + return (Tcl_WideInt)(dblRepPtr->start + ((index) * dblRepPtr->step)); } else { - ArithSeriesInt *intRepPtr = (ArithSeriesInt *) arithSeriesRepPtr; - return intRepPtr->start + (index * intRepPtr->step); + return (arithSeriesRepPtr->start + (index * arithSeriesRepPtr->step)); } } -static inline ArithSeries * -ArithSeriesGetInternalRep( - Tcl_Obj *objPtr) +static inline ArithSeries* +ArithSeriesGetInternalRep(Tcl_Obj *objPtr) { - const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, - &arithSeriesType); - return irPtr ? (ArithSeries *) irPtr->twoPtrValue.ptr1 : NULL; + const Tcl_ObjInternalRep *irPtr; + irPtr = TclFetchInternalRep((objPtr), &tclArithSeriesType); + return irPtr ? (ArithSeries *)irPtr->twoPtrValue.ptr1 : NULL; } /* - * Compute number of significant fractional digits + * Compute number of significant factional digits */ -static inline unsigned -Precision( - double d) +static inline int +Precision(double d) { - char tmp[TCL_DOUBLE_SPACE + 2], *off; - + char tmp[TCL_DOUBLE_SPACE+2], *off; tmp[0] = 0; - Tcl_PrintDouble(NULL, d, tmp); + Tcl_PrintDouble(NULL,d,tmp); off = strchr(tmp, '.'); - return (off ? strlen(off + 1) : 0); + return (off ? strlen(off+1) : 0); } /* * Find longest number of digits after the decimal point. */ -static inline unsigned -maxPrecision( - double start, - double end, - double step) +static inline int +maxPrecision(double start, double end, double step) { - unsigned dp = Precision(step); - unsigned i = Precision(start); - + int dp = Precision(step); + int i = Precision(start); dp = i>dp ? i : dp; i = Precision(end); dp = i>dp ? i : dp; return dp; } - + + /* *---------------------------------------------------------------------- * @@ -250,38 +187,31 @@ maxPrecision( *---------------------------------------------------------------------- */ static Tcl_WideInt -ArithSeriesLenInt( - Tcl_WideInt start, - Tcl_WideInt end, - Tcl_WideInt step) +ArithSeriesLenInt(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step) { Tcl_WideInt len; if (step == 0) { return 0; } - len = 1 + ((end - start) / step); + len = 1 + ((end-start)/step); return (len < 0) ? -1 : len; } static Tcl_WideInt -ArithSeriesLenDbl( - double start, - double end, - double step, - unsigned precision) +ArithSeriesLenDbl(double start, double end, double step, int precision) { double istart, iend, istep, ilen; - if (step == 0) { return 0; } - istart = start * power10(precision); - iend = end * power10(precision); - istep = step * power10(precision); - ilen = (iend - istart + istep) / istep; + istart = start * pow(10,precision); + iend = end * pow(10,precision); + istep = step * pow(10,precision); + ilen = ((iend-istart+istep)/istep); return floor(ilen); } + /* *---------------------------------------------------------------------- @@ -290,7 +220,6 @@ ArithSeriesLenDbl( * * Initialize the internal representation of a arithseries Tcl_Obj to a * copy of the internal representation of an existing arithseries object. - * The copy does not share the cache of the elements. * * Results: * None. @@ -298,7 +227,6 @@ ArithSeriesLenDbl( * Side effects: * We set "copyPtr"s internal rep to a pointer to a * newly allocated ArithSeries structure. - * *---------------------------------------------------------------------- */ @@ -307,28 +235,29 @@ DupArithSeriesInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - ArithSeries *srcRepPtr = (ArithSeries *) - srcPtr->internalRep.twoPtrValue.ptr1; - - if (srcRepPtr->isDouble) { - ArithSeriesDbl *srcDblPtr = (ArithSeriesDbl *) srcRepPtr; - ArithSeriesDbl *copyDblPtr = (ArithSeriesDbl *) - Tcl_Alloc(sizeof(ArithSeriesDbl)); + ArithSeries *srcArithSeriesRepPtr = + (ArithSeries *) srcPtr->internalRep.twoPtrValue.ptr1; - *copyDblPtr = *srcDblPtr; - copyDblPtr->base.elements = NULL; - copyPtr->internalRep.twoPtrValue.ptr1 = copyDblPtr; + /* + * Allocate a new ArithSeries structure. */ + + if (srcArithSeriesRepPtr->isDouble) { + ArithSeriesDbl *srcArithSeriesDblRepPtr = + (ArithSeriesDbl *)srcArithSeriesRepPtr; + ArithSeriesDbl *copyArithSeriesDblRepPtr = + (ArithSeriesDbl *)ckalloc(sizeof(ArithSeriesDbl)); + *copyArithSeriesDblRepPtr = *srcArithSeriesDblRepPtr; + copyArithSeriesDblRepPtr->elements = NULL; + copyPtr->internalRep.twoPtrValue.ptr1 = copyArithSeriesDblRepPtr; } else { - ArithSeriesInt *srcIntPtr = (ArithSeriesInt *) srcRepPtr; - ArithSeriesInt *copyIntPtr = (ArithSeriesInt *) - Tcl_Alloc(sizeof(ArithSeriesInt)); - - *copyIntPtr = *srcIntPtr; - copyIntPtr->base.elements = NULL; - copyPtr->internalRep.twoPtrValue.ptr1 = copyIntPtr; + ArithSeries *copyArithSeriesRepPtr = + (ArithSeries *)ckalloc(sizeof(ArithSeries)); + *copyArithSeriesRepPtr = *srcArithSeriesRepPtr; + copyArithSeriesRepPtr->elements = NULL; + copyPtr->internalRep.twoPtrValue.ptr1 = copyArithSeriesRepPtr; } copyPtr->internalRep.twoPtrValue.ptr2 = NULL; - copyPtr->typePtr = &arithSeriesType; + copyPtr->typePtr = &tclArithSeriesType; } /* @@ -345,34 +274,22 @@ DupArithSeriesInternalRep( * *---------------------------------------------------------------------- */ - -static inline void -FreeElements( - ArithSeries *arithSeriesRepPtr) +static void +FreeArithSeriesInternalRep(Tcl_Obj *arithSeriesObjPtr) /* Free any allocated memory */ { - if (arithSeriesRepPtr->elements) { - Tcl_WideInt i, len = arithSeriesRepPtr->len; + ArithSeries *arithSeriesRepPtr = (ArithSeries *)arithSeriesObjPtr->internalRep.twoPtrValue.ptr1; - for (i=0; i<len; i++) { + if (arithSeriesRepPtr->elements) { + Tcl_Size i; + for(i=0; i<arithSeriesRepPtr->len; i++) { Tcl_DecrRefCount(arithSeriesRepPtr->elements[i]); } - Tcl_Free((char *) arithSeriesRepPtr->elements); + ckfree((char *)arithSeriesRepPtr->elements); arithSeriesRepPtr->elements = NULL; } + ckfree((char *)arithSeriesRepPtr); } -static void -FreeArithSeriesInternalRep( - Tcl_Obj *arithSeriesObjPtr) -{ - ArithSeries *arithSeriesRepPtr = (ArithSeries *) - arithSeriesObjPtr->internalRep.twoPtrValue.ptr1; - - if (arithSeriesRepPtr) { - FreeElements(arithSeriesRepPtr); - Tcl_Free((char *) arithSeriesRepPtr); - } -} /* *---------------------------------------------------------------------- @@ -388,20 +305,17 @@ FreeArithSeriesInternalRep( * A NULL pointer of the range is invalid. * * Side Effects: - * None. * + * None. *---------------------------------------------------------------------- */ -static Tcl_Obj * -NewArithSeriesInt( - Tcl_WideInt start, - Tcl_WideInt end, - Tcl_WideInt step, - Tcl_WideInt len) +static +Tcl_Obj * +NewArithSeriesInt(Tcl_WideInt start, Tcl_WideInt end, Tcl_WideInt step, Tcl_WideInt len) { Tcl_WideInt length; Tcl_Obj *arithSeriesObj; - ArithSeriesInt *arithSeriesRepPtr; + ArithSeries *arithSeriesRepPtr; length = len>=0 ? len : -1; if (length < 0) { @@ -414,16 +328,16 @@ NewArithSeriesInt( return arithSeriesObj; } - arithSeriesRepPtr = (ArithSeriesInt *) Tcl_Alloc(sizeof(ArithSeriesInt)); - arithSeriesRepPtr->base.len = length; - arithSeriesRepPtr->base.elements = NULL; - arithSeriesRepPtr->base.isDouble = 0; + arithSeriesRepPtr = (ArithSeries*)ckalloc(sizeof (ArithSeries)); + arithSeriesRepPtr->isDouble = 0; arithSeriesRepPtr->start = start; arithSeriesRepPtr->end = end; arithSeriesRepPtr->step = step; + arithSeriesRepPtr->len = length; + arithSeriesRepPtr->elements = NULL; arithSeriesObj->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr; arithSeriesObj->internalRep.twoPtrValue.ptr2 = NULL; - arithSeriesObj->typePtr = &arithSeriesType; + arithSeriesObj->typePtr = &tclArithSeriesType; if (length > 0) { Tcl_InvalidateStringRep(arithSeriesObj); } @@ -450,12 +364,9 @@ NewArithSeriesInt( *---------------------------------------------------------------------- */ -static Tcl_Obj * -NewArithSeriesDbl( - double start, - double end, - double step, - Tcl_WideInt len) +static +Tcl_Obj * +NewArithSeriesDbl(double start, double end, double step, Tcl_WideInt len) { Tcl_WideInt length; Tcl_Obj *arithSeriesObj; @@ -472,17 +383,17 @@ NewArithSeriesDbl( return arithSeriesObj; } - arithSeriesRepPtr = (ArithSeriesDbl *) Tcl_Alloc(sizeof(ArithSeriesDbl)); - arithSeriesRepPtr->base.len = length; - arithSeriesRepPtr->base.elements = NULL; - arithSeriesRepPtr->base.isDouble = 1; + arithSeriesRepPtr = (ArithSeriesDbl*)ckalloc(sizeof (ArithSeriesDbl)); + arithSeriesRepPtr->isDouble = 1; arithSeriesRepPtr->start = start; arithSeriesRepPtr->end = end; arithSeriesRepPtr->step = step; - arithSeriesRepPtr->precision = maxPrecision(start, end, step); + arithSeriesRepPtr->len = length; + arithSeriesRepPtr->elements = NULL; + arithSeriesRepPtr->precision = maxPrecision(start,end,step); arithSeriesObj->internalRep.twoPtrValue.ptr1 = arithSeriesRepPtr; arithSeriesObj->internalRep.twoPtrValue.ptr2 = NULL; - arithSeriesObj->typePtr = &arithSeriesType; + arithSeriesObj->typePtr = &tclArithSeriesType; if (length > 0) { Tcl_InvalidateStringRep(arithSeriesObj); @@ -614,7 +525,7 @@ TclNewArithSeriesObj( assert(dstep!=0); if (!lenObj) { if (useDoubles) { - unsigned precision = maxPrecision(dstart, dend, dstep); + int precision = maxPrecision(dstart,dend,dstep); len = ArithSeriesLenDbl(dstart, dend, dstep, precision); } else { len = ArithSeriesLenInt(start, end, step); @@ -625,21 +536,21 @@ TclNewArithSeriesObj( if (!endObj) { if (useDoubles) { // Compute precision based on given command argument values - unsigned precision = maxPrecision(dstart, len, dstep); - + int precision = maxPrecision(dstart,len,dstep); dend = dstart + (dstep * (len-1)); // Make computed end value match argument(s) precision dend = ArithRound(dend, precision); end = dend; } else { - end = start + (step * (len - 1)); + end = start + (step * (len-1)); dend = end; } } if (len > TCL_SIZE_MAX) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "max length of a Tcl list exceeded", TCL_AUTO_LENGTH)); + Tcl_SetObjResult( + interp, + Tcl_NewStringObj("max length of a Tcl list exceeded", -1)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL); return TCL_ERROR; } @@ -659,42 +570,40 @@ TclNewArithSeriesObj( * * Returns the element with the specified index in the list * represented by the specified Arithmetic Sequence object. - * If the index is out of range, TCL_ERROR is returned, - * otherwise TCL_OK is returned and the integer value of the - * element is stored in *element. + * If the index is out of range, NULL is returned. * * Results: * - * TCL_OK on success. + * The element on success, NULL on index out of range. * * Side Effects: * * On success, the integer pointed by *element is modified. - * An empty string ("") is assigned if index is out-of-bounds. * *---------------------------------------------------------------------- */ -int + +Tcl_Obj * TclArithSeriesObjIndex( TCL_UNUSED(Tcl_Interp *), - Tcl_Obj *arithSeriesObj, /* List obj */ - Tcl_Size index, /* index to element of interest */ - Tcl_Obj **elemObj) /* Return value */ + Tcl_Obj *arithSeriesObj, + Tcl_Size index) { - ArithSeries *arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj); + ArithSeries *arithSeriesRepPtr; - if (index < 0 || arithSeriesRepPtr->len <= index) { - *elemObj = NULL; + if (!TclHasInternalRep(arithSeriesObj, &tclArithSeriesType)) { + Tcl_Panic("TclArithSeriesObjIndex called with a not ArithSeries Obj."); + } + arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj); + if (index < 0 || index >= arithSeriesRepPtr->len) { + return Tcl_NewObj(); + } + /* List[i] = Start + (Step * index) */ + if (arithSeriesRepPtr->isDouble) { + return Tcl_NewDoubleObj(ArithSeriesIndexDbl(arithSeriesRepPtr, index)); } else { - /* List[i] = Start + (Step * index) */ - if (arithSeriesRepPtr->isDouble) { - *elemObj = Tcl_NewDoubleObj(ArithSeriesIndexDbl(arithSeriesRepPtr, index)); - } else { - *elemObj = Tcl_NewWideIntObj(ArithSeriesIndexInt(arithSeriesRepPtr, index)); - } + return Tcl_NewWideIntObj(ArithSeriesIndexInt(arithSeriesRepPtr, index)); } - - return TCL_OK; } /* @@ -715,10 +624,10 @@ TclArithSeriesObjIndex( *---------------------------------------------------------------------- */ Tcl_Size -ArithSeriesObjLength( +TclArithSeriesObjLength( Tcl_Obj *arithSeriesObj) { - ArithSeries *arithSeriesRepPtr = (ArithSeries *) + ArithSeries *arithSeriesRepPtr = (ArithSeries*) arithSeriesObj->internalRep.twoPtrValue.ptr1; return arithSeriesRepPtr->len; } @@ -726,7 +635,7 @@ ArithSeriesObjLength( /* *---------------------------------------------------------------------- * - * TclArithSeriesObjStep -- + * ArithSeriesObjStep -- * * Return a Tcl_Obj with the step value from the give ArithSeries Obj. * refcount = 0. @@ -742,21 +651,25 @@ ArithSeriesObjLength( *---------------------------------------------------------------------- */ -int -TclArithSeriesObjStep( - Tcl_Obj *arithSeriesObj, - Tcl_Obj **stepObj) +Tcl_Obj * +ArithSeriesObjStep( + Tcl_Obj *arithSeriesObj) { - ArithSeries *arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj); + ArithSeries *arithSeriesRepPtr; + Tcl_Obj *stepObj; + if (!TclHasInternalRep(arithSeriesObj, &tclArithSeriesType)) { + Tcl_Panic("ArithSeriesObjStep called with a not ArithSeries Obj."); + } + arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj); if (arithSeriesRepPtr->isDouble) { - *stepObj = Tcl_NewDoubleObj(((ArithSeriesDbl *) arithSeriesRepPtr)->step); + TclNewDoubleObj(stepObj, ((ArithSeriesDbl*)(arithSeriesRepPtr))->step); } else { - *stepObj = Tcl_NewWideIntObj(((ArithSeriesInt *) arithSeriesRepPtr)->step); + TclNewIntObj(stepObj, arithSeriesRepPtr->step); } - return TCL_OK; + return stepObj; } - + /* *---------------------------------------------------------------------- * @@ -807,32 +720,28 @@ SetArithSeriesFromAny( *---------------------------------------------------------------------- */ -int +Tcl_Obj * TclArithSeriesObjRange( Tcl_Interp *interp, /* For error message(s) */ Tcl_Obj *arithSeriesObj, /* List object to take a range from. */ Tcl_Size fromIdx, /* Index of first element to include. */ - Tcl_Size toIdx, /* Index of last element to include. */ - Tcl_Obj **newObjPtr) /* return value */ + Tcl_Size toIdx) /* Index of last element to include. */ { ArithSeries *arithSeriesRepPtr; Tcl_Obj *startObj, *endObj, *stepObj; - (void)interp; /* silence compiler */ - arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj); - if (fromIdx == TCL_INDEX_NONE) { + if (fromIdx < TCL_INDEX_NONE) { fromIdx = 0; } - if (toIdx >= arithSeriesRepPtr->len) { - toIdx = arithSeriesRepPtr->len-1; - } - - if (fromIdx > toIdx || fromIdx >= arithSeriesRepPtr->len) { - TclNewObj(*newObjPtr); - return TCL_OK; + if (fromIdx > toIdx || + (toIdx > arithSeriesRepPtr->len-1 && + fromIdx > arithSeriesRepPtr->len-1)) { + Tcl_Obj *obj; + TclNewObj(obj); + return obj; } if (fromIdx < 0) { @@ -841,25 +750,35 @@ TclArithSeriesObjRange( if (toIdx < 0) { toIdx = 0; } - if (toIdx > arithSeriesRepPtr->len - 1) { - toIdx = arithSeriesRepPtr->len - 1; + if (toIdx > arithSeriesRepPtr->len-1) { + toIdx = arithSeriesRepPtr->len-1; } - TclArithSeriesObjIndex(interp, arithSeriesObj, fromIdx, &startObj); + startObj = TclArithSeriesObjIndex(interp, arithSeriesObj, fromIdx); + if (startObj == NULL) { + return NULL; + } Tcl_IncrRefCount(startObj); - TclArithSeriesObjIndex(interp, arithSeriesObj, toIdx, &endObj); + endObj = TclArithSeriesObjIndex(interp, arithSeriesObj, toIdx); + if (endObj == NULL) { + return NULL; + } Tcl_IncrRefCount(endObj); - TclArithSeriesObjStep(arithSeriesObj, &stepObj); + stepObj = ArithSeriesObjStep(arithSeriesObj); Tcl_IncrRefCount(stepObj); - if (Tcl_IsShared(arithSeriesObj) || (arithSeriesObj->refCount > 1)) { - int status = TclNewArithSeriesObj(NULL, newObjPtr, - arithSeriesRepPtr->isDouble, startObj, endObj, stepObj, NULL); - + if (Tcl_IsShared(arithSeriesObj) || + ((arithSeriesObj->refCount > 1))) { + Tcl_Obj *newSlicePtr; + if (TclNewArithSeriesObj(interp, &newSlicePtr, + arithSeriesRepPtr->isDouble, startObj, endObj, + stepObj, NULL) != TCL_OK) { + newSlicePtr = NULL; + } Tcl_DecrRefCount(startObj); Tcl_DecrRefCount(endObj); Tcl_DecrRefCount(stepObj); - return status; + return newSlicePtr; } /* @@ -874,39 +793,37 @@ TclArithSeriesObjRange( TclInvalidateStringRep(arithSeriesObj); if (arithSeriesRepPtr->isDouble) { - ArithSeriesDbl *dblRepPtr = (ArithSeriesDbl *) arithSeriesRepPtr; + ArithSeriesDbl *arithSeriesDblRepPtr = (ArithSeriesDbl*)arithSeriesRepPtr; double start, end, step; Tcl_GetDoubleFromObj(NULL, startObj, &start); Tcl_GetDoubleFromObj(NULL, endObj, &end); Tcl_GetDoubleFromObj(NULL, stepObj, &step); - dblRepPtr->start = start; - dblRepPtr->end = end; - dblRepPtr->step = step; - dblRepPtr->precision = maxPrecision(start, end, step); - FreeElements(arithSeriesRepPtr); - dblRepPtr->base.len = - ArithSeriesLenDbl(start, end, step, dblRepPtr->precision); + arithSeriesDblRepPtr->start = start; + arithSeriesDblRepPtr->end = end; + arithSeriesDblRepPtr->step = step; + arithSeriesDblRepPtr->precision = maxPrecision(start, end, step); + arithSeriesDblRepPtr->len = + ArithSeriesLenDbl(start, end, step, arithSeriesDblRepPtr->precision); + arithSeriesDblRepPtr->elements = NULL; + } else { - ArithSeriesInt *intRepPtr = (ArithSeriesInt *) arithSeriesRepPtr; Tcl_WideInt start, end, step; - Tcl_GetWideIntFromObj(NULL, startObj, &start); Tcl_GetWideIntFromObj(NULL, endObj, &end); Tcl_GetWideIntFromObj(NULL, stepObj, &step); - intRepPtr->start = start; - intRepPtr->end = end; - intRepPtr->step = step; - FreeElements(arithSeriesRepPtr); - intRepPtr->base.len = ArithSeriesLenInt(start, end, step); + arithSeriesRepPtr->start = start; + arithSeriesRepPtr->end = end; + arithSeriesRepPtr->step = step; + arithSeriesRepPtr->len = ArithSeriesLenInt(start, end, step); + arithSeriesRepPtr->elements = NULL; } Tcl_DecrRefCount(startObj); Tcl_DecrRefCount(endObj); Tcl_DecrRefCount(stepObj); - *newObjPtr = arithSeriesObj; - return TCL_OK; + return arithSeriesObj; } /* @@ -948,34 +865,34 @@ TclArithSeriesGetElements( Tcl_Obj ***objvPtr) /* Where to store the pointer to an array of * pointers to the list's objects. */ { - if (TclHasInternalRep(objPtr, &arithSeriesType)) { - ArithSeries *arithSeriesRepPtr = ArithSeriesGetInternalRep(objPtr); + if (TclHasInternalRep(objPtr, &tclArithSeriesType)) { + ArithSeries *arithSeriesRepPtr; Tcl_Obj **objv; - Tcl_Size objc = arithSeriesRepPtr->len; + int i, objc; + + arithSeriesRepPtr = ArithSeriesGetInternalRep(objPtr); + objc = arithSeriesRepPtr->len; if (objc > 0) { if (arithSeriesRepPtr->elements) { /* If this exists, it has already been populated */ objv = arithSeriesRepPtr->elements; } else { /* Construct the elements array */ - objv = (Tcl_Obj **) Tcl_Alloc(sizeof(Tcl_Obj*) * objc); + objv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj*) * objc); if (objv == NULL) { if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "max length of a Tcl list exceeded", - TCL_AUTO_LENGTH)); + Tcl_SetObjResult( + interp, + Tcl_NewStringObj("max length of a Tcl list exceeded", -1)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL); } return TCL_ERROR; } arithSeriesRepPtr->elements = objv; - - Tcl_Size i; for (i = 0; i < objc; i++) { - int status = TclArithSeriesObjIndex(interp, objPtr, i, &objv[i]); - - if (status) { + objv[i] = TclArithSeriesObjIndex(interp, objPtr, i); + if (objv[i] == NULL) { return TCL_ERROR; } Tcl_IncrRefCount(objv[i]); @@ -988,8 +905,7 @@ TclArithSeriesGetElements( *objcPtr = objc; } else { if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "value is not an arithseries", TCL_AUTO_LENGTH)); + Tcl_SetObjResult(interp, Tcl_NewStringObj("value is not an arithseries", TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "UNKNOWN", (void *)NULL); } return TCL_ERROR; @@ -1002,23 +918,24 @@ TclArithSeriesGetElements( * * TclArithSeriesObjReverse -- * - * Reverse the order of the ArithSeries value. The arithSeriesObj is - * assumed to be a valid ArithSeries. The new Obj has the Start and End - * values appropriately swapped and the Step value sign is changed. + * Reverse the order of the ArithSeries value. + * *arithSeriesObj must be known to be a valid list. * * Results: - * The result will be an ArithSeries in the reverse order. + * Returns a pointer to the reordered series. + * This may be a new object or the same object if not shared. * * Side effects: - * The ogiginal obj will be modified and returned if it is not Shared. + * ?The possible conversion of the object referenced by listPtr? + * ?to a list object.? * *---------------------------------------------------------------------- */ -int + +Tcl_Obj * TclArithSeriesObjReverse( Tcl_Interp *interp, /* For error message(s) */ - Tcl_Obj *arithSeriesObj, /* List object to reverse. */ - Tcl_Obj **newObjPtr) + Tcl_Obj *arithSeriesObj) /* List object to reverse. */ { ArithSeries *arithSeriesRepPtr; Tcl_Obj *startObj, *endObj, *stepObj; @@ -1027,22 +944,16 @@ TclArithSeriesObjReverse( double dstart, dend, dstep; int isDouble; - (void)interp; - - if (newObjPtr == NULL) { - return TCL_ERROR; - } - arithSeriesRepPtr = ArithSeriesGetInternalRep(arithSeriesObj); isDouble = arithSeriesRepPtr->isDouble; len = arithSeriesRepPtr->len; - TclArithSeriesObjIndex(NULL, arithSeriesObj, len - 1, &startObj); + startObj = TclArithSeriesObjIndex(NULL, arithSeriesObj, (len-1)); Tcl_IncrRefCount(startObj); - TclArithSeriesObjIndex(NULL, arithSeriesObj, 0, &endObj); + endObj = TclArithSeriesObjIndex(NULL, arithSeriesObj, 0); Tcl_IncrRefCount(endObj); - TclArithSeriesObjStep(arithSeriesObj, &stepObj); + stepObj = ArithSeriesObjStep(arithSeriesObj); Tcl_IncrRefCount(stepObj); if (isDouble) { @@ -1059,16 +970,17 @@ TclArithSeriesObjReverse( TclSetIntObj(stepObj, step); } - if (Tcl_IsShared(arithSeriesObj) || (arithSeriesObj->refCount > 1)) { + if (Tcl_IsShared(arithSeriesObj) || + ((arithSeriesObj->refCount > 1))) { Tcl_Obj *lenObj; - TclNewIntObj(lenObj, len); - if (TclNewArithSeriesObj(NULL, &resultObj, isDouble, + if (TclNewArithSeriesObj(interp, &resultObj, isDouble, startObj, endObj, stepObj, lenObj) != TCL_OK) { resultObj = NULL; } Tcl_DecrRefCount(lenObj); } else { + /* * In-place is possible. */ @@ -1076,18 +988,25 @@ TclArithSeriesObjReverse( TclInvalidateStringRep(arithSeriesObj); if (isDouble) { - ArithSeriesDbl *dblRepPtr = (ArithSeriesDbl *) arithSeriesRepPtr; - - dblRepPtr->start = dstart; - dblRepPtr->end = dend; - dblRepPtr->step = dstep; + ArithSeriesDbl *arithSeriesDblRepPtr = + (ArithSeriesDbl*)arithSeriesRepPtr; + arithSeriesDblRepPtr->start = dstart; + arithSeriesDblRepPtr->end = dend; + arithSeriesDblRepPtr->step = dstep; } else { - ArithSeriesInt *intRepPtr = (ArithSeriesInt *) arithSeriesRepPtr; - intRepPtr->start = start; - intRepPtr->end = end; - intRepPtr->step = step; + arithSeriesRepPtr->start = start; + arithSeriesRepPtr->end = end; + arithSeriesRepPtr->step = step; } - FreeElements(arithSeriesRepPtr); + if (arithSeriesRepPtr->elements) { + Tcl_WideInt i; + for (i=0; i<len; i++) { + Tcl_DecrRefCount(arithSeriesRepPtr->elements[i]); + } + ckfree((char*)arithSeriesRepPtr->elements); + } + arithSeriesRepPtr->elements = NULL; + resultObj = arithSeriesObj; } @@ -1095,9 +1014,7 @@ TclArithSeriesObjReverse( Tcl_DecrRefCount(endObj); Tcl_DecrRefCount(stepObj); - *newObjPtr = resultObj; - - return TCL_OK; + return resultObj; } /* @@ -1127,31 +1044,29 @@ TclArithSeriesObjReverse( * *---------------------------------------------------------------------- */ + static void -UpdateStringOfArithSeries( - Tcl_Obj *arithSeriesObjPtr) +UpdateStringOfArithSeries(Tcl_Obj *arithSeriesObjPtr) { - ArithSeries *arithSeriesRepPtr = (ArithSeries *) - arithSeriesObjPtr->internalRep.twoPtrValue.ptr1; + ArithSeries *arithSeriesRepPtr = (ArithSeries*)arithSeriesObjPtr->internalRep.twoPtrValue.ptr1; char *p; Tcl_Obj *eleObj; Tcl_Size i, bytlen = 0; + Tcl_Size slen; /* * Pass 1: estimate space. */ if (!arithSeriesRepPtr->isDouble) { for (i = 0; i < arithSeriesRepPtr->len; i++) { - double d = ArithSeriesIndexInt(arithSeriesRepPtr, i); - size_t slen = d>0 ? log10(d)+1 : d<0 ? log10(-d)+2 : 1; - + double d = ArithSeriesIndexDbl(arithSeriesRepPtr, i); + slen = d>0 ? log10(d)+1 : d<0 ? log10((0-d))+2 : 1; bytlen += slen; } } else { for (i = 0; i < arithSeriesRepPtr->len; i++) { double d = ArithSeriesIndexDbl(arithSeriesRepPtr, i); - char tmp[TCL_DOUBLE_SPACE + 2]; - + char tmp[TCL_DOUBLE_SPACE+2]; tmp[0] = 0; Tcl_PrintDouble(NULL,d,tmp); if ((bytlen + strlen(tmp)) > TCL_SIZE_MAX) { @@ -1167,113 +1082,22 @@ UpdateStringOfArithSeries( */ p = Tcl_InitStringRep(arithSeriesObjPtr, NULL, bytlen); - for (i = 0; i < arithSeriesRepPtr->len; i++) { - if (TclArithSeriesObjIndex(NULL, arithSeriesObjPtr, i, &eleObj) == TCL_OK) { - Tcl_Size slen; - char *str = TclGetStringFromObj(eleObj, &slen); - - strcpy(p, str); - p[slen] = ' '; - p += slen + 1; - Tcl_DecrRefCount(eleObj); - } // else TODO: report error here? - } - if (bytlen > 0) { - arithSeriesObjPtr->bytes[bytlen - 1] = '\0'; + if (p == NULL) { + Tcl_Panic("Unable to allocate string size %d", bytlen); } - arithSeriesObjPtr->length = bytlen - 1; -} - -/* - *---------------------------------------------------------------------- - * - * ArithSeriesInOperator -- - * - * Evaluate the "in" operation for expr - * - * This can be done more efficiently in the Arith Series relative to - * doing a linear search as implemented in expr. - * - * Results: - * Boolean true or false (1/0) - * - * Side effects: - * None - * - *---------------------------------------------------------------------- - */ - -static int -ArithSeriesInOperation( - Tcl_Interp *interp, - Tcl_Obj *valueObj, - Tcl_Obj *arithSeriesObjPtr, - int *boolResult) -{ - ArithSeries *repPtr = (ArithSeries *) - arithSeriesObjPtr->internalRep.twoPtrValue.ptr1; - int status; - Tcl_Size index, incr, elen, vlen; - - if (repPtr->isDouble) { - ArithSeriesDbl *dblRepPtr = (ArithSeriesDbl *) repPtr; - double y; - int test = 0; - - incr = 0; // Check index+incr where incr is 0 and 1 - status = Tcl_GetDoubleFromObj(interp, valueObj, &y); - if (status != TCL_OK) { - test = 0; - } else { - const char *vstr = TclGetStringFromObj(valueObj, &vlen); - index = (y - dblRepPtr->start) / dblRepPtr->step; - while (incr<2) { - Tcl_Obj *elemObj; - - elen = 0; - TclArithSeriesObjIndex(interp, arithSeriesObjPtr, (index+incr), &elemObj); - - const char *estr = elemObj ? TclGetStringFromObj(elemObj, &elen) : ""; - - /* "in" operation defined as a string compare */ - test = (elen == vlen) ? (memcmp(estr, vstr, elen) == 0) : 0; - Tcl_BounceRefCount(elemObj); - /* Stop if we have a match */ - if (test) { - break; - } - incr++; - } - } - if (boolResult) { - *boolResult = test; - } - } else { - ArithSeriesInt *intRepPtr = (ArithSeriesInt *) repPtr; - Tcl_WideInt y; - - status = Tcl_GetWideIntFromObj(NULL, valueObj, &y); - if (status != TCL_OK) { - if (boolResult) { - *boolResult = 0; - } - } else { - Tcl_Obj *elemObj; - - elen = 0; - index = (y - intRepPtr->start) / intRepPtr->step; - TclArithSeriesObjIndex(interp, arithSeriesObjPtr, index, &elemObj); - - char const *vstr = TclGetStringFromObj(valueObj, &vlen); - char const *estr = elemObj ? TclGetStringFromObj(elemObj, &elen) : ""; - - if (boolResult) { - *boolResult = (elen == vlen) ? (memcmp(estr, vstr, elen) == 0) : 0; - } - Tcl_BounceRefCount(elemObj); + for (i = 0; i < arithSeriesRepPtr->len; i++) { + eleObj = TclArithSeriesObjIndex(NULL, arithSeriesObjPtr, i); + char *str = TclGetStringFromObj(eleObj, &slen); + if (((p - arithSeriesObjPtr->bytes)+slen) > bytlen) { + break; } + strncpy(p, str, slen); + p[slen] = ' '; + p += slen+1; + Tcl_DecrRefCount(eleObj); } - return TCL_OK; + if (bytlen > 0) arithSeriesObjPtr->bytes[bytlen-1] = '\0'; + arithSeriesObjPtr->length = bytlen-1; } /* diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 7bec144..61eb319 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -222,9 +222,9 @@ typedef struct AssemblyEnv { Tcl_HashTable labelHash; /* Hash table whose keys are labels and whose * values are 'label' objects storing the code * offsets of the labels. */ - Tcl_Size cmdLine; /* Current line number within the assembly + int cmdLine; /* Current line number within the assembly * code */ - Tcl_Size* clNext; /* Invisible continuation line for + int* clNext; /* Invisible continuation line for * [info frame] */ BasicBlock* head_bb; /* First basic block in the code */ BasicBlock* curr_bb; /* Current basic block */ @@ -277,7 +277,7 @@ static void DeleteMirrorJumpTable(JumptableInfo* jtPtr); static void FillInJumpOffsets(AssemblyEnv*); static int CreateMirrorJumpTable(AssemblyEnv* assemEnvPtr, Tcl_Obj* jumpTable); -static size_t FindLocalVar(AssemblyEnv* envPtr, +static int FindLocalVar(AssemblyEnv* envPtr, Tcl_Token** tokenPtrPtr); static int FinishAssembly(AssemblyEnv*); static void FreeAssemblyEnv(AssemblyEnv*); @@ -325,8 +325,7 @@ static const Tcl_ObjType assembleCodeType = { FreeAssembleCodeInternalRep, /* freeIntRepProc */ DupAssembleCodeInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ - NULL, /* setFromAnyProc */ - TCL_OBJTYPE_V0 + NULL /* setFromAnyProc */ }; /* @@ -410,6 +409,7 @@ static const TalInstDesc TalInstructionTable[] = { {"jumpTrue", ASSEM_JUMP, INST_JUMP_TRUE1, 1, 0}, {"jumpTrue4", ASSEM_JUMP4, INST_JUMP_TRUE4, 1, 0}, {"label", ASSEM_LABEL, 0, 0, 0}, + {"land", ASSEM_1BYTE, INST_LAND, 2, 1}, {"lappend", ASSEM_LVT, (INST_LAPPEND_SCALAR1<<8 | INST_LAPPEND_SCALAR4), 1, 1}, @@ -437,6 +437,7 @@ static const TalInstDesc TalInstructionTable[] = { | INST_LOAD_ARRAY4), 1, 1}, {"loadArrayStk", ASSEM_1BYTE, INST_LOAD_ARRAY_STK, 2, 1}, {"loadStk", ASSEM_1BYTE, INST_LOAD_STK, 1, 1}, + {"lor", ASSEM_1BYTE, INST_LOR, 2, 1}, {"lsetFlat", ASSEM_LSET_FLAT,INST_LSET_FLAT, INT_MIN,1}, {"lsetList", ASSEM_1BYTE, INST_LSET_LIST, 3, 1}, {"lshift", ASSEM_1BYTE, INST_LSHIFT, 2, 1}, @@ -771,7 +772,7 @@ BBEmitInst1or4( int Tcl_AssembleObjCmd( - void *clientData, /* clientData */ + ClientData clientData, /* clientData */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -786,7 +787,7 @@ Tcl_AssembleObjCmd( int TclNRAssembleObjCmd( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -857,7 +858,7 @@ CompileAssembleObj( * names in the bytecode resolve */ int status; /* Status return from Tcl_AssembleCode */ const char* source; /* String representation of the source code */ - Tcl_Size sourceLen; /* Length of the source code in bytes */ + int sourceLen; /* Length of the source code in bytes */ /* * Get the expression ByteCode from the object. If it exists, make sure it @@ -964,9 +965,9 @@ TclCompileAssembleCmd( { Tcl_Token *tokenPtr; /* Token in the input script */ - size_t numCommands = envPtr->numCommands; + int numCommands = envPtr->numCommands; int offset = envPtr->codeNext - envPtr->codeStart; - size_t depth = envPtr->currStackDepth; + int depth = envPtr->currStackDepth; /* * Make sure that the command has a single arg that is a simple word. */ @@ -986,9 +987,10 @@ TclCompileAssembleCmd( if (TCL_ERROR == TclAssembleCode(envPtr, tokenPtr[1].start, tokenPtr[1].size, TCL_EVAL_DIRECT)) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (\"%.*s\" body, line %d)", - (int)parsePtr->tokenPtr->size, parsePtr->tokenPtr->start, + parsePtr->tokenPtr->size, parsePtr->tokenPtr->start, Tcl_GetErrorLine(interp))); envPtr->numCommands = numCommands; envPtr->codeNext = envPtr->codeStart + offset; @@ -1075,7 +1077,7 @@ TclAssembleCode( */ if (parsePtr->numWords > 0) { - size_t instLen = parsePtr->commandSize; + int instLen = parsePtr->commandSize; /* Length in bytes of the current command */ if (parsePtr->term == parsePtr->commandStart + instLen - 1) { @@ -1089,7 +1091,7 @@ TclAssembleCode( #ifdef TCL_COMPILE_DEBUG if ((tclTraceCompile >= 2) && (envPtr->procPtr == NULL)) { printf(" %4" TCL_Z_MODIFIER "d Assembling: ", - envPtr->codeNext - envPtr->codeStart); + (size_t)(envPtr->codeNext - envPtr->codeStart)); TclPrintSource(stdout, parsePtr->commandStart, TclMin(instLen, 55)); printf("\n"); @@ -1215,14 +1217,14 @@ FreeAssemblyEnv( Tcl_DecrRefCount(thisBB->jumpTarget); } if (thisBB->foreignExceptions != NULL) { - Tcl_Free(thisBB->foreignExceptions); + ckfree(thisBB->foreignExceptions); } nextBB = thisBB->successor1; if (thisBB->jtPtr != NULL) { DeleteMirrorJumpTable(thisBB->jtPtr); thisBB->jtPtr = NULL; } - Tcl_Free(thisBB); + ckfree(thisBB); } /* @@ -1268,10 +1270,10 @@ AssembleOneLine( Tcl_Obj* operand1Obj = NULL; /* First operand to the instruction */ const char* operand1; /* String rep of the operand */ - Tcl_Size operand1Len; /* String length of the operand */ + int operand1Len; /* String length of the operand */ int opnd; /* Integer representation of an operand */ int litIndex; /* Literal pool index of a constant */ - Tcl_Size localVar; /* LVT index of a local variable */ + int localVar; /* LVT index of a local variable */ int flags; /* Flags for a basic block */ JumptableInfo* jtPtr; /* Pointer to a jumptable */ int infoIndex; /* Index of the jumptable in auxdata */ @@ -1383,7 +1385,7 @@ AssembleOneLine( } if (opnd < 0 || opnd > 3) { Tcl_SetObjResult(interp, - Tcl_NewStringObj("operand must be [0..3]", -1)); + Tcl_NewStringObj("operand must be [0..3]", -1)); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "OPERAND<0,>3", (void *)NULL); goto cleanup; } @@ -1541,7 +1543,7 @@ AssembleOneLine( goto cleanup; } - jtPtr = (JumptableInfo*)Tcl_Alloc(sizeof(JumptableInfo)); + jtPtr = (JumptableInfo*)ckalloc(sizeof(JumptableInfo)); Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS); assemEnvPtr->curr_bb->jumpLine = assemEnvPtr->cmdLine; @@ -1811,15 +1813,15 @@ CompileEmbeddedScript( * code. */ - size_t savedStackDepth = envPtr->currStackDepth; - size_t savedMaxStackDepth = envPtr->maxStackDepth; + int savedStackDepth = envPtr->currStackDepth; + int savedMaxStackDepth = envPtr->maxStackDepth; int savedExceptArrayNext = envPtr->exceptArrayNext; envPtr->currStackDepth = 0; envPtr->maxStackDepth = 0; StartBasicBlock(assemEnvPtr, BB_FALLTHRU, NULL); - switch (instPtr->tclInstCode) { + switch(instPtr->tclInstCode) { case INST_EVAL_STK: TclCompileScript(interp, tokenPtr->start, tokenPtr->size, envPtr); break; @@ -1935,7 +1937,7 @@ MoveExceptionRangesToBasicBlock( curr_bb->foreignExceptionBase = savedExceptArrayNext; curr_bb->foreignExceptionCount = exceptionCount; curr_bb->foreignExceptions = - (ExceptionRange*)Tcl_Alloc(exceptionCount * sizeof(ExceptionRange)); + (ExceptionRange*)ckalloc(exceptionCount * sizeof(ExceptionRange)); memcpy(curr_bb->foreignExceptions, envPtr->exceptArrayPtr + savedExceptArrayNext, exceptionCount * sizeof(ExceptionRange)); @@ -1968,7 +1970,7 @@ CreateMirrorJumpTable( AssemblyEnv* assemEnvPtr, /* Assembly environment */ Tcl_Obj* jumps) /* List of alternating keywords and labels */ { - Tcl_Size objc; /* Number of elements in the 'jumps' list */ + int objc; /* Number of elements in the 'jumps' list */ Tcl_Obj** objv; /* Pointers to the elements in the list */ CompileEnv* envPtr = assemEnvPtr->envPtr; /* Compilation environment */ @@ -1981,7 +1983,7 @@ CreateMirrorJumpTable( Tcl_HashEntry* hashEntry; /* Entry for a key in the hashtable */ int isNew; /* Flag==1 if the key is not yet in the * table. */ - Tcl_Size i; + int i; if (TclListObjLength(interp, jumps, &objc) != TCL_OK) { return TCL_ERROR; @@ -2003,7 +2005,7 @@ CreateMirrorJumpTable( * Allocate the jumptable. */ - jtPtr = (JumptableInfo*)Tcl_Alloc(sizeof(JumptableInfo)); + jtPtr = (JumptableInfo*)ckalloc(sizeof(JumptableInfo)); jtHashPtr = &jtPtr->hashTable; Tcl_InitHashTable(jtHashPtr, TCL_STRING_KEYS); @@ -2068,7 +2070,7 @@ DeleteMirrorJumpTable( Tcl_SetHashValue(entry, NULL); } Tcl_DeleteHashTable(jtHashPtr); - Tcl_Free(jtPtr); + ckfree(jtPtr); } /* @@ -2246,7 +2248,7 @@ static int GetListIndexOperand( AssemblyEnv* assemEnvPtr, /* Assembly environment */ Tcl_Token** tokenPtrPtr, /* Current token from the parser */ - int* result) /* OUTPUT: encoded index derived from the token */ + int* result) /* OUTPUT: Integer extracted from the token */ { CompileEnv* envPtr = assemEnvPtr->envPtr; /* Compilation environment */ @@ -2298,7 +2300,7 @@ GetListIndexOperand( *----------------------------------------------------------------------------- */ -static size_t +static int FindLocalVar( AssemblyEnv* assemEnvPtr, /* Assembly environment */ Tcl_Token** tokenPtrPtr) @@ -2312,27 +2314,27 @@ FindLocalVar( * source code. */ Tcl_Obj* varNameObj; /* Name of the variable */ const char* varNameStr; - Tcl_Size varNameLen; - Tcl_Size localVar; /* Index of the variable in the LVT */ + int varNameLen; + int localVar; /* Index of the variable in the LVT */ if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &varNameObj) != TCL_OK) { - return TCL_INDEX_NONE; + return -1; } varNameStr = TclGetStringFromObj(varNameObj, &varNameLen); if (CheckNamespaceQualifiers(interp, varNameStr, varNameLen)) { Tcl_DecrRefCount(varNameObj); - return TCL_INDEX_NONE; + return -1; } localVar = TclFindCompiledLocal(varNameStr, varNameLen, 1, envPtr); Tcl_DecrRefCount(varNameObj); - if (localVar < 0) { + if (localVar == -1) { if (assemEnvPtr->flags & TCL_EVAL_DIRECT) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot use this instruction to create a variable" " in a non-proc context", -1)); Tcl_SetErrorCode(interp, "TCL", "ASSEM", "LVT", (void *)NULL); } - return TCL_INDEX_NONE; + return -1; } *tokenPtrPtr = TokenAfter(tokenPtr); return localVar; @@ -2652,7 +2654,7 @@ AllocBB( AssemblyEnv* assemEnvPtr) /* Assembly environment */ { CompileEnv* envPtr = assemEnvPtr->envPtr; - BasicBlock *bb = (BasicBlock*)Tcl_Alloc(sizeof(BasicBlock)); + BasicBlock *bb = (BasicBlock*)ckalloc(sizeof(BasicBlock)); bb->originalStartOffset = bb->startOffset = envPtr->codeNext - envPtr->codeStart; @@ -2914,7 +2916,7 @@ CheckJumpTableLabels( valEntryPtr = Tcl_FindHashEntry(&assemEnvPtr->labelHash, TclGetString(symbolObj)); DEBUG_PRINT(" %s -> %s (%d)\n", - (char *)Tcl_GetHashKey(symHash, symEntryPtr), + (char*) Tcl_GetHashKey(symHash, symEntryPtr), TclGetString(symbolObj), (valEntryPtr != NULL)); if (valEntryPtr == NULL) { ReportUndefinedLabel(assemEnvPtr, bbPtr, symbolObj); @@ -3119,7 +3121,7 @@ ResolveJumpTableTargets( 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), + (char*) Tcl_GetHashKey(symHash, symEntryPtr), TclGetString(symbolObj), jumpTargetBBPtr, jumpTargetBBPtr->startOffset, realJumpEntryPtr); @@ -3320,7 +3322,7 @@ CheckStack( { CompileEnv* envPtr = assemEnvPtr->envPtr; /* Compilation environment */ - Tcl_Size maxDepth; /* Maximum stack depth overall */ + int maxDepth; /* Maximum stack depth overall */ /* * Checking the head block will check all the other blocks recursively. @@ -3930,8 +3932,8 @@ BuildExceptionRanges( * Allocate memory for a stack of active catches. */ - catches = (BasicBlock**)Tcl_Alloc(maxCatchDepth * sizeof(BasicBlock*)); - catchIndices = (int *)Tcl_Alloc(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; @@ -3970,8 +3972,8 @@ BuildExceptionRanges( /* Free temp storage */ - Tcl_Free(catchIndices); - Tcl_Free(catches); + ckfree(catchIndices); + ckfree(catches); return TCL_OK; } @@ -4129,7 +4131,7 @@ StackFreshCatches( TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); range = envPtr->exceptArrayPtr + catchIndices[catchDepth]; range->nestingLevel = envPtr->exceptDepth + catchDepth; - envPtr->maxExceptDepth= + envPtr->maxExceptDepth = TclMax(range->nestingLevel + 1, envPtr->maxExceptDepth); range->codeOffset = bbPtr->startOffset; @@ -4166,7 +4168,7 @@ RestoreEmbeddedExceptionRanges( BasicBlock* bbPtr; /* Current basic block */ int rangeBase; /* Base of the foreign exception ranges when * they are reinstalled */ - size_t rangeIndex; /* Index of the current foreign exception + int rangeIndex; /* Index of the current foreign exception * range as reinstalled */ ExceptionRange* range; /* Current foreign exception range */ unsigned char opcode; /* Current instruction's opcode */ @@ -4193,7 +4195,7 @@ RestoreEmbeddedExceptionRanges( range->nestingLevel += envPtr->exceptDepth + bbPtr->catchDepth; memcpy(envPtr->exceptArrayPtr + rangeIndex, range, sizeof(ExceptionRange)); - if (range->nestingLevel + 1 >= envPtr->maxExceptDepth + 1) { + if (range->nestingLevel >= envPtr->maxExceptDepth) { envPtr->maxExceptDepth = range->nestingLevel + 1; } } diff --git a/generic/tclAsync.c b/generic/tclAsync.c index f0f0c9c..9ce2c88 100644 --- a/generic/tclAsync.c +++ b/generic/tclAsync.c @@ -30,7 +30,7 @@ typedef struct AsyncHandler { * for the process. */ Tcl_AsyncProc *proc; /* Procedure to call when handler is * invoked. */ - void *clientData; /* Value to pass to handler when it is + ClientData clientData; /* Value to pass to handler when it is * invoked. */ struct ThreadSpecificData *originTsd; /* Used in Tcl_AsyncMark to modify thread- @@ -38,7 +38,7 @@ typedef struct AsyncHandler { * associated to. */ Tcl_ThreadId originThrdId; /* Origin thread where this token was created * and where it will be yielded. */ - void *notifierData; /* Platform notifier data or NULL. */ + ClientData notifierData; /* Platform notifier data or NULL. */ } AsyncHandler; typedef struct ThreadSpecificData { @@ -115,7 +115,7 @@ TclFinalizeAsync(void) while (toDelete != NULL) { token = toDelete; toDelete = toDelete->nextPtr; - Tcl_Free(token); + ckfree(token); } } @@ -142,12 +142,12 @@ Tcl_AsyncHandler Tcl_AsyncCreate( Tcl_AsyncProc *proc, /* Procedure to call when handler is * invoked. */ - void *clientData) /* Argument to pass to handler. */ + ClientData clientData) /* Argument to pass to handler. */ { AsyncHandler *asyncPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - asyncPtr = (AsyncHandler*)Tcl_Alloc(sizeof(AsyncHandler)); + asyncPtr = (AsyncHandler*)ckalloc(sizeof(AsyncHandler)); asyncPtr->ready = 0; asyncPtr->nextPtr = NULL; asyncPtr->prevPtr = NULL; @@ -406,7 +406,7 @@ Tcl_AsyncDelete( asyncPtr->nextPtr->prevPtr = asyncPtr->prevPtr; } Tcl_MutexUnlock(&asyncMutex); - Tcl_Free(asyncPtr); + ckfree(asyncPtr); } /* diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 3faa201..ef13c5a 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -113,6 +113,18 @@ TclGetCStackPtr(void) #endif /* + * The following structure defines the client data for a math function + * registered with Tcl_CreateMathFunc + */ + +typedef struct OldMathFuncData { + Tcl_MathProc *proc; /* Handler function */ + int numArgs; /* Number of args expected */ + Tcl_ValueType *argTypes; /* Types of the args */ + void *clientData; /* Client data for the handler function */ +} OldMathFuncData; + +/* * This is the script cancellation struct and hash table. The hash table is * used to keep track of the information necessary to process script * cancellation requests, including the original interp, asynchronous handler @@ -184,7 +196,6 @@ static Tcl_NRPostProc DTraceCmdReturn; #else # define DTraceCmdReturn NULL #endif /* USE_DTRACE */ -static Tcl_ObjCmdProc InvokeStringCommand; static Tcl_ObjCmdProc ExprAbsFunc; static Tcl_ObjCmdProc ExprBinaryFunc; static Tcl_ObjCmdProc ExprBoolFunc; @@ -214,18 +225,22 @@ static Tcl_NRPostProc NRCoroutineCallerCallback; static Tcl_NRPostProc NRCoroutineExitCallback; static Tcl_NRPostProc NRCommand; +#if !defined(TCL_NO_DEPRECATED) +static Tcl_ObjCmdProc OldMathFuncProc; +static void OldMathFuncDeleteProc(void *clientData); +#endif /* !defined(TCL_NO_DEPRECATED) */ static void ProcessUnexpectedResult(Tcl_Interp *interp, int returnCode); static int RewindCoroutine(CoroutineData *corPtr, int result); static void TEOV_SwitchVarFrame(Tcl_Interp *interp); static void TEOV_PushExceptionHandlers(Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[], int flags); + Tcl_Size objc, Tcl_Obj *const objv[], int flags); static inline Command * TEOV_LookupCmdFromObj(Tcl_Interp *interp, Tcl_Obj *namePtr, Namespace *lookupNsPtr); -static int TEOV_NotFound(Tcl_Interp *interp, int objc, +static int TEOV_NotFound(Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], Namespace *lookupNsPtr); static int TEOV_RunEnterTraces(Tcl_Interp *interp, - Command **cmdPtrPtr, Tcl_Obj *commandPtr, int objc, + Command **cmdPtrPtr, Tcl_Obj *commandPtr, Tcl_Size objc, Tcl_Obj *const objv[]); static Tcl_NRPostProc RewindCoroutineCallback; static Tcl_NRPostProc TEOEx_ByteCodeCallback; @@ -300,16 +315,6 @@ typedef struct { * The built-in commands, and the functions that implement them: */ -static int -procObjCmd( - void *clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - return Tcl_ProcObjCmd(clientData, interp, objc, objv); -} - static const CmdInfo builtInCmds[] = { /* * Commands in the generic core. @@ -318,9 +323,11 @@ 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}, +#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}, - {"const", Tcl_ConstObjCmd, TclCompileConstCmd, 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}, @@ -338,7 +345,7 @@ static const CmdInfo builtInCmds[] = { {"join", Tcl_JoinObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lappend", Tcl_LappendObjCmd, TclCompileLappendCmd, NULL, CMD_IS_SAFE}, {"lassign", Tcl_LassignObjCmd, TclCompileLassignCmd, NULL, CMD_IS_SAFE}, - {"ledit", Tcl_LeditObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"ledit", Tcl_LeditObjCmd, NULL, NULL, CMD_IS_SAFE}, {"lindex", Tcl_LindexObjCmd, TclCompileLindexCmd, NULL, CMD_IS_SAFE}, {"linsert", Tcl_LinsertObjCmd, TclCompileLinsertCmd, NULL, CMD_IS_SAFE}, {"list", Tcl_ListObjCmd, TclCompileListCmd, NULL, CMD_IS_SAFE|CMD_COMPILES_EXPANDED}, @@ -355,7 +362,7 @@ static const CmdInfo builtInCmds[] = { {"lset", Tcl_LsetObjCmd, TclCompileLsetCmd, NULL, CMD_IS_SAFE}, {"lsort", Tcl_LsortObjCmd, NULL, NULL, CMD_IS_SAFE}, {"package", Tcl_PackageObjCmd, NULL, TclNRPackageObjCmd, CMD_IS_SAFE}, - {"proc", procObjCmd, NULL, NULL, CMD_IS_SAFE}, + {"proc", Tcl_ProcObjCmd, NULL, NULL, CMD_IS_SAFE}, {"regexp", Tcl_RegexpObjCmd, TclCompileRegexpCmd, NULL, CMD_IS_SAFE}, {"regsub", Tcl_RegsubObjCmd, TclCompileRegsubCmd, NULL, CMD_IS_SAFE}, {"rename", Tcl_RenameObjCmd, NULL, NULL, CMD_IS_SAFE}, @@ -651,10 +658,10 @@ TclFinalizeEvaluation(void) */ static int -buildInfoObjCmd2( +buildInfoObjCmd( void *clientData, Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Size objc, /* Number of arguments. */ + int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { if (objc > 2) { @@ -736,16 +743,6 @@ buildInfoObjCmd2( return TCL_OK; } -static int -buildInfoObjCmd( - void *clientData, - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - return buildInfoObjCmd2(clientData, interp, objc, objv); -} - /* *---------------------------------------------------------------------- * @@ -797,13 +794,16 @@ Tcl_CreateInterp(void) Tcl_Panic("Tcl_CallFrame must not be smaller than CallFrame"); } -#if defined(_WIN32) && !defined(_WIN64) - if (sizeof(time_t) != 8) { - Tcl_Panic("<time.h> is not compatible with VS2005+"); - } +#if defined(_WIN32) && !defined(_WIN64) && !defined(_USE_64BIT_TIME_T) + /* If Tcl is compiled on Win32 using -D_USE_64BIT_TIME_T + * the result is a binary incompatible with the 'standard' build of + * Tcl: All extensions using Tcl_StatBuf need to be recompiled in + * the same way. Therefore, this is not officially supported. + * In stead, it is recommended to use Win64 or Tcl 9.0 (not released yet) + */ if ((offsetof(Tcl_StatBuf,st_atime) != 32) - || (offsetof(Tcl_StatBuf,st_ctime) != 48)) { - Tcl_Panic("<sys/stat.h> is not compatible with VS2005+"); + || (offsetof(Tcl_StatBuf,st_ctime) != 40)) { + Tcl_Panic("<sys/stat.h> is not compatible with MSVC"); } #endif @@ -837,13 +837,15 @@ Tcl_CreateInterp(void) * object type table and other object management code. */ - iPtr = (Interp *)Tcl_Alloc(sizeof(Interp)); + iPtr = (Interp *)ckalloc(sizeof(Interp)); interp = (Tcl_Interp *) iPtr; - iPtr->legacyResult = NULL; - /* Special invalid value: Any attempt to free the legacy result - * will cause a crash. */ - iPtr->legacyFreeProc = (void (*) (void))-1; +#ifdef TCL_NO_DEPRECATED + iPtr->result = &tclEmptyString; +#else + iPtr->result = iPtr->resultSpace; +#endif + iPtr->freeProc = NULL; iPtr->errorLine = 0; iPtr->stubTable = &tclStubs; TclNewObj(iPtr->objResultPtr); @@ -853,7 +855,8 @@ Tcl_CreateInterp(void) iPtr->hiddenCmdTablePtr = NULL; iPtr->interpInfo = NULL; - iPtr->optimizer = TclOptimizeBytecode; + TCL_CT_ASSERT(sizeof(iPtr->extra) <= sizeof(Tcl_HashTable)); + iPtr->extra.optimizer = TclOptimizeBytecode; iPtr->numLevels = 0; iPtr->maxNestingDepth = MAX_NESTING_DEPTH; @@ -866,10 +869,10 @@ Tcl_CreateInterp(void) */ iPtr->cmdFramePtr = NULL; - iPtr->linePBodyPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); - iPtr->lineBCPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); - iPtr->lineLAPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); - iPtr->lineLABCPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); + iPtr->linePBodyPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + iPtr->lineBCPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + iPtr->lineLAPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); + iPtr->lineLABCPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(iPtr->linePBodyPtr, TCL_ONE_WORD_KEYS); Tcl_InitHashTable(iPtr->lineBCPtr, TCL_ONE_WORD_KEYS); Tcl_InitHashTable(iPtr->lineLAPtr, TCL_ONE_WORD_KEYS); @@ -902,6 +905,12 @@ 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; @@ -934,6 +943,9 @@ Tcl_CreateInterp(void) TclNewObj(iPtr->emptyObjPtr); /* Another empty object. */ Tcl_IncrRefCount(iPtr->emptyObjPtr); +#ifndef TCL_NO_DEPRECATED + iPtr->resultSpace[0] = 0; +#endif iPtr->threadId = Tcl_GetCurrentThread(); /* TIP #378 */ @@ -967,7 +979,7 @@ Tcl_CreateInterp(void) */ /* This is needed to satisfy GCC 3.3's strict aliasing rules */ - framePtr = (CallFrame *)Tcl_Alloc(sizeof(CallFrame)); + framePtr = (CallFrame *)ckalloc(sizeof(CallFrame)); (void) Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr, (Tcl_Namespace *) iPtr->globalNsPtr, /*isProcCallFrame*/ 0); framePtr->objc = 0; @@ -997,7 +1009,7 @@ Tcl_CreateInterp(void) TclNewObj(iPtr->asyncCancelMsg); - cancelInfo = (CancelInfo *)Tcl_Alloc(sizeof(CancelInfo)); + cancelInfo = (CancelInfo *)ckalloc(sizeof(CancelInfo)); cancelInfo->interp = interp; iPtr->asyncCancel = Tcl_AsyncCreate(CancelEvalProc, cancelInfo); @@ -1072,7 +1084,7 @@ Tcl_CreateInterp(void) /* * Create the core commands. Do it here, rather than calling Tcl_CreateObjCommand, * because it's faster (there's no need to check for a preexisting command - * by the same name). Set the Tcl_CmdProc to NULL. + * by the same name). Set the Tcl_CmdProc to TclInvokeObjectCommand. */ for (cmdInfoPtr = builtInCmds; cmdInfoPtr->name != NULL; cmdInfoPtr++) { @@ -1085,13 +1097,13 @@ Tcl_CreateInterp(void) hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable, cmdInfoPtr->name, &isNew); if (isNew) { - cmdPtr = (Command *)Tcl_Alloc(sizeof(Command)); + cmdPtr = (Command *)ckalloc(sizeof(Command)); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = iPtr->globalNsPtr; cmdPtr->refCount = 1; cmdPtr->cmdEpoch = 0; cmdPtr->compileProc = cmdInfoPtr->compileProc; - cmdPtr->proc = NULL; + cmdPtr->proc = TclInvokeObjectCommand; cmdPtr->clientData = cmdPtr; cmdPtr->objProc = cmdInfoPtr->objProc; cmdPtr->objClientData = NULL; @@ -1215,7 +1227,7 @@ Tcl_CreateInterp(void) #define MATH_OP_PREFIX_LEN 15 /* == strlen("::tcl::mathop::") */ memcpy(mathFuncName, "::tcl::mathop::", MATH_OP_PREFIX_LEN); for (opcmdInfoPtr=mathOpCmds ; opcmdInfoPtr->name!=NULL ; opcmdInfoPtr++){ - TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)Tcl_Alloc(sizeof(TclOpCmdClientData)); + TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)ckalloc(sizeof(TclOpCmdClientData)); occdPtr->op = opcmdInfoPtr->name; occdPtr->i.numArgs = opcmdInfoPtr->i.numArgs; @@ -1273,8 +1285,24 @@ Tcl_CreateInterp(void) 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); +#if TCL_THREADS && !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 + /* + * The existence of the "threaded" element of the tcl_platform array + * indicates that this particular Tcl shell has been compiled with threads + * turned on. Using "info exists tcl_platform(threaded)" a Tcl script can + * introspect on the interpreter level of thread safety. + */ + + Tcl_SetVar2(interp, "tcl_platform", "threaded", "1", TCL_GLOBAL_ONLY); +#endif + /* * Register Tcl's version number. * TIP #268: Full patchlevel instead of just major.minor @@ -1283,13 +1311,8 @@ Tcl_CreateInterp(void) Tcl_PkgProvideEx(interp, "Tcl", TCL_PATCH_LEVEL, &tclStubs); Tcl_PkgProvideEx(interp, "tcl", TCL_PATCH_LEVEL, &tclStubs); - Tcl_CmdInfo info2; - Tcl_Command buildInfoCmd = Tcl_CreateObjCommand(interp, "::tcl::build-info", + Tcl_CreateObjCommand(interp, "::tcl::build-info", buildInfoObjCmd, (void *)version, NULL); - Tcl_GetCommandInfoFromToken(buildInfoCmd, &info2); - info2.objProc2 = buildInfoObjCmd2; - info2.objClientData2 = (void *)version; - Tcl_SetCommandInfoFromToken(buildInfoCmd, &info2); if (TclTommath_Init(interp) != TCL_OK) { Tcl_Panic("%s", Tcl_GetStringResult(interp)); @@ -1323,7 +1346,7 @@ DeleteOpCmdClientData( { TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)clientData; - Tcl_Free(occdPtr); + ckfree(occdPtr); } /* @@ -1532,14 +1555,14 @@ Tcl_CallWhenDeleted( (int *)Tcl_GetThreadData(&assocDataCounterKey, sizeof(int)); int isNew; char buffer[32 + TCL_INTEGER_SPACE]; - AssocData *dPtr = (AssocData *)Tcl_Alloc(sizeof(AssocData)); + AssocData *dPtr = (AssocData *)ckalloc(sizeof(AssocData)); Tcl_HashEntry *hPtr; snprintf(buffer, sizeof(buffer), "Assoc Data Key #%d", *assocDataCounterPtr); (*assocDataCounterPtr)++; if (iPtr->assocData == NULL) { - iPtr->assocData = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); + iPtr->assocData = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); } hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &isNew); @@ -1588,7 +1611,7 @@ Tcl_DontCallWhenDeleted( hPtr = Tcl_NextHashEntry(&hSearch)) { dPtr = (AssocData *)Tcl_GetHashValue(hPtr); if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) { - Tcl_Free(dPtr); + ckfree(dPtr); Tcl_DeleteHashEntry(hPtr); return; } @@ -1628,14 +1651,14 @@ Tcl_SetAssocData( int isNew; if (iPtr->assocData == NULL) { - iPtr->assocData = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); + iPtr->assocData = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS); } hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &isNew); if (isNew == 0) { dPtr = (AssocData *)Tcl_GetHashValue(hPtr); } else { - dPtr = (AssocData *)Tcl_Alloc(sizeof(AssocData)); + dPtr = (AssocData *)ckalloc(sizeof(AssocData)); } dPtr->proc = proc; dPtr->clientData = clientData; @@ -1681,7 +1704,7 @@ Tcl_DeleteAssocData( if (dPtr->proc != NULL) { dPtr->proc(dPtr->clientData, interp); } - Tcl_Free(dPtr); + ckfree(dPtr); } /* @@ -1828,7 +1851,7 @@ Tcl_DeleteInterp( static void DeleteInterpProc( - void *blockPtr) /* Interpreter to delete. */ + char *blockPtr) /* Interpreter to delete. */ { Tcl_Interp *interp = (Tcl_Interp *) blockPtr; Interp *iPtr = (Interp *) interp; @@ -1877,9 +1900,9 @@ DeleteInterpProc( if (cancelInfo != NULL) { if (cancelInfo->result != NULL) { - Tcl_Free(cancelInfo->result); + ckfree(cancelInfo->result); } - Tcl_Free(cancelInfo); + ckfree(cancelInfo); } Tcl_DeleteHashEntry(hPtr); @@ -1934,7 +1957,7 @@ DeleteInterpProc( Tcl_DeleteCommandFromToken(interp, (Tcl_Command)Tcl_GetHashValue(hPtr)); } Tcl_DeleteHashTable(hTablePtr); - Tcl_Free(hTablePtr); + ckfree(hTablePtr); } @@ -1954,10 +1977,10 @@ DeleteInterpProc( dPtr->proc(dPtr->clientData, interp); } Tcl_DeleteHashEntry(hPtr); - Tcl_Free(dPtr); + ckfree(dPtr); } Tcl_DeleteHashTable(hTablePtr); - Tcl_Free(hTablePtr); + ckfree(hTablePtr); iPtr->assocData = NULL; } @@ -1970,7 +1993,7 @@ DeleteInterpProc( Tcl_Panic("DeleteInterpProc: popping rootCallFrame with other frames on top"); } Tcl_PopCallFrame(interp); - Tcl_Free(iPtr->rootFramePtr); + ckfree(iPtr->rootFramePtr); iPtr->rootFramePtr = NULL; Tcl_DeleteNamespace((Tcl_Namespace *) iPtr->globalNsPtr); @@ -1979,6 +2002,10 @@ DeleteInterpProc( * could have transferred ownership of the result string to Tcl. */ +#ifndef TCL_NO_DEPRECATED + Tcl_FreeResult(interp); + iPtr->result = NULL; +#endif Tcl_DecrRefCount(iPtr->objResultPtr); iPtr->objResultPtr = NULL; Tcl_DecrRefCount(iPtr->ecVar); @@ -2000,6 +2027,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); @@ -2017,8 +2050,8 @@ DeleteInterpProc( resPtr = iPtr->resolverPtr; while (resPtr) { nextResPtr = resPtr->nextPtr; - Tcl_Free(resPtr->name); - Tcl_Free(resPtr); + ckfree(resPtr->name); + ckfree(resPtr); resPtr = nextResPtr; } @@ -2045,13 +2078,13 @@ DeleteInterpProc( if (cfPtr->type == TCL_LOCATION_SOURCE) { Tcl_DecrRefCount(cfPtr->data.eval.path); } - Tcl_Free(cfPtr->line); - Tcl_Free(cfPtr); + ckfree(cfPtr->line); + ckfree(cfPtr); } Tcl_DeleteHashEntry(hPtr); } Tcl_DeleteHashTable(iPtr->linePBodyPtr); - Tcl_Free(iPtr->linePBodyPtr); + ckfree(iPtr->linePBodyPtr); iPtr->linePBodyPtr = NULL; /* @@ -2067,18 +2100,18 @@ DeleteInterpProc( Tcl_DecrRefCount(eclPtr->path); } for (i=0; i<eclPtr->nuloc; i++) { - Tcl_Free(eclPtr->loc[i].line); + ckfree(eclPtr->loc[i].line); } if (eclPtr->loc != NULL) { - Tcl_Free(eclPtr->loc); + ckfree(eclPtr->loc); } - Tcl_Free(eclPtr); + ckfree(eclPtr); Tcl_DeleteHashEntry(hPtr); } Tcl_DeleteHashTable(iPtr->lineBCPtr); - Tcl_Free(iPtr->lineBCPtr); + ckfree(iPtr->lineBCPtr); iPtr->lineBCPtr = NULL; /* @@ -2097,7 +2130,7 @@ DeleteInterpProc( } Tcl_DeleteHashTable(iPtr->lineLAPtr); - Tcl_Free(iPtr->lineLAPtr); + ckfree(iPtr->lineLAPtr); iPtr->lineLAPtr = NULL; if (iPtr->lineLABCPtr->numEntries && !TclInExit()) { @@ -2110,7 +2143,7 @@ DeleteInterpProc( } Tcl_DeleteHashTable(iPtr->lineLABCPtr); - Tcl_Free(iPtr->lineLABCPtr); + ckfree(iPtr->lineLABCPtr); iPtr->lineLABCPtr = NULL; /* @@ -2121,7 +2154,7 @@ DeleteInterpProc( Tcl_DeleteHashTable(&iPtr->varTraces); Tcl_DeleteHashTable(&iPtr->varSearches); - Tcl_Free(iPtr); + ckfree(iPtr); } /* @@ -2189,7 +2222,7 @@ Tcl_HideCommand( if (strstr(hiddenCmdToken, "::") != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot use namespace qualifiers in hidden command" - " token (rename)", -1)); + " token (rename)", TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "HIDDENTOKEN", (char *)NULL); return TCL_ERROR; } @@ -2214,7 +2247,7 @@ Tcl_HideCommand( if (cmdPtr->nsPtr != iPtr->globalNsPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "can only hide global namespace commands (use rename then hide)", - -1)); + TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "HIDE", "NON_GLOBAL", (char *)NULL); return TCL_ERROR; } @@ -2225,7 +2258,7 @@ Tcl_HideCommand( hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr; if (hiddenCmdTablePtr == NULL) { - hiddenCmdTablePtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); + hiddenCmdTablePtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(hiddenCmdTablePtr, TCL_STRING_KEYS); iPtr->hiddenCmdTablePtr = hiddenCmdTablePtr; } @@ -2344,7 +2377,7 @@ Tcl_ExposeCommand( if (strstr(cmdName, "::") != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "cannot expose to a namespace (use expose to toplevel, then rename)", - -1)); + TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "EXPOSE", "NON_GLOBAL", (char *)NULL); return TCL_ERROR; } @@ -2381,7 +2414,7 @@ Tcl_ExposeCommand( Tcl_SetObjResult(interp, Tcl_NewStringObj( "trying to expose a non-global command namespace command", - -1)); + TCL_INDEX_NONE)); return TCL_ERROR; } @@ -2481,7 +2514,7 @@ Tcl_ExposeCommand( * In the future, when cmdName is seen as the name of a command by * Tcl_Eval, proc will be called. To support the bytecode interpreter, * the command is created with a wrapper Tcl_ObjCmdProc - * (InvokeStringCommand) that eventually calls proc. When the command + * (TclInvokeStringCommand) that eventually calls proc. When the command * is deleted from the table, deleteProc will be called. See the manual * entry for details on the calling sequence. * @@ -2591,7 +2624,7 @@ Tcl_CreateCommand( * infinite loop). */ - Tcl_Free(Tcl_GetHashValue(hPtr)); + ckfree(Tcl_GetHashValue(hPtr)); } if (!deleted) { @@ -2616,14 +2649,14 @@ Tcl_CreateCommand( TclInvalidateNsCmdLookup(nsPtr); TclInvalidateNsPath(nsPtr); } - cmdPtr = (Command *)Tcl_Alloc(sizeof(Command)); + cmdPtr = (Command *)ckalloc(sizeof(Command)); Tcl_SetHashValue(hPtr, cmdPtr); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = nsPtr; cmdPtr->refCount = 1; cmdPtr->cmdEpoch = 0; cmdPtr->compileProc = NULL; - cmdPtr->objProc = InvokeStringCommand; + cmdPtr->objProc = TclInvokeStringCommand; cmdPtr->objClientData = cmdPtr; cmdPtr->proc = proc; cmdPtr->clientData = clientData; @@ -2674,6 +2707,7 @@ Tcl_CreateCommand( * Side effects: * If a command named "cmdName" already exists for interp, it is * first deleted. Then the new command is created from the arguments. + * [***] (See below for exception). * * In the future, during bytecode evaluation when "cmdName" is seen as * the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based @@ -2684,71 +2718,6 @@ Tcl_CreateCommand( *---------------------------------------------------------------------- */ -typedef struct { - Tcl_ObjCmdProc2 *proc; - void *clientData; /* Arbitrary value to pass to proc function. */ - Tcl_CmdDeleteProc *deleteProc; - void *deleteData; /* Arbitrary value to pass to deleteProc function. */ - Tcl_ObjCmdProc2 *nreProc; -} CmdWrapperInfo; - - -static int -cmdWrapperProc( - void *clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj * const *objv) -{ - CmdWrapperInfo *info = (CmdWrapperInfo *)clientData; - if (objc < 0) { - objc = -1; - } - return info->proc(info->clientData, interp, objc, objv); -} - -static void -cmdWrapperDeleteProc( - void *clientData) -{ - CmdWrapperInfo *info = (CmdWrapperInfo *)clientData; - - clientData = info->deleteData; - Tcl_CmdDeleteProc *deleteProc = info->deleteProc; - Tcl_Free(info); - if (deleteProc != NULL) { - deleteProc(clientData); - } -} - -Tcl_Command -Tcl_CreateObjCommand2( - Tcl_Interp *interp, /* Token for command interpreter (returned by - * previous call to Tcl_CreateInterp). */ - const char *cmdName, /* Name of command. If it contains namespace - * qualifiers, the new command is put in the - * specified namespace; otherwise it is put in - * the global namespace. */ - Tcl_ObjCmdProc2 *proc, /* Object-based function to associate with - * name. */ - void *clientData, /* Arbitrary value to pass to object - * function. */ - Tcl_CmdDeleteProc *deleteProc - /* If not NULL, gives a function to call when - * this command is deleted. */ -) -{ - CmdWrapperInfo *info = (CmdWrapperInfo *)Tcl_Alloc(sizeof(CmdWrapperInfo)); - info->proc = proc; - info->clientData = clientData; - info->deleteProc = deleteProc; - info->deleteData = clientData; - - return Tcl_CreateObjCommand(interp, cmdName, - (proc ? cmdWrapperProc : NULL), - info, cmdWrapperDeleteProc); -} - Tcl_Command Tcl_CreateObjCommand( Tcl_Interp *interp, /* Token for command interpreter (returned by @@ -2847,7 +2816,24 @@ TclCreateObjCommandInNs( cmdPtr = (Command *)Tcl_GetHashValue(hPtr); /* - * Command already exists; delete it. Be careful to preserve any + * [***] This is wrong. See Tcl Bug a16752c252. + * However, this buggy behavior is kept under particular circumstances + * to accommodate deployed binaries of the "tclcompiler" program + * <http://sourceforge.net/projects/tclpro/> that crash if the bug is + * fixed. + */ + + if (cmdPtr->objProc == TclInvokeStringCommand + && cmdPtr->clientData == clientData + && cmdPtr->deleteData == clientData + && cmdPtr->deleteProc == deleteProc) { + cmdPtr->objProc = proc; + cmdPtr->objClientData = clientData; + return (Tcl_Command) cmdPtr; + } + + /* + * Otherwise, we delete the old command. Be careful to preserve any * existing import links so we can restore them down below. That way, * you can redefine a command and its import status will remain * intact. @@ -2883,7 +2869,7 @@ TclCreateObjCommandInNs( * infinite loop). */ - Tcl_Free(Tcl_GetHashValue(hPtr)); + ckfree(Tcl_GetHashValue(hPtr)); } if (!deleted) { @@ -2908,7 +2894,7 @@ TclCreateObjCommandInNs( TclInvalidateNsCmdLookup(nsPtr); TclInvalidateNsPath(nsPtr); } - cmdPtr = (Command *)Tcl_Alloc(sizeof(Command)); + cmdPtr = (Command *)ckalloc(sizeof(Command)); Tcl_SetHashValue(hPtr, cmdPtr); cmdPtr->hPtr = hPtr; cmdPtr->nsPtr = nsPtr; @@ -2917,7 +2903,7 @@ TclCreateObjCommandInNs( cmdPtr->compileProc = NULL; cmdPtr->objProc = proc; cmdPtr->objClientData = clientData; - cmdPtr->proc = NULL; + cmdPtr->proc = TclInvokeObjectCommand; cmdPtr->clientData = cmdPtr; cmdPtr->deleteProc = deleteProc; cmdPtr->deleteData = clientData; @@ -2958,7 +2944,7 @@ TclCreateObjCommandInNs( /* *---------------------------------------------------------------------- * - * InvokeStringCommand -- + * TclInvokeStringCommand -- * * "Wrapper" Tcl_ObjCmdProc used to call an existing string-based * Tcl_CmdProc if no object-based function exists for a command. A @@ -2971,13 +2957,13 @@ TclCreateObjCommandInNs( * * Side effects: * Besides those side effects of the called Tcl_CmdProc, - * InvokeStringCommand allocates and frees storage. + * TclInvokeStringCommand allocates and frees storage. * *---------------------------------------------------------------------- */ int -InvokeStringCommand( +TclInvokeStringCommand( void *clientData, /* Points to command's Command structure. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ @@ -3006,6 +2992,78 @@ InvokeStringCommand( /* *---------------------------------------------------------------------- * + * TclInvokeObjectCommand -- + * + * "Wrapper" Tcl_CmdProc used to call an existing object-based + * Tcl_ObjCmdProc if no string-based function exists for a command. A + * pointer to this function is stored as the Tcl_CmdProc in a Command + * structure. It simply turns around and calls the object Tcl_ObjCmdProc + * in the Command structure. + * + * Results: + * A standard Tcl result value. + * + * Side effects: + * Besides those side effects of the called Tcl_ObjCmdProc, + * TclInvokeObjectCommand allocates and frees storage. + * + *---------------------------------------------------------------------- + */ + +int +TclInvokeObjectCommand( + void *clientData, /* Points to command's Command structure. */ + Tcl_Interp *interp, /* Current interpreter. */ + int argc, /* Number of arguments. */ + const char **argv) /* Argument strings. */ +{ + Command *cmdPtr = ( Command *) clientData; + Tcl_Obj *objPtr; + int i, length, result; + Tcl_Obj **objv = (Tcl_Obj **) + TclStackAlloc(interp, (argc * sizeof(Tcl_Obj *))); + + for (i = 0; i < argc; i++) { + length = strlen(argv[i]); + TclNewStringObj(objPtr, argv[i], length); + Tcl_IncrRefCount(objPtr); + objv[i] = objPtr; + } + + /* + * Invoke the command's object-based Tcl_ObjCmdProc. + */ + + if (cmdPtr->objProc != NULL) { + result = cmdPtr->objProc(cmdPtr->objClientData, interp, argc, objv); + } else { + result = Tcl_NRCallObjProc(interp, cmdPtr->nreProc, + cmdPtr->objClientData, argc, objv); + } + + /* + * Move the interpreter's object result to the string result, then reset + * the object result. + */ + + (void) Tcl_GetStringResult(interp); + + /* + * Decrement the ref counts for the argument objects created above, then + * free the objv array if malloc'ed storage was used. + */ + + for (i = 0; i < argc; i++) { + objPtr = objv[i]; + Tcl_DecrRefCount(objPtr); + } + TclStackFree(interp, objv); + return result; +} + +/* + *---------------------------------------------------------------------- + * * TclRenameCommand -- * * Called to give an existing Tcl command a different name. Both the old @@ -3165,11 +3223,11 @@ TclRenameCommand( */ Tcl_DStringInit(&newFullName); - Tcl_DStringAppend(&newFullName, newNsPtr->fullName, -1); + Tcl_DStringAppend(&newFullName, newNsPtr->fullName, TCL_INDEX_NONE); if (newNsPtr != iPtr->globalNsPtr) { TclDStringAppendLiteral(&newFullName, "::"); } - Tcl_DStringAppend(&newFullName, newTail, -1); + Tcl_DStringAppend(&newFullName, newTail, TCL_INDEX_NONE); cmdPtr->refCount++; CallCommandTraces(iPtr, cmdPtr, TclGetString(oldFullName), Tcl_DStringValue(&newFullName), TCL_TRACE_RENAME); @@ -3264,42 +3322,6 @@ Tcl_SetCommandInfo( *---------------------------------------------------------------------- */ -static int -invokeObj2Command( - void *clientData, /* Points to command's Command structure. */ - Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Size objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - int result; - Command *cmdPtr = (Command *) clientData; - - if (objc > INT_MAX) { - return TclCommandWordLimitError(interp, objc); - } - if (cmdPtr->objProc != NULL) { - result = cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); - } else { - result = Tcl_NRCallObjProc(interp, cmdPtr->nreProc, - cmdPtr->objClientData, objc, objv); - } - return result; -} - -static int -cmdWrapper2Proc( - void *clientData, - Tcl_Interp *interp, - Tcl_Size objc, - Tcl_Obj *const objv[]) -{ - Command *cmdPtr = (Command *)clientData; - if (objc > INT_MAX) { - return TclCommandWordLimitError(interp, objc); - } - return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); -} - int Tcl_SetCommandInfoFromToken( Tcl_Command cmd, @@ -3319,7 +3341,7 @@ Tcl_SetCommandInfoFromToken( cmdPtr->proc = infoPtr->proc; cmdPtr->clientData = infoPtr->clientData; if (infoPtr->objProc == NULL) { - cmdPtr->objProc = InvokeStringCommand; + cmdPtr->objProc = TclInvokeStringCommand; cmdPtr->objClientData = cmdPtr; cmdPtr->nreProc = NULL; } else { @@ -3329,36 +3351,8 @@ Tcl_SetCommandInfoFromToken( } cmdPtr->objClientData = infoPtr->objClientData; } - if (cmdPtr->deleteProc == cmdWrapperDeleteProc) { - CmdWrapperInfo *info = (CmdWrapperInfo *)cmdPtr->deleteData; - if (infoPtr->objProc2 == NULL) { - info->proc = invokeObj2Command; - info->clientData = cmdPtr; - info->nreProc = NULL; - } else { - if (infoPtr->objProc2 != info->proc) { - info->nreProc = NULL; - info->proc = infoPtr->objProc2; - } - info->clientData = infoPtr->objClientData2; - } - info->deleteProc = infoPtr->deleteProc; - info->deleteData = infoPtr->deleteData; - } else { - if ((infoPtr->objProc2 != NULL) && (infoPtr->objProc2 != cmdWrapper2Proc)) { - CmdWrapperInfo *info = (CmdWrapperInfo *)Tcl_Alloc(sizeof(CmdWrapperInfo)); - info->proc = infoPtr->objProc2; - info->clientData = infoPtr->objClientData2; - info->nreProc = NULL; - info->deleteProc = infoPtr->deleteProc; - info->deleteData = infoPtr->deleteData; - cmdPtr->deleteProc = cmdWrapperDeleteProc; - cmdPtr->deleteData = info; - } else { - cmdPtr->deleteProc = infoPtr->deleteProc; - cmdPtr->deleteData = infoPtr->deleteData; - } - } + cmdPtr->deleteProc = infoPtr->deleteProc; + cmdPtr->deleteData = infoPtr->deleteData; return 1; } @@ -3425,32 +3419,18 @@ Tcl_GetCommandInfoFromToken( /* * Set isNativeObjectProc 1 if objProc was registered by a call to - * Tcl_CreateObjCommand. Set isNativeObjectProc 2 if objProc was - * registered by a call to Tcl_CreateObjCommand2. Otherwise set it to 0. + * Tcl_CreateObjCommand. Otherwise set it to 0. */ cmdPtr = (Command *) cmd; infoPtr->isNativeObjectProc = - (cmdPtr->objProc != InvokeStringCommand); + (cmdPtr->objProc != TclInvokeStringCommand); infoPtr->objProc = cmdPtr->objProc; infoPtr->objClientData = cmdPtr->objClientData; infoPtr->proc = cmdPtr->proc; infoPtr->clientData = cmdPtr->clientData; - if (cmdPtr->deleteProc == cmdWrapperDeleteProc) { - CmdWrapperInfo *info = (CmdWrapperInfo *)cmdPtr->deleteData; - infoPtr->deleteProc = info->deleteProc; - infoPtr->deleteData = info->deleteData; - infoPtr->objProc2 = info->proc; - infoPtr->objClientData2 = info->clientData; - if (cmdPtr->objProc == cmdWrapperProc) { - infoPtr->isNativeObjectProc = 2; - } - } else { - infoPtr->deleteProc = cmdPtr->deleteProc; - infoPtr->deleteData = cmdPtr->deleteData; - infoPtr->objProc2 = cmdWrapper2Proc; - infoPtr->objClientData2 = cmdPtr; - } + infoPtr->deleteProc = cmdPtr->deleteProc; + infoPtr->deleteData = cmdPtr->deleteData; infoPtr->namespacePtr = (Tcl_Namespace *) cmdPtr->nsPtr; return 1; } @@ -3535,14 +3515,14 @@ Tcl_GetCommandFullName( if ((cmdPtr != NULL) && TclRoutineHasName(cmdPtr)) { if (cmdPtr->nsPtr != NULL) { - Tcl_AppendToObj(objPtr, cmdPtr->nsPtr->fullName, -1); + Tcl_AppendToObj(objPtr, cmdPtr->nsPtr->fullName, TCL_INDEX_NONE); if (cmdPtr->nsPtr != iPtr->globalNsPtr) { Tcl_AppendToObj(objPtr, "::", 2); } } if (cmdPtr->hPtr != NULL) { name = (char *)Tcl_GetHashKey(cmdPtr->hPtr->tablePtr, cmdPtr->hPtr); - Tcl_AppendToObj(objPtr, name, -1); + Tcl_AppendToObj(objPtr, name, TCL_INDEX_NONE); } } } @@ -3678,7 +3658,7 @@ Tcl_DeleteCommandFromToken( CommandTrace *nextPtr = tracePtr->nextPtr; if (tracePtr->refCount-- <= 1) { - Tcl_Free(tracePtr); + ckfree(tracePtr); } tracePtr = nextPtr; } @@ -3730,10 +3710,10 @@ Tcl_DeleteCommandFromToken( * If you are getting a crash during the call to deleteProc and * cmdPtr->deleteProc is a pointer to the function free(), the most * likely cause is that your extension allocated memory for the - * clientData argument to Tcl_CreateObjCommand with the Tcl_Alloc() + * clientData argument to Tcl_CreateObjCommand with the ckalloc() * macro and you are now trying to deallocate this memory with free() - * instead of Tcl_Free(). You should pass a pointer to your own method - * that calls Tcl_Free(). + * instead of ckfree(). You should pass a pointer to your own method + * that calls ckfree(). */ cmdPtr->deleteProc(cmdPtr->deleteData); @@ -3871,7 +3851,7 @@ CallCommandTraces( oldName, newName, flags); cmdPtr->flags &= ~tracePtr->flags; if (tracePtr->refCount-- <= 1) { - Tcl_Free(tracePtr); + ckfree(tracePtr); } } @@ -4002,13 +3982,376 @@ TclCleanupCommand( * be freed. */ { if (cmdPtr->refCount-- <= 1) { - Tcl_Free(cmdPtr); + ckfree(cmdPtr); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_CreateMathFunc -- + * + * Creates a new math function for expressions in a given interpreter. + * + * Results: + * None. + * + * Side effects: + * The Tcl function defined by "name" is created or redefined. If the + * function already exists then its definition is replaced; this includes + * the builtin functions. Redefining a builtin function forces all + * existing code to be invalidated since that code may be compiled using + * an instruction specific to the replaced function. In addition, + * redefining a non-builtin function will force existing code to be + * invalidated if the number of arguments has changed. + * + *---------------------------------------------------------------------- + */ + +#if !defined(TCL_NO_DEPRECATED) +void +Tcl_CreateMathFunc( + Tcl_Interp *interp, /* Interpreter in which function is to be + * available. */ + const char *name, /* Name of function (e.g. "sin"). */ + int numArgs, /* Number of arguments required by + * function. */ + Tcl_ValueType *argTypes, /* Array of types acceptable for each + * argument. */ + Tcl_MathProc *proc, /* C function that implements the math + * function. */ + void *clientData) /* Additional value to pass to the + * function. */ +{ + Tcl_DString bigName; + OldMathFuncData *data = (OldMathFuncData *)ckalloc(sizeof(OldMathFuncData)); + + data->proc = proc; + data->numArgs = numArgs; + data->argTypes = (Tcl_ValueType *)ckalloc(numArgs * sizeof(Tcl_ValueType)); + if ((numArgs > 0) && (argTypes != NULL)) { + memcpy(data->argTypes, argTypes, numArgs * sizeof(Tcl_ValueType)); } + data->clientData = clientData; + + Tcl_DStringInit(&bigName); + TclDStringAppendLiteral(&bigName, "::tcl::mathfunc::"); + Tcl_DStringAppend(&bigName, name, -1); + + Tcl_CreateObjCommand(interp, Tcl_DStringValue(&bigName), + OldMathFuncProc, data, OldMathFuncDeleteProc); + Tcl_DStringFree(&bigName); } /* *---------------------------------------------------------------------- * + * OldMathFuncProc -- + * + * Dispatch to a math function created with Tcl_CreateMathFunc + * + * Results: + * Returns a standard Tcl result. + * + * Side effects: + * Whatever the math function does. + * + *---------------------------------------------------------------------- + */ + +static int +OldMathFuncProc( + void *clientData, /* Pointer to OldMathFuncData describing the + * function being called */ + Tcl_Interp *interp, /* Tcl interpreter */ + int objc, /* Actual parameter count */ + Tcl_Obj *const *objv) /* Parameter vector */ +{ + Tcl_Obj *valuePtr; + OldMathFuncData *dataPtr = (OldMathFuncData *)clientData; + Tcl_Value funcResult, *args; + int result; + int j, k; + double d; + + /* + * Check argument count. + */ + + if (objc != dataPtr->numArgs + 1) { + MathFuncWrongNumArgs(interp, dataPtr->numArgs+1, objc, objv); + return TCL_ERROR; + } + + /* + * Convert arguments from Tcl_Obj's to Tcl_Value's. + */ + + args = (Tcl_Value *)ckalloc(dataPtr->numArgs * sizeof(Tcl_Value)); + for (j = 1, k = 0; j < objc; ++j, ++k) { + /* TODO: Convert to Tcl_GetNumberFromObj? */ + valuePtr = objv[j]; + result = Tcl_GetDoubleFromObj(NULL, valuePtr, &d); +#ifdef ACCEPT_NAN + if (result != TCL_OK) { + const Tcl_ObjInternalRep *irPtr + = TclFetchInternalRep(valuePtr, &tclDoubleType); + + if (irPtr) { + d = irPtr->doubleValue; + result = TCL_OK; + } + } +#endif + if (result != TCL_OK) { + /* + * We have a non-numeric argument. + */ + + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "argument to math function didn't have numeric value", + -1)); + TclCheckBadOctal(interp, TclGetString(valuePtr)); + ckfree(args); + return TCL_ERROR; + } + + /* + * Copy the object's numeric value to the argument record, converting + * it if necessary. + * + * NOTE: no bignum support; use the new mathfunc interface for that. + */ + + args[k].type = dataPtr->argTypes[k]; + switch (args[k].type) { + case TCL_EITHER: + if (Tcl_GetLongFromObj(NULL, valuePtr, &args[k].intValue) + == TCL_OK) { + args[k].type = TCL_INT; + break; + } + if (TclGetWideIntFromObj(interp, valuePtr, &args[k].wideValue) + == TCL_OK) { + args[k].type = TCL_WIDE_INT; + break; + } + args[k].type = TCL_DOUBLE; + /* FALLTHROUGH */ + + case TCL_DOUBLE: + args[k].doubleValue = d; + break; + case TCL_INT: + if (ExprIntFunc(NULL, interp, 2, &objv[j-1]) != TCL_OK) { + ckfree(args); + return TCL_ERROR; + } + valuePtr = Tcl_GetObjResult(interp); + Tcl_GetLongFromObj(NULL, valuePtr, &args[k].intValue); + Tcl_ResetResult(interp); + break; + case TCL_WIDE_INT: + if (ExprWideFunc(NULL, interp, 2, &objv[j-1]) != TCL_OK) { + ckfree(args); + return TCL_ERROR; + } + valuePtr = Tcl_GetObjResult(interp); + TclGetWideIntFromObj(NULL, valuePtr, &args[k].wideValue); + Tcl_ResetResult(interp); + break; + } + } + + /* + * Call the function. + */ + + errno = 0; + result = dataPtr->proc(dataPtr->clientData, interp, args, &funcResult); + ckfree(args); + if (result != TCL_OK) { + return result; + } + + /* + * Return the result of the call. + */ + + if (funcResult.type == TCL_INT) { + TclNewIntObj(valuePtr, funcResult.intValue); + } else if (funcResult.type == TCL_WIDE_INT) { + TclNewIntObj(valuePtr, funcResult.wideValue); + } else { + return CheckDoubleResult(interp, funcResult.doubleValue); + } + Tcl_SetObjResult(interp, valuePtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * OldMathFuncDeleteProc -- + * + * Cleans up after deleting a math function registered with + * Tcl_CreateMathFunc + * + * Results: + * None. + * + * Side effects: + * Frees allocated memory. + * + *---------------------------------------------------------------------- + */ + +static void +OldMathFuncDeleteProc( + void *clientData) +{ + OldMathFuncData *dataPtr = (OldMathFuncData *)clientData; + + ckfree(dataPtr->argTypes); + ckfree(dataPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetMathFuncInfo -- + * + * Discovers how a particular math function was created in a given + * interpreter. + * + * Results: + * TCL_OK if it succeeds, TCL_ERROR else (leaving an error message in the + * interpreter result if that happens.) + * + * Side effects: + * If this function succeeds, the variables pointed to by the numArgsPtr + * and argTypePtr arguments will be updated to detail the arguments + * allowed by the function. The variable pointed to by the procPtr + * argument will be set to NULL if the function is a builtin function, + * and will be set to the address of the C function used to implement the + * math function otherwise (in which case the variable pointed to by the + * clientDataPtr argument will also be updated.) + * + *---------------------------------------------------------------------- + */ + +int +Tcl_GetMathFuncInfo( + Tcl_Interp *interp, + const char *name, + int *numArgsPtr, + Tcl_ValueType **argTypesPtr, + Tcl_MathProc **procPtr, + void **clientDataPtr) +{ + Tcl_Obj *cmdNameObj; + Command *cmdPtr; + + /* + * Get the command that implements the math function. + */ + + TclNewLiteralStringObj(cmdNameObj, "tcl::mathfunc::"); + Tcl_AppendToObj(cmdNameObj, name, -1); + Tcl_IncrRefCount(cmdNameObj); + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdNameObj); + Tcl_DecrRefCount(cmdNameObj); + + /* + * Report unknown functions. + */ + + if (cmdPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "unknown math function \"%s\"", name)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "MATHFUNC", name, (char *)NULL); + *numArgsPtr = -1; + *argTypesPtr = NULL; + *procPtr = NULL; + *clientDataPtr = NULL; + return TCL_ERROR; + } + + /* + * Retrieve function info for user defined functions; return dummy + * information for builtins. + */ + + if (cmdPtr->objProc == &OldMathFuncProc) { + OldMathFuncData *dataPtr = (OldMathFuncData *)cmdPtr->clientData; + + *procPtr = dataPtr->proc; + *numArgsPtr = dataPtr->numArgs; + *argTypesPtr = dataPtr->argTypes; + *clientDataPtr = dataPtr->clientData; + } else { + *procPtr = NULL; + *numArgsPtr = -1; + *argTypesPtr = NULL; + *procPtr = NULL; + *clientDataPtr = NULL; + } + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_ListMathFuncs -- + * + * Produces a list of all the math functions defined in a given + * interpreter. + * + * Results: + * A pointer to a Tcl_Obj structure with a reference count of zero, or + * NULL in the case of an error (in which case a suitable error message + * will be left in the interpreter result.) + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +Tcl_ListMathFuncs( + Tcl_Interp *interp, + const char *pattern) +{ + Tcl_Obj *script = Tcl_NewStringObj("::info functions ", -1); + Tcl_Obj *result; + Tcl_InterpState state; + + if (pattern) { + Tcl_Obj *patternObj = Tcl_NewStringObj(pattern, -1); + Tcl_Obj *arg = Tcl_NewListObj(1, &patternObj); + + Tcl_AppendObjToObj(script, arg); + Tcl_DecrRefCount(arg); /* Should tear down patternObj too */ + } + + state = Tcl_SaveInterpState(interp, TCL_OK); + Tcl_IncrRefCount(script); + if (TCL_OK == Tcl_EvalObjEx(interp, script, 0)) { + result = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); + } else { + TclNewObj(result); + } + Tcl_DecrRefCount(script); + Tcl_RestoreInterpState(interp, state); + + return result; +} +#endif /* !defined(TCL_NO_DEPRECATED) */ + +/* + *---------------------------------------------------------------------- + * * TclInterpReady -- * * Check if an interpreter is ready to eval commands or scripts, i.e., if @@ -4019,7 +4362,7 @@ TclCleanupCommand( * otherwise. * * Side effects: - * The interpreter's result is cleared. + * The interpreters object and string results are cleared. * *---------------------------------------------------------------------- */ @@ -4043,7 +4386,7 @@ TclInterpReady( if (iPtr->flags & DELETED) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "attempt to call eval in deleted interpreter", -1)); + "attempt to call eval in deleted interpreter", TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "IDELETE", "attempt to call eval in deleted interpreter", (char *)NULL); return TCL_ERROR; @@ -4072,7 +4415,7 @@ TclInterpReady( } Tcl_SetObjResult(interp, Tcl_NewStringObj( - "too many nested evaluations (infinite loop?)", -1)); + "too many nested evaluations (infinite loop?)", TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "LIMIT", "STACK", (char *)NULL); return TCL_ERROR; } @@ -4206,7 +4549,7 @@ Tcl_Canceled( } } - Tcl_SetObjResult(interp, Tcl_NewStringObj(message, -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj(message, TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "CANCEL", id, message, (char *)NULL); } @@ -4289,7 +4632,7 @@ Tcl_CancelEval( if (resultObjPtr != NULL) { result = TclGetStringFromObj(resultObjPtr, &cancelInfo->length); - cancelInfo->result = (char *)Tcl_Realloc(cancelInfo->result,cancelInfo->length); + cancelInfo->result = (char *)ckrealloc(cancelInfo->result,cancelInfo->length); memcpy(cancelInfo->result, result, cancelInfo->length); TclDecrRefCount(resultObjPtr); /* Discard their result object. */ } else { @@ -4411,7 +4754,7 @@ EvalObjvCore( { Command *cmdPtr = NULL, *preCmdPtr = (Command *)data[0]; int flags = PTR2INT(data[1]); - int objc = PTR2INT(data[2]); + Tcl_Size objc = PTR2INT(data[2]); Tcl_Obj **objv = (Tcl_Obj **)data[3]; Interp *iPtr = (Interp *) interp; Namespace *lookupNsPtr = NULL; @@ -4571,14 +4914,14 @@ Dispatch( { Tcl_ObjCmdProc *objProc = (Tcl_ObjCmdProc *)data[0]; void *clientData = data[1]; - Tcl_Size objc = PTR2INT(data[2]); + int objc = PTR2INT(data[2]); Tcl_Obj **objv = (Tcl_Obj **)data[3]; Interp *iPtr = (Interp *) interp; #ifdef USE_DTRACE if (TCL_DTRACE_CMD_ARGS_ENABLED()) { const char *a[10]; - Tcl_Size i = 0; + int i = 0; while (i < 10) { a[i] = i < objc ? TclGetString(objv[i]) : NULL; i++; @@ -4616,6 +4959,30 @@ 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 + * either empty or stale because some function set interp->result + * directly. If so, move the string result to the result object, then + * reset the string result. + * + * This only needs to be done for the first item in the list: all other + * 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. + */ + while (TOP_CB(interp) != rootPtr) { NRE_callback *callbackPtr = TOP_CB(interp); Tcl_NRPostProc *procPtr = callbackPtr->procPtr; @@ -4684,7 +5051,7 @@ NRCommand( static void TEOV_PushExceptionHandlers( Tcl_Interp *interp, - int objc, + Tcl_Size objc, Tcl_Obj *const objv[], int flags) { @@ -4780,7 +5147,7 @@ TEOV_Error( Tcl_Obj *listPtr; const char *cmdString; Tcl_Size cmdLen; - int objc = PTR2INT(data[0]); + Tcl_Size objc = PTR2INT(data[0]); Tcl_Obj **objv = (Tcl_Obj **)data[1]; if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { @@ -4802,7 +5169,7 @@ TEOV_Error( static int TEOV_NotFound( Tcl_Interp *interp, - int objc, + Tcl_Size objc, Tcl_Obj *const objv[], Namespace *lookupNsPtr) { @@ -4903,11 +5270,11 @@ TEOV_NotFoundCallback( int result) { Interp *iPtr = (Interp *) interp; - int objc = PTR2INT(data[0]); + Tcl_Size objc = PTR2INT(data[0]); Tcl_Obj **objv = (Tcl_Obj **)data[1]; Namespace *savedNsPtr = (Namespace *)data[2]; - int i; + Tcl_Size i; if (savedNsPtr) { iPtr->varFramePtr->nsPtr = savedNsPtr; @@ -4930,7 +5297,7 @@ TEOV_RunEnterTraces( Tcl_Interp *interp, Command **cmdPtrPtr, Tcl_Obj *commandPtr, - int objc, + Tcl_Size objc, Tcl_Obj *const objv[]) { Interp *iPtr = (Interp *) interp; @@ -4984,7 +5351,7 @@ TEOV_RunLeaveTraces( { Interp *iPtr = (Interp *) interp; int traceCode = TCL_OK; - int objc = PTR2INT(data[0]); + Tcl_Size objc = PTR2INT(data[0]); Tcl_Obj *commandPtr = (Tcl_Obj *)data[1]; Command *cmdPtr = (Command *)data[2]; Tcl_Obj **objv = (Tcl_Obj **)data[3]; @@ -5078,6 +5445,56 @@ Tcl_EvalTokensStandard( NULL, NULL); } +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 +/* + *---------------------------------------------------------------------- + * + * Tcl_EvalTokens -- + * + * Given an array of tokens parsed from a Tcl command (e.g., the tokens + * that make up a word or the index for an array variable) this function + * evaluates the tokens and concatenates their values to form a single + * result value. + * + * Results: + * The return value is a pointer to a newly allocated Tcl_Obj containing + * the value of the array of tokens. The reference count of the returned + * object has been incremented. If an error occurs in evaluating the + * tokens then a NULL value is returned and an error message is left in + * interp's result. + * + * Side effects: + * A new object is allocated to hold the result. + * + *---------------------------------------------------------------------- + * + * This uses a non-standard return convention; its use is now deprecated. It + * is a wrapper for the new function Tcl_EvalTokensStandard, and is not used + * in the core any longer. It is only kept for backward compatibility. + */ + +Tcl_Obj * +Tcl_EvalTokens( + Tcl_Interp *interp, /* Interpreter in which to lookup variables, + * execute nested commands, and report + * errors. */ + Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to + * evaluate and concatenate. */ + Tcl_Size count) /* Number of tokens to consider at tokenPtr. + * Must be at least 1. */ +{ + Tcl_Obj *resPtr; + + if (Tcl_EvalTokensStandard(interp, tokenPtr, count) != TCL_OK) { + return NULL; + } + resPtr = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(resPtr); + Tcl_ResetResult(interp); + return resPtr; +} +#endif /* !TCL_NO_DEPRECATED */ + /* *---------------------------------------------------------------------- * @@ -5303,9 +5720,9 @@ TclEvalEx( */ if (numWords > minObjs) { - expand = (int *)Tcl_Alloc(numWords * sizeof(int)); - objvSpace = (Tcl_Obj **)Tcl_Alloc(numWords * sizeof(Tcl_Obj *)); - lineSpace = (Tcl_Size *)Tcl_Alloc(numWords * sizeof(Tcl_Size)); + expand = (int *)ckalloc(numWords * sizeof(int)); + objvSpace = (Tcl_Obj **)ckalloc(numWords * sizeof(Tcl_Obj *)); + lineSpace = (Tcl_Size *)ckalloc(numWords * sizeof(Tcl_Size)); } expandRequested = 0; objv = objvSpace; @@ -5315,8 +5732,6 @@ TclEvalEx( for (objectsUsed = 0, tokenPtr = parsePtr->tokenPtr; objectsUsed < numWords; objectsUsed++, tokenPtr += tokenPtr->numComponents+1) { - Tcl_Size additionalObjsCount; - /* * TIP #280. Track lines to current word. Save the information * on a per-word basis, signaling dynamic words as needed. @@ -5366,21 +5781,11 @@ TclEvalEx( expandRequested = 1; expand[objectsUsed] = 1; - additionalObjsCount = (numElements ? numElements : 1); - + objectsNeeded += (numElements ? numElements : 1); } else { expand[objectsUsed] = 0; - additionalObjsCount = 1; - } - - /* Currently max command words in INT_MAX */ - if (additionalObjsCount > INT_MAX || - objectsNeeded > (INT_MAX - additionalObjsCount)) { - code = TclCommandWordLimitError(interp, -1); - Tcl_DecrRefCount(objv[objectsUsed]); - break; + objectsNeeded++; } - objectsNeeded += additionalObjsCount; if (wordCLNext) { TclContinuationsEnterDerived(objv[objectsUsed], @@ -5403,8 +5808,8 @@ TclEvalEx( if ((numWords > minObjs) || (objectsNeeded > minObjs)) { objv = objvSpace = - (Tcl_Obj **)Tcl_Alloc(objectsNeeded * sizeof(Tcl_Obj *)); - lines = lineSpace = (Tcl_Size *)Tcl_Alloc(objectsNeeded * sizeof(Tcl_Size)); + (Tcl_Obj **)ckalloc(objectsNeeded * sizeof(Tcl_Obj *)); + lines = lineSpace = (Tcl_Size *)ckalloc(objectsNeeded * sizeof(Tcl_Size)); } objectsUsed = 0; @@ -5431,10 +5836,10 @@ TclEvalEx( objv += objIdx+1; if (copy != stackObjArray) { - Tcl_Free(copy); + ckfree(copy); } if (lcopy != linesStack) { - Tcl_Free(lcopy); + ckfree(lcopy); } } @@ -5479,9 +5884,9 @@ TclEvalEx( } objectsUsed = 0; if (objvSpace != stackObjArray) { - Tcl_Free(objvSpace); + ckfree(objvSpace); objvSpace = stackObjArray; - Tcl_Free(lineSpace); + ckfree(lineSpace); lineSpace = linesStack; } @@ -5491,7 +5896,7 @@ TclEvalEx( */ if (expand != expandStack) { - Tcl_Free(expand); + ckfree(expand); expand = expandStack; } } @@ -5557,11 +5962,11 @@ TclEvalEx( Tcl_FreeParse(parsePtr); } if (objvSpace != stackObjArray) { - Tcl_Free(objvSpace); - Tcl_Free(lineSpace); + ckfree(objvSpace); + ckfree(lineSpace); } if (expand != expandStack) { - Tcl_Free(expand); + ckfree(expand); } iPtr->varFramePtr = savedVarFramePtr; @@ -5698,11 +6103,12 @@ void TclArgumentEnter( Tcl_Interp *interp, Tcl_Obj **objv, - int objc, + Tcl_Size objc, CmdFrame *cfPtr) { Interp *iPtr = (Interp *) interp; - int isNew, i; + int isNew; + Tcl_Size i; Tcl_HashEntry *hPtr; CFWord *cfwPtr; @@ -5725,7 +6131,7 @@ TclArgumentEnter( * and initialize references. */ - cfwPtr = (CFWord *)Tcl_Alloc(sizeof(CFWord)); + cfwPtr = (CFWord *)ckalloc(sizeof(CFWord)); cfwPtr->framePtr = cfPtr; cfwPtr->word = i; cfwPtr->refCount = 1; @@ -5766,10 +6172,10 @@ void TclArgumentRelease( Tcl_Interp *interp, Tcl_Obj **objv, - int objc) + Tcl_Size objc) { Interp *iPtr = (Interp *) interp; - int i; + Tcl_Size i; for (i = 1; i < objc; i++) { CFWord *cfwPtr; @@ -5785,7 +6191,7 @@ TclArgumentRelease( continue; } - Tcl_Free(cfwPtr); + ckfree(cfwPtr); Tcl_DeleteHashEntry(hPtr); } } @@ -5814,14 +6220,14 @@ void TclArgumentBCEnter( Tcl_Interp *interp, Tcl_Obj *objv[], - int objc, + Tcl_Size objc, void *codePtr, CmdFrame *cfPtr, Tcl_Size cmd, Tcl_Size pc) { ExtCmdLoc *eclPtr; - int word; + Tcl_Size word; ECL *ePtr; CFWordBC *lastPtr = NULL; Interp *iPtr = (Interp *) interp; @@ -5867,7 +6273,7 @@ TclArgumentBCEnter( int isNew; Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(iPtr->lineLABCPtr, objv[word], &isNew); - CFWordBC *cfwPtr = (CFWordBC *)Tcl_Alloc(sizeof(CFWordBC)); + CFWordBC *cfwPtr = (CFWordBC *)ckalloc(sizeof(CFWordBC)); cfwPtr->framePtr = cfPtr; cfwPtr->obj = objv[word]; @@ -5945,7 +6351,7 @@ TclArgumentBCRelease( Tcl_DeleteHashEntry(hPtr); } - Tcl_Free(cfwPtr); + ckfree(cfwPtr); cfwPtr = nextPtr; } @@ -6027,6 +6433,83 @@ TclArgumentGet( /* *---------------------------------------------------------------------- * + * Tcl_Eval -- + * + * Execute a Tcl command in a string. This function executes the script + * directly, rather than compiling it to bytecodes. Before the arrival of + * the bytecode compiler in Tcl 8.0 Tcl_Eval was the main function used + * for executing Tcl commands, but nowadays it isn't used much. + * + * Results: + * The return value is one of the return codes defined in tcl.h (such as + * TCL_OK), and interp's result contains a value to supplement the return + * code. The value of the result will persist only until the next call to + * Tcl_Eval or Tcl_EvalObj: you must copy it or lose it! + * + * Side effects: + * Can be almost arbitrary, depending on the commands in the script. + * + *---------------------------------------------------------------------- + */ + +#ifndef TCL_NO_DEPRECATED +#undef Tcl_Eval +int +Tcl_Eval( + Tcl_Interp *interp, /* Token for command interpreter (returned by + * previous call to Tcl_CreateInterp). */ + const char *script) /* Pointer to TCL command to execute. */ +{ + int code = Tcl_EvalEx(interp, script, TCL_INDEX_NONE, 0); + + /* + * For backwards compatibility with old C code that predates the object + * system in Tcl 8.0, we have to mirror the object result back into the + * string result (some callers may expect it there). + */ + + (void) Tcl_GetStringResult(interp); + return code; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_EvalObj, Tcl_GlobalEvalObj -- + * + * These functions are deprecated but we keep them around for backwards + * compatibility reasons. + * + * Results: + * See the functions they call. + * + * Side effects: + * See the functions they call. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_EvalObj +int +Tcl_EvalObj( + Tcl_Interp *interp, + Tcl_Obj *objPtr) +{ + return Tcl_EvalObjEx(interp, objPtr, 0); +} +#undef Tcl_GlobalEvalObj +int +Tcl_GlobalEvalObj( + Tcl_Interp *interp, + Tcl_Obj *objPtr) +{ + return Tcl_EvalObjEx(interp, objPtr, TCL_EVAL_GLOBAL); +} +#endif /* TCL_NO_DEPRECATED */ + +/* + *---------------------------------------------------------------------- + * * Tcl_EvalObjEx, TclEvalObjEx -- * * Execute Tcl commands stored in a Tcl object. These commands are @@ -6356,10 +6839,10 @@ ProcessUnexpectedResult( Tcl_ResetResult(interp); if (returnCode == TCL_BREAK) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "invoked \"break\" outside of a loop", -1)); + "invoked \"break\" outside of a loop", TCL_INDEX_NONE)); } else if (returnCode == TCL_CONTINUE) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "invoked \"continue\" outside of a loop", -1)); + "invoked \"continue\" outside of a loop", TCL_INDEX_NONE)); } else { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "command returned bad code: %d", returnCode)); @@ -6405,10 +6888,13 @@ Tcl_ExprLong( *ptr = 0; } else { - exprPtr = Tcl_NewStringObj(exprstring, -1); + exprPtr = Tcl_NewStringObj(exprstring, TCL_INDEX_NONE); Tcl_IncrRefCount(exprPtr); result = Tcl_ExprLongObj(interp, exprPtr, ptr); Tcl_DecrRefCount(exprPtr); + if (result != TCL_OK) { + (void) Tcl_GetStringResult(interp); + } } return result; } @@ -6430,11 +6916,14 @@ Tcl_ExprDouble( *ptr = 0.0; } else { - exprPtr = Tcl_NewStringObj(exprstring, -1); + exprPtr = Tcl_NewStringObj(exprstring, TCL_INDEX_NONE); Tcl_IncrRefCount(exprPtr); result = Tcl_ExprDoubleObj(interp, exprPtr, ptr); Tcl_DecrRefCount(exprPtr); /* Discard the expression object. */ + if (result != TCL_OK) { + (void) Tcl_GetStringResult(interp); + } } return result; } @@ -6455,11 +6944,19 @@ Tcl_ExprBoolean( return TCL_OK; } else { int result; - Tcl_Obj *exprPtr = Tcl_NewStringObj(exprstring, -1); + Tcl_Obj *exprPtr = Tcl_NewStringObj(exprstring, TCL_INDEX_NONE); Tcl_IncrRefCount(exprPtr); result = Tcl_ExprBooleanObj(interp, exprPtr, ptr); Tcl_DecrRefCount(exprPtr); + if (result != TCL_OK) { + /* + * Move the interpreter's object result to the string result, then + * reset the object result. + */ + + (void) Tcl_GetStringResult(interp); + } return result; } } @@ -6572,7 +7069,7 @@ int Tcl_ExprBooleanObj( Tcl_Interp *interp, /* Context in which to evaluate the * expression. */ - Tcl_Obj *objPtr, /* Expression to evaluate. */ + Tcl_Obj *objPtr, /* Expression to evaluate. */ int *ptr) /* Where to store 0/1 result. */ { Tcl_Obj *resultPtr; @@ -6668,7 +7165,7 @@ TclObjInvoke( } if ((objc < 1) || (objv == NULL)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "illegal argument vector", -1)); + "illegal argument vector", TCL_INDEX_NONE)); return TCL_ERROR; } if ((flags & TCL_INVOKE_HIDDEN) == 0) { @@ -6767,7 +7264,7 @@ Tcl_ExprString( Tcl_SetObjResult(interp, Tcl_NewWideIntObj(0)); } else { - Tcl_Obj *resultPtr, *exprObj = Tcl_NewStringObj(expr, -1); + Tcl_Obj *resultPtr, *exprObj = Tcl_NewStringObj(expr, TCL_INDEX_NONE); Tcl_IncrRefCount(exprObj); code = Tcl_ExprObj(interp, exprObj, &resultPtr); @@ -6777,6 +7274,12 @@ Tcl_ExprString( Tcl_DecrRefCount(resultPtr); } } + + /* + * Force the string rep of the interp result. + */ + + (void) Tcl_GetStringResult(interp); return code; } @@ -6799,6 +7302,7 @@ Tcl_ExprString( *---------------------------------------------------------------------- */ +#undef Tcl_AddObjErrorInfo void Tcl_AppendObjToErrorInfo( Tcl_Interp *interp, /* Interpreter to which error information @@ -6807,9 +7311,74 @@ Tcl_AppendObjToErrorInfo( { Tcl_Size length; const char *message = TclGetStringFromObj(objPtr, &length); - Interp *iPtr = (Interp *) interp; Tcl_IncrRefCount(objPtr); + Tcl_AddObjErrorInfo(interp, message, length); + Tcl_DecrRefCount(objPtr); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AddErrorInfo -- + * + * Add information to the errorInfo field that describes the current + * error. + * + * Results: + * None. + * + * Side effects: + * The contents of message are appended to the errorInfo field. If we are + * just starting to log an error, errorInfo is initialized from the error + * message in the interpreter's result. + * + *---------------------------------------------------------------------- + */ + +#ifndef TCL_NO_DEPRECATED +#undef Tcl_AddErrorInfo +void +Tcl_AddErrorInfo( + Tcl_Interp *interp, /* Interpreter to which error information + * pertains. */ + const char *message) /* Message to record. */ +{ + Tcl_AddObjErrorInfo(interp, message, -1); +} +#endif /* TCL_NO_DEPRECATED */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_AddObjErrorInfo -- + * + * Add information to the errorInfo field that describes the current + * error. This routine differs from Tcl_AddErrorInfo by taking a byte + * pointer and length. + * + * Results: + * None. + * + * Side effects: + * "length" bytes from "message" are appended to the errorInfo field. If + * "length" is negative, use bytes up to the first NULL byte. If we are + * just starting to log an error, errorInfo is initialized from the error + * message in the interpreter's result. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AddObjErrorInfo( + Tcl_Interp *interp, /* Interpreter to which error information + * pertains. */ + const char *message, /* Points to the first byte of an array of + * bytes of the message. */ + Tcl_Size length) /* The number of bytes in the message. If < 0, + * then append all bytes up to a NULL byte. */ +{ + Interp *iPtr = (Interp *) interp; /* * If we are just starting to log an error, errorInfo is initialized from @@ -6818,7 +7387,20 @@ Tcl_AppendObjToErrorInfo( iPtr->flags |= ERR_LEGACY_COPY; if (iPtr->errorInfo == NULL) { - iPtr->errorInfo = iPtr->objResultPtr; +#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 + * expect interp->result to continue to be set, so we'll take + * special pains to avoid clearing it, until we drop support for + * interp->result completely. + */ + + iPtr->errorInfo = Tcl_NewStringObj(iPtr->result, TCL_INDEX_NONE); + } else +#endif /* !defined(TCL_NO_DEPRECATED) */ + iPtr->errorInfo = iPtr->objResultPtr; Tcl_IncrRefCount(iPtr->errorInfo); if (!iPtr->errorCode) { Tcl_SetErrorCode(interp, "NONE", (char *)NULL); @@ -6837,13 +7419,12 @@ Tcl_AppendObjToErrorInfo( } Tcl_AppendToObj(iPtr->errorInfo, message, length); } - Tcl_DecrRefCount(objPtr); } /* *---------------------------------------------------------------------- * - * Tcl_VarEval -- + * Tcl_VarEvalVA -- * * Given a variable number of string arguments, concatenate them all * together and execute the result as a Tcl command. @@ -6859,20 +7440,18 @@ Tcl_AppendObjToErrorInfo( */ int -Tcl_VarEval( - Tcl_Interp *interp, - ...) +Tcl_VarEvalVA( + Tcl_Interp *interp, /* Interpreter in which to evaluate command */ + va_list argList) /* Variable argument list. */ { - va_list argList; - int result; Tcl_DString buf; char *string; + int result; - va_start(argList, interp); /* * Copy the strings one after the other into a single larger string. Use * stack-allocated space for small commands, but if the command gets too - * large than call Tcl_Alloc to create the space. + * large than call ckalloc to create the space. */ Tcl_DStringInit(&buf); @@ -6881,10 +7460,10 @@ Tcl_VarEval( if (string == NULL) { break; } - Tcl_DStringAppend(&buf, string, -1); + Tcl_DStringAppend(&buf, string, TCL_INDEX_NONE); } - result = Tcl_EvalEx(interp, Tcl_DStringValue(&buf), -1, 0); + result = Tcl_EvalEx(interp, Tcl_DStringValue(&buf), TCL_INDEX_NONE, 0); Tcl_DStringFree(&buf); return result; } @@ -6892,6 +7471,78 @@ Tcl_VarEval( /* *---------------------------------------------------------------------- * + * Tcl_VarEval -- + * + * Given a variable number of string arguments, concatenate them all + * together and execute the result as a Tcl command. + * + * Results: + * A standard Tcl return result. An error message or other result may be + * left in the interp. + * + * Side effects: + * Depends on what was done by the command. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_VarEval( + Tcl_Interp *interp, + ...) +{ + va_list argList; + int result; + + va_start(argList, interp); + result = Tcl_VarEvalVA(interp, argList); + va_end(argList); + + return result; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_GlobalEval -- + * + * Evaluate a command at global level in an interpreter. + * + * Results: + * A standard Tcl result is returned, and the interp's result is modified + * accordingly. + * + * Side effects: + * The command string is executed in interp, and the execution is carried + * out in the variable context of global level (no functions active), + * just as if an "uplevel #0" command were being executed. + * + *---------------------------------------------------------------------- + */ + +#ifndef TCL_NO_DEPRECATED +#undef Tcl_GlobalEval +int +Tcl_GlobalEval( + Tcl_Interp *interp, /* Interpreter in which to evaluate + * command. */ + const char *command) /* Command to evaluate. */ +{ + Interp *iPtr = (Interp *) interp; + int result; + CallFrame *savedVarFramePtr; + + savedVarFramePtr = iPtr->varFramePtr; + iPtr->varFramePtr = iPtr->rootFramePtr; + result = Tcl_EvalEx(interp, command, TCL_INDEX_NONE, 0); + iPtr->varFramePtr = savedVarFramePtr; + return result; +} +#endif /* TCL_NO_DEPRECATED */ + +/* + *---------------------------------------------------------------------- + * * Tcl_SetRecursionLimit -- * * Set the maximum number of recursive calls that may be active for an @@ -7187,7 +7838,7 @@ ExprIsqrtFunc( negarg: Tcl_SetObjResult(interp, Tcl_NewStringObj( - "square root of negative argument", -1)); + "square root of negative argument", TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", "domain error: argument not in valid range", (char *)NULL); return TCL_ERROR; @@ -8399,7 +9050,7 @@ TclDTraceInfo( for (i = 0; i < 2; i++) { Tcl_DictObjGet(NULL, info, *k++, &val); if (val) { - Tcl_GetSizeIntFromObj(NULL, val, &argsi[i]); + TclGetIntFromObj(NULL, val, &argsi[i]); } else { argsi[i] = 0; } @@ -8480,46 +9131,6 @@ Tcl_NRCallObjProc( return TclNRRunCallbacks(interp, TCL_OK, rootPtr); } -static int -wrapperNRObjProc( - void *clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - CmdWrapperInfo *info = (CmdWrapperInfo *)clientData; - clientData = info->clientData; - Tcl_ObjCmdProc2 *proc = info->proc; - Tcl_Free(info); - if (objc < 0) { - objc = -1; - } - return proc(clientData, interp, (Tcl_Size)objc, objv); -} - -int -Tcl_NRCallObjProc2( - Tcl_Interp *interp, - Tcl_ObjCmdProc2 *objProc, - void *clientData, - Tcl_Size objc, - Tcl_Obj *const objv[]) -{ - if (objc > INT_MAX) { - Tcl_WrongNumArgs(interp, 1, objv, "?args?"); - return TCL_ERROR; - } - - NRE_callback *rootPtr = TOP_CB(interp); - CmdWrapperInfo *info = (CmdWrapperInfo *)Tcl_Alloc(sizeof(CmdWrapperInfo)); - info->clientData = clientData; - info->proc = objProc; - - TclNRAddCallback(interp, Dispatch, wrapperNRObjProc, info, - INT2PTR(objc), objv); - return TclNRRunCallbacks(interp, TCL_OK, rootPtr); -} - /* *---------------------------------------------------------------------- * @@ -8534,7 +9145,7 @@ Tcl_NRCallObjProc2( * Side effects: * If no command named "cmdName" already exists for interp, one is * created. Otherwise, if a command does exist, then if the object-based - * Tcl_ObjCmdProc is InvokeStringCommand, we assume Tcl_CreateCommand + * Tcl_ObjCmdProc is TclInvokeStringCommand, we assume Tcl_CreateCommand * was called previously for the same command and just set its * Tcl_ObjCmdProc to the argument "proc"; otherwise, we delete the old * command. @@ -8548,51 +9159,6 @@ Tcl_NRCallObjProc2( *---------------------------------------------------------------------- */ -static int -cmdWrapperNreProc( - void *clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj *const objv[]) -{ - CmdWrapperInfo *info = (CmdWrapperInfo *)clientData; - if (objc < 0) { - objc = -1; - } - return info->nreProc(info->clientData, interp, objc, objv); -} - -Tcl_Command -Tcl_NRCreateCommand2( - Tcl_Interp *interp, /* Token for command interpreter (returned by - * previous call to Tcl_CreateInterp). */ - const char *cmdName, /* Name of command. If it contains namespace - * qualifiers, the new command is put in the - * specified namespace; otherwise it is put in - * the global namespace. */ - Tcl_ObjCmdProc2 *proc, /* Object-based function to associate with - * name, provides direct access for direct - * calls. */ - Tcl_ObjCmdProc2 *nreProc, /* Object-based function to associate with - * name, provides NR implementation */ - void *clientData, /* Arbitrary value to pass to object - * function. */ - Tcl_CmdDeleteProc *deleteProc) - /* If not NULL, gives a function to call when - * this command is deleted. */ -{ - CmdWrapperInfo *info = (CmdWrapperInfo *)Tcl_Alloc(sizeof(CmdWrapperInfo)); - info->proc = proc; - info->clientData = clientData; - info->nreProc = nreProc; - info->deleteProc = deleteProc; - info->deleteData = clientData; - return Tcl_NRCreateCommand(interp, cmdName, - (proc ? cmdWrapperProc : NULL), - (nreProc ? cmdWrapperNreProc : NULL), - info, cmdWrapperDeleteProc); -} - Tcl_Command Tcl_NRCreateCommand( Tcl_Interp *interp, /* Token for command interpreter (returned by @@ -8804,7 +9370,7 @@ TclNRTailcallObjCmd( if (!(iPtr->varFramePtr->isProcCallFrame & 1)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "tailcall can only be called from a proc, lambda or method", -1)); + "tailcall can only be called from a proc, lambda or method", TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", (char *)NULL); return TCL_ERROR; } @@ -8834,7 +9400,7 @@ TclNRTailcallObjCmd( * namespace, the rest the command to be tailcalled. */ - nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1); + nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, TCL_INDEX_NONE); listPtr = Tcl_NewListObj(objc, objv); TclListObjSetElement(interp, listPtr, 0, nsObjPtr); @@ -8966,7 +9532,7 @@ TclNRYieldObjCmd( if (!corPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "yield can only be called in a coroutine", -1)); + "yield can only be called in a coroutine", TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", (char *)NULL); return TCL_ERROR; } @@ -8999,14 +9565,14 @@ TclNRYieldToObjCmd( if (!corPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "yieldto can only be called in a coroutine", -1)); + "yieldto can only be called in a coroutine", TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", (char *)NULL); return TCL_ERROR; } if (((Namespace *) nsPtr)->flags & NS_DYING) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "yieldto called in deleted namespace", -1)); + "yieldto called in deleted namespace", TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED", (char *)NULL); return TCL_ERROR; @@ -9019,7 +9585,7 @@ TclNRYieldToObjCmd( */ listPtr = Tcl_NewListObj(objc, objv); - nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1); + nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, TCL_INDEX_NONE); TclListObjSetElement(interp, listPtr, 0, nsObjPtr); /* @@ -9100,7 +9666,7 @@ NRCoroutineCallerCallback( NRE_ASSERT(iPtr->varFramePtr == corPtr->caller.varFramePtr); NRE_ASSERT(iPtr->framePtr == corPtr->caller.framePtr); NRE_ASSERT(iPtr->cmdFramePtr == corPtr->caller.cmdFramePtr); - Tcl_Free(corPtr); + ckfree(corPtr); return result; } @@ -9159,7 +9725,7 @@ NRCoroutineExitCallback( */ Tcl_DeleteHashTable(corPtr->lineLABCPtr); - Tcl_Free(corPtr->lineLABCPtr); + ckfree(corPtr->lineLABCPtr); corPtr->lineLABCPtr = NULL; RESTORE_CONTEXT(corPtr->caller); @@ -9242,7 +9808,7 @@ TclNRCoroutineActivateCallback( Tcl_SetObjResult(interp, Tcl_NewStringObj( - "cannot yield: C stack busy", -1)); + "cannot yield: C stack busy", TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "CANT_YIELD", (char *)NULL); return TCL_ERROR; @@ -9331,7 +9897,7 @@ CoroTypeObjCmd( cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]); if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can only get coroutine type of a coroutine", -1)); + "can only get coroutine type of a coroutine", TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE", TclGetString(objv[1]), (char *)NULL); return TCL_ERROR; @@ -9344,7 +9910,7 @@ CoroTypeObjCmd( corPtr = (CoroutineData *)cmdPtr->objClientData; if (!COR_IS_SUSPENDED(corPtr)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj("active", -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj("active", TCL_INDEX_NONE)); return TCL_OK; } @@ -9355,14 +9921,14 @@ CoroTypeObjCmd( switch (corPtr->nargs) { case COROUTINE_ARGUMENTS_SINGLE_OPTIONAL: - Tcl_SetObjResult(interp, Tcl_NewStringObj("yield", -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj("yield", TCL_INDEX_NONE)); return TCL_OK; case COROUTINE_ARGUMENTS_ARBITRARY: - Tcl_SetObjResult(interp, Tcl_NewStringObj("yieldto", -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj("yieldto", TCL_INDEX_NONE)); return TCL_OK; default: Tcl_SetObjResult(interp, Tcl_NewStringObj( - "unknown coroutine type", -1)); + "unknown coroutine type", TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "BAD_TYPE", (char *)NULL); return TCL_ERROR; } @@ -9391,7 +9957,7 @@ GetCoroutineFromObj( Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objPtr); if ((!cmdPtr) || (cmdPtr->nreProc != TclNRInterpCoroutine)) { - Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj(errMsg, TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE", TclGetString(objPtr), (char *)NULL); return NULL; @@ -9425,7 +9991,7 @@ TclNRCoroInjectObjCmd( } if (!COR_IS_SUSPENDED(corPtr)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can only inject a command into a suspended coroutine", -1)); + "can only inject a command into a suspended coroutine", TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", (char *)NULL); return TCL_ERROR; } @@ -9471,7 +10037,7 @@ TclNRCoroProbeObjCmd( if (!COR_IS_SUSPENDED(corPtr)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "can only inject a probe command into a suspended coroutine", - -1)); + TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", (char *)NULL); return TCL_ERROR; } @@ -9662,7 +10228,7 @@ NRInjectObjCmd( } if (!COR_IS_SUSPENDED(corPtr)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "can only inject a command into a suspended coroutine", -1)); + "can only inject a command into a suspended coroutine", TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", (char *)NULL); return TCL_ERROR; } @@ -9716,7 +10282,7 @@ TclNRInterpCoroutine( if (corPtr->nargs + 1 != objc) { Tcl_SetObjResult(interp, Tcl_NewStringObj("wrong coro nargs; how did we get here? " - "not implemented!", -1)); + "not implemented!", TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", (char *)NULL); return TCL_ERROR; } @@ -9787,7 +10353,7 @@ TclNRCoroutineObjCmd( * struct and create the corresponding command. */ - corPtr = (CoroutineData *)Tcl_Alloc(sizeof(CoroutineData)); + corPtr = (CoroutineData *)ckalloc(sizeof(CoroutineData)); cmdPtr = (Command *) TclNRCreateCommandInNs(interp, simpleName, (Tcl_Namespace *)nsPtr, /*objProc*/ NULL, TclNRInterpCoroutine, @@ -9809,7 +10375,7 @@ TclNRCoroutineObjCmd( Tcl_HashSearch hSearch; Tcl_HashEntry *hePtr; - corPtr->lineLABCPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); + corPtr->lineLABCPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(corPtr->lineLABCPtr, TCL_ONE_WORD_KEYS); for (hePtr = Tcl_FirstHashEntry(iPtr->lineLABCPtr,&hSearch); diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 329cfe2..b5f63c5 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -55,22 +55,25 @@ * Prototypes for local procedures defined in this file: */ +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, Tcl_Size *countPtr, int *flagsPtr); static Tcl_Obj * ScanNumber(unsigned char *buffer, int type, int flags, Tcl_HashTable **numberCachePtr); -static int SetByteArrayFromAny(Tcl_Interp *interp, Tcl_Size limit, +static int SetByteArrayFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void UpdateStringOfByteArray(Tcl_Obj *listPtr); static void DeleteScanNumberCache(Tcl_HashTable *numberCachePtr); static int NeedReversing(int format); static void CopyNumber(const void *from, void *to, - size_t length, int type); + unsigned int length, int type); /* Binary ensemble commands */ static Tcl_ObjCmdProc BinaryFormatCmd; static Tcl_ObjCmdProc BinaryScanCmd; @@ -145,6 +148,9 @@ static const EnsembleImplMap decodeMap[] = { * 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 will aid understanding. + * * 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. A simple encoding is to @@ -152,9 +158,50 @@ static const EnsembleImplMap decodeMap[] = { * 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. Tcl string values outside that subset do no represent any valid - * bytearray value. Attempts to treat those values as bytearrays will lead - * to errors. See TIP 568 for how this differs from Tcl 8. + * 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. + * + * 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, and motivated the proposal + * of TIP 568 to migrate away from it and to the more sensible design where + * each bytearray value has only one string representation. Full details are + * recorded in that TIP for those who seek them. + * + * 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 internalrep, as a canonical flag would require. This benefit is made + * available to extensions through the public routine Tcl_GetBytesFromObj(), + * first available in Tcl 8.7. + * + * The public routines Tcl_GetByteArrayFromObj() and Tcl_SetByteArrayLength() + * must continue to follow their documented behavior through the 8.* series of + * releases. To support that legacy operation, 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 + * shows up, it's a signal of a bug being ignored. + * + * In Tcl 9, the incompatibility in the behavior of these public routines + * has been approved, and the legacy internal rep is no longer retained. + * The internal changes seen below are the limit of what can be done + * in a Tcl 8.* release. They provide a great expansion of the histories + * over which bytearray values can be useful. */ static const Tcl_ObjType properByteArrayType = { @@ -162,8 +209,15 @@ static const Tcl_ObjType properByteArrayType = { FreeProperByteArrayInternalRep, DupProperByteArrayInternalRep, UpdateStringOfByteArray, + NULL +}; + +const Tcl_ObjType tclByteArrayType = { + "bytearray", + FreeByteArrayInternalRep, + DupByteArrayInternalRep, NULL, - TCL_OBJTYPE_V0 + SetByteArrayFromAny }; /* @@ -173,25 +227,26 @@ static const Tcl_ObjType properByteArrayType = { * fewer mallocs. */ -typedef struct { - Tcl_Size used; /* The number of bytes used in the byte - * array. */ - Tcl_Size allocated; /* The amount of space actually allocated - * minus 1 byte. */ - unsigned char bytes[TCLFLEXARRAY]; /* The array of bytes. The actual size of this - * field depends on the 'allocated' field +typedef struct ByteArray { + unsigned int bad; /* Index of first character that is a nonbyte. + * If all characters are bytes, bad = used. */ + unsigned int used; /* The number of bytes used in the byte + * array. Must be <= allocated. The bytes + * used to store the value are indexed from + * 0 to used-1. */ + unsigned int allocated; /* The number of bytes of space allocated. */ + unsigned char bytes[TCLFLEXARRAY]; + /* The array of bytes. The actual size of this + * field is stored in the 'allocated' field * above. */ } ByteArray; -#define BYTEARRAY_MAX_LEN (TCL_SIZE_MAX - (Tcl_Size)offsetof(ByteArray, bytes)) #define BYTEARRAY_SIZE(len) \ - ( (len < 0 || BYTEARRAY_MAX_LEN < (len)) \ - ? (Tcl_Panic("negative length specified or max size of a Tcl value exceeded"), 0) \ - : (offsetof(ByteArray, bytes) + (len)) ) + (offsetof(ByteArray, bytes) + (len)) #define GET_BYTEARRAY(irPtr) ((ByteArray *) (irPtr)->twoPtrValue.ptr1) #define SET_BYTEARRAY(irPtr, baPtr) \ - (irPtr)->twoPtrValue.ptr1 = (baPtr) - + (irPtr)->twoPtrValue.ptr1 = (void *) (baPtr) + int TclIsPureByteArray( Tcl_Obj * objPtr) @@ -285,7 +340,7 @@ Tcl_Obj * Tcl_DbNewByteArrayObj( const unsigned char *bytes, /* The array of bytes used to initialize the * new object. */ - Tcl_Size numBytes, /* Number of bytes in the array, + int numBytes, /* Number of bytes in the array, * must be >= 0. */ TCL_UNUSED(const char *) /*file*/, TCL_UNUSED(int) /*line*/) @@ -329,7 +384,8 @@ Tcl_SetByteArrayObj( TclInvalidateStringRep(objPtr); assert(numBytes >= 0); - byteArrayPtr = (ByteArray *)Tcl_Alloc(BYTEARRAY_SIZE(numBytes)); + byteArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(numBytes)); + byteArrayPtr->bad = numBytes; byteArrayPtr->used = numBytes; byteArrayPtr->allocated = numBytes; @@ -344,7 +400,7 @@ Tcl_SetByteArrayObj( /* *---------------------------------------------------------------------- * - * TclGetBytesFromObj -- + * Tcl_GetBytesFromObj -- * * Attempt to extract the value from objPtr in the representation * of a byte sequence. On success return the extracted byte sequence. @@ -358,7 +414,6 @@ Tcl_SetByteArrayObj( *---------------------------------------------------------------------- */ -#undef Tcl_GetBytesFromObj unsigned char * Tcl_GetBytesFromObj( Tcl_Interp *interp, /* For error reporting */ @@ -371,10 +426,25 @@ Tcl_GetBytesFromObj( = TclFetchInternalRep(objPtr, &properByteArrayType); if (irPtr == NULL) { - if (TCL_ERROR == SetByteArrayFromAny(interp, TCL_INDEX_NONE, objPtr)) { + SetByteArrayFromAny(NULL, objPtr); + irPtr = TclFetchInternalRep(objPtr, &properByteArrayType); + if (irPtr == NULL) { + if (interp) { + const char *nonbyte; + int ucs4; + + irPtr = TclFetchInternalRep(objPtr, &tclByteArrayType); + baPtr = GET_BYTEARRAY(irPtr); + nonbyte = TclUtfAtIndex(TclGetString(objPtr), baPtr->bad); + TclUtfToUniChar(nonbyte, &ucs4); + + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected byte sequence but character %d " + "was '%1s' (U+%06X)", baPtr->bad, nonbyte, ucs4)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "BYTES", (char *)NULL); + } return NULL; } - irPtr = TclFetchInternalRep(objPtr, &properByteArrayType); } baPtr = GET_BYTEARRAY(irPtr); @@ -383,36 +453,49 @@ Tcl_GetBytesFromObj( } return baPtr->bytes; } + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetByteArrayFromObj -- + * + * Attempt to get the array of bytes from the Tcl object. If the object + * is not already a ByteArray object, an attempt will be made to convert + * it to one. + * + * Results: + * Pointer to array of bytes representing the ByteArray object. + * + * Side effects: + * Frees old internal rep. Allocates memory for new internal rep. + * + *---------------------------------------------------------------------- + */ -#if !defined(TCL_NO_DEPRECATED) unsigned char * -TclGetBytesFromObj( - Tcl_Interp *interp, /* For error reporting */ - Tcl_Obj *objPtr, /* Value to extract from */ - void *numBytesPtr) /* If non-NULL, write the number of bytes +Tcl_GetByteArrayFromObj( + Tcl_Obj *objPtr, /* The ByteArray object. */ + Tcl_Size *numBytesPtr) /* If non-NULL, write the number of bytes * in the array here */ { - Tcl_Size numBytes = 0; - unsigned char *bytes = Tcl_GetBytesFromObj(interp, objPtr, &numBytes); + ByteArray *baPtr; + const Tcl_ObjInternalRep *irPtr; + unsigned char *result = Tcl_GetBytesFromObj(NULL, objPtr, numBytesPtr); - if (bytes && numBytesPtr) { - if (numBytes > INT_MAX) { - /* Caller asked for numBytes to be written to an int, but the - * value is outside the int range. */ + if (result) { + return result; + } - if (interp) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "byte sequence length exceeds INT_MAX", -1)); - Tcl_SetErrorCode(interp, "TCL", "API", "OUTDATED", (void *)NULL); - } - return NULL; - } else { - *(int *)numBytesPtr = (int) numBytes; - } + irPtr = TclFetchInternalRep(objPtr, &tclByteArrayType); + assert(irPtr != NULL); + + baPtr = GET_BYTEARRAY(irPtr); + + if (numBytesPtr != NULL) { + *numBytesPtr = baPtr->used; } - return bytes; + return (unsigned char *) baPtr->bytes; } -#endif /* *---------------------------------------------------------------------- @@ -439,157 +522,110 @@ TclGetBytesFromObj( unsigned char * Tcl_SetByteArrayLength( Tcl_Obj *objPtr, /* The ByteArray object. */ - Tcl_Size numBytes) /* Number of bytes in resized array - * Must be >= 0 */ + Tcl_Size numBytes) /* Number of bytes in resized array */ { ByteArray *byteArrayPtr; + unsigned newLength; Tcl_ObjInternalRep *irPtr; assert(numBytes >= 0); + newLength = (unsigned int)numBytes; + if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_SetByteArrayLength"); } irPtr = TclFetchInternalRep(objPtr, &properByteArrayType); if (irPtr == NULL) { - if (TCL_ERROR == SetByteArrayFromAny(NULL, numBytes, objPtr)) { - return NULL; + irPtr = TclFetchInternalRep(objPtr, &tclByteArrayType); + if (irPtr == NULL) { + SetByteArrayFromAny(NULL, objPtr); + irPtr = TclFetchInternalRep(objPtr, &properByteArrayType); + if (irPtr == NULL) { + irPtr = TclFetchInternalRep(objPtr, &tclByteArrayType); + } } - irPtr = TclFetchInternalRep(objPtr, &properByteArrayType); } + /* Note that during truncation, the implementation does not free + * memory that is no longer needed. */ + byteArrayPtr = GET_BYTEARRAY(irPtr); - if (numBytes > byteArrayPtr->allocated) { - byteArrayPtr = (ByteArray *)Tcl_Realloc(byteArrayPtr, - BYTEARRAY_SIZE(numBytes)); - byteArrayPtr->allocated = numBytes; + if (newLength > byteArrayPtr->allocated) { + byteArrayPtr = (ByteArray *)ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(newLength)); + byteArrayPtr->allocated = newLength; SET_BYTEARRAY(irPtr, byteArrayPtr); } TclInvalidateStringRep(objPtr); - byteArrayPtr->used = numBytes; + objPtr->typePtr = &properByteArrayType; + byteArrayPtr->bad = newLength; + byteArrayPtr->used = newLength; return byteArrayPtr->bytes; } /* *---------------------------------------------------------------------- * - * MakeByteArray -- - * - * Generate a ByteArray internal rep from the string rep of objPtr. - * The generated byte sequence may have no more than limit bytes. - * A negative value for limit indicates no limit imposed. If - * boolean argument demandProper is true, then no byte sequence should - * be output to the caller (write NULL instead). When no bytes sequence - * is output and interp is not NULL, leave an error message and error - * code in interp explaining why a proper byte sequence could not be - * made. - * - * Results: - * Returns a boolean indicating whether the bytes generated (up to - * limit bytes) are a proper representation of (a limited prefix of) - * the string. Writes a pointer to the generated ByteArray to - * *byteArrayPtrPtr. If not NULL it needs to be released with Tcl_Free(). - * - *---------------------------------------------------------------------- - */ - -static int -MakeByteArray( - Tcl_Interp *interp, - Tcl_Obj *objPtr, - Tcl_Size limit, - int demandProper, - ByteArray **byteArrayPtrPtr) -{ - Tcl_Size length; - const char *src = TclGetStringFromObj(objPtr, &length); - Tcl_Size numBytes = (limit >= 0 && limit < length) ? limit : length; - ByteArray *byteArrayPtr = (ByteArray *)Tcl_Alloc(BYTEARRAY_SIZE(numBytes)); - unsigned char *dst = byteArrayPtr->bytes; - unsigned char *dstEnd = dst + numBytes; - const char *srcEnd = src + length; - int proper = 1; - - for (; src < srcEnd && dst < dstEnd; ) { - int ch; - int count = TclUtfToUniChar(src, &ch); - - if (ch > 255) { - proper = 0; - if (demandProper) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "expected byte sequence but character %" - TCL_Z_MODIFIER "u was '%1s' (U+%06X)", - dst - byteArrayPtr->bytes, src, ch)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "BYTES", (void *)NULL); - } - Tcl_Free(byteArrayPtr); - *byteArrayPtrPtr = NULL; - return proper; - } - } - src += count; - *dst++ = UCHAR(ch); - } - byteArrayPtr->used = dst - byteArrayPtr->bytes; - byteArrayPtr->allocated = numBytes; - - *byteArrayPtrPtr = byteArrayPtr; - return proper; -} - -static Tcl_Obj * -TclNarrowToBytes( - Tcl_Obj *objPtr) -{ - if (NULL == TclFetchInternalRep(objPtr, &properByteArrayType)) { - Tcl_ObjInternalRep ir; - ByteArray *byteArrayPtr; - - if (0 == MakeByteArray(NULL, objPtr, TCL_INDEX_NONE, 0, &byteArrayPtr)) { - TclNewObj(objPtr); - TclInvalidateStringRep(objPtr); - } - SET_BYTEARRAY(&ir, byteArrayPtr); - Tcl_StoreInternalRep(objPtr, &properByteArrayType, &ir); - } - Tcl_IncrRefCount(objPtr); - return objPtr; -} - - -/* - *---------------------------------------------------------------------- - * * SetByteArrayFromAny -- * * Generate the ByteArray internal rep from the string rep. * * Results: - * Tcl return code indicating OK or ERROR. + * The return value is always TCL_OK. * * Side effects: - * A ByteArray struct may be stored as the internal rep of objPtr. + * A ByteArray object is stored as the internal rep of objPtr. * *---------------------------------------------------------------------- */ static int SetByteArrayFromAny( - Tcl_Interp *interp, /* For error reporting. */ - Tcl_Size limit, /* Create no more than this many bytes */ + TCL_UNUSED(Tcl_Interp *), Tcl_Obj *objPtr) /* The object to convert to type ByteArray. */ { + int length, bad; + const char *src, *srcEnd; + unsigned char *dst; + Tcl_UniChar ch = 0; ByteArray *byteArrayPtr; Tcl_ObjInternalRep ir; - if (0 == MakeByteArray(interp, objPtr, limit, 1, &byteArrayPtr)) { - return TCL_ERROR; + if (TclHasInternalRep(objPtr, &properByteArrayType)) { + return TCL_OK; + } + if (TclHasInternalRep(objPtr, &tclByteArrayType)) { + return TCL_OK; + } + + src = TclGetStringFromObj(objPtr, &length); + bad = length; + srcEnd = src + length; + + /* Note the allocation is over-sized, possibly by a factor of four, + * or even a factor of two with a proper byte array value. */ + + byteArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(length)); + for (dst = byteArrayPtr->bytes; src < srcEnd; ) { + src += TclUtfToUniChar(src, &ch); + if ((bad == length) && (ch > 255)) { + bad = dst - byteArrayPtr->bytes; + } + *dst++ = UCHAR(ch); } SET_BYTEARRAY(&ir, byteArrayPtr); - Tcl_StoreInternalRep(objPtr, &properByteArrayType, &ir); + byteArrayPtr->allocated = length; + byteArrayPtr->used = dst - byteArrayPtr->bytes; + + if (bad == length) { + byteArrayPtr->bad = byteArrayPtr->used; + Tcl_StoreInternalRep(objPtr, &properByteArrayType, &ir); + } else { + byteArrayPtr->bad = bad; + Tcl_StoreInternalRep(objPtr, &tclByteArrayType, &ir); + } + return TCL_OK; } @@ -611,10 +647,17 @@ SetByteArrayFromAny( */ static void +FreeByteArrayInternalRep( + Tcl_Obj *objPtr) /* Object with internal rep to free. */ +{ + ckfree(GET_BYTEARRAY(TclFetchInternalRep(objPtr, &tclByteArrayType))); +} + +static void FreeProperByteArrayInternalRep( Tcl_Obj *objPtr) /* Object with internal rep to free. */ { - Tcl_Free(GET_BYTEARRAY(TclFetchInternalRep(objPtr, &properByteArrayType))); + ckfree(GET_BYTEARRAY(TclFetchInternalRep(objPtr, &properByteArrayType))); } /* @@ -635,18 +678,41 @@ FreeProperByteArrayInternalRep( */ static void +DupByteArrayInternalRep( + 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_ObjInternalRep ir; + + srcArrayPtr = GET_BYTEARRAY(TclFetchInternalRep(srcPtr, &tclByteArrayType)); + length = srcArrayPtr->used; + + copyArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(length)); + copyArrayPtr->bad = srcArrayPtr->bad; + copyArrayPtr->used = length; + copyArrayPtr->allocated = length; + memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, length); + + SET_BYTEARRAY(&ir, copyArrayPtr); + Tcl_StoreInternalRep(copyPtr, &tclByteArrayType, &ir); +} + +static void DupProperByteArrayInternalRep( Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ Tcl_Obj *copyPtr) /* Object with internal rep to set. */ { - Tcl_Size length; + unsigned int length; ByteArray *srcArrayPtr, *copyArrayPtr; Tcl_ObjInternalRep ir; srcArrayPtr = GET_BYTEARRAY(TclFetchInternalRep(srcPtr, &properByteArrayType)); length = srcArrayPtr->used; - copyArrayPtr = (ByteArray *)Tcl_Alloc(BYTEARRAY_SIZE(length)); + copyArrayPtr = (ByteArray *)ckalloc(BYTEARRAY_SIZE(length)); + copyArrayPtr->bad = length; copyArrayPtr->used = length; copyArrayPtr->allocated = length; memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, length); @@ -680,18 +746,21 @@ UpdateStringOfByteArray( const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &properByteArrayType); ByteArray *byteArrayPtr = GET_BYTEARRAY(irPtr); unsigned char *src = byteArrayPtr->bytes; - Tcl_Size i, length = byteArrayPtr->used; - Tcl_Size size = length; + unsigned int i, length = byteArrayPtr->used; + unsigned int size = length; /* * How much space will string rep need? */ - for (i = 0; i < length; i++) { + for (i = 0; i < length && size <= INT_MAX; i++) { if ((src[i] == 0) || (src[i] > 127)) { size++; } } + if (size > INT_MAX) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } if (size == length) { char *dst = Tcl_InitStringRep(objPtr, (char *)src, size); @@ -733,7 +802,7 @@ TclAppendBytesToByteArray( Tcl_Size len) { ByteArray *byteArrayPtr; - Tcl_Size needed; + unsigned int length, needed; Tcl_ObjInternalRep *irPtr; if (Tcl_IsShared(objPtr)) { @@ -751,41 +820,73 @@ TclAppendBytesToByteArray( return; } + length = (unsigned int) len; + irPtr = TclFetchInternalRep(objPtr, &properByteArrayType); if (irPtr == NULL) { - if (TCL_ERROR == SetByteArrayFromAny(NULL, TCL_INDEX_NONE, objPtr)) { - Tcl_Panic("attempt to append bytes to non-bytearray"); + irPtr = TclFetchInternalRep(objPtr, &tclByteArrayType); + if (irPtr == NULL) { + SetByteArrayFromAny(NULL, objPtr); + irPtr = TclFetchInternalRep(objPtr, &properByteArrayType); + if (irPtr == NULL) { + irPtr = TclFetchInternalRep(objPtr, &tclByteArrayType); + } } - irPtr = TclFetchInternalRep(objPtr, &properByteArrayType); } byteArrayPtr = GET_BYTEARRAY(irPtr); + if (length > INT_MAX - byteArrayPtr->used) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } + + needed = byteArrayPtr->used + length; /* * If we need to, resize the allocated space in the byte array. */ - if ((BYTEARRAY_MAX_LEN - byteArrayPtr->used) < len) { - /* Will wrap around !! */ - Tcl_Panic("max size of a byte array exceeded"); - } - needed = byteArrayPtr->used + len; if (needed > byteArrayPtr->allocated) { - Tcl_Size newCapacity; - byteArrayPtr = - (ByteArray *)TclReallocElemsEx(byteArrayPtr, - needed, - 1, - offsetof(ByteArray, bytes), - &newCapacity); - byteArrayPtr->allocated = newCapacity; + ByteArray *ptr = NULL; + unsigned int attempt; + + if (needed <= INT_MAX/2) { + /* + * Try to allocate double the total space that is needed. + */ + + attempt = 2 * needed; + ptr = (ByteArray *)attemptckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt)); + } + if (ptr == NULL) { + /* + * Try to allocate double the increment that is needed (plus). + */ + + unsigned int limit = INT_MAX - needed; + unsigned int extra = length + TCL_MIN_GROWTH; + int growth = (int) ((extra > limit) ? limit : extra); + + attempt = needed + growth; + ptr = (ByteArray *)attemptckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt)); + } + if (ptr == NULL) { + /* + * Last chance: Try to allocate exactly what is needed. + */ + + attempt = needed; + ptr = (ByteArray *)ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(attempt)); + } + byteArrayPtr = ptr; + byteArrayPtr->allocated = attempt; 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); + objPtr->typePtr = &properByteArrayType; } /* @@ -895,9 +996,7 @@ BinaryFormatCmd( goto badIndex; } if (count == BINARY_ALL) { - if (Tcl_GetBytesFromObj(NULL, objv[arg], &count) == NULL) { - count = Tcl_GetCharLength(objv[arg]); - } + Tcl_GetByteArrayFromObj(objv[arg], &count); } else if (count == BINARY_NOCOUNT) { count = 1; } @@ -961,7 +1060,8 @@ BinaryFormatCmd( * The macro evals its args more than once: avoid arg++ */ - if (TclListObjLength(interp, objv[arg], &listc) != TCL_OK) { + if (TclListObjLength(interp, objv[arg], &listc + ) != TCL_OK) { return TCL_ERROR; } @@ -1063,9 +1163,8 @@ BinaryFormatCmd( case 'A': { char pad = (char) (cmd == 'a' ? '\0' : ' '); unsigned char *bytes; - Tcl_Obj *copy = TclNarrowToBytes(objv[arg++]); - bytes = Tcl_GetBytesFromObj(NULL, copy, &length); + bytes = Tcl_GetByteArrayFromObj(objv[arg++], &length); if (count == BINARY_ALL) { count = length; @@ -1079,7 +1178,6 @@ BinaryFormatCmd( memset(cursor + length, pad, count - length); } cursor += count; - Tcl_DecrRefCount(copy); break; } case 'b': @@ -1365,7 +1463,7 @@ BinaryScanCmd( unsigned char *buffer; /* Start of result buffer. */ const char *errorString; const char *str; - Tcl_Size offset, size, length = 0, i; + Tcl_Size offset, size, length, i; Tcl_Obj *valuePtr, *elementPtr; Tcl_HashTable numberCacheHash; @@ -1376,12 +1474,9 @@ BinaryScanCmd( "value formatString ?varName ...?"); return TCL_ERROR; } - buffer = Tcl_GetBytesFromObj(interp, objv[1], &length); - if (buffer == NULL) { - return TCL_ERROR; - } numberCachePtr = &numberCacheHash; Tcl_InitHashTable(numberCachePtr, TCL_ONE_WORD_KEYS); + buffer = Tcl_GetByteArrayFromObj(objv[1], &length); format = TclGetString(objv[2]); arg = 3; offset = 0; @@ -1768,14 +1863,14 @@ GetFormatSpec( (*formatPtr)++; *countPtr = BINARY_ALL; } else if (isdigit(UCHAR(**formatPtr))) { /* INTL: digit */ - unsigned long long count; + unsigned long count; errno = 0; - count = strtoull(*formatPtr, (char **) formatPtr, 10); - if (errno || (count > TCL_SIZE_MAX)) { - *countPtr = TCL_SIZE_MAX; + count = strtoul(*formatPtr, (char **) formatPtr, 10); + if (errno || (count > (unsigned long) INT_MAX)) { + *countPtr = INT_MAX; } else { - *countPtr = count; + *countPtr = (int) count; } } else { *countPtr = BINARY_NOCOUNT; @@ -1901,7 +1996,7 @@ static void CopyNumber( const void *from, /* source */ void *to, /* destination */ - size_t length, /* Number of bytes to copy */ + unsigned length, /* Number of bytes to copy */ int type) /* What type of thing are we copying? */ { switch (NeedReversing(type)) { @@ -1968,7 +2063,7 @@ CopyNumber( * * FormatNumber -- * - * This routine is called by Tcl_BinaryObjCmd to format a number into a + * This routine is called by BinaryFormatCmd to format a number into a * location pointed at by cursor. * * Results: @@ -2141,7 +2236,7 @@ FormatNumber( * * ScanNumber -- * - * This routine is called by Tcl_BinaryObjCmd to scan a number out of a + * This routine is called by BinaryScanCmd to scan a number out of a * buffer. * * Results: @@ -2446,12 +2541,8 @@ BinaryEncodeHex( return TCL_ERROR; } - data = Tcl_GetBytesFromObj(interp, objv[1], &count); - if (data == NULL) { - return TCL_ERROR; - } - TclNewObj(resultObj); + data = Tcl_GetByteArrayFromObj(objv[1], &count); cursor = Tcl_SetByteArrayLength(resultObj, count * 2); for (offset = 0; offset < count; ++offset) { *cursor++ = HexDigits[(data[offset] >> 4) & 0x0F]; @@ -2513,7 +2604,7 @@ BinaryDecodeHex( data = Tcl_GetBytesFromObj(NULL, objv[objc - 1], &count); if (data == NULL) { pure = 0; - data = (unsigned char *)TclGetStringFromObj(objv[objc - 1], &count); + data = (unsigned char *) TclGetStringFromObj(objv[objc - 1], &count); } datastart = data; dataend = data + count; @@ -2567,9 +2658,9 @@ BinaryDecodeHex( } TclDecrRefCount(resultObj); Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "invalid hexadecimal digit \"%c\" (U+%06X) at position %" - TCL_Z_MODIFIER "u", ucs4, ucs4, data - datastart - 1)); - Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", (void *)NULL); + "invalid hexadecimal digit \"%c\" (U+%06X) at position %d", + ucs4, ucs4, (int) (data - datastart - 1))); + Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", (char *)NULL); return TCL_ERROR; } @@ -2631,14 +2722,14 @@ BinaryEncode64( } switch (index) { case OPT_MAXLEN: - if (TclGetWideIntFromObj(interp, objv[i + 1], &maxlen) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[i + 1], &maxlen) != TCL_OK) { return TCL_ERROR; } if (maxlen < 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "line length out of range", -1)); Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", - "LINE_LENGTH", (void *)NULL); + "LINE_LENGTH", (char *)NULL); return TCL_ERROR; } break; @@ -2656,11 +2747,8 @@ BinaryEncode64( maxlen = 0; } - data = Tcl_GetBytesFromObj(interp, objv[objc - 1], &count); - if (data == NULL) { - return TCL_ERROR; - } TclNewObj(resultObj); + data = Tcl_GetByteArrayFromObj(objv[objc - 1], &count); if (count > 0) { unsigned char *cursor = NULL; @@ -2742,7 +2830,7 @@ BinaryEncodeUu( int lineLength = 61; const unsigned char SingleNewline[] = { UCHAR('\n') }; const unsigned char *wrapchar = SingleNewline; - Tcl_Size j, rawLength, offset, count = 0, wrapcharlen = sizeof(SingleNewline); + Tcl_Size j, rawLength, offset, count, wrapcharlen = sizeof(SingleNewline); enum { OPT_MAXLEN, OPT_WRAPCHAR }; static const char *const optStrings[] = { "-maxlen", "-wrapchar", NULL }; @@ -2766,13 +2854,13 @@ BinaryEncodeUu( Tcl_SetObjResult(interp, Tcl_NewStringObj( "line length out of range", -1)); Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", - "LINE_LENGTH", (void *)NULL); + "LINE_LENGTH", (char *)NULL); return TCL_ERROR; } lineLength = ((lineLength - 1) & -4) + 1; /* 5, 9, 13 ... */ break; case OPT_WRAPCHAR: - wrapchar = (const unsigned char *)TclGetStringFromObj( + wrapchar = (const unsigned char *) TclGetStringFromObj( objv[i + 1], &wrapcharlen); { const unsigned char *p = wrapchar; @@ -2795,7 +2883,7 @@ BinaryEncodeUu( "invalid wrapchar; will defeat decoding", -1)); Tcl_SetErrorCode(interp, "TCL", "BINARY", - "ENCODE", "WRAPCHAR", (void *)NULL); + "ENCODE", "WRAPCHAR", (char *)NULL); return TCL_ERROR; } } @@ -2812,12 +2900,9 @@ BinaryEncodeUu( * enough". */ - offset = 0; - data = Tcl_GetBytesFromObj(interp, objv[objc - 1], &count); - if (data == NULL) { - return TCL_ERROR; - } TclNewObj(resultObj); + offset = 0; + data = Tcl_GetByteArrayFromObj(objv[objc - 1], &count); rawLength = (lineLength - 1) * 3 / 4; start = cursor = Tcl_SetByteArrayLength(resultObj, (lineLength + wrapcharlen) * @@ -3020,7 +3105,7 @@ BinaryDecodeUu( shortUu: Tcl_SetObjResult(interp, Tcl_ObjPrintf("short uuencode data")); - Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "SHORT", (void *)NULL); + Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "SHORT", (char *)NULL); TclDecrRefCount(resultObj); return TCL_ERROR; @@ -3031,9 +3116,9 @@ BinaryDecodeUu( TclUtfToUniChar((const char *)(data - 1), &ucs4); } Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "invalid uuencode character \"%c\" (U+%06X) at position %" - TCL_Z_MODIFIER "u", ucs4, ucs4, data - datastart - 1)); - Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", (void *)NULL); + "invalid uuencode character \"%c\" (U+%06X) at position %d", + ucs4, ucs4, (int) (data - datastart - 1))); + Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", (char *)NULL); TclDecrRefCount(resultObj); return TCL_ERROR; } @@ -3207,9 +3292,9 @@ BinaryDecode64( } Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "invalid base64 character \"%c\" (U+%06X) at position %" - TCL_Z_MODIFIER "u", ucs4, ucs4, data - datastart - 1)); - Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", (void *)NULL); + "invalid base64 character \"%c\" (U+%06X) at position %d", + ucs4, ucs4, (int) (data - datastart - 1))); + Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", (char *)NULL); TclDecrRefCount(resultObj); return TCL_ERROR; } diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c index 1c12106..f0c625f 100644 --- a/generic/tclCkalloc.c +++ b/generic/tclCkalloc.c @@ -16,7 +16,6 @@ */ #include "tclInt.h" -#include <assert.h> #define FALSE 0 #define TRUE 1 @@ -122,7 +121,7 @@ static char dumpFile[100]; /* Records where to dump memory allocation /* * Mutex to serialize allocations. This is a low-level mutex that must be * explicitly initialized. This is necessary because the self initializing - * mutexes use Tcl_Alloc... + * mutexes use ckalloc... */ static Tcl_Mutex *ckallocMutexPtr; @@ -251,7 +250,7 @@ ValidateMemory( hiPtr = (unsigned char *)memHeaderP->body + memHeaderP->length; for (idx = 0; idx < HIGH_GUARD_SIZE; idx++) { - byte = hiPtr[idx]; + byte = *(hiPtr + idx); if (byte != GUARD_VALUE) { guard_failed = TRUE; fflush(stdout); @@ -366,7 +365,7 @@ Tcl_DumpActiveMemory( /* *---------------------------------------------------------------------- * - * Tcl_DbCkalloc - debugging Tcl_Alloc + * Tcl_DbCkalloc - debugging ckalloc * * Allocate the requested amount of space plus some extra for guard bands * at both ends of the request, plus a size, panicking if there isn't @@ -375,15 +374,15 @@ Tcl_DumpActiveMemory( * * The second and third arguments are file and line, these contain the * filename and line number corresponding to the caller. These are sent - * by the Tcl_Alloc macro; it uses the preprocessor autodefines __FILE__ + * by the ckalloc macro; it uses the preprocessor autodefines __FILE__ * and __LINE__. * *---------------------------------------------------------------------- */ -void * +char * Tcl_DbCkalloc( - size_t size, + unsigned int size, const char *file, int line) { @@ -394,14 +393,14 @@ Tcl_DbCkalloc( } /* Don't let size argument to TclpAlloc overflow */ - if (size <= (size_t)-2 - offsetof(struct mem_header, body) - HIGH_GUARD_SIZE) { + if (size <= UINT_MAX - offsetof(struct mem_header, body) - 1U - HIGH_GUARD_SIZE) { result = (struct mem_header *) TclpAlloc(size + offsetof(struct mem_header, body) + 1U + HIGH_GUARD_SIZE); } if (result == NULL) { fflush(stdout); TclDumpMemoryInfo(stderr, 0); - Tcl_Panic("unable to alloc %" TCL_Z_MODIFIER "u bytes, %s line %d", size, file, line); + Tcl_Panic("unable to alloc %u bytes, %s line %d", size, file, line); } /* @@ -447,7 +446,7 @@ Tcl_DbCkalloc( } if (alloc_tracing) { - fprintf(stderr,"Tcl_Alloc %p %" TCL_Z_MODIFIER "u %s %d\n", + fprintf(stderr,"ckalloc %p %u %s %d\n", result->body, size, file, line); } @@ -471,9 +470,9 @@ Tcl_DbCkalloc( return result->body; } -void * +char * Tcl_AttemptDbCkalloc( - size_t size, + unsigned int size, const char *file, int line) { @@ -484,7 +483,7 @@ Tcl_AttemptDbCkalloc( } /* Don't let size argument to TclpAlloc overflow */ - if (size <= (size_t)-2 - offsetof(struct mem_header, body) - HIGH_GUARD_SIZE) { + if (size <= UINT_MAX - offsetof(struct mem_header, body) - 1U - HIGH_GUARD_SIZE) { result = (struct mem_header *) TclpAlloc(size + offsetof(struct mem_header, body) + 1U + HIGH_GUARD_SIZE); } @@ -536,7 +535,7 @@ Tcl_AttemptDbCkalloc( } if (alloc_tracing) { - fprintf(stderr,"Tcl_Alloc %p %" TCL_Z_MODIFIER "u %s %d\n", + fprintf(stderr,"ckalloc %p %u %s %d\n", result->body, size, file, line); } @@ -563,7 +562,7 @@ Tcl_AttemptDbCkalloc( /* *---------------------------------------------------------------------- * - * Tcl_DbCkfree - debugging Tcl_Free + * Tcl_DbCkfree - debugging ckfree * * Verify that the low and high guards are intact, and if so then free * the buffer else Tcl_Panic. @@ -572,7 +571,7 @@ Tcl_AttemptDbCkalloc( * * The second and third arguments are file and line, these contain the * filename and line number corresponding to the caller. These are sent - * by the Tcl_Free macro; it uses the preprocessor autodefines __FILE__ and + * by the ckfree macro; it uses the preprocessor autodefines __FILE__ and * __LINE__. * *---------------------------------------------------------------------- @@ -580,7 +579,7 @@ Tcl_AttemptDbCkalloc( void Tcl_DbCkfree( - void *ptr, + char *ptr, const char *file, int line) { @@ -601,7 +600,7 @@ Tcl_DbCkfree( memp = (struct mem_header *) (((size_t) ptr) - BODY_OFFSET); if (alloc_tracing) { - fprintf(stderr, "Tcl_Free %p %" TCL_Z_MODIFIER "u %s %d\n", + fprintf(stderr, "ckfree %p %" TCL_Z_MODIFIER "u %s %d\n", memp->body, memp->length, file, line); } @@ -645,7 +644,7 @@ Tcl_DbCkfree( /* *-------------------------------------------------------------------- * - * Tcl_DbCkrealloc - debugging Tcl_Realloc + * Tcl_DbCkrealloc - debugging ckrealloc * * Reallocate a chunk of memory by allocating a new one of the right * size, copying the old data to the new location, and then freeing the @@ -655,10 +654,10 @@ Tcl_DbCkfree( *-------------------------------------------------------------------- */ -void * +char * Tcl_DbCkrealloc( - void *ptr, - size_t size, + char *ptr, + unsigned int size, const char *file, int line) { @@ -686,10 +685,10 @@ Tcl_DbCkrealloc( return newPtr; } -void * +char * Tcl_AttemptDbCkrealloc( - void *ptr, - size_t size, + char *ptr, + unsigned int size, const char *file, int line) { @@ -738,38 +737,38 @@ Tcl_AttemptDbCkrealloc( *---------------------------------------------------------------------- */ -void * +char * Tcl_Alloc( - size_t size) + unsigned int size) { return Tcl_DbCkalloc(size, "unknown", 0); } -void * +char * Tcl_AttemptAlloc( - size_t size) + unsigned int size) { return Tcl_AttemptDbCkalloc(size, "unknown", 0); } void Tcl_Free( - void *ptr) + char *ptr) { Tcl_DbCkfree(ptr, "unknown", 0); } -void * +char * Tcl_Realloc( - void *ptr, - size_t size) + char *ptr, + unsigned int size) { return Tcl_DbCkrealloc(ptr, size, "unknown", 0); } -void * +char * Tcl_AttemptRealloc( - void *ptr, - size_t size) + char *ptr, + unsigned int size) { return Tcl_AttemptDbCkrealloc(ptr, size, "unknown", 0); } @@ -837,7 +836,7 @@ MemoryCmd( if (objc != 3) { goto argError; } - if (TclGetWideIntFromObj(interp, objv[2], &value) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[2], &value) != TCL_OK) { return TCL_ERROR; } break_on_malloc = value; @@ -922,7 +921,7 @@ MemoryCmd( if (objc != 3) { goto argError; } - if (TclGetWideIntFromObj(interp, objv[2], &value) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[2], &value) != TCL_OK) { return TCL_ERROR; } trace_on_at_malloc = value; @@ -1031,11 +1030,11 @@ Tcl_InitMemory( *---------------------------------------------------------------------- */ -void * +char * Tcl_Alloc( - size_t size) + unsigned int size) { - void *result = TclpAlloc(size); + char *result = (char *)TclpAlloc(size); /* * Most systems will not alloc(0), instead bumping it to one so that NULL @@ -1048,23 +1047,22 @@ Tcl_Alloc( */ if ((result == NULL) && size) { - Tcl_Panic("unable to alloc %" TCL_Z_MODIFIER "u bytes", size); + Tcl_Panic("unable to alloc %u bytes", size); } return result; } -void * +char * Tcl_DbCkalloc( - size_t size, + unsigned int size, const char *file, int line) { - void *result = TclpAlloc(size); + char *result = (char *)TclpAlloc(size); if ((result == NULL) && size) { fflush(stdout); - Tcl_Panic("unable to alloc %" TCL_Z_MODIFIER "u bytes, %s line %d", - size, file, line); + Tcl_Panic("unable to alloc %u bytes, %s line %d", size, file, line); } return result; } @@ -1080,16 +1078,16 @@ Tcl_DbCkalloc( *---------------------------------------------------------------------- */ -void * +char * Tcl_AttemptAlloc( - size_t size) + unsigned int size) { return (char *)TclpAlloc(size); } -void * +char * Tcl_AttemptDbCkalloc( - size_t size, + unsigned int size, TCL_UNUSED(const char *) /*file*/, TCL_UNUSED(int) /*line*/) { @@ -1107,32 +1105,31 @@ Tcl_AttemptDbCkalloc( *---------------------------------------------------------------------- */ -void * +char * Tcl_Realloc( - void *ptr, - size_t size) + char *ptr, + unsigned int size) { - void *result = TclpRealloc(ptr, size); + char *result = (char *)TclpRealloc(ptr, size); if ((result == NULL) && size) { - Tcl_Panic("unable to realloc %" TCL_Z_MODIFIER "u bytes", size); + Tcl_Panic("unable to realloc %u bytes", size); } return result; } -void * +char * Tcl_DbCkrealloc( - void *ptr, - size_t size, + char *ptr, + unsigned int size, const char *file, int line) { - void *result = TclpRealloc(ptr, size); + char *result = (char *)TclpRealloc(ptr, size); if ((result == NULL) && size) { fflush(stdout); - Tcl_Panic("unable to realloc %" TCL_Z_MODIFIER "u bytes, %s line %d", - size, file, line); + Tcl_Panic("unable to realloc %u bytes, %s line %d", size, file, line); } return result; } @@ -1148,18 +1145,18 @@ Tcl_DbCkrealloc( *---------------------------------------------------------------------- */ -void * +char * Tcl_AttemptRealloc( - void *ptr, - size_t size) + char *ptr, + unsigned int size) { return (char *)TclpRealloc(ptr, size); } -void * +char * Tcl_AttemptDbCkrealloc( - void *ptr, - size_t size, + char *ptr, + unsigned int size, TCL_UNUSED(const char *) /*file*/, TCL_UNUSED(int) /*line*/) { @@ -1180,14 +1177,14 @@ Tcl_AttemptDbCkrealloc( void Tcl_Free( - void *ptr) + char *ptr) { TclpFree(ptr); } void Tcl_DbCkfree( - void *ptr, + char *ptr, TCL_UNUSED(const char *) /*file*/, TCL_UNUSED(int) /*line*/) { @@ -1235,148 +1232,6 @@ TclDumpMemoryInfo( #endif /* TCL_MEM_DEBUG */ /* - *------------------------------------------------------------------------ - * - * TclAllocElemsEx -- - * - * See TclAttemptAllocElemsEx. This function differs in that it panics - * on failure. - * - * Results: - * Non-NULL pointer to allocated memory block. - * - * Side effects: - * Panics if memory of at least the requested size could not be - * allocated. - * - *------------------------------------------------------------------------ - */ -void * -TclAllocElemsEx( - Tcl_Size elemCount, /* Allocation will store at least these many... */ - Tcl_Size elemSize, /* ...elements of this size */ - Tcl_Size leadSize, /* Additional leading space in bytes */ - Tcl_Size *capacityPtr) /* OUTPUT: Actual capacity is stored - here if non-NULL. Only modified on success */ -{ - void *ptr = TclAttemptReallocElemsEx( - NULL, elemCount, elemSize, leadSize, capacityPtr); - if (ptr == NULL) { - Tcl_Panic("Failed to allocate %" TCL_SIZE_MODIFIER - "d elements of size %" TCL_SIZE_MODIFIER "d bytes.", - elemCount, - elemSize); - } - return ptr; -} - -/* - *------------------------------------------------------------------------ - * - * TclAttemptReallocElemsEx -- - * - * Attempts to allocate (oldPtr == NULL) or reallocate memory of the - * requested size plus some more for future growth. The amount of - * reallocation is adjusted depending on on failure. - * - * - * Results: - * Pointer to allocated memory block which is at least as large - * as the requested size or NULL if allocation failed. - * - *------------------------------------------------------------------------ - */ -void * -TclAttemptReallocElemsEx( - void *oldPtr, /* Pointer to memory block to reallocate or - * NULL to indicate this is a new allocation */ - Tcl_Size elemCount, /* Allocation will store at least these many... */ - Tcl_Size elemSize, /* ...elements of this size */ - Tcl_Size leadSize, /* Additional leading space in bytes */ - Tcl_Size *capacityPtr) /* OUTPUT: Actual capacity is stored - here if non-NULL. Only modified on success */ -{ - void *ptr; - Tcl_Size limit; - Tcl_Size attempt; - - assert(elemCount > 0); - assert(elemSize > 0); - assert(elemSize < TCL_SIZE_MAX); - assert(leadSize >= 0); - assert(leadSize < TCL_SIZE_MAX); - - limit = (TCL_SIZE_MAX - leadSize) / elemSize; - if (elemCount > limit) { - return NULL; - } - /* Loop trying for extra space, reducing request each time */ - attempt = TclUpsizeAlloc(0, elemCount, limit); - ptr = NULL; - while (attempt > elemCount) { - if (oldPtr) { - ptr = Tcl_AttemptRealloc(oldPtr, leadSize + attempt * elemSize); - } else { - ptr = Tcl_AttemptAlloc(leadSize + attempt * elemSize); - } - if (ptr) { - break; - } - attempt = TclUpsizeRetry(elemCount, attempt); - } - /* Try exact size as a last resort */ - if (ptr == NULL) { - attempt = elemCount; - if (oldPtr) { - ptr = Tcl_AttemptRealloc(oldPtr, leadSize + attempt * elemSize); - } else { - ptr = Tcl_AttemptAlloc(leadSize + attempt * elemSize); - } - } - if (ptr && capacityPtr) { - *capacityPtr = attempt; - } - return ptr; -} - -/* - *------------------------------------------------------------------------ - * - * TclReallocElemsEx -- - * - * See TclAttemptReallocElemsEx. This function differs in that it panics - * on failure. - * - * Results: - * Non-NULL pointer to allocated memory block. - * - * Side effects: - * Panics if memory of at least the requested size could not be - * allocated. - * - *------------------------------------------------------------------------ - */ -void * -TclReallocElemsEx( - void *oldPtr, /* Pointer to memory block to reallocate */ - Tcl_Size elemCount, /* Allocation will store at least these many... */ - Tcl_Size elemSize, /* ...elements of this size */ - Tcl_Size leadSize, /* Additional leading space in bytes */ - Tcl_Size *capacityPtr) /* OUTPUT: Actual capacity is stored - here if non-NULL. Only modified on success */ -{ - void *ptr = TclAttemptReallocElemsEx( - oldPtr, elemCount, elemSize, leadSize, capacityPtr); - if (ptr == NULL) { - Tcl_Panic("Failed to reallocate %" TCL_SIZE_MODIFIER - "d elements of size %" TCL_SIZE_MODIFIER "d bytes.", - elemCount, - elemSize); - } - return ptr; -} - -/* *--------------------------------------------------------------------------- * * TclFinalizeMemorySubsystem -- diff --git a/generic/tclClock.c b/generic/tclClock.c index 2cfa4a5..c0fe59a 100644 --- a/generic/tclClock.c +++ b/generic/tclClock.c @@ -203,9 +203,9 @@ TclClockInit( * Create the client data, which is a refcounted literal pool. */ - data = (ClockClientData *)Tcl_Alloc(sizeof(ClockClientData)); + data = (ClockClientData *)ckalloc(sizeof(ClockClientData)); data->refCount = 0; - data->literals = (Tcl_Obj **)Tcl_Alloc(LIT__END * sizeof(Tcl_Obj*)); + data->literals = (Tcl_Obj **)ckalloc(LIT__END * sizeof(Tcl_Obj*)); for (i = 0; i < LIT__END; ++i) { TclInitObjRef(data->literals[i], Tcl_NewStringObj( Literals[i], TCL_AUTO_LENGTH)); @@ -249,7 +249,7 @@ TclClockInit( memset(&data->lastTZOffsCache, 0, sizeof(data->lastTZOffsCache)); - data->defFlags = CLF_VALIDATE; + data->defFlags = 0; /* * Install the commands. @@ -362,21 +362,21 @@ ClockDeleteCmdProc( for (i = 0; i < MCLIT__END; ++i) { Tcl_DecrRefCount(data->mcLiterals[i]); } - Tcl_Free(data->mcLiterals); + ckfree(data->mcLiterals); data->mcLiterals = NULL; } if (data->mcLitIdxs != NULL) { for (i = 0; i < MCLIT__END; ++i) { Tcl_DecrRefCount(data->mcLitIdxs[i]); } - Tcl_Free(data->mcLitIdxs); + ckfree(data->mcLitIdxs); data->mcLitIdxs = NULL; } ClockConfigureClear(data); - Tcl_Free(data->literals); - Tcl_Free(data); + ckfree(data->literals); + ckfree(data); } } @@ -724,7 +724,7 @@ ClockMCDict( int i; dataPtr->mcLiterals = (Tcl_Obj **) - Tcl_Alloc(MCLIT__END * sizeof(Tcl_Obj*)); + ckalloc(MCLIT__END * sizeof(Tcl_Obj*)); for (i = 0; i < MCLIT__END; ++i) { TclInitObjRef(dataPtr->mcLiterals[i], Tcl_NewStringObj( MsgCtLiterals[i], TCL_AUTO_LENGTH)); @@ -900,7 +900,7 @@ ClockMCSetIdx( if (dataPtr->mcLitIdxs == NULL) { int i; - dataPtr->mcLitIdxs = (Tcl_Obj **)Tcl_Alloc(MCLIT__END * sizeof(Tcl_Obj*)); + dataPtr->mcLitIdxs = (Tcl_Obj **)ckalloc(MCLIT__END * sizeof(Tcl_Obj*)); for (i = 0; i < MCLIT__END; ++i) { TclInitObjRef(dataPtr->mcLitIdxs[i], Tcl_NewStringObj(MsgCtLitIdxs[i], TCL_AUTO_LENGTH)); @@ -4697,15 +4697,15 @@ TzsetIfNecessary(void) || wcscmp(tzNow, tz.was) != 0)) { tzset(); if (tz.was != NULL && tz.was != TZ_INIT_MARKER) { - Tcl_Free(tz.was); + ckfree(tz.was); } - tz.was = (WCHAR *)Tcl_Alloc(sizeof(WCHAR) * (wcslen(tzNow) + 1)); + tz.was = (WCHAR *)ckalloc(sizeof(WCHAR) * (wcslen(tzNow) + 1)); wcscpy(tz.was, tzNow); epoch = ++tz.epoch; } else if (tzNow == NULL && tz.was != NULL) { tzset(); if (tz.was != TZ_INIT_MARKER) { - Tcl_Free(tz.was); + ckfree(tz.was); } tz.was = NULL; epoch = ++tz.epoch; @@ -4724,7 +4724,7 @@ ClockFinalize( ClockFrmScnFinalize(); if (tz.was && tz.was != TZ_INIT_MARKER) { - Tcl_Free(tz.was); + ckfree(tz.was); } Tcl_MutexFinalize(&clockMutex); diff --git a/generic/tclClockFmt.c b/generic/tclClockFmt.c index 140ecdd..154c8ee 100644 --- a/generic/tclClockFmt.c +++ b/generic/tclClockFmt.c @@ -557,7 +557,7 @@ ClockFmtScnStorageAllocProc( allocsize -= sizeof(hPtr->key); } - fss = (ClockFmtScnStorage *)Tcl_Alloc(allocsize); + fss = (ClockFmtScnStorage *)ckalloc(allocsize); /* initialize */ memset(fss, 0, sizeof(*fss)); @@ -589,17 +589,17 @@ ClockFmtScnStorageFreeProc( ClockFmtScnStorage *fss = FmtScn4HashEntry(hPtr); if (fss->scnTok != NULL) { - Tcl_Free(fss->scnTok); + ckfree(fss->scnTok); fss->scnTok = NULL; fss->scnTokC = 0; } if (fss->fmtTok != NULL) { - Tcl_Free(fss->fmtTok); + ckfree(fss->fmtTok); fss->fmtTok = NULL; fss->fmtTokC = 0; } - Tcl_Free(fss); + ckfree(fss); } /* @@ -636,8 +636,7 @@ static const Tcl_ObjType ClockFmtObjType = { ClockFmtObj_FreeInternalRep, /* freeIntRepProc */ ClockFmtObj_DupInternalRep, /* dupIntRepProc */ ClockFmtObj_UpdateString, /* updateStringProc */ - ClockFmtObj_SetFromAny, /* setFromAnyProc */ - TCL_OBJTYPE_V0 + ClockFmtObj_SetFromAny /* setFromAnyProc */ }; #define ObjClockFmtScn(objPtr) \ @@ -670,7 +669,7 @@ ClockFmtObj_DupInternalRep( /* if no format representation, dup string representation */ if (fss == NULL) { - copyPtr->bytes = (char *)Tcl_Alloc(srcPtr->length + 1); + copyPtr->bytes = (char *)ckalloc(srcPtr->length + 1); memcpy(copyPtr->bytes, srcPtr->bytes, srcPtr->length + 1); copyPtr->length = srcPtr->length; } @@ -737,7 +736,7 @@ ClockFmtObj_UpdateString( } len = strlen(name); objPtr->length = len++, - objPtr->bytes = (char *)Tcl_AttemptAlloc(len); + objPtr->bytes = (char *)attemptckalloc(len); if (objPtr->bytes) { memcpy(objPtr->bytes, name, len); } @@ -2142,7 +2141,7 @@ EstimateTokenCount( #define AllocTokenInChain(tok, chain, tokCnt, type) \ if (++(tok) >= (chain) + (tokCnt)) { \ - chain = (type)Tcl_AttemptRealloc((char *)(chain), \ + chain = (type)attemptckrealloc((char *)(chain), \ (tokCnt + CLOCK_MIN_TOK_CHAIN_BLOCK_SIZE) * sizeof(*(tok))); \ if ((chain) == NULL) { \ goto done; \ @@ -2188,7 +2187,7 @@ ClockGetOrParseScanFormat( fss->scnSpaceCount = 0; - scnTok = tok = (ClockScanToken *)Tcl_Alloc(sizeof(*tok) * fss->scnTokC); + scnTok = tok = (ClockScanToken *)ckalloc(sizeof(*tok) * fss->scnTokC); memset(tok, 0, sizeof(*tok)); tokCnt = 1; while (p < e) { @@ -2340,7 +2339,7 @@ ClockGetOrParseScanFormat( * (1 is acceptable delta to prevent memory fragmentation) */ if (fss->scnTokC > tokCnt + (CLOCK_MIN_TOK_CHAIN_BLOCK_SIZE / 2)) { if ((tok = (ClockScanToken *) - Tcl_AttemptRealloc(scnTok, tokCnt * sizeof(*tok))) != NULL) { + attemptckrealloc(scnTok, tokCnt * sizeof(*tok))) != NULL) { scnTok = tok; } } @@ -2731,13 +2730,13 @@ FrmResultAllocate( char *newRes; /* differentiate between stack and memory */ if (!FrmResultIsAllocated(dateFmt)) { - newRes = (char *)Tcl_AttemptAlloc(newsize); + newRes = (char *)attemptckalloc(newsize); if (newRes == NULL) { return TCL_ERROR; } memcpy(newRes, dateFmt->resMem, dateFmt->output - dateFmt->resMem); } else { - newRes = (char *)Tcl_AttemptRealloc(dateFmt->resMem, newsize); + newRes = (char *)attemptckrealloc(dateFmt->resMem, newsize); if (newRes == NULL) { return TCL_ERROR; } @@ -3263,7 +3262,7 @@ ClockGetOrParseFmtFormat( /* estimate token count by % char and format length */ fss->fmtTokC = EstimateTokenCount(p, e); - fmtTok = tok = (ClockFormatToken *)Tcl_Alloc(sizeof(*tok) * fss->fmtTokC); + fmtTok = tok = (ClockFormatToken *)ckalloc(sizeof(*tok) * fss->fmtTokC); memset(tok, 0, sizeof(*tok)); tokCnt = 1; while (p < e) { @@ -3358,7 +3357,7 @@ ClockGetOrParseFmtFormat( * (1 is acceptable delta to prevent memory fragmentation) */ if (fss->fmtTokC > tokCnt + (CLOCK_MIN_TOK_CHAIN_BLOCK_SIZE / 2)) { if ((tok = (ClockFormatToken *) - Tcl_AttemptRealloc(fmtTok, tokCnt * sizeof(*tok))) != NULL) { + attemptckrealloc(fmtTok, tokCnt * sizeof(*tok))) != NULL) { fmtTok = tok; } } @@ -3399,7 +3398,7 @@ ClockFormat( dateFmt->resMem = resMem; dateFmt->resEnd = dateFmt->resMem + sizeof(resMem); if (fss->fmtMinAlloc > sizeof(resMem)) { - dateFmt->resMem = (char *)Tcl_AttemptAlloc(fss->fmtMinAlloc); + dateFmt->resMem = (char *)attemptckalloc(fss->fmtMinAlloc); if (dateFmt->resMem == NULL) { return TCL_ERROR; } @@ -3511,7 +3510,7 @@ ClockFormat( error: if (dateFmt->resMem != resMem) { - Tcl_Free(dateFmt->resMem); + ckfree(dateFmt->resMem); } dateFmt->resMem = NULL; @@ -3524,13 +3523,13 @@ ClockFormat( result->length = dateFmt->output - dateFmt->resMem; size = result->length + 1; if (dateFmt->resMem == resMem) { - result->bytes = (char *)Tcl_AttemptAlloc(size); + result->bytes = (char *)attemptckalloc(size); if (result->bytes == NULL) { return TCL_ERROR; } memcpy(result->bytes, dateFmt->resMem, size); } else if ((dateFmt->resEnd - dateFmt->resMem) / size > MAX_FMT_RESULT_THRESHOLD) { - result->bytes = (char *)Tcl_AttemptRealloc(dateFmt->resMem, size); + result->bytes = (char *)attemptckrealloc(dateFmt->resMem, size); if (result->bytes == NULL) { result->bytes = dateFmt->resMem; } diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 288271b..6a87582 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.c @@ -13,7 +13,6 @@ #include "tclInt.h" #include "tclIO.h" -#include "tclTomMath.h" #ifdef _WIN32 # include "tclWinInt.h" #endif @@ -62,7 +61,7 @@ static int GetStatBuf(Tcl_Interp *interp, Tcl_Obj *pathPtr, static const char * GetTypeFromMode(int mode); static int StoreStatData(Tcl_Interp *interp, Tcl_Obj *varName, Tcl_StatBuf *statPtr); -static int EachloopCmd(Tcl_Interp *interp, int collect, +static int EachloopCmd(Tcl_Interp *interp, int collect, int objc, Tcl_Obj *const objv[]); static Tcl_NRPostProc CatchObjCmdCallback; static Tcl_NRPostProc ExprCallback; @@ -137,6 +136,142 @@ Tcl_BreakObjCmd( /* *---------------------------------------------------------------------- * + * Tcl_CaseObjCmd -- + * + * This procedure is invoked to process the "case" Tcl command. See the + * user documentation for details on what it does. THIS COMMAND IS + * OBSOLETE AND DEPRECATED. SLATED FOR REMOVAL IN TCL 9.0. + * + * Results: + * A standard Tcl object result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 +int +Tcl_CaseObjCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int i; + int body, result, caseObjc; + const char *stringPtr, *arg; + Tcl_Obj *const *caseObjv; + Tcl_Obj *armPtr; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, + "string ?in? ?pattern body ...? ?default body?"); + return TCL_ERROR; + } + + stringPtr = TclGetString(objv[1]); + body = -1; + + arg = TclGetString(objv[2]); + if (strcmp(arg, "in") == 0) { + i = 3; + } else { + i = 2; + } + caseObjc = objc - i; + caseObjv = objv + i; + + /* + * If all of the pattern/command pairs are lumped into a single argument, + * split them out again. + */ + + if (caseObjc == 1) { + Tcl_Obj **newObjv; + + TclListObjGetElements(interp, caseObjv[0], &caseObjc, &newObjv); + caseObjv = newObjv; + } + + for (i = 0; i < caseObjc; i += 2) { + int patObjc, j; + const char **patObjv; + const char *pat, *p; + + if (i == caseObjc-1) { + Tcl_ResetResult(interp); + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "extra case pattern with no body", -1)); + return TCL_ERROR; + } + + /* + * Check for special case of single pattern (no list) with no + * backslash sequences. + */ + + pat = TclGetString(caseObjv[i]); + for (p = pat; *p != '\0'; p++) { + if (TclIsSpaceProcM(*p) || (*p == '\\')) { + break; + } + } + if (*p == '\0') { + if ((*pat == 'd') && (strcmp(pat, "default") == 0)) { + body = i + 1; + } + if (Tcl_StringMatch(stringPtr, pat)) { + body = i + 1; + goto match; + } + continue; + } + + /* + * Break up pattern lists, then check each of the patterns in the + * list. + */ + + result = Tcl_SplitList(interp, pat, &patObjc, &patObjv); + if (result != TCL_OK) { + return result; + } + for (j = 0; j < patObjc; j++) { + if (Tcl_StringMatch(stringPtr, patObjv[j])) { + body = i + 1; + break; + } + } + ckfree(patObjv); + if (j < patObjc) { + break; + } + } + + match: + if (body != -1) { + armPtr = caseObjv[body - 1]; + result = Tcl_EvalObjEx(interp, caseObjv[body], 0); + if (result == TCL_ERROR) { + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (\"%.50s\" arm line %d)", + TclGetString(armPtr), Tcl_GetErrorLine(interp))); + } + return result; + } + + /* + * Nothing matched: return nothing. + */ + + return TCL_OK; +} +#endif /* !TCL_NO_DEPRECATED */ + +/* + *---------------------------------------------------------------------- + * * Tcl_CatchObjCmd -- * * This object-based procedure is invoked to process the "catch" Tcl @@ -274,21 +409,13 @@ Tcl_CdObjCmd( if (objc == 2) { dir = objv[1]; } else { - dir = TclGetHomeDirObj(interp, NULL); - if (dir == NULL) { - return TCL_ERROR; - } + TclNewLiteralStringObj(dir, "~"); Tcl_IncrRefCount(dir); } if (Tcl_FSConvertToPathType(interp, dir) != TCL_OK) { result = TCL_ERROR; } else { - Tcl_DString ds; - result = Tcl_UtfToExternalDStringEx(NULL, TCLFSENCODING, TclGetString(dir), -1, 0, &ds, NULL); - Tcl_DStringFree(&ds); - if (result == TCL_OK) { - result = Tcl_FSChdir(dir); - } + result = Tcl_FSChdir(dir); if (result != TCL_OK) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't change working directory to \"%s\": %s", @@ -424,7 +551,7 @@ TclInitEncodingCmd( *------------------------------------------------------------------------ */ static int -EncodingConvertParseOptions( +EncodingConvertParseOptions ( Tcl_Interp *interp, /* For error messages. May be NULL */ int objc, /* Number of arguments */ Tcl_Obj *const objv[], /* Argument objects as passed to command. */ @@ -439,7 +566,7 @@ EncodingConvertParseOptions( Tcl_Encoding encoding; Tcl_Obj *dataObj; Tcl_Obj *failVarObj; - int profile = TCL_ENCODING_PROFILE_STRICT; + int profile = TCL_ENCODING_PROFILE_TCL8; /* * Possible combinations: @@ -452,9 +579,11 @@ EncodingConvertParseOptions( */ if (objc == 1) { - numArgsError: /* ONLY jump here if nothing needs to be freed!!! */ - Tcl_WrongNumArgs(interp, 1, objv, - "?-profile profile? ?-failindex var? encoding data"); +numArgsError: /* ONLY jump here if nothing needs to be freed!!! */ + Tcl_WrongNumArgs(interp, + 1, + objv, + "?-profile profile? ?-failindex var? encoding data"); ((Interp *)interp)->flags |= INTERP_ALTERNATE_WRONG_ARGS; Tcl_WrongNumArgs(interp, 1, objv, "data"); return TCL_ERROR; @@ -467,8 +596,9 @@ EncodingConvertParseOptions( } else { int argIndex; for (argIndex = 1; argIndex < (objc-2); ++argIndex) { - if (Tcl_GetIndexFromObj(interp, objv[argIndex], options, "option", - 0, &optIndex) != TCL_OK) { + if (Tcl_GetIndexFromObj( + interp, objv[argIndex], options, "option", 0, &optIndex) + != TCL_OK) { return TCL_ERROR; } if (++argIndex == (objc - 2)) { @@ -477,7 +607,8 @@ EncodingConvertParseOptions( switch (optIndex) { case PROFILE: if (TclEncodingProfileNameToId(interp, - Tcl_GetString(objv[argIndex]), &profile) != TCL_OK) { + TclGetString(objv[argIndex]), + &profile) != TCL_OK) { return TCL_ERROR; } break; @@ -487,7 +618,8 @@ EncodingConvertParseOptions( } } /* Get encoding after opts so no need to free it on option error */ - if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) != TCL_OK) { + if (Tcl_GetEncodingFromObj(interp, objv[objc - 2], &encoding) + != TCL_OK) { return TCL_ERROR; } dataObj = objv[objc - 1]; @@ -525,28 +657,35 @@ EncodingConvertfromObjCmd( Tcl_Obj *data; /* Byte array to convert */ Tcl_DString ds; /* Buffer to hold the string */ Tcl_Encoding encoding; /* Encoding to use */ - Tcl_Size length = 0; /* Length of the byte array being converted */ + Tcl_Size length; /* Length of the byte array being converted */ const char *bytesPtr; /* Pointer to the first byte of the array */ int flags; int result; Tcl_Obj *failVarObj; Tcl_Size errorLocation; - if (EncodingConvertParseOptions(interp, objc, objv, &encoding, &data, - &flags, &failVarObj) != TCL_OK) { + if (EncodingConvertParseOptions( + interp, objc, objv, &encoding, &data, &flags, &failVarObj) + != TCL_OK) { return TCL_ERROR; } /* * Convert the string into a byte array in 'ds'. */ - bytesPtr = (char *) Tcl_GetBytesFromObj(interp, data, &length); +#if !defined(TCL_NO_DEPRECATED) + if (ENCODING_PROFILE_GET(flags) == TCL_ENCODING_PROFILE_TCL8) { + /* Permits high bits to be non-0 in byte array (Tcl 8 style) */ + bytesPtr = (char *) Tcl_GetByteArrayFromObj(data, &length); + } else +#endif + bytesPtr = (char *) Tcl_GetBytesFromObj(interp, data, &length); if (bytesPtr == NULL) { return TCL_ERROR; } result = Tcl_ExternalToUtfDStringEx(interp, encoding, bytesPtr, length, flags, - &ds, failVarObj ? &errorLocation : NULL); + &ds, failVarObj ? &errorLocation : NULL); /* NOTE: ds must be freed beyond this point even on error */ switch (result) { case TCL_OK: @@ -577,8 +716,11 @@ EncodingConvertfromObjCmd( if (failVarObj) { Tcl_Obj *failIndex; TclNewIndexObj(failIndex, errorLocation); - if (Tcl_ObjSetVar2(interp, failVarObj, NULL, failIndex, - TCL_LEAVE_ERR_MSG) == NULL) { + if (Tcl_ObjSetVar2(interp, + failVarObj, + NULL, + failIndex, + TCL_LEAVE_ERR_MSG) == NULL) { Tcl_DStringFree(&ds); return TCL_ERROR; } @@ -621,15 +763,16 @@ EncodingConverttoObjCmd( Tcl_Obj *data; /* String to convert */ Tcl_DString ds; /* Buffer to hold the byte array */ Tcl_Encoding encoding; /* Encoding to use */ - Tcl_Size length; /* Length of the string being converted */ + Tcl_Size length; /* Length of the string being converted */ const char *stringPtr; /* Pointer to the first byte of the string */ int result; int flags; Tcl_Obj *failVarObj; Tcl_Size errorLocation; - if (EncodingConvertParseOptions(interp, objc, objv, &encoding, &data, - &flags, &failVarObj) != TCL_OK) { + if (EncodingConvertParseOptions( + interp, objc, objv, &encoding, &data, &flags, &failVarObj) + != TCL_OK) { return TCL_ERROR; } @@ -639,7 +782,7 @@ EncodingConverttoObjCmd( stringPtr = TclGetStringFromObj(data, &length); result = Tcl_UtfToExternalDStringEx(interp, encoding, stringPtr, length, flags, - &ds, failVarObj ? &errorLocation : NULL); + &ds, failVarObj ? &errorLocation : NULL); /* NOTE: ds must be freed beyond this point even on error */ switch (result) { @@ -669,18 +812,20 @@ EncodingConverttoObjCmd( */ if (failVarObj) { Tcl_Obj *failIndex; - TclNewIndexObj(failIndex, errorLocation); - if (Tcl_ObjSetVar2(interp, failVarObj, NULL, failIndex, - TCL_LEAVE_ERR_MSG) == NULL) { + if (Tcl_ObjSetVar2(interp, + failVarObj, + NULL, + failIndex, + TCL_LEAVE_ERR_MSG) == NULL) { Tcl_DStringFree(&ds); return TCL_ERROR; } } - Tcl_SetObjResult(interp, Tcl_NewByteArrayObj( - (unsigned char*) Tcl_DStringValue(&ds), - Tcl_DStringLength(&ds))); + Tcl_SetObjResult(interp, + Tcl_NewByteArrayObj((unsigned char*) Tcl_DStringValue(&ds), + Tcl_DStringLength(&ds))); Tcl_DStringFree(&ds); /* We're done with the encoding */ @@ -822,7 +967,7 @@ EncodingSystemObjCmd( } if (objc == 1) { Tcl_SetObjResult(interp, - Tcl_NewStringObj(Tcl_GetEncodingName(NULL), -1)); + Tcl_NewStringObj(Tcl_GetEncodingName(NULL), -1)); } else { return Tcl_SetSystemEncoding(interp, TclGetString(objv[1])); } @@ -1193,8 +1338,8 @@ FileAttrAccessTimeCmd( /* We use a value of 0 to indicate the access time not available */ if (Tcl_GetAccessTimeFromStat(&buf) == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "could not get access time for file \"%s\"", - TclGetString(objv[1]))); + "could not get access time for file \"%s\"", + TclGetString(objv[1]))); return TCL_ERROR; } #endif @@ -1275,8 +1420,8 @@ FileAttrModifyTimeCmd( /* We use a value of 0 to indicate the modification time not available */ if (Tcl_GetModificationTimeFromStat(&buf) == 0) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "could not get modification time for file \"%s\"", - TclGetString(objv[1]))); + "could not get modification time for file \"%s\"", + TclGetString(objv[1]))); return TCL_ERROR; } #endif @@ -2242,16 +2387,10 @@ CheckAccess( * access(). */ { int value; - Tcl_DString ds; if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) { value = 0; - } else if (Tcl_UtfToExternalDStringEx(NULL, TCLFSENCODING, TclGetString(pathPtr), - TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { - value = 0; - Tcl_DStringFree(&ds); } else { - Tcl_DStringFree(&ds); value = (Tcl_FSAccess(pathPtr, mode) == 0); } Tcl_SetObjResult(interp, Tcl_NewBooleanObj(value)); @@ -2289,19 +2428,12 @@ GetStatBuf( * calling (*statProc)(). */ { int status; - Tcl_DString ds; if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) { return TCL_ERROR; } - if (Tcl_UtfToExternalDStringEx(NULL, TCLFSENCODING, TclGetString(pathPtr), - TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { - status = -1; - } else { - status = statProc(pathPtr, statPtr); - } - Tcl_DStringFree(&ds); + status = statProc(pathPtr, statPtr); if (status < 0) { if (interp != NULL) { @@ -2376,6 +2508,8 @@ StoreStatData( } /* + * Assume Tcl_ObjSetVar2() does not keep a copy of the field name! + * * Might be a better idea to call Tcl_SetVar2Ex() instead, except we want * to have an object (i.e. possibly cached) array variable name but a * string element name, so no API exists. Messy. @@ -2808,7 +2942,9 @@ EachloopCmd( for (i=0 ; i<numLists ; i++) { /* List */ /* Variables */ - statePtr->vCopyList[i] = TclListObjCopy(interp, objv[1+i*2]); + + /* Do not use TclListObjCopy here - shimmers arithseries to list */ + statePtr->vCopyList[i] = Tcl_DuplicateObj(objv[1+i*2]); if (statePtr->vCopyList[i] == NULL) { result = TCL_ERROR; goto done; @@ -2833,15 +2969,15 @@ EachloopCmd( &statePtr->varcList[i], &statePtr->varvList[i]); /* Values */ - if (TclObjTypeHasProc(objv[2+i*2],indexProc)) { - /* Special case for AbstractList */ + if (TclHasInternalRep(objv[2+i*2],&tclArithSeriesType)) { + /* Special case for Arith Series */ statePtr->aCopyList[i] = Tcl_DuplicateObj(objv[2+i*2]); if (statePtr->aCopyList[i] == NULL) { result = TCL_ERROR; goto done; } /* Don't compute values here, wait until the last moment */ - statePtr->argcList[i] = TclObjTypeLength(statePtr->aCopyList[i]); + statePtr->argcList[i] = TclArithSeriesObjLength(statePtr->aCopyList[i]); } else { /* List values */ statePtr->aCopyList[i] = TclListObjCopy(interp, objv[2+i*2]); @@ -2915,12 +3051,8 @@ ForeachLoopStep( break; case TCL_OK: if (statePtr->resultList != NULL) { - result = Tcl_ListObjAppendElement( - interp, statePtr->resultList, Tcl_GetObjResult(interp)); - if (result != TCL_OK) { - /* e.g. memory alloc failure on big data tests */ - goto done; - } + Tcl_ListObjAppendElement(interp, statePtr->resultList, + Tcl_GetObjResult(interp)); } break; case TCL_BREAK: @@ -2982,14 +3114,13 @@ ForeachAssignments( Tcl_Obj *valuePtr, *varValuePtr; for (i=0 ; i<statePtr->numLists ; i++) { - int isAbstractList = - TclObjTypeHasProc(statePtr->aCopyList[i],indexProc) != NULL; - + int isarithseries = TclHasInternalRep(statePtr->aCopyList[i],&tclArithSeriesType); for (v=0 ; v<statePtr->varcList[i] ; v++) { k = statePtr->index[i]++; if (k < statePtr->argcList[i]) { - if (isAbstractList) { - if (TclObjTypeIndex(interp, statePtr->aCopyList[i], k, &valuePtr) != TCL_OK) { + if (isarithseries) { + valuePtr = TclArithSeriesObjIndex(interp, statePtr->aCopyList[i], k); + if (valuePtr == NULL) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (setting %s loop variable \"%s\")", (statePtr->resultList != NULL ? "lmap" : "foreach"), diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index c46ab60..d3d0efc 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -38,7 +38,7 @@ typedef struct SortElement { } collationKey; union { /* Object being sorted, or its index. */ Tcl_Obj *objPtr; - size_t index; + Tcl_Size index; } payload; struct SortElement *nextPtr;/* Next element in the list, or NULL for end * of list. */ @@ -50,7 +50,6 @@ typedef struct SortElement { */ typedef int (*SortStrCmpFn_t) (const char *, const char *); -typedef int (*SortMemCmpFn_t) (const void *, const void *, Tcl_Size); /* * The "lsort" command needs to pass certain information down to the function @@ -160,8 +159,6 @@ static const EnsembleImplMap defaultInfoMap[] = { {"cmdtype", InfoCmdTypeCmd, TclCompileBasic1ArgCmd, NULL, NULL, 1}, {"commands", InfoCommandsCmd, TclCompileInfoCommandsCmd, NULL, NULL, 0}, {"complete", InfoCompleteCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"constant", TclInfoConstantCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, - {"consts", TclInfoConstsCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, {"coroutine", TclInfoCoroutineCmd, TclCompileInfoCoroutineCmd, NULL, NULL, 0}, {"default", InfoDefaultCmd, TclCompileBasic3ArgCmd, NULL, NULL, 0}, {"errorstack", InfoErrorStackCmd, TclCompileBasic0Or1ArgCmd, NULL, NULL, 0}, @@ -992,8 +989,8 @@ InfoDefaultCmd( Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1)); } else { Tcl_Obj *nullObjPtr; - TclNewObj(nullObjPtr); + TclNewObj(nullObjPtr); valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL, nullObjPtr, TCL_LEAVE_ERR_MSG); if (valueObjPtr == NULL) { @@ -1587,7 +1584,7 @@ InfoLevelCmd( Interp *iPtr = (Interp *) interp; if (objc == 1) { /* Just "info level" */ - Tcl_SetObjResult(interp, Tcl_NewWideIntObj((int)iPtr->varFramePtr->level)); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(iPtr->varFramePtr->level)); return TCL_OK; } @@ -1606,7 +1603,7 @@ InfoLevelCmd( } for (framePtr=iPtr->varFramePtr ; framePtr!=rootFramePtr; framePtr=framePtr->callerVarPtr) { - if ((int)framePtr->level == level) { + if (framePtr->level == level) { break; } } @@ -1839,6 +1836,9 @@ InfoProcsCmd( const char *cmdName, *pattern; const char *simplePattern; Namespace *nsPtr; +#ifdef INFO_PROCS_SEARCH_GLOBAL_NS + Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); +#endif Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); Tcl_Obj *listPtr, *elemObjPtr; int specificNsInPattern = 0;/* Init. to avoid compiler warning. */ @@ -1890,6 +1890,7 @@ InfoProcsCmd( */ listPtr = Tcl_NewListObj(0, NULL); +#ifndef INFO_PROCS_SEARCH_GLOBAL_NS if (simplePattern != NULL && TclMatchIsTrivial(simplePattern)) { entryPtr = Tcl_FindHashEntry(&nsPtr->cmdTable, simplePattern); if (entryPtr != NULL) { @@ -1913,7 +1914,9 @@ InfoProcsCmd( Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); } } - } else { + } else +#endif /* !INFO_PROCS_SEARCH_GLOBAL_NS */ + { entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); while (entryPtr != NULL) { cmdName = (const char *)Tcl_GetHashKey(&nsPtr->cmdTable, entryPtr); @@ -1923,7 +1926,7 @@ InfoProcsCmd( if (!TclIsProc(cmdPtr)) { realCmdPtr = (Command *) - TclGetOriginalCommand((Tcl_Command) cmdPtr); + TclGetOriginalCommand((Tcl_Command)cmdPtr); if (realCmdPtr != NULL && TclIsProc(realCmdPtr)) { goto procOK; } @@ -1931,7 +1934,7 @@ InfoProcsCmd( procOK: if (specificNsInPattern) { TclNewObj(elemObjPtr); - Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, + Tcl_GetCommandFullName(interp, (Tcl_Command)cmdPtr, elemObjPtr); } else { elemObjPtr = Tcl_NewStringObj(cmdName, -1); @@ -1941,6 +1944,46 @@ InfoProcsCmd( } entryPtr = Tcl_NextHashEntry(&search); } + + /* + * If the effective namespace isn't the global :: namespace, and a + * specific namespace wasn't requested in the pattern, then add in all + * global :: procs that match the simple pattern. Of course, we add in + * only those procs that aren't hidden by a proc in the effective + * namespace. + */ + +#ifdef INFO_PROCS_SEARCH_GLOBAL_NS + /* + * If "info procs" worked like "info commands", returning the commands + * also seen in the global namespace, then you would include this + * code. As this could break backwards compatibility with 8.0-8.2, we + * decided not to "fix" it in 8.3, leaving the behavior slightly + * different. + */ + + if ((nsPtr != globalNsPtr) && !specificNsInPattern) { + entryPtr = Tcl_FirstHashEntry(&globalNsPtr->cmdTable, &search); + while (entryPtr != NULL) { + cmdName = (const char *)Tcl_GetHashKey(&globalNsPtr->cmdTable, entryPtr); + if ((simplePattern == NULL) + || Tcl_StringMatch(cmdName, simplePattern)) { + if (Tcl_FindHashEntry(&nsPtr->cmdTable,cmdName) == NULL) { + cmdPtr = (Command *)Tcl_GetHashValue(entryPtr); + realCmdPtr = (Command *) TclGetOriginalCommand( + (Tcl_Command) cmdPtr); + + if (TclIsProc(cmdPtr) || ((realCmdPtr != NULL) + && TclIsProc(realCmdPtr))) { + Tcl_ListObjAppendElement(interp, listPtr, + Tcl_NewStringObj(cmdName, -1)); + } + } + } + entryPtr = Tcl_NextHashEntry(&search); + } + } +#endif } Tcl_SetObjResult(interp, listPtr); @@ -2119,7 +2162,7 @@ InfoCmdTypeCmd( } /* - * There's one special case: safe child interpreters can't see aliases as + * There's one special case: safe interpreters can't see aliases as * aliases as they're part of the security mechanisms. */ @@ -2158,7 +2201,7 @@ Tcl_JoinObjCmd( Tcl_Obj *const objv[]) /* The argument objects. */ { Tcl_Size length, listLen; - int isAbstractList = 0; + int isArithSeries = 0; Tcl_Obj *resObjPtr = NULL, *joinObjPtr, **elemPtrs; if ((objc < 2) || (objc > 3)) { @@ -2171,16 +2214,14 @@ Tcl_JoinObjCmd( * pointer to its array of element pointers. */ - if (TclObjTypeHasProc(objv[1], getElementsProc)) { - listLen = TclObjTypeLength(objv[1]); - isAbstractList = (listLen ? 1 : 0); - if (listLen > 1 && TclObjTypeGetElements(interp, objv[1], - &listLen, &elemPtrs) != TCL_OK) { + if (TclHasInternalRep(objv[1],&tclArithSeriesType)) { + isArithSeries = 1; + listLen = TclArithSeriesObjLength(objv[1]); + } else { + if (TclListObjGetElements(interp, objv[1], &listLen, + &elemPtrs) != TCL_OK) { return TCL_ERROR; } - } else if (TclListObjGetElements(interp, objv[1], &listLen, - &elemPtrs) != TCL_OK) { - return TCL_ERROR; } if (listLen == 0) { @@ -2189,15 +2230,14 @@ Tcl_JoinObjCmd( } if (listLen == 1) { /* One element; return it */ - if (!isAbstractList) { - Tcl_SetObjResult(interp, elemPtrs[0]); - } else { - Tcl_Obj *elemObj; - - if (TclObjTypeIndex(interp, objv[1], 0, &elemObj) != TCL_OK) { + if (isArithSeries) { + Tcl_Obj *valueObj = TclArithSeriesObjIndex(interp, objv[1], 0); + if (valueObj == NULL) { return TCL_ERROR; } - Tcl_SetObjResult(interp, elemObj); + Tcl_SetObjResult(interp, valueObj); + } else { + Tcl_SetObjResult(interp, elemPtrs[0]); } return TCL_OK; } @@ -2205,26 +2245,49 @@ Tcl_JoinObjCmd( joinObjPtr = (objc == 2) ? Tcl_NewStringObj(" ", 1) : objv[2]; Tcl_IncrRefCount(joinObjPtr); - (void)TclGetStringFromObj(joinObjPtr, &length); + (void) TclGetStringFromObj(joinObjPtr, &length); if (length == 0) { resObjPtr = TclStringCat(interp, listLen, elemPtrs, 0); } else { Tcl_Size i; TclNewObj(resObjPtr); - for (i = 0; i < listLen; i++) { - if (i > 0) { + if (isArithSeries) { + Tcl_Obj *valueObj; + 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); + } + valueObj = TclArithSeriesObjIndex(interp, objv[1], i); + if (valueObj == NULL) { + return TCL_ERROR; + } + Tcl_AppendObjToObj(resObjPtr, valueObj); + Tcl_DecrRefCount(valueObj); + } + } else { + for (i = 0; i < listLen; i++) { + if (i > 0) { - /* - * NOTE: This code is relying on Tcl_AppendObjToObj() **NOT** - * to shimmer joinObjPtr. If it did, then the case where - * objv[1] and objv[2] are the same value would not be safe. - * Accessing elemPtrs would crash. - */ + /* + * NOTE: This code is relying on Tcl_AppendObjToObj() **NOT** + * to shimmer joinObjPtr. If it did, then the case where + * objv[1] and objv[2] are the same value would not be safe. + * Accessing elemPtrs would crash. + */ - Tcl_AppendObjToObj(resObjPtr, joinObjPtr); + Tcl_AppendObjToObj(resObjPtr, joinObjPtr); + } + Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]); } - Tcl_AppendObjToObj(resObjPtr, elemPtrs[i]); } } Tcl_DecrRefCount(joinObjPtr); @@ -2259,94 +2322,65 @@ Tcl_LassignObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Obj *listPtr; + Tcl_Obj *listCopyPtr; + Tcl_Obj **listObjv; /* The contents of the list. */ Tcl_Size listObjc; /* The length of the list. */ Tcl_Size origListObjc; /* Original length */ - int i; + int code = TCL_OK; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "list ?varName ...?"); return TCL_ERROR; } - /* - * Note: no need to Dup the list to avoid shimmering. That is only - * needed when Tcl_ListObjGetElements is used since that returns - * pointers to internal structures. Using Tcl_ListObjIndex does not - * have that problem. However, we now have to IncrRef each elemObj - * (see below). I see that as preferable as duping lists is potentially - * expensive for abstract lists when they have a string representation. - */ - listPtr = objv[1]; - - if (TclListObjLength(interp, listPtr, &listObjc) != TCL_OK) { + listCopyPtr = TclListObjCopy(interp, objv[1]); + if (listCopyPtr == NULL) { return TCL_ERROR; } + Tcl_IncrRefCount(listCopyPtr); /* Important! fs */ + + TclListObjGetElements(NULL, listCopyPtr, &listObjc, &listObjv); origListObjc = listObjc; objc -= 2; objv += 2; - for (i = 0; i < objc && i < listObjc; ++i) { - Tcl_Obj *elemObj; - - if (Tcl_ListObjIndex(interp, listPtr, i, &elemObj) != TCL_OK) { - return TCL_ERROR; - } - /* - * Must incrref elemObj. If the var name being set is same as the - * the list value, ObjSetVar2 will shimmer the list to a VAR freeing - * the elements in the list (in case list refCount was 1) BEFORE - * the elemObj is stored in the var. See tests 6.{25,26} - */ - Tcl_IncrRefCount(elemObj); - if (Tcl_ObjSetVar2(interp, *objv++, NULL, elemObj, + while (code == TCL_OK && objc > 0 && listObjc > 0) { + if (Tcl_ObjSetVar2(interp, *objv++, NULL, *listObjv++, TCL_LEAVE_ERR_MSG) == NULL) { - Tcl_DecrRefCount(elemObj); - return TCL_ERROR; + code = TCL_ERROR; } - Tcl_DecrRefCount(elemObj); + objc--; + listObjc--; } - objc -= i; - listObjc -= i; - if (objc > 0) { - /* Still some variables left to be assigned */ + if (code == TCL_OK && objc > 0) { Tcl_Obj *emptyObj; TclNewObj(emptyObj); Tcl_IncrRefCount(emptyObj); - while (objc-- > 0) { + while (code == TCL_OK && objc-- > 0) { if (Tcl_ObjSetVar2(interp, *objv++, NULL, emptyObj, TCL_LEAVE_ERR_MSG) == NULL) { - Tcl_DecrRefCount(emptyObj); - return TCL_ERROR; + code = TCL_ERROR; } } Tcl_DecrRefCount(emptyObj); } - if (listObjc > 0) { - Tcl_Obj *resultObjPtr = NULL; - Tcl_Size fromIdx = origListObjc - listObjc; - Tcl_Size toIdx = origListObjc - 1; - if (TclObjTypeHasProc(listPtr, sliceProc)) { - if (TclObjTypeSlice( - interp, listPtr, fromIdx, toIdx, &resultObjPtr) != TCL_OK) { - return TCL_ERROR; - } + if (code == TCL_OK && listObjc > 0) { + Tcl_Obj *resultObjPtr = TclListObjRange( + interp, listCopyPtr, origListObjc - listObjc, origListObjc - 1); + if (resultObjPtr == NULL) { + code = TCL_ERROR; } else { - resultObjPtr = TclListObjRange( - interp, listPtr, origListObjc - listObjc, origListObjc - 1); - if (resultObjPtr == NULL) { - return TCL_ERROR; - } + Tcl_SetObjResult(interp, resultObjPtr); } - Tcl_SetObjResult(interp, resultObjPtr); } - return TCL_OK; + Tcl_DecrRefCount(listCopyPtr); + return code; } - + /* *---------------------------------------------------------------------- * @@ -2431,7 +2465,7 @@ Tcl_LinsertObjCmd( { Tcl_Obj *listPtr; Tcl_Size len, index; - int copied = 0, result; + int result; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "list index ?element ...?"); @@ -2465,7 +2499,6 @@ Tcl_LinsertObjCmd( listPtr = objv[1]; if (Tcl_IsShared(listPtr)) { listPtr = TclListObjCopy(NULL, listPtr); - copied = 1; } if ((objc == 4) && (index == len)) { @@ -2473,19 +2506,10 @@ Tcl_LinsertObjCmd( * Special case: insert one element at the end of the list. */ - result = Tcl_ListObjAppendElement(NULL, listPtr, objv[3]); - if (result != TCL_OK) { - if (copied) { - Tcl_DecrRefCount(listPtr); - } - return result; - } + Tcl_ListObjAppendElement(NULL, listPtr, objv[3]); } else { if (TCL_OK != Tcl_ListObjReplace(interp, listPtr, index, 0, (objc-3), &(objv[3]))) { - if (copied) { - Tcl_DecrRefCount(listPtr); - } return TCL_ERROR; } } @@ -2609,9 +2633,9 @@ Tcl_LpopObjCmd( /* Argument objects. */ { Tcl_Size listLen; - int copied = 0, result; + int result; Tcl_Obj *elemPtr, *stored; - Tcl_Obj *listPtr; + Tcl_Obj *listPtr, **elemPtrs; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "listvar ?index?"); @@ -2623,7 +2647,7 @@ Tcl_LpopObjCmd( return TCL_ERROR; } - result = TclListObjLength(interp, listPtr, &listLen); + result = TclListObjGetElements(interp, listPtr, &listLen, &elemPtrs); if (result != TCL_OK) { return result; } @@ -2642,12 +2666,7 @@ Tcl_LpopObjCmd( "OUTOFRANGE", (char *)NULL); return TCL_ERROR; } - - result = Tcl_ListObjIndex(interp, listPtr, (listLen-1), &elemPtr); - if (result != TCL_OK) { - return result; - } - + elemPtr = elemPtrs[listLen - 1]; Tcl_IncrRefCount(elemPtr); } else { elemPtr = TclLindexFlat(interp, listPtr, objc-2, objv+2); @@ -2667,35 +2686,22 @@ Tcl_LpopObjCmd( if (objc == 2) { if (Tcl_IsShared(listPtr)) { listPtr = TclListObjCopy(NULL, listPtr); - copied = 1; } result = Tcl_ListObjReplace(interp, listPtr, listLen - 1, 1, 0, NULL); if (result != TCL_OK) { - if (copied) { - Tcl_DecrRefCount(listPtr); - } return result; } + Tcl_IncrRefCount(listPtr); } else { - Tcl_Obj *newListPtr; - Tcl_ObjTypeSetElement *proc = TclObjTypeHasProc(listPtr, setElementProc); - if (proc) { - newListPtr = proc(interp, listPtr, objc-2, objv+2, NULL); - } else { - newListPtr = TclLsetFlat(interp, listPtr, objc-2, objv+2, NULL); - } - if (newListPtr == NULL) { - if (copied) { - Tcl_DecrRefCount(listPtr); - } + listPtr = TclLsetFlat(interp, listPtr, objc-2, objv+2, NULL); + + if (listPtr == NULL) { return TCL_ERROR; - } else { - listPtr = newListPtr; - TclUndoRefCount(listPtr); } } stored = Tcl_ObjSetVar2(interp, objv[1], NULL, listPtr, TCL_LEAVE_ERR_MSG); + Tcl_DecrRefCount(listPtr); if (stored == NULL) { return TCL_ERROR; } @@ -2752,11 +2758,11 @@ Tcl_LrangeObjCmd( return result; } - if (TclObjTypeHasProc(objv[1], sliceProc)) { - Tcl_Obj *resultObj; - int status = TclObjTypeSlice(interp, objv[1], first, last, &resultObj); - if (status == TCL_OK) { - Tcl_SetObjResult(interp, resultObj); + if (TclHasInternalRep(objv[1],&tclArithSeriesType)) { + Tcl_Obj *rangeObj; + rangeObj = TclArithSeriesObjRange(interp, objv[1], first, last); + if (rangeObj) { + Tcl_SetObjResult(interp, rangeObj); } else { return TCL_ERROR; } @@ -2833,7 +2839,7 @@ Tcl_LremoveObjCmd( Tcl_SetObjResult(interp, listObj); return TCL_OK; } - idxv = (Tcl_Size *)Tcl_Alloc((objc - 2) * sizeof(*idxv)); + idxv = (Tcl_Size *)ckalloc((objc - 2) * sizeof(*idxv)); for (i = 2; i < objc; i++) { status = (TclGetIntForIndexM(interp, objv[i], /*endValue*/ listLen - 1, &idxv[i - 2]) != TCL_OK); @@ -2912,7 +2918,7 @@ Tcl_LremoveObjCmd( } Tcl_SetObjResult(interp, listObj); done: - Tcl_Free(idxv); + ckfree(idxv); return status; } @@ -2935,7 +2941,7 @@ done: int Tcl_LrepeatObjCmd( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) @@ -3086,7 +3092,7 @@ Tcl_LreplaceObjCmd( return result; } - if (first < 0) { + if (first == TCL_INDEX_NONE) { first = 0; } else if (first > listLen) { first = listLen; @@ -3096,7 +3102,7 @@ Tcl_LreplaceObjCmd( last = listLen - 1; } if (first <= last) { - numToDelete = (size_t)last - (size_t)first + 1; /* See [3d3124d01d] */ + numToDelete = (unsigned)last - (unsigned)first + 1; /* See [3d3124d01d] */ } else { numToDelete = 0; } @@ -3121,7 +3127,6 @@ Tcl_LreplaceObjCmd( if (TCL_OK != Tcl_ListObjReplace(interp, listPtr, first, numToDelete, objc-4, objv+4)) { - Tcl_DecrRefCount(listPtr); return TCL_ERROR; } @@ -3166,18 +3171,20 @@ Tcl_LreverseObjCmd( } /* - * Handle AbstractList special case - do not shimmer into a list, if it - * supports a private Reverse function, just to reverse it. + * Handle ArithSeries special case - don't shimmer a series into a list + * just to reverse it. */ - if (TclObjTypeHasProc(objv[1], reverseProc)) { - Tcl_Obj *resultObj; - - if (TclObjTypeReverse(interp, objv[1], &resultObj) == TCL_OK) { - Tcl_SetObjResult(interp, resultObj); + if (TclHasInternalRep(objv[1],&tclArithSeriesType)) { + Tcl_Obj *resObj = TclArithSeriesObjReverse(interp, objv[1]); + if (resObj) { + Tcl_SetObjResult(interp, resObj); return TCL_OK; + } else { + return TCL_ERROR; } - } /* end Abstract List */ + } /* end ArithSeries */ + /* True List */ if (TclListObjLength(interp, objv[1], &elemc) != TCL_OK) { return TCL_ERROR; } @@ -3195,7 +3202,7 @@ Tcl_LreverseObjCmd( } if (Tcl_IsShared(objv[1]) - || ListObjRepIsShared(objv[1])) { /* Bug 1675044 */ + || ListObjRepIsShared(objv[1])) { /* Bug 1675044 */ Tcl_Obj *resultObj, **dataArray; ListRep listRep; @@ -3262,15 +3269,15 @@ Tcl_LsearchObjCmd( { const char *bytes, *patternBytes; int match, result=TCL_OK, bisect; - Tcl_Size i, length = 0, listc, elemLen, start, index; - Tcl_Size groupOffset, lower, upper; + Tcl_Size i, length, listc, elemLen, start, index; + Tcl_Size groupSize, groupOffset, lower, upper; int allocatedIndexVector = 0; - int isIncreasing; - Tcl_WideInt patWide, objWide, wide, groupSize; + int dataType, isIncreasing; + Tcl_WideInt patWide, objWide, wide; int allMatches, inlineReturn, negatedMatch, returnSubindices, noCase; double patDouble, objDouble; SortInfo sortInfo; - Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr = NULL; + Tcl_Obj *patObj, **listv, *listPtr, *startPtr, *itemPtr; SortStrCmpFn_t strCmpFn = TclUtfCmp; Tcl_RegExp regexp = NULL; static const char *const options[] = { @@ -3289,7 +3296,7 @@ Tcl_LsearchObjCmd( }; enum datatypes { ASCII, DICTIONARY, INTEGER, REAL - } dataType; + }; enum modes { EXACT, GLOB, REGEXP, SORTED }; @@ -3323,13 +3330,12 @@ Tcl_LsearchObjCmd( } for (i = 1; i < objc-2; i++) { - enum lsearchoptions idx; - if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &idx) + if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &index) != TCL_OK) { result = TCL_ERROR; goto done; } - switch (idx) { + switch ((enum lsearchoptions) index) { case LSEARCH_ALL: /* -all */ allMatches = 1; break; @@ -3423,13 +3429,13 @@ Tcl_LsearchObjCmd( result = TCL_ERROR; goto done; } - if (TclGetWideIntFromObj(interp, objv[i+1], &wide) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[i+1], &wide) != TCL_OK) { result = TCL_ERROR; goto done; } - if (wide < 1) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "stride length must be at least 1", -1)); + if ((wide < 1) || (wide > LIST_MAX)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "stride length must be between 1 and %d", LIST_MAX)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH", "BADSTRIDE", (char *)NULL); result = TCL_ERROR; @@ -3503,7 +3509,7 @@ Tcl_LsearchObjCmd( } if (result == TCL_ERROR) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (-index option item number %" TCL_Z_MODIFIER "u)", j)); + "\n (-index option item number %" TCL_SIZE_MODIFIER "d)", j)); goto done; } sortInfo.indexv[j] = encoded; @@ -3657,7 +3663,7 @@ Tcl_LsearchObjCmd( patObj = objv[objc - 1]; patternBytes = NULL; if (mode == EXACT || mode == SORTED) { - switch (dataType) { + switch ((enum datatypes) dataType) { case ASCII: case DICTIONARY: patternBytes = TclGetStringFromObj(patObj, &length); @@ -3715,14 +3721,9 @@ Tcl_LsearchObjCmd( lower = start - groupSize; upper = listc; - itemPtr = NULL; while (lower + groupSize != upper && sortInfo.resultCode == TCL_OK) { i = (lower + upper)/2; i -= i % groupSize; - - Tcl_BounceRefCount(itemPtr); - itemPtr = NULL; - if (sortInfo.indexc != 0) { itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo); if (sortInfo.resultCode != TCL_OK) { @@ -3732,7 +3733,7 @@ Tcl_LsearchObjCmd( } else { itemPtr = listv[i+groupOffset]; } - switch (dataType) { + switch ((enum datatypes) dataType) { case ASCII: bytes = TclGetString(itemPtr); match = strCmpFn(patternBytes, bytes); @@ -3821,9 +3822,6 @@ Tcl_LsearchObjCmd( } for (i = start; i < listc; i += groupSize) { match = 0; - Tcl_BounceRefCount(itemPtr); - itemPtr = NULL; - if (sortInfo.indexc != 0) { itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo); if (sortInfo.resultCode != TCL_OK) { @@ -3840,7 +3838,7 @@ Tcl_LsearchObjCmd( switch (mode) { case SORTED: case EXACT: - switch (dataType) { + switch ((enum datatypes) dataType) { case ASCII: bytes = TclGetStringFromObj(itemPtr, &elemLen); if (length == elemLen) { @@ -3923,7 +3921,6 @@ Tcl_LsearchObjCmd( */ if (returnSubindices && (sortInfo.indexc != 0)) { - Tcl_BounceRefCount(itemPtr); itemPtr = SelectObjFromSublist(listv[i+groupOffset], &sortInfo); Tcl_ListObjAppendElement(interp, listPtr, itemPtr); @@ -3931,7 +3928,6 @@ Tcl_LsearchObjCmd( Tcl_ListObjReplace(interp, listPtr, LIST_MAX, 0, groupSize, &listv[i]); } else { - Tcl_BounceRefCount(itemPtr); itemPtr = listv[i]; Tcl_ListObjAppendElement(interp, listPtr, itemPtr); } @@ -3941,8 +3937,7 @@ Tcl_LsearchObjCmd( TclNewIndexObj(itemPtr, i+groupOffset); for (j=0 ; j<sortInfo.indexc ; j++) { Tcl_Obj *elObj; - size_t elValue = TclIndexDecode(sortInfo.indexv[j], listc); - TclNewIndexObj(elObj, elValue); + TclNewIndexObj(elObj, TclIndexDecode(sortInfo.indexv[j], listc)); Tcl_ListObjAppendElement(interp, itemPtr, elObj); } Tcl_ListObjAppendElement(interp, listPtr, itemPtr); @@ -3952,9 +3947,6 @@ Tcl_LsearchObjCmd( } } - Tcl_BounceRefCount(itemPtr); - itemPtr = NULL; - /* * Return everything or a single value. */ @@ -3968,8 +3960,7 @@ Tcl_LsearchObjCmd( TclNewIndexObj(itemPtr, index+groupOffset); for (j=0 ; j<sortInfo.indexc ; j++) { Tcl_Obj *elObj; - size_t elValue = TclIndexDecode(sortInfo.indexv[j], listc); - TclNewIndexObj(elObj, elValue); + TclNewIndexObj(elObj, TclIndexDecode(sortInfo.indexv[j], listc)); Tcl_ListObjAppendElement(interp, itemPtr, elObj); } Tcl_SetObjResult(interp, itemPtr); @@ -3984,7 +3975,7 @@ Tcl_LsearchObjCmd( * default... */ - Tcl_SetObjResult(interp, Tcl_NewObj()); + Tcl_ResetResult(interp); } else { if (returnSubindices) { Tcl_SetObjResult(interp, SelectObjFromSublist(listv[i+groupOffset], @@ -4002,9 +3993,6 @@ Tcl_LsearchObjCmd( */ done: - /* potential lingering abstract list element */ - Tcl_BounceRefCount(itemPtr); - if (startPtr != NULL) { Tcl_DecrRefCount(startPtr); } @@ -4154,7 +4142,7 @@ Tcl_LseqObjCmd( Tcl_WideInt values[5]; Tcl_Obj *numValues[5]; Tcl_Obj *numberObj; - int status = TCL_ERROR, keyword, useDoubles = 0; + int status, keyword, useDoubles = 0; Tcl_Obj *arithSeriesPtr; SequenceOperators opmode; SequenceDecoded decoded; @@ -4224,6 +4212,7 @@ Tcl_LseqObjCmd( case 0: Tcl_WrongNumArgs(interp, 1, objv, "n ??op? n ??by? n??"); + status = TCL_ERROR; goto done; break; @@ -4270,6 +4259,7 @@ Tcl_LseqObjCmd( step = one; break; default: + status = TCL_ERROR; goto done; } break; @@ -4292,9 +4282,11 @@ Tcl_LseqObjCmd( break; case LSEQ_BY: /* Error case */ + status = TCL_ERROR; goto done; break; default: + status = TCL_ERROR; goto done; break; } @@ -4313,6 +4305,7 @@ Tcl_LseqObjCmd( case LSEQ_TO: case LSEQ_COUNT: default: + status = TCL_ERROR; goto done; break; } @@ -4328,6 +4321,7 @@ Tcl_LseqObjCmd( step = numValues[4]; break; default: + status = TCL_ERROR; goto done; break; } @@ -4343,6 +4337,7 @@ Tcl_LseqObjCmd( elementCount = numValues[2]; break; default: + status = TCL_ERROR; goto done; break; } @@ -4356,6 +4351,7 @@ Tcl_LseqObjCmd( case 1212: opmode = (SequenceOperators)values[3]; goto KeywordError; break; KeywordError: + status = TCL_ERROR; switch (opmode) { case LSEQ_DOTS: case LSEQ_TO: @@ -4371,12 +4367,14 @@ Tcl_LseqObjCmd( "missing \"by\" value.")); break; } + status = TCL_ERROR; goto done; break; /* All other argument errors */ default: Tcl_WrongNumArgs(interp, 1, objv, "n ??op? n ??by? n??"); + status = TCL_ERROR; goto done; break; } @@ -4394,9 +4392,7 @@ Tcl_LseqObjCmd( done: // Free number arguments. while (--value_i>=0) { - if (numValues[value_i]) { - Tcl_DecrRefCount(numValues[value_i]); - } + if (numValues[value_i]) Tcl_DecrRefCount(numValues[value_i]); } // Free constants @@ -4460,16 +4456,8 @@ Tcl_LsetObjCmd( if (objc == 4) { finalValuePtr = TclLsetList(interp, listPtr, objv[2], objv[3]); } else { - if (TclObjTypeHasProc(listPtr, setElementProc)) { - finalValuePtr = TclObjTypeSetElement(interp, listPtr, - objc-3, objv+2, objv[objc-1]); - if (finalValuePtr) { - Tcl_IncrRefCount(finalValuePtr); - } - } else { - finalValuePtr = TclLsetFlat(interp, listPtr, objc-3, objv+2, - objv[objc-1]); - } + finalValuePtr = TclLsetFlat(interp, listPtr, objc-3, objv+2, + objv[objc-1]); } /* @@ -4518,18 +4506,17 @@ Tcl_LsetObjCmd( int Tcl_LsortObjCmd( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument values. */ { - int indices, nocase = 0, indexc; + int i, j, index, indices, length, nocase = 0, indexc; int sortMode = SORTMODE_ASCII; - int group, allocatedIndexVector = 0; - Tcl_Size j, idx, groupOffset, length; - Tcl_WideInt wide, groupSize; + int group, groupSize, groupOffset, idx, allocatedIndexVector = 0; Tcl_Obj *resultPtr, *cmdPtr, **listObjPtrs, *listObj, *indexPtr; - Tcl_Size i, elmArrSize; + size_t elmArrSize; + Tcl_WideInt wide; SortElement *elementArray = NULL, *elementPtr; SortInfo sortInfo; /* Information about this sort that needs to * be passed to the comparison function. */ @@ -4549,7 +4536,7 @@ Tcl_LsortObjCmd( LSORT_ASCII, LSORT_COMMAND, LSORT_DECREASING, LSORT_DICTIONARY, LSORT_INCREASING, LSORT_INDEX, LSORT_INDICES, LSORT_INTEGER, LSORT_NOCASE, LSORT_REAL, LSORT_STRIDE, LSORT_UNIQUE - } index; + }; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "?-option value ...? list"); @@ -4579,7 +4566,7 @@ Tcl_LsortObjCmd( sortInfo.resultCode = TCL_ERROR; goto done; } - switch (index) { + switch ((enum Lsort_Switches) index) { case LSORT_ASCII: sortInfo.sortMode = SORTMODE_ASCII; break; @@ -4646,7 +4633,7 @@ Tcl_LsortObjCmd( } if (result == TCL_ERROR) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (-index option item number %" TCL_Z_MODIFIER "u)", j)); + "\n (-index option item number %d)", j)); sortInfo.resultCode = TCL_ERROR; goto done; } @@ -4679,13 +4666,13 @@ Tcl_LsortObjCmd( sortInfo.resultCode = TCL_ERROR; goto done; } - if (TclGetWideIntFromObj(interp, objv[i+1], &wide) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[i+1], &wide) != TCL_OK) { sortInfo.resultCode = TCL_ERROR; goto done; } - if (wide < 2) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "stride length must be at least 2", -1)); + if ((wide < 2) || (wide > LIST_MAX)) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "stride length must be between 2 and %d", LIST_MAX)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", "BADSTRIDE", (char *)NULL); sortInfo.resultCode = TCL_ERROR; @@ -4760,17 +4747,20 @@ Tcl_LsortObjCmd( if (Tcl_ListObjAppendElement(interp, newCommandPtr, newObjPtr) != TCL_OK) { TclDecrRefCount(newCommandPtr); + TclDecrRefCount(listObj); + Tcl_IncrRefCount(newObjPtr); TclDecrRefCount(newObjPtr); sortInfo.resultCode = TCL_ERROR; goto done; } - Tcl_ListObjAppendElement(interp, newCommandPtr, Tcl_NewObj()); + TclNewObj(newObjPtr); + Tcl_ListObjAppendElement(interp, newCommandPtr, newObjPtr); sortInfo.compareCmdPtr = newCommandPtr; } - if (TclObjTypeHasProc(objv[1], getElementsProc)) { - sortInfo.resultCode = - TclObjTypeGetElements(interp, listObj, &length, &listObjPtrs); + if (TclHasInternalRep(listObj,&tclArithSeriesType)) { + sortInfo.resultCode = TclArithSeriesGetElements(interp, + listObj, &length, &listObjPtrs); } else { sortInfo.resultCode = TclListObjGetElements(interp, listObj, &length, &listObjPtrs); @@ -4862,13 +4852,13 @@ Tcl_LsortObjCmd( elmArrSize = length * sizeof(SortElement); if (elmArrSize <= MAXCALLOC) { - elementArray = (SortElement *)Tcl_Alloc(elmArrSize); + elementArray = (SortElement *)ckalloc(elmArrSize); } else { elementArray = (SortElement *)malloc(elmArrSize); } if (!elementArray) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "no enough memory to proccess sort of %" TCL_Z_MODIFIER "u items", length)); + "no enough memory to proccess sort of %d items", length)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL); sortInfo.resultCode = TCL_ERROR; goto done; @@ -4905,7 +4895,8 @@ Tcl_LsortObjCmd( } else if (sortMode == SORTMODE_REAL) { double a; - if (Tcl_GetDoubleFromObj(sortInfo.interp, indexPtr, &a) != TCL_OK) { + if (Tcl_GetDoubleFromObj(sortInfo.interp, indexPtr, + &a) != TCL_OK) { sortInfo.resultCode = TCL_ERROR; goto done; } @@ -5009,7 +5000,7 @@ Tcl_LsortObjCmd( } if (elementArray) { if (elmArrSize <= MAXCALLOC) { - Tcl_Free(elementArray); + ckfree((char *)elementArray); } else { free((char *)elementArray); } @@ -5081,7 +5072,7 @@ Tcl_LeditObjCmd( return result; } - if (first < 0) { + if (first == TCL_INDEX_NONE) { first = 0; } else if (first > listLen) { first = listLen; @@ -5091,7 +5082,7 @@ Tcl_LeditObjCmd( last = listLen - 1; } if (first <= last) { - numToDelete = (size_t)last - (size_t)first + 1; /* See [3d3124d01d] */ + numToDelete = (unsigned)last - (unsigned)first + 1; /* See [3d3124d01d] */ } else { numToDelete = 0; } @@ -5113,11 +5104,19 @@ Tcl_LeditObjCmd( } /* - * Tcl_ObjSetVar2 may return a value different from listPtr in the - * presence of traces etc. + * Tcl_ObjSetVar2 mau return a value different from listPtr in the + * presence of traces etc.. Note that finalValuePtr will always have a + * reference count of at least 1 corresponding to the reference from the + * var. If it is same as listPtr, then ref count will be at least 2 + * since we are incr'ing the latter below (safer when calling + * Tcl_ObjSetVar2 which can release it in some cases). Note that we + * leave the incrref of listPtr this late because we want to pass it as + * unshared to Tcl_ListObjReplace above if possible. */ + Tcl_IncrRefCount(listPtr); finalValuePtr = Tcl_ObjSetVar2(interp, objv[1], NULL, listPtr, TCL_LEAVE_ERR_MSG); + Tcl_DecrRefCount(listPtr); /* safe irrespective of createdNewObj */ if (finalValuePtr == NULL) { return TCL_ERROR; } @@ -5368,7 +5367,7 @@ DictionaryCompare( int secondaryDiff = 0; while (1) { - if (isdigit(UCHAR(*right)) /* INTL: digit */ + if (isdigit(UCHAR(*right)) /* INTL: digit */ && isdigit(UCHAR(*left))) { /* INTL: digit */ /* * There are decimal numbers embedded in the two strings. Compare @@ -5514,7 +5513,7 @@ SelectObjFromSublist( for (i=0 ; i<infoPtr->indexc ; i++) { Tcl_Size listLen; int index; - Tcl_Obj *currentObj, *lastObj=NULL; + Tcl_Obj *currentObj; if (TclListObjLength(infoPtr->interp, objPtr, &listLen) != TCL_OK) { infoPtr->resultCode = TCL_ERROR; @@ -5545,8 +5544,6 @@ SelectObjFromSublist( return NULL; } objPtr = currentObj; - Tcl_BounceRefCount(lastObj); - lastObj = currentObj; } return objPtr; } diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 3effdf1..0a1a16a 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.c @@ -20,7 +20,6 @@ #include "tclCompile.h" #include "tclRegexp.h" #include "tclStringTrim.h" -#include "tclTomMath.h" static inline Tcl_Obj * During(Tcl_Interp *interp, int resultCode, Tcl_Obj *oldOptions, Tcl_Obj *errorInfo); @@ -30,7 +29,7 @@ static Tcl_NRPostProc TryPostFinal; static Tcl_NRPostProc TryPostHandler; static int UniCharIsAscii(int character); static int UniCharIsHexDigit(int character); -static int StringCmpOpts(Tcl_Interp *interp, int objc, +static int StringCmpOpts(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], int *nocase, Tcl_Size *reqlength); @@ -145,17 +144,18 @@ Tcl_RegexpObjCmd( REGEXP_ALL, REGEXP_ABOUT, REGEXP_INDICES, REGEXP_INLINE, REGEXP_EXPANDED,REGEXP_LINE, REGEXP_LINESTOP,REGEXP_LINEANCHOR, REGEXP_NOCASE, REGEXP_START, REGEXP_LAST - } index; + }; indices = 0; about = 0; cflags = TCL_REG_ADVANCED; - offset = TCL_INDEX_START; + offset = 0; all = 0; doinline = 0; for (i = 1; i < objc; i++) { const char *name; + int index; name = TclGetString(objv[i]); if (name[0] != '-') { @@ -165,7 +165,7 @@ Tcl_RegexpObjCmd( &index) != TCL_OK) { goto optionError; } - switch (index) { + switch ((enum regexpoptions) index) { case REGEXP_ALL: all = 1; break; @@ -259,13 +259,13 @@ Tcl_RegexpObjCmd( */ objPtr = objv[1]; - stringLength = Tcl_GetCharLength(objPtr); + stringLength = TclGetCharLength(objPtr); if (startIndex) { TclGetIntForIndexM(interp, startIndex, stringLength, &offset); Tcl_DecrRefCount(startIndex); if (offset < 0) { - offset = TCL_INDEX_START; + offset = 0; } } @@ -309,11 +309,11 @@ Tcl_RegexpObjCmd( * start of the string unless the previous character is a newline. */ - if (offset == TCL_INDEX_START) { + if (offset == 0) { eflags = 0; } else if (offset > stringLength) { eflags = TCL_REG_NOTBOL; - } else if (Tcl_GetUniChar(objPtr, offset-1) == '\n') { + } else if (TclGetUniChar(objPtr, offset-1) == '\n') { eflags = 0; } else { eflags = TCL_REG_NOTBOL; @@ -375,7 +375,7 @@ Tcl_RegexpObjCmd( * area. (Scriptics Bug 4391/SF Bug #219232) */ - if (i <= (int)info.nsubs && info.matches[i].start >= 0) { + if (i <= info.nsubs && info.matches[i].start >= 0) { start = offset + info.matches[i].start; end = offset + info.matches[i].end; @@ -397,8 +397,8 @@ Tcl_RegexpObjCmd( newPtr = Tcl_NewListObj(2, objs); } else { - if ((i <= (int)info.nsubs) && (info.matches[i].end > 0)) { - newPtr = Tcl_GetRange(objPtr, + if ((i <= info.nsubs) && (info.matches[i].end > 0)) { + newPtr = TclGetRange(objPtr, offset + info.matches[i].start, offset + info.matches[i].end - 1); } else { @@ -491,7 +491,7 @@ Tcl_RegsubObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { int result, cflags, all, match, command; - Tcl_Size idx, wlen, wsublen = 0, offset, numMatches, numParts; + Tcl_Size idx, wlen, wsublen, offset, numMatches, numParts; Tcl_Size start, end, subStart, subEnd; Tcl_RegExp regExpr; Tcl_RegExpInfo info; @@ -507,16 +507,17 @@ Tcl_RegsubObjCmd( REGSUB_ALL, REGSUB_COMMAND, REGSUB_EXPANDED, REGSUB_LINE, REGSUB_LINESTOP, REGSUB_LINEANCHOR, REGSUB_NOCASE, REGSUB_START, REGSUB_LAST - } index; + }; cflags = TCL_REG_ADVANCED; all = 0; - offset = TCL_INDEX_START; + offset = 0; command = 0; resultPtr = NULL; for (idx = 1; idx < objc; idx++) { const char *name; + int index; name = TclGetString(objv[idx]); if (name[0] != '-') { @@ -526,7 +527,7 @@ Tcl_RegsubObjCmd( TCL_EXACT, &index) != TCL_OK) { goto optionError; } - switch (index) { + switch ((enum regsubobjoptions) index) { case REGSUB_ALL: all = 1; break; @@ -584,7 +585,7 @@ Tcl_RegsubObjCmd( objv += idx; if (startIndex) { - Tcl_Size stringLength = Tcl_GetCharLength(objv[1]); + Tcl_Size stringLength = TclGetCharLength(objv[1]); TclGetIntForIndexM(interp, startIndex, stringLength, &offset); Tcl_DecrRefCount(startIndex); @@ -610,9 +611,9 @@ Tcl_RegsubObjCmd( nocase = (cflags & TCL_REG_NOCASE); strCmpFn = nocase ? TclUniCharNcasecmp : TclUniCharNcmp; - wsrc = Tcl_GetUnicodeFromObj(objv[0], &slen); - wstring = Tcl_GetUnicodeFromObj(objv[1], &wlen); - wsubspec = Tcl_GetUnicodeFromObj(objv[2], &wsublen); + wsrc = TclGetUnicodeFromObj(objv[0], &slen); + wstring = TclGetUnicodeFromObj(objv[1], &wlen); + wsubspec = TclGetUnicodeFromObj(objv[2], &wsublen); wend = wstring + wlen - (slen ? slen - 1 : 0); result = TCL_OK; @@ -623,11 +624,11 @@ Tcl_RegsubObjCmd( */ if (wstring < wend) { - resultPtr = Tcl_NewUnicodeObj(wstring, 0); + resultPtr = TclNewUnicodeObj(wstring, 0); Tcl_IncrRefCount(resultPtr); for (; wstring < wend; wstring++) { - Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen); - Tcl_AppendUnicodeToObj(resultPtr, wstring, 1); + TclAppendUnicodeToObj(resultPtr, wsubspec, wsublen); + TclAppendUnicodeToObj(resultPtr, wstring, 1); numMatches++; } wlen = 0; @@ -637,20 +638,21 @@ Tcl_RegsubObjCmd( for (p = wfirstChar = wstring; wstring < wend; wstring++) { if ((*wstring == *wsrc || (nocase && Tcl_UniCharToLower(*wstring)==wsrclc)) && - (slen==1 || (strCmpFn(wstring, wsrc, slen) == 0))) { + (slen==1 || (strCmpFn(wstring, wsrc, + (unsigned long) slen) == 0))) { if (numMatches == 0) { - resultPtr = Tcl_NewUnicodeObj(wstring, 0); + resultPtr = TclNewUnicodeObj(wstring, 0); Tcl_IncrRefCount(resultPtr); } if (p != wstring) { - Tcl_AppendUnicodeToObj(resultPtr, p, wstring - p); + TclAppendUnicodeToObj(resultPtr, p, wstring - p); p = wstring + slen; } else { p += slen; } wstring = p - 1; - Tcl_AppendUnicodeToObj(resultPtr, wsubspec, wsublen); + TclAppendUnicodeToObj(resultPtr, wsubspec, wsublen); numMatches++; } } @@ -702,14 +704,14 @@ Tcl_RegsubObjCmd( } else { objPtr = objv[1]; } - wstring = Tcl_GetUnicodeFromObj(objPtr, &wlen); + wstring = TclGetUnicodeFromObj(objPtr, &wlen); if (objv[2] == objv[0]) { subPtr = Tcl_DuplicateObj(objv[2]); } else { subPtr = objv[2]; } if (!command) { - wsubspec = Tcl_GetUnicodeFromObj(subPtr, &wsublen); + wsubspec = TclGetUnicodeFromObj(subPtr, &wsublen); } result = TCL_OK; @@ -745,15 +747,15 @@ Tcl_RegsubObjCmd( break; } if (numMatches == 0) { - resultPtr = Tcl_NewUnicodeObj(wstring, 0); + resultPtr = TclNewUnicodeObj(wstring, 0); Tcl_IncrRefCount(resultPtr); - if (offset > TCL_INDEX_START) { + if (offset > 0) { /* * Copy the initial portion of the string in if an offset was * specified. */ - Tcl_AppendUnicodeToObj(resultPtr, wstring, offset); + TclAppendUnicodeToObj(resultPtr, wstring, offset); } } numMatches++; @@ -766,7 +768,7 @@ Tcl_RegsubObjCmd( Tcl_RegExpGetInfo(regExpr, &info); start = info.matches[0].start; end = info.matches[0].end; - Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, start); + TclAppendUnicodeToObj(resultPtr, wstring + offset, start); /* * In command-prefix mode, the substitutions are added as quoted @@ -781,17 +783,17 @@ Tcl_RegsubObjCmd( TclListObjGetElements(interp, subPtr, &numParts, &parts); numArgs = numParts + info.nsubs + 1; - args = (Tcl_Obj **)Tcl_Alloc(sizeof(Tcl_Obj*) * numArgs); + args = (Tcl_Obj **)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( + args[idx + numParts] = TclNewUnicodeObj( wstring + offset + subStart, subEnd - subStart); } else { - args[idx + numParts] = Tcl_NewObj(); + TclNewObj(args[idx + numParts]); } Tcl_IncrRefCount(args[idx + numParts]); } @@ -811,7 +813,7 @@ Tcl_RegsubObjCmd( for (idx = 0 ; idx <= info.nsubs ; idx++) { TclDecrRefCount(args[idx + numParts]); } - Tcl_Free(args); + ckfree(args); if (result != TCL_OK) { if (result == TCL_ERROR) { Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( @@ -829,7 +831,7 @@ Tcl_RegsubObjCmd( * the user code. */ - wstring = Tcl_GetUnicodeFromObj(objPtr, &wlen); + wstring = TclGetUnicodeFromObj(objPtr, &wlen); offset += end; if (end == 0 || start == end) { @@ -841,7 +843,7 @@ Tcl_RegsubObjCmd( */ if (offset < wlen) { - Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); + TclAppendUnicodeToObj(resultPtr, wstring + offset, 1); } offset++; } @@ -870,7 +872,7 @@ Tcl_RegsubObjCmd( idx = ch - '0'; } else if ((ch == '\\') || (ch == '&')) { *wsrc = ch; - Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, + TclAppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar + 1); *wsrc = '\\'; wfirstChar = wsrc + 2; @@ -884,7 +886,7 @@ Tcl_RegsubObjCmd( } if (wfirstChar != wsrc) { - Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, + TclAppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar); } @@ -892,7 +894,7 @@ Tcl_RegsubObjCmd( subStart = info.matches[idx].start; subEnd = info.matches[idx].end; if ((subStart >= 0) && (subEnd >= 0)) { - Tcl_AppendUnicodeToObj(resultPtr, + TclAppendUnicodeToObj(resultPtr, wstring + offset + subStart, subEnd - subStart); } } @@ -904,7 +906,7 @@ Tcl_RegsubObjCmd( } if (wfirstChar != wsrc) { - Tcl_AppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar); + TclAppendUnicodeToObj(resultPtr, wfirstChar, wsrc - wfirstChar); } if (end == 0) { @@ -914,7 +916,7 @@ Tcl_RegsubObjCmd( */ if (offset < wlen) { - Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); + TclAppendUnicodeToObj(resultPtr, wstring + offset, 1); } offset++; } else { @@ -926,7 +928,7 @@ Tcl_RegsubObjCmd( */ if (offset < wlen) { - Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, 1); + TclAppendUnicodeToObj(resultPtr, wstring + offset, 1); } offset++; } @@ -951,7 +953,7 @@ Tcl_RegsubObjCmd( resultPtr = objv[1]; Tcl_IncrRefCount(resultPtr); } else if (offset < wlen) { - Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset); + TclAppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset); } if (objc == 4) { if (Tcl_ObjSetVar2(interp, objv[3], NULL, resultPtr, @@ -1055,7 +1057,7 @@ Tcl_ReturnObjCmd( */ int explicitResult = (0 == (objc % 2)); - int numOptionWords = objc - 1 - explicitResult; + Tcl_Size numOptionWords = objc - 1 - explicitResult; if (TCL_ERROR == TclMergeReturnOptions(interp, numOptionWords, objv+1, &returnOpts, &code, &level)) { @@ -1310,7 +1312,7 @@ StringFirstCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Size start = TCL_INDEX_START; + Tcl_Size start = 0; if (objc < 3 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, @@ -1319,7 +1321,7 @@ StringFirstCmd( } if (objc == 4) { - Tcl_Size end = Tcl_GetCharLength(objv[2]) - 1; + Tcl_Size end = TclGetCharLength(objv[2]) - 1; if (TCL_OK != TclGetIntForIndexM(interp, objv[3], end, &start)) { return TCL_ERROR; @@ -1363,7 +1365,7 @@ StringLastCmd( } if (objc == 4) { - Tcl_Size end = Tcl_GetCharLength(objv[2]) - 1; + Tcl_Size end = TclGetCharLength(objv[2]) - 1; if (TCL_OK != TclGetIntForIndexM(interp, objv[3], end, &last)) { return TCL_ERROR; @@ -1409,13 +1411,13 @@ StringIndexCmd( * Get the char length to calculate what 'end' means. */ - end = Tcl_GetCharLength(objv[1]) - 1; + end = TclGetCharLength(objv[1]) - 1; if (TclGetIntForIndexM(interp, objv[2], end, &index) != TCL_OK) { return TCL_ERROR; } if ((index >= 0) && (index <= end)) { - int ch = Tcl_GetUniChar(objv[1], index); + int ch = TclGetUniChar(objv[1], index); if (ch == -1) { return TCL_OK; @@ -1434,6 +1436,9 @@ StringIndexCmd( char buf[4] = ""; end = Tcl_UniCharToUtf(ch, buf); + if ((ch >= 0xD800) && (end < 3)) { + end += Tcl_UniCharToUtf(-1, buf + end); + } Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, end)); } } @@ -1474,13 +1479,13 @@ StringInsertCmd( return TCL_ERROR; } - length = Tcl_GetCharLength(objv[1]); + length = TclGetCharLength(objv[1]); if (TclGetIntForIndexM(interp, objv[2], length, &index) != TCL_OK) { return TCL_ERROR; } if (index < 0) { - index = TCL_INDEX_START; + index = 0; } if (index > length) { index = length; @@ -1524,8 +1529,7 @@ StringIsCmd( { const char *string1, *end, *stop; int (*chcomp)(int) = NULL; /* The UniChar comparison function. */ - int i, result = 1, strict = 0; - Tcl_Size failat = 0, length1, length2, length3; + int i, failat = 0, result = 1, strict = 0, index, length1, length2; Tcl_Obj *objPtr, *failVarObj = NULL; Tcl_WideInt w; @@ -1544,13 +1548,13 @@ StringIsCmd( 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 - } index; + }; static const char *const isOptions[] = { "-strict", "-failindex", NULL }; enum isOptionsEnum { OPT_STRICT, OPT_FAILIDX - } idx2; + }; if (objc < 3 || objc > 6) { Tcl_WrongNumArgs(interp, 1, objv, @@ -1564,11 +1568,13 @@ StringIsCmd( if (objc != 3) { for (i = 2; i < objc-1; i++) { + int idx2; + if (Tcl_GetIndexFromObj(interp, objv[i], isOptions, "option", 0, &idx2) != TCL_OK) { return TCL_ERROR; } - switch (idx2) { + switch ((enum isOptionsEnum) idx2) { case OPT_STRICT: strict = 1; break; @@ -1597,7 +1603,7 @@ StringIsCmd( * When entering here, result == 1 and failat == 0. */ - switch (index) { + switch ((enum isClassesEnum) index) { case STR_IS_ALNUM: chcomp = Tcl_UniCharIsAlnum; break; @@ -1618,9 +1624,11 @@ StringIsCmd( string1 = TclGetStringFromObj(objPtr, &length1); result = length1 == 0; } - } else if ((objPtr->internalRep.wideValue != 0) - ? (index == STR_IS_FALSE) : (index == STR_IS_TRUE)) { - 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: @@ -1667,7 +1675,7 @@ StringIsCmd( p++; } TclNewStringObj(tmpStr, string1, p-string1); - failat = Tcl_GetCharLength(tmpStr); + failat = TclGetCharLength(tmpStr); TclDecrRefCount(tmpStr); break; } @@ -1809,7 +1817,7 @@ StringIsCmd( * well-formed lists. */ - if (TCL_OK == TclListObjLength(NULL, objPtr, &length3)) { + if (TCL_OK == TclListObjLength(NULL, objPtr, &length2)) { break; } @@ -1821,8 +1829,7 @@ StringIsCmd( */ const char *elemStart, *nextElem; - Tcl_Size lenRemain; - Tcl_Size elemSize; + Tcl_Size lenRemain, elemSize; const char *p; string1 = TclGetStringFromObj(objPtr, &length1); @@ -1848,7 +1855,7 @@ StringIsCmd( p++; } TclNewStringObj(tmpStr, string1, p-string1); - failat = Tcl_GetCharLength(tmpStr); + failat = TclGetCharLength(tmpStr); TclDecrRefCount(tmpStr); break; } @@ -1954,7 +1961,7 @@ StringMapCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Size length1, length2, mapElemc, index; + Tcl_Size length1, length2, mapElemc, index; int nocase = 0, mapWithDict = 0, copySource = 0; Tcl_Obj **mapElemv, *sourceObj, *resultPtr; Tcl_UniChar *ustring1, *ustring2, *p, *end; @@ -1987,8 +1994,7 @@ StringMapCmd( if (!TclHasStringRep(objv[objc-2]) && TclHasInternalRep(objv[objc-2], &tclDictType)) { - Tcl_Size i; - int done; + int i, done; Tcl_DictSearch search; /* @@ -1996,8 +2002,8 @@ StringMapCmd( * sure. This shortens this code quite a bit. */ - Tcl_DictObjSize(interp, objv[objc-2], &i); - if (i == 0) { + Tcl_DictObjSize(interp, objv[objc-2], &mapElemc); + if (mapElemc == 0) { /* * Empty charMap, just return whatever string was given. */ @@ -2006,7 +2012,7 @@ StringMapCmd( return TCL_OK; } - mapElemc = 2 * i; + mapElemc *= 2; mapWithDict = 1; /* @@ -2017,17 +2023,15 @@ StringMapCmd( mapElemv = (Tcl_Obj **)TclStackAlloc(interp, sizeof(Tcl_Obj *) * mapElemc); Tcl_DictObjFirst(interp, objv[objc-2], &search, mapElemv+0, mapElemv+1, &done); - for (index=2 ; index<mapElemc ; index+=2) { - Tcl_DictObjNext(&search, mapElemv+index, mapElemv+index+1, &done); + for (i=2 ; i<mapElemc ; i+=2) { + Tcl_DictObjNext(&search, mapElemv+i, mapElemv+i+1, &done); } Tcl_DictObjDone(&search); } else { - Tcl_Size i; - if (TclListObjGetElements(interp, objv[objc-2], &i, + if (TclListObjGetElements(interp, objv[objc-2], &mapElemc, &mapElemv) != TCL_OK) { return TCL_ERROR; } - mapElemc = i; if (mapElemc == 0) { /* * empty charMap, just return whatever string was given. @@ -2059,7 +2063,7 @@ StringMapCmd( } else { sourceObj = objv[objc-1]; } - ustring1 = Tcl_GetUnicodeFromObj(sourceObj, &length1); + ustring1 = TclGetUnicodeFromObj(sourceObj, &length1); if (length1 == 0) { /* * Empty input string, just stop now. @@ -2075,7 +2079,7 @@ StringMapCmd( * Force result to be Unicode */ - resultPtr = Tcl_NewUnicodeObj(ustring1, 0); + resultPtr = TclNewUnicodeObj(ustring1, 0); if (mapElemc == 2) { /* @@ -2089,7 +2093,7 @@ StringMapCmd( int u2lc; Tcl_UniChar *mapString; - ustring2 = Tcl_GetUnicodeFromObj(mapElemv[0], &length2); + ustring2 = TclGetUnicodeFromObj(mapElemv[0], &length2); p = ustring1; if ((length2 > length1) || (length2 == 0)) { /* @@ -2098,29 +2102,29 @@ StringMapCmd( ustring1 = end; } else { - mapString = Tcl_GetUnicodeFromObj(mapElemv[1], &mapLen); + mapString = TclGetUnicodeFromObj(mapElemv[1], &mapLen); u2lc = (nocase ? Tcl_UniCharToLower(*ustring2) : 0); for (; ustring1 < end; ustring1++) { if (((*ustring1 == *ustring2) || (nocase&&Tcl_UniCharToLower(*ustring1)==u2lc)) && (length2==1 || strCmpFn(ustring1, ustring2, - length2) == 0)) { + (unsigned long) length2) == 0)) { if (p != ustring1) { - Tcl_AppendUnicodeToObj(resultPtr, p, ustring1-p); + TclAppendUnicodeToObj(resultPtr, p, ustring1-p); p = ustring1 + length2; } else { p += length2; } ustring1 = p - 1; - Tcl_AppendUnicodeToObj(resultPtr, mapString, mapLen); + TclAppendUnicodeToObj(resultPtr, mapString, mapLen); } } } } else { Tcl_UniChar **mapStrings; Tcl_Size *mapLens; - int *u2lc = 0; + int *u2lc = NULL; /* * Precompute pointers to the Unicode string and length. This saves us @@ -2135,7 +2139,7 @@ StringMapCmd( u2lc = (int *)TclStackAlloc(interp, mapElemc * sizeof(int)); } for (index = 0; index < mapElemc; index++) { - mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index], + mapStrings[index] = TclGetUnicodeFromObj(mapElemv[index], mapLens+index); if (nocase && ((index % 2) == 0)) { u2lc[index/2] = Tcl_UniCharToLower(*mapStrings[index]); @@ -2152,14 +2156,14 @@ StringMapCmd( if ((length2 > 0) && ((*ustring1 == *ustring2) || (nocase && (Tcl_UniCharToLower(*ustring1) == u2lc[index/2]))) && /* Restrict max compare length. */ - ((end-ustring1) >= length2) && ((length2 == 1) || + (end-ustring1 >= length2) && ((length2 == 1) || !strCmpFn(ustring2, ustring1, length2))) { if (p != ustring1) { /* * Put the skipped chars onto the result first. */ - Tcl_AppendUnicodeToObj(resultPtr, p, ustring1-p); + TclAppendUnicodeToObj(resultPtr, p, ustring1-p); p = ustring1 + length2; } else { p += length2; @@ -2175,7 +2179,7 @@ StringMapCmd( * Append the map value to the Unicode string. */ - Tcl_AppendUnicodeToObj(resultPtr, + TclAppendUnicodeToObj(resultPtr, mapStrings[index+1], mapLens[index+1]); break; } @@ -2192,7 +2196,7 @@ StringMapCmd( * Put the rest of the unmapped chars onto result. */ - Tcl_AppendUnicodeToObj(resultPtr, p, ustring1 - p); + TclAppendUnicodeToObj(resultPtr, p, ustring1 - p); } Tcl_SetObjResult(interp, resultPtr); done: @@ -2241,7 +2245,8 @@ StringMatchCmd( Tcl_Size length; const char *string = TclGetStringFromObj(objv[1], &length); - if ((length > 1) && strncmp(string, "-nocase", length) == 0) { + if ((length > 1) && + strncmp(string, "-nocase", length) == 0) { nocase = TCL_MATCH_NOCASE; } else { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -2293,7 +2298,7 @@ StringRangeCmd( * 'end' refers to the last character, not one past it. */ - end = Tcl_GetCharLength(objv[1]) - 1; + end = TclGetCharLength(objv[1]) - 1; if (TclGetIntForIndexM(interp, objv[2], end, &first) != TCL_OK || TclGetIntForIndexM(interp, objv[3], end, &last) != TCL_OK) { @@ -2301,7 +2306,7 @@ StringRangeCmd( } if (last >= 0) { - Tcl_SetObjResult(interp, Tcl_GetRange(objv[1], first, last)); + Tcl_SetObjResult(interp, TclGetRange(objv[1], first, last)); } return TCL_OK; } @@ -2331,7 +2336,7 @@ StringReptCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_WideInt count; + int count; Tcl_Obj *resultPtr; if (objc != 3) { @@ -2339,7 +2344,7 @@ StringReptCmd( return TCL_ERROR; } - if (TclGetWideIntFromObj(interp, objv[2], &count) != TCL_OK) { + if (TclGetIntFromObj(interp, objv[2], &count) != TCL_OK) { return TCL_ERROR; } @@ -2394,7 +2399,7 @@ StringRplcCmd( return TCL_ERROR; } - end = Tcl_GetCharLength(objv[1]) - 1; + end = TclGetCharLength(objv[1]) - 1; if (TclGetIntForIndexM(interp, objv[2], end, &first) != TCL_OK || TclGetIntForIndexM(interp, objv[3], end, &last) != TCL_OK) { @@ -2407,7 +2412,7 @@ StringRplcCmd( * result is the original string. */ - if ((last < 0) || /* Range ends before start of 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 */ /* @@ -2421,7 +2426,7 @@ StringRplcCmd( Tcl_Obj *resultPtr; if (first < 0) { - first = TCL_INDEX_START; + first = 0; } if (last > end) { last = end; @@ -2507,7 +2512,7 @@ StringStartCmd( return TCL_ERROR; } - string = Tcl_GetUnicodeFromObj(objv[1], &length); + string = TclGetUnicodeFromObj(objv[1], &length); if (TclGetIntForIndexM(interp, objv[2], length-1, &index) != TCL_OK) { return TCL_ERROR; } @@ -2527,7 +2532,7 @@ StringStartCmd( break; } - next = ((p > string) ? (p - 1) : p); + next = (p > string) ? p - 1 : p; do { next += delta; ch = *next; @@ -2578,7 +2583,7 @@ StringEndCmd( return TCL_ERROR; } - string = Tcl_GetUnicodeFromObj(objv[1], &length); + string = TclGetUnicodeFromObj(objv[1], &length); if (TclGetIntForIndexM(interp, objv[2], length-1, &index) != TCL_OK) { return TCL_ERROR; } @@ -2658,7 +2663,7 @@ StringEqualCmd( goto str_cmp_args; } i++; - if (TclGetWideIntFromObj(interp, objv[i], &reqlength) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[i], &reqlength) != TCL_OK) { return TCL_ERROR; } if ((Tcl_WideUInt)reqlength > TCL_SIZE_MAX) { @@ -2761,7 +2766,7 @@ StringCmpOpts( goto str_cmp_args; } i++; - if (TclGetWideIntFromObj(interp, objv[i], &wreqlength) != TCL_OK) { + if (Tcl_GetWideIntFromObj(interp, objv[i], &wreqlength) != TCL_OK) { return TCL_ERROR; } if ((Tcl_WideUInt)wreqlength > TCL_SIZE_MAX) { @@ -2828,6 +2833,45 @@ StringCatCmd( /* *---------------------------------------------------------------------- * + * StringBytesCmd -- + * + * This procedure is invoked to process the "string bytelength" 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. + * + *---------------------------------------------------------------------- + */ +#if TCL_MAJOR_VERSION < 9 && !defined(TCL_NO_DEPRECATED) +static int +StringBytesCmd( + TCL_UNUSED(ClientData), + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int length; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "string"); + return TCL_ERROR; + } + + (void) TclGetStringFromObj(objv[1], &length); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(length)); + return TCL_OK; +} +#endif + +/* + *---------------------------------------------------------------------- + * * StringLenCmd -- * * This procedure is invoked to process the "string length" Tcl command. @@ -2855,7 +2899,7 @@ StringLenCmd( return TCL_ERROR; } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(Tcl_GetCharLength(objv[1]))); + Tcl_SetObjResult(interp, Tcl_NewWideIntObj(TclGetCharLength(objv[1]))); return TCL_OK; } @@ -2906,7 +2950,7 @@ StringLowerCmd( const char *start, *end; Tcl_Obj *resultPtr; - length1 = Tcl_NumUtfChars(string1, length1) - 1; + length1 = TclNumUtfChars(string1, length1) - 1; if (TclGetIntForIndexM(interp,objv[2],length1, &first) != TCL_OK) { return TCL_ERROR; } @@ -2929,8 +2973,8 @@ StringLowerCmd( } string1 = TclGetStringFromObj(objv[1], &length1); - start = Tcl_UtfAtIndex(string1, first); - end = Tcl_UtfAtIndex(start, last - first + 1); + start = TclUtfAtIndex(string1, first); + end = TclUtfAtIndex(start, last - first + 1); resultPtr = Tcl_NewStringObj(string1, end - string1); string2 = TclGetString(resultPtr) + (start - string1); @@ -2991,7 +3035,7 @@ StringUpperCmd( const char *start, *end; Tcl_Obj *resultPtr; - length1 = Tcl_NumUtfChars(string1, length1) - 1; + length1 = TclNumUtfChars(string1, length1) - 1; if (TclGetIntForIndexM(interp,objv[2],length1, &first) != TCL_OK) { return TCL_ERROR; } @@ -3014,8 +3058,8 @@ StringUpperCmd( } string1 = TclGetStringFromObj(objv[1], &length1); - start = Tcl_UtfAtIndex(string1, first); - end = Tcl_UtfAtIndex(start, last - first + 1); + start = TclUtfAtIndex(string1, first); + end = TclUtfAtIndex(start, last - first + 1); resultPtr = Tcl_NewStringObj(string1, end - string1); string2 = TclGetString(resultPtr) + (start - string1); @@ -3076,7 +3120,7 @@ StringTitleCmd( const char *start, *end; Tcl_Obj *resultPtr; - length1 = Tcl_NumUtfChars(string1, length1) - 1; + length1 = TclNumUtfChars(string1, length1) - 1; if (TclGetIntForIndexM(interp,objv[2],length1, &first) != TCL_OK) { return TCL_ERROR; } @@ -3099,8 +3143,8 @@ StringTitleCmd( } string1 = TclGetStringFromObj(objv[1], &length1); - start = Tcl_UtfAtIndex(string1, first); - end = Tcl_UtfAtIndex(start, last - first + 1); + start = TclUtfAtIndex(string1, first); + end = TclUtfAtIndex(start, last - first + 1); resultPtr = Tcl_NewStringObj(string1, end - string1); string2 = TclGetString(resultPtr) + (start - string1); @@ -3140,7 +3184,7 @@ StringTrimCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { const char *string1, *string2; - Tcl_Size triml, trimr, length1, length2; + int triml, trimr, length1, length2; if (objc == 3) { string2 = TclGetStringFromObj(objv[2], &length2); @@ -3282,6 +3326,9 @@ TclInitStringCmd( Tcl_Interp *interp) /* Current interpreter. */ { static const EnsembleImplMap stringImplMap[] = { +#if TCL_MAJOR_VERSION < 9 && !defined(TCL_NO_DEPRECATED) + {"bytelength", StringBytesCmd, TclCompileBasic1ArgCmd, NULL, NULL, 0}, +#endif {"cat", StringCatCmd, TclCompileStringCatCmd, NULL, NULL, 0}, {"compare", StringCmpCmd, TclCompileStringCmpCmd, NULL, NULL, 0}, {"equal", StringEqualCmd, TclCompileStringEqualCmd, NULL, NULL, 0}, @@ -3433,7 +3480,7 @@ TclNRSwitchObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int i, mode, foundmode, splitObjs, numMatchesSaved; + int i, index, mode, foundmode, splitObjs, numMatchesSaved; int noCase; Tcl_Size patternLength, j; const char *pattern; @@ -3459,7 +3506,7 @@ TclNRSwitchObjCmd( enum switchOptionsEnum { OPT_EXACT, OPT_GLOB, OPT_INDEXV, OPT_MATCHV, OPT_NOCASE, OPT_REGEXP, OPT_LAST - } index; + }; typedef int (*strCmpFn_t)(const char *, const char *); strCmpFn_t strCmpFn = TclUtfCmp; @@ -3477,7 +3524,7 @@ TclNRSwitchObjCmd( &index) != TCL_OK) { return TCL_ERROR; } - switch (index) { + switch ((enum switchOptionsEnum) index) { /* * General options. */ @@ -3583,10 +3630,9 @@ TclNRSwitchObjCmd( splitObjs = 0; if (objc == 1) { Tcl_Obj **listv; - Tcl_Size listc; blist = objv[0]; - if (TclListObjLength(interp, objv[0], &listc) != TCL_OK) { + if (TclListObjLength(interp, objv[0], &objc) != TCL_OK) { return TCL_ERROR; } @@ -3594,15 +3640,14 @@ TclNRSwitchObjCmd( * Ensure that the list is non-empty. */ - if (listc < 1 || listc > INT_MAX) { + if (objc < 1) { Tcl_WrongNumArgs(interp, 1, savedObjv, "?-option ...? string {?pattern body ...? ?default body?}"); return TCL_ERROR; } - if (TclListObjGetElements(interp, objv[0], &listc, &listv) != TCL_OK) { + if (TclListObjGetElements(interp, objv[0], &objc, &listv) != TCL_OK) { return TCL_ERROR; } - objc = listc; objv = listv; splitObjs = 1; } @@ -3771,7 +3816,7 @@ TclNRSwitchObjCmd( Tcl_Obj *substringObj; if (info.matches[j].end > 0) { - substringObj = Tcl_GetRange(stringObj, + substringObj = TclGetRange(stringObj, info.matches[j].start, info.matches[j].end-1); } else { TclNewObj(substringObj); @@ -3852,7 +3897,7 @@ TclNRSwitchObjCmd( if (ctxPtr->type == TCL_LOCATION_SOURCE && ctxPtr->line[bidx] >= 0) { int bline = ctxPtr->line[bidx]; - ctxPtr->line = (Tcl_Size *)Tcl_Alloc(objc * sizeof(Tcl_Size)); + ctxPtr->line = (Tcl_Size *)ckalloc(objc * sizeof(Tcl_Size)); ctxPtr->nline = objc; TclListLines(blist, bline, objc, ctxPtr->line, objv); } else { @@ -3866,7 +3911,7 @@ TclNRSwitchObjCmd( int k; - ctxPtr->line = (Tcl_Size *)Tcl_Alloc(objc * sizeof(Tcl_Size)); + ctxPtr->line = (Tcl_Size *)ckalloc(objc * sizeof(Tcl_Size)); ctxPtr->nline = objc; for (k=0; k < objc; k++) { ctxPtr->line[k] = -1; @@ -3916,7 +3961,7 @@ SwitchPostProc( */ if (splitObjs) { - Tcl_Free(ctxPtr->line); + ckfree(ctxPtr->line); if (pc && (ctxPtr->type == TCL_LOCATION_SOURCE)) { /* * Death of SrcInfo reference. @@ -3936,7 +3981,7 @@ SwitchPostProc( Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (\"%.*s%s\" arm line %d)", - (int) (overflow ? limit : patternLength), pattern, + (overflow ? limit : patternLength), pattern, (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); } TclStackFree(interp, ctxPtr); @@ -4159,7 +4204,7 @@ Tcl_TimeRateObjCmd( ByteCode *codePtr = NULL; for (i = 1; i < objc - 1; i++) { - enum timeRateOptionsEnum index; + int index; if (Tcl_GetIndexFromObj(NULL, objv[i], options, "option", TCL_EXACT, &index) != TCL_OK) { @@ -4169,7 +4214,7 @@ Tcl_TimeRateObjCmd( i++; break; } - switch (index) { + switch ((enum timeRateOptionsEnum)index) { case TMRT_EV_DIRECT: direct = objv[i]; break; @@ -4198,15 +4243,14 @@ Tcl_TimeRateObjCmd( } objPtr = objv[i++]; if (i < objc) { /* max-time */ - result = TclGetWideIntFromObj(interp, objv[i], &maxms); - i++; // Keep this separate from TclGetWideIntFromObj macro above! + result = Tcl_GetWideIntFromObj(interp, objv[i++], &maxms); if (result != TCL_OK) { return result; } if (i < objc) { /* max-count*/ Tcl_WideInt v; - result = TclGetWideIntFromObj(interp, objv[i], &v); + result = Tcl_GetWideIntFromObj(interp, objv[i], &v); if (result != TCL_OK) { return result; } @@ -4710,7 +4754,7 @@ TclNRTryObjCmd( bodyShared = 0; haveHandlers = 0; for (i=2 ; i<objc ; i++) { - enum Handlers type; + int type; Tcl_Obj *info[5]; if (Tcl_GetIndexFromObj(interp, objv[i], handlerNames, "handler type", @@ -4718,7 +4762,7 @@ TclNRTryObjCmd( Tcl_DecrRefCount(handlersObj); return TCL_ERROR; } - switch (type) { + switch ((enum Handlers) type) { case TryFinally: /* finally script */ if (i < objc-2) { Tcl_SetObjResult(interp, Tcl_NewStringObj( diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 99a97ad..2fdc22d 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -286,8 +286,7 @@ TclCompileArraySetCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr, *dataTokenPtr; int isScalar, localIndex, code = TCL_OK; - int isDataLiteral, isDataValid, isDataEven; - Tcl_Size len; + int isDataLiteral, isDataValid, isDataEven, len; int keyVar, valVar, infoIndex; int fwd, offsetBack, offsetFwd; Tcl_Obj *literalObj; @@ -391,9 +390,9 @@ TclCompileArraySetCmd( keyVar = AnonymousLocal(envPtr); valVar = AnonymousLocal(envPtr); - infoPtr = (ForeachInfo *)Tcl_Alloc(offsetof(ForeachInfo, varLists) + sizeof(ForeachVarList *)); + infoPtr = (ForeachInfo *)ckalloc(offsetof(ForeachInfo, varLists) + sizeof(ForeachVarList *)); infoPtr->numLists = 1; - infoPtr->varLists[0] = (ForeachVarList *)Tcl_Alloc(offsetof(ForeachVarList, varIndexes) + 2 * sizeof(Tcl_Size)); + infoPtr->varLists[0] = (ForeachVarList *)ckalloc(offsetof(ForeachVarList, varIndexes) + 2 * sizeof(int)); infoPtr->varLists[0]->numVars = 2; infoPtr->varLists[0]->varIndexes[0] = keyVar; infoPtr->varLists[0]->varIndexes[1] = valVar; @@ -584,7 +583,7 @@ TclCompileCatchCmd( * Let runtime checks determine if syntax has changed. */ - if (((int)parsePtr->numWords < 2) || ((int)parsePtr->numWords > 4)) { + if ((parsePtr->numWords < 2) || (parsePtr->numWords > 4)) { return TCL_ERROR; } @@ -593,7 +592,7 @@ TclCompileCatchCmd( * (not in a procedure), don't compile it inline: the payoff is too small. */ - if (((int)parsePtr->numWords >= 3) && !EnvHasLVT(envPtr)) { + if ((parsePtr->numWords >= 3) && !EnvHasLVT(envPtr)) { return TCL_ERROR; } @@ -604,7 +603,7 @@ TclCompileCatchCmd( resultIndex = optsIndex = -1; cmdTokenPtr = TokenAfter(parsePtr->tokenPtr); - if ((int)parsePtr->numWords >= 3) { + if (parsePtr->numWords >= 3) { resultNameTokenPtr = TokenAfter(cmdTokenPtr); /* DGP */ resultIndex = LocalScalarFromToken(resultNameTokenPtr, envPtr); @@ -687,8 +686,8 @@ TclCompileCatchCmd( /* Stack at this point on both branches: result returnCode */ if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { - Tcl_Panic("TclCompileCatchCmd: bad jump distance %" TCL_Z_MODIFIER "d", - (CurrentOffset(envPtr) - jumpFixup.codeOffset)); + Tcl_Panic("TclCompileCatchCmd: bad jump distance %d", + (int)(CurrentOffset(envPtr) - jumpFixup.codeOffset)); } /* @@ -772,15 +771,15 @@ TclCompileClockClicksCmd( */ tokenPtr = TokenAfter(parsePtr->tokenPtr); if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD - || tokenPtr[1].size < 4 - || tokenPtr[1].size > 13) { + || tokenPtr[1].size < 4 + || tokenPtr[1].size > 13) { return TCL_ERROR; } else if (!strncmp(tokenPtr[1].start, "-microseconds", - tokenPtr[1].size)) { + tokenPtr[1].size)) { TclEmitInstInt1(INST_CLOCK_READ, 1, envPtr); break; } else if (!strncmp(tokenPtr[1].start, "-milliseconds", - tokenPtr[1].size)) { + tokenPtr[1].size)) { TclEmitInstInt1(INST_CLOCK_READ, 2, envPtr); break; } else { @@ -877,7 +876,7 @@ TclCompileConcatCmd( */ TclNewObj(listObj); - for (i = 1, tokenPtr = parsePtr->tokenPtr; i < (int)parsePtr->numWords; i++) { + for (i = 1, tokenPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++) { tokenPtr = TokenAfter(tokenPtr); TclNewObj(objPtr); if (!TclWordKnownAtCompileTime(tokenPtr, objPtr)) { @@ -891,13 +890,13 @@ TclCompileConcatCmd( if (listObj != NULL) { Tcl_Obj **objs; const char *bytes; - Tcl_Size len, slen; + int len; TclListObjGetElements(NULL, listObj, &len, &objs); objPtr = Tcl_ConcatObj(len, objs); Tcl_DecrRefCount(listObj); - bytes = TclGetStringFromObj(objPtr, &slen); - PushLiteral(envPtr, bytes, slen); + bytes = TclGetStringFromObj(objPtr, &len); + PushLiteral(envPtr, bytes, len); Tcl_DecrRefCount(objPtr); return TCL_OK; } @@ -906,7 +905,7 @@ TclCompileConcatCmd( * General case: runtime concat. */ - for (i = 1, tokenPtr = parsePtr->tokenPtr; i < (int)parsePtr->numWords; i++) { + for (i = 1, tokenPtr = parsePtr->tokenPtr; i < parsePtr->numWords; i++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, i); } @@ -919,84 +918,6 @@ TclCompileConcatCmd( /* *---------------------------------------------------------------------- * - * TclCompileConstCmd -- - * - * Procedure called to compile the "const" command. - * - * Results: - * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer - * evaluation to runtime. - * - * Side effects: - * Instructions are added to envPtr to execute the "const" command at - * runtime. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileConstCmd( - Tcl_Interp *interp, /* The interpreter. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - TCL_UNUSED(Command *), - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - DefineLineInformation; /* TIP #280 */ - Tcl_Token *varTokenPtr, *valueTokenPtr; - int isScalar, localIndex; - - /* - * Need exactly two arguments. - */ - if (parsePtr->numWords != 3) { - return TCL_ERROR; - } - - /* - * Decide if we can use a frame slot for the var/array name or if we need - * to emit code to compute and push the name at runtime. We use a frame - * slot (entry in the array of local vars) if we are compiling a procedure - * body and if the name is simple text that does not include namespace - * qualifiers. - */ - - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - PushVarNameWord(interp, varTokenPtr, envPtr, 0, - &localIndex, &isScalar, 1); - - /* - * If the user specified an array element, we don't bother handling - * that. - */ - if (!isScalar) { - return TCL_ERROR; - } - - /* - * We are doing an assignment to set the value of the constant. This will - * need to be extended to push a value for each argument. - */ - - valueTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, valueTokenPtr, interp, 2); - - if (localIndex < 0) { - TclEmitOpcode(INST_CONST_STK, envPtr); - } else { - TclEmitInstInt4(INST_CONST_IMM, localIndex, envPtr); - } - - /* - * The const command's result is an empty string. - */ - PushStringLiteral(envPtr, ""); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * * TclCompileContinueCmd -- * * Procedure called to compile the "continue" command. @@ -1091,7 +1012,7 @@ TclCompileDictSetCmd( * There must be at least one argument after the command. */ - if ((int)parsePtr->numWords < 4) { + if (parsePtr->numWords < 4) { return TCL_ERROR; } @@ -1112,7 +1033,7 @@ TclCompileDictSetCmd( */ tokenPtr = TokenAfter(varTokenPtr); - for (i=2 ; i< (int)parsePtr->numWords ; i++) { + for (i=2 ; i< parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } @@ -1121,7 +1042,7 @@ TclCompileDictSetCmd( * Now emit the instruction to do the dict manipulation. */ - TclEmitInstInt4( INST_DICT_SET, (int)parsePtr->numWords-3, envPtr); + TclEmitInstInt4( INST_DICT_SET, parsePtr->numWords-3, envPtr); TclEmitInt4( dictVarIndex, envPtr); TclAdjustStackDepth(-1, envPtr); return TCL_OK; @@ -1144,7 +1065,7 @@ TclCompileDictIncrCmd( * There must be at least two arguments after the command. */ - if ((int)parsePtr->numWords < 3 || (int)parsePtr->numWords > 4) { + if (parsePtr->numWords < 3 || parsePtr->numWords > 4) { return TCL_ERROR; } varTokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1156,8 +1077,7 @@ TclCompileDictIncrCmd( if (parsePtr->numWords == 4) { const char *word; - Tcl_Size numBytes; - int code; + int numBytes, code; Tcl_Token *incrTokenPtr; Tcl_Obj *intObj; @@ -1218,7 +1138,7 @@ TclCompileDictGetCmd( */ /* TODO: Consider support for compiling expanded args. */ - if ((int)parsePtr->numWords < 3) { + if (parsePtr->numWords < 3) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1227,11 +1147,11 @@ TclCompileDictGetCmd( * Only compile this because we need INST_DICT_GET anyway. */ - for (i=1 ; i<(int)parsePtr->numWords ; i++) { + for (i=1 ; i<parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4(INST_DICT_GET, (int)parsePtr->numWords-2, envPtr); + TclEmitInstInt4(INST_DICT_GET, parsePtr->numWords-2, envPtr); TclAdjustStackDepth(-1, envPtr); return TCL_OK; } @@ -1253,16 +1173,16 @@ TclCompileDictGetWithDefaultCmd( */ /* TODO: Consider support for compiling expanded args. */ - if ((int)parsePtr->numWords < 4) { + if (parsePtr->numWords < 4) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); - for (i=1 ; i<(int)parsePtr->numWords ; i++) { + for (i=1 ; i<parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4(INST_DICT_GET_DEF, (int)parsePtr->numWords-3, envPtr); + TclEmitInstInt4(INST_DICT_GET_DEF, parsePtr->numWords-3, envPtr); TclAdjustStackDepth(-2, envPtr); return TCL_OK; } @@ -1285,7 +1205,7 @@ TclCompileDictExistsCmd( */ /* TODO: Consider support for compiling expanded args. */ - if ((int)parsePtr->numWords < 3) { + if (parsePtr->numWords < 3) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1294,11 +1214,11 @@ TclCompileDictExistsCmd( * Now we do the code generation. */ - for (i=1 ; i<(int)parsePtr->numWords ; i++) { + for (i=1 ; i<parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4(INST_DICT_EXISTS, (int)parsePtr->numWords-2, envPtr); + TclEmitInstInt4(INST_DICT_EXISTS, parsePtr->numWords-2, envPtr); TclAdjustStackDepth(-1, envPtr); return TCL_OK; } @@ -1322,7 +1242,7 @@ TclCompileDictUnsetCmd( */ /* TODO: Consider support for compiling expanded args. */ - if ((int)parsePtr->numWords < 3) { + if (parsePtr->numWords < 3) { return TCL_ERROR; } @@ -1342,7 +1262,7 @@ TclCompileDictUnsetCmd( * Remaining words (the key path) can be handled normally. */ - for (i=2 ; i<(int)parsePtr->numWords ; i++) { + for (i=2 ; i<parsePtr->numWords ; i++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, i); } @@ -1351,7 +1271,7 @@ TclCompileDictUnsetCmd( * Now emit the instruction to do the dict manipulation. */ - TclEmitInstInt4( INST_DICT_UNSET, (int)parsePtr->numWords-2, envPtr); + TclEmitInstInt4( INST_DICT_UNSET, parsePtr->numWords-2, envPtr); TclEmitInt4( dictVarIndex, envPtr); return TCL_OK; } @@ -1370,8 +1290,7 @@ TclCompileDictCreateCmd( Tcl_Token *tokenPtr; Tcl_Obj *keyObj, *valueObj, *dictObj; const char *bytes; - int i; - Tcl_Size len; + int i, len; if ((parsePtr->numWords & 1) == 0) { return TCL_ERROR; @@ -1384,7 +1303,7 @@ TclCompileDictCreateCmd( tokenPtr = TokenAfter(parsePtr->tokenPtr); TclNewObj(dictObj); Tcl_IncrRefCount(dictObj); - for (i=1 ; i<(int)parsePtr->numWords ; i+=2) { + for (i=1 ; i<parsePtr->numWords ; i+=2) { TclNewObj(keyObj); Tcl_IncrRefCount(keyObj); if (!TclWordKnownAtCompileTime(tokenPtr, keyObj)) { @@ -1434,7 +1353,7 @@ TclCompileDictCreateCmd( Emit14Inst( INST_STORE_SCALAR, worker, envPtr); TclEmitOpcode( INST_POP, envPtr); tokenPtr = TokenAfter(parsePtr->tokenPtr); - for (i=1 ; i<(int)parsePtr->numWords ; i+=2) { + for (i=1 ; i<parsePtr->numWords ; i+=2) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, i+1); @@ -1469,7 +1388,7 @@ TclCompileDictMergeCmd( */ /* TODO: Consider support for compiling expanded args. (less likely) */ - if ((int)parsePtr->numWords < 2) { + if (parsePtr->numWords < 2) { PushStringLiteral(envPtr, ""); return TCL_OK; } else if (parsePtr->numWords == 2) { @@ -1511,7 +1430,7 @@ TclCompileDictMergeCmd( outLoop = TclCreateExceptRange(CATCH_EXCEPTION_RANGE, envPtr); TclEmitInstInt4( INST_BEGIN_CATCH4, outLoop, envPtr); ExceptionRangeStarts(envPtr, outLoop); - for (i=2 ; i<(int)parsePtr->numWords ; i++) { + for (i=2 ; i<parsePtr->numWords ; i++) { /* * Get the dictionary, and merge its pairs into the first dict (using * a small loop). @@ -1606,8 +1525,7 @@ CompileDictEachCmd( Tcl_Token *varsTokenPtr, *dictTokenPtr, *bodyTokenPtr; int keyVarIndex, valueVarIndex, nameChars, loopRange, catchRange; int infoIndex, jumpDisplacement, bodyTargetOffset, emptyTargetOffset; - Tcl_Size numVars; - int endTargetOffset; + int numVars, endTargetOffset; int collectVar = -1; /* Index of temp var holding the result * dict. */ const char **argv; @@ -1655,7 +1573,7 @@ CompileDictEachCmd( } Tcl_DStringFree(&buffer); if (numVars != 2) { - Tcl_Free((void *)argv); + ckfree(argv); return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); } @@ -1663,7 +1581,7 @@ CompileDictEachCmd( keyVarIndex = LocalScalar(argv[0], nameChars, envPtr); nameChars = strlen(argv[1]); valueVarIndex = LocalScalar(argv[1], nameChars, envPtr); - Tcl_Free((void *)argv); + ckfree(argv); if ((keyVarIndex < 0) || (valueVarIndex < 0)) { return TclCompileBasic3ArgCmd(interp, parsePtr, cmdPtr, envPtr); @@ -1839,7 +1757,7 @@ TclCompileDictUpdateCmd( * There must be at least one argument after the command. */ - if ((int)parsePtr->numWords < 5) { + if (parsePtr->numWords < 5) { return TCL_ERROR; } @@ -1848,7 +1766,7 @@ TclCompileDictUpdateCmd( * dict update <lit(eral)> <any> <lit> ?<any> <lit> ...? <lit> */ - if (((int)parsePtr->numWords - 1) & 1) { + if ((parsePtr->numWords - 1) & 1) { return TCL_ERROR; } numVars = (parsePtr->numWords - 3) / 2; @@ -1871,7 +1789,7 @@ TclCompileDictUpdateCmd( * that are to be used. */ - duiPtr = (DictUpdateInfo *)Tcl_Alloc(offsetof(DictUpdateInfo, varIndices) + sizeof(size_t) * numVars); + duiPtr = (DictUpdateInfo *)ckalloc(offsetof(DictUpdateInfo, varIndices) + sizeof(int) * numVars); duiPtr->length = numVars; keyTokenPtrs = (Tcl_Token **)TclStackAlloc(interp, sizeof(Tcl_Token *) * numVars); tokenPtr = TokenAfter(dictVarTokenPtr); @@ -1890,7 +1808,7 @@ TclCompileDictUpdateCmd( */ duiPtr->varIndices[i] = LocalScalarFromToken(tokenPtr, envPtr); - if (duiPtr->varIndices[i] == TCL_INDEX_NONE) { + if (duiPtr->varIndices[i] < 0) { goto failedUpdateInfoAssembly; } tokenPtr = TokenAfter(tokenPtr); @@ -1954,8 +1872,8 @@ TclCompileDictUpdateCmd( TclEmitInvoke(envPtr,INST_RETURN_STK); if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { - Tcl_Panic("TclCompileDictCmd(update): bad jump distance %" TCL_Z_MODIFIER "d", - CurrentOffset(envPtr) - jumpFixup.codeOffset); + Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d", + (int) (CurrentOffset(envPtr) - jumpFixup.codeOffset)); } TclStackFree(interp, keyTokenPtrs); return TCL_OK; @@ -1965,7 +1883,7 @@ TclCompileDictUpdateCmd( */ failedUpdateInfoAssembly: - Tcl_Free(duiPtr); + ckfree(duiPtr); TclStackFree(interp, keyTokenPtrs); issueFallback: return TclCompileBasicMin2ArgCmd(interp, parsePtr, cmdPtr, envPtr); @@ -1991,7 +1909,7 @@ TclCompileDictAppendCmd( */ /* TODO: Consider support for compiling expanded args. */ - if ((int)parsePtr->numWords<4 || (int)parsePtr->numWords>100) { + if (parsePtr->numWords<4 || parsePtr->numWords>100) { return TCL_ERROR; } @@ -2010,12 +1928,12 @@ TclCompileDictAppendCmd( */ tokenPtr = TokenAfter(tokenPtr); - for (i=2 ; i<(int)parsePtr->numWords ; i++) { + for (i=2 ; i<parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - if ((int)parsePtr->numWords > 4) { - TclEmitInstInt1(INST_STR_CONCAT1, (int)parsePtr->numWords-3, envPtr); + if (parsePtr->numWords > 4) { + TclEmitInstInt1(INST_STR_CONCAT1, parsePtr->numWords-3, envPtr); } /* @@ -2092,7 +2010,7 @@ TclCompileDictWithCmd( */ /* TODO: Consider support for compiling expanded args. */ - if ((int)parsePtr->numWords < 3) { + if (parsePtr->numWords < 3) { return TCL_ERROR; } @@ -2103,7 +2021,7 @@ TclCompileDictWithCmd( varTokenPtr = TokenAfter(parsePtr->tokenPtr); tokenPtr = TokenAfter(varTokenPtr); - for (i=3 ; i<(int)parsePtr->numWords ; i++) { + for (i=3 ; i<parsePtr->numWords ; i++) { tokenPtr = TokenAfter(tokenPtr); } if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { @@ -2131,7 +2049,7 @@ TclCompileDictWithCmd( * Determine if we're manipulating a dict in a simple local variable. */ - gotPath = ((int)parsePtr->numWords > 3); + gotPath = (parsePtr->numWords > 3); dictVar = LocalScalarFromToken(varTokenPtr, envPtr); /* @@ -2150,11 +2068,11 @@ TclCompileDictWithCmd( */ tokenPtr = TokenAfter(varTokenPtr); - for (i=2 ; i<(int)parsePtr->numWords-1 ; i++) { + for (i=2 ; i<parsePtr->numWords-1 ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4(INST_LIST, (int)parsePtr->numWords-3,envPtr); + TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr); Emit14Inst( INST_LOAD_SCALAR, dictVar, envPtr); TclEmitInstInt4(INST_OVER, 1, envPtr); TclEmitOpcode( INST_DICT_EXPAND, envPtr); @@ -2177,11 +2095,11 @@ TclCompileDictWithCmd( */ tokenPtr = varTokenPtr; - for (i=1 ; i<(int)parsePtr->numWords-1 ; i++) { + for (i=1 ; i<parsePtr->numWords-1 ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4(INST_LIST, (int)parsePtr->numWords-3,envPtr); + TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr); TclEmitInstInt4(INST_OVER, 1, envPtr); TclEmitOpcode( INST_LOAD_STK, envPtr); TclEmitInstInt4(INST_OVER, 1, envPtr); @@ -2232,11 +2150,11 @@ TclCompileDictWithCmd( } tokenPtr = TokenAfter(varTokenPtr); if (gotPath) { - for (i=2 ; i<(int)parsePtr->numWords-1 ; i++) { + for (i=2 ; i<parsePtr->numWords-1 ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4( INST_LIST, (int)parsePtr->numWords-3,envPtr); + TclEmitInstInt4( INST_LIST, parsePtr->numWords-3,envPtr); Emit14Inst( INST_STORE_SCALAR, pathTmp, envPtr); TclEmitOpcode( INST_POP, envPtr); } @@ -2298,7 +2216,7 @@ TclCompileDictWithCmd( if (dictVar == -1) { Emit14Inst( INST_LOAD_SCALAR, varNameTmp, envPtr); } - if ((int)parsePtr->numWords > 3) { + if (parsePtr->numWords > 3) { Emit14Inst( INST_LOAD_SCALAR, pathTmp, envPtr); } else { PushStringLiteral(envPtr, ""); @@ -2316,8 +2234,8 @@ TclCompileDictWithCmd( */ if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) { - Tcl_Panic("TclCompileDictCmd(update): bad jump distance %" TCL_Z_MODIFIER "d", - CurrentOffset(envPtr) - jumpFixup.codeOffset); + Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d", + (int) (CurrentOffset(envPtr) - jumpFixup.codeOffset)); } return TCL_OK; } @@ -2353,8 +2271,8 @@ DupDictUpdateInfo( size_t len; dui1Ptr = (DictUpdateInfo *)clientData; - len = offsetof(DictUpdateInfo, varIndices) + sizeof(size_t) * dui1Ptr->length; - dui2Ptr = (DictUpdateInfo *)Tcl_Alloc(len); + len = offsetof(DictUpdateInfo, varIndices) + sizeof(int) * dui1Ptr->length; + dui2Ptr = (DictUpdateInfo *)ckalloc(len); memcpy(dui2Ptr, dui1Ptr, len); return dui2Ptr; } @@ -2363,7 +2281,7 @@ static void FreeDictUpdateInfo( void *clientData) { - Tcl_Free(clientData); + ckfree(clientData); } static void @@ -2371,16 +2289,16 @@ PrintDictUpdateInfo( void *clientData, Tcl_Obj *appendObj, TCL_UNUSED(ByteCode *), - TCL_UNUSED(size_t)) + TCL_UNUSED(unsigned int)) { DictUpdateInfo *duiPtr = (DictUpdateInfo *)clientData; - Tcl_Size i; + int i; for (i=0 ; i<duiPtr->length ; i++) { if (i) { Tcl_AppendToObj(appendObj, ", ", -1); } - Tcl_AppendPrintfToObj(appendObj, "%%v%" TCL_Z_MODIFIER "u", duiPtr->varIndices[i]); + Tcl_AppendPrintfToObj(appendObj, "%%v%u", duiPtr->varIndices[i]); } } @@ -2389,10 +2307,10 @@ DisassembleDictUpdateInfo( void *clientData, Tcl_Obj *dictObj, TCL_UNUSED(ByteCode *), - TCL_UNUSED(size_t)) + TCL_UNUSED(unsigned int)) { DictUpdateInfo *duiPtr = (DictUpdateInfo *)clientData; - Tcl_Size i; + int i; Tcl_Obj *variables; TclNewObj(variables); @@ -2437,7 +2355,7 @@ TclCompileErrorCmd( * General syntax: [error message ?errorInfo? ?errorCode?] */ - if ((int)parsePtr->numWords < 2 || (int)parsePtr->numWords > 4) { + if (parsePtr->numWords < 2 || parsePtr->numWords > 4) { return TCL_ERROR; } @@ -2517,7 +2435,7 @@ TclCompileExprCmd( envPtr->extCmdMapPtr->nuloc-1].line[1]; firstWordPtr = TokenAfter(parsePtr->tokenPtr); - TclCompileExprWords(interp, firstWordPtr, (int)parsePtr->numWords-1, envPtr); + TclCompileExprWords(interp, firstWordPtr, parsePtr->numWords-1, envPtr); return TCL_OK; } @@ -2767,8 +2685,7 @@ CompileEachloopCmd( Tcl_Token *tokenPtr, *bodyTokenPtr; int jumpBackOffset, infoIndex, range; - int numWords, numLists, i, code = TCL_OK; - Tcl_Size j; + int numWords, numLists, i, j, code = TCL_OK; Tcl_Obj *varListObj = NULL; /* @@ -2780,7 +2697,7 @@ CompileEachloopCmd( return TCL_ERROR; } - numWords = (int)parsePtr->numWords; + numWords = parsePtr->numWords; if ((numWords < 4) || (numWords%2 != 0)) { return TCL_ERROR; } @@ -2805,7 +2722,7 @@ CompileEachloopCmd( */ numLists = (numWords - 2)/2; - infoPtr = (ForeachInfo *)Tcl_Alloc(offsetof(ForeachInfo, varLists) + infoPtr = (ForeachInfo *)ckalloc(offsetof(ForeachInfo, varLists) + numLists * sizeof(ForeachVarList *)); infoPtr->numLists = 0; /* Count this up as we go */ @@ -2820,7 +2737,7 @@ CompileEachloopCmd( i < numWords-1; i++, tokenPtr = TokenAfter(tokenPtr)) { ForeachVarList *varListPtr; - Tcl_Size numVars; + int numVars; if (i%2 != 1) { continue; @@ -2839,8 +2756,8 @@ CompileEachloopCmd( goto done; } - varListPtr = (ForeachVarList *)Tcl_Alloc(offsetof(ForeachVarList, varIndexes) - + numVars * sizeof(varListPtr->varIndexes[0])); + varListPtr = (ForeachVarList *)ckalloc(offsetof(ForeachVarList, varIndexes) + + numVars * sizeof(int)); varListPtr->numVars = numVars; infoPtr->varLists[i/2] = varListPtr; infoPtr->numLists++; @@ -2848,13 +2765,11 @@ CompileEachloopCmd( for (j = 0; j < numVars; j++) { Tcl_Obj *varNameObj; const char *bytes; - int varIndex; - Tcl_Size length; - + int numBytes, varIndex; Tcl_ListObjIndex(NULL, varListObj, j, &varNameObj); - bytes = TclGetStringFromObj(varNameObj, &length); - varIndex = LocalScalar(bytes, length, envPtr); + bytes = TclGetStringFromObj(varNameObj, &numBytes); + varIndex = LocalScalar(bytes, numBytes, envPtr); if (varIndex < 0) { code = TCL_ERROR; goto done; @@ -2977,7 +2892,7 @@ DupForeachInfo( ForeachVarList *srcListPtr, *dupListPtr; int numVars, i, j, numLists = srcPtr->numLists; - dupPtr = (ForeachInfo *)Tcl_Alloc(offsetof(ForeachInfo, varLists) + dupPtr = (ForeachInfo *)ckalloc(offsetof(ForeachInfo, varLists) + numLists * sizeof(ForeachVarList *)); dupPtr->numLists = numLists; dupPtr->firstValueTemp = srcPtr->firstValueTemp; @@ -2986,8 +2901,8 @@ DupForeachInfo( for (i = 0; i < numLists; i++) { srcListPtr = srcPtr->varLists[i]; numVars = srcListPtr->numVars; - dupListPtr = (ForeachVarList *)Tcl_Alloc(offsetof(ForeachVarList, varIndexes) - + numVars * sizeof(size_t)); + dupListPtr = (ForeachVarList *)ckalloc(offsetof(ForeachVarList, varIndexes) + + numVars * sizeof(int)); dupListPtr->numVars = numVars; for (j = 0; j < numVars; j++) { dupListPtr->varIndexes[j] = srcListPtr->varIndexes[j]; @@ -3023,13 +2938,14 @@ FreeForeachInfo( { ForeachInfo *infoPtr = (ForeachInfo *)clientData; ForeachVarList *listPtr; - size_t i, numLists = infoPtr->numLists; + int numLists = infoPtr->numLists; + int i; for (i = 0; i < numLists; i++) { listPtr = infoPtr->varLists[i]; - Tcl_Free(listPtr); + ckfree(listPtr); } - Tcl_Free(infoPtr); + ckfree(infoPtr); } /* @@ -3054,11 +2970,11 @@ PrintForeachInfo( void *clientData, Tcl_Obj *appendObj, TCL_UNUSED(ByteCode *), - TCL_UNUSED(size_t)) + TCL_UNUSED(unsigned int)) { ForeachInfo *infoPtr = (ForeachInfo *)clientData; ForeachVarList *varsPtr; - Tcl_Size i, j; + int i, j; Tcl_AppendToObj(appendObj, "data=[", -1); @@ -3066,24 +2982,24 @@ PrintForeachInfo( if (i) { Tcl_AppendToObj(appendObj, ", ", -1); } - Tcl_AppendPrintfToObj(appendObj, "%%v%" TCL_Z_MODIFIER "u", - (infoPtr->firstValueTemp + i)); + Tcl_AppendPrintfToObj(appendObj, "%%v%u", + (unsigned) (infoPtr->firstValueTemp + i)); } - Tcl_AppendPrintfToObj(appendObj, "], loop=%%v%" TCL_Z_MODIFIER "u", - infoPtr->loopCtTemp); + Tcl_AppendPrintfToObj(appendObj, "], loop=%%v%u", + (unsigned) infoPtr->loopCtTemp); for (i=0 ; i<infoPtr->numLists ; i++) { if (i) { Tcl_AppendToObj(appendObj, ",", -1); } - Tcl_AppendPrintfToObj(appendObj, "\n\t\t it%%v%" TCL_Z_MODIFIER "u\t[", - (infoPtr->firstValueTemp + i)); + Tcl_AppendPrintfToObj(appendObj, "\n\t\t it%%v%u\t[", + (unsigned) (infoPtr->firstValueTemp + i)); varsPtr = infoPtr->varLists[i]; for (j=0 ; j<varsPtr->numVars ; j++) { if (j) { Tcl_AppendToObj(appendObj, ", ", -1); } - Tcl_AppendPrintfToObj(appendObj, "%%v%" TCL_Z_MODIFIER "u", - varsPtr->varIndexes[j]); + Tcl_AppendPrintfToObj(appendObj, "%%v%u", + (unsigned) varsPtr->varIndexes[j]); } Tcl_AppendToObj(appendObj, "]", -1); } @@ -3094,13 +3010,13 @@ PrintNewForeachInfo( void *clientData, Tcl_Obj *appendObj, TCL_UNUSED(ByteCode *), - TCL_UNUSED(size_t)) + TCL_UNUSED(unsigned int)) { ForeachInfo *infoPtr = (ForeachInfo *)clientData; ForeachVarList *varsPtr; - Tcl_Size i, j; + int i, j; - Tcl_AppendPrintfToObj(appendObj, "jumpOffset=%+" TCL_Z_MODIFIER "d, vars=", + Tcl_AppendPrintfToObj(appendObj, "jumpOffset=%+d, vars=", infoPtr->loopCtTemp); for (i=0 ; i<infoPtr->numLists ; i++) { if (i) { @@ -3112,8 +3028,8 @@ PrintNewForeachInfo( if (j) { Tcl_AppendToObj(appendObj, ",", -1); } - Tcl_AppendPrintfToObj(appendObj, "%%v%" TCL_Z_MODIFIER "u", - varsPtr->varIndexes[j]); + Tcl_AppendPrintfToObj(appendObj, "%%v%u", + (unsigned) varsPtr->varIndexes[j]); } Tcl_AppendToObj(appendObj, "]", -1); } @@ -3124,11 +3040,11 @@ DisassembleForeachInfo( void *clientData, Tcl_Obj *dictObj, TCL_UNUSED(ByteCode *), - TCL_UNUSED(size_t)) + TCL_UNUSED(unsigned int)) { ForeachInfo *infoPtr = (ForeachInfo *)clientData; ForeachVarList *varsPtr; - Tcl_Size i, j; + int i, j; Tcl_Obj *objPtr, *innerPtr; /* @@ -3171,11 +3087,11 @@ DisassembleNewForeachInfo( void *clientData, Tcl_Obj *dictObj, TCL_UNUSED(ByteCode *), - TCL_UNUSED(size_t)) + TCL_UNUSED(unsigned int)) { ForeachInfo *infoPtr = (ForeachInfo *)clientData; ForeachVarList *varsPtr; - Tcl_Size i, j; + int i, j; Tcl_Obj *objPtr, *innerPtr; /* @@ -3233,14 +3149,13 @@ TclCompileFormatCmd( Tcl_Token *tokenPtr = parsePtr->tokenPtr; Tcl_Obj **objv, *formatObj, *tmpObj; const char *bytes, *start; - int i, j; - Tcl_Size len; + int i, j, len; /* * Don't handle any guaranteed-error cases. */ - if ((int)parsePtr->numWords < 2) { + if (parsePtr->numWords < 2) { return TCL_ERROR; } @@ -3257,8 +3172,8 @@ TclCompileFormatCmd( return TCL_ERROR; } - objv = (Tcl_Obj **)Tcl_Alloc(((int)parsePtr->numWords-2) * sizeof(Tcl_Obj *)); - for (i=0 ; i+2 < (int)parsePtr->numWords ; i++) { + objv = (Tcl_Obj **)ckalloc((parsePtr->numWords-2) * sizeof(Tcl_Obj *)); + for (i=0 ; i+2 < parsePtr->numWords ; i++) { tokenPtr = TokenAfter(tokenPtr); TclNewObj(objv[i]); Tcl_IncrRefCount(objv[i]); @@ -3273,11 +3188,11 @@ TclCompileFormatCmd( */ tmpObj = Tcl_Format(interp, TclGetString(formatObj), - (int)parsePtr->numWords-2, objv); + parsePtr->numWords-2, objv); for (; --i>=0 ;) { Tcl_DecrRefCount(objv[i]); } - Tcl_Free(objv); + ckfree(objv); Tcl_DecrRefCount(formatObj); if (tmpObj == NULL) { TclCompileSyntaxError(interp, envPtr); @@ -3307,7 +3222,7 @@ TclCompileFormatCmd( for (; i>=0 ; i--) { Tcl_DecrRefCount(objv[i]); } - Tcl_Free(objv); + ckfree(objv); tokenPtr = TokenAfter(parsePtr->tokenPtr); tokenPtr = TokenAfter(tokenPtr); i = 0; @@ -3334,7 +3249,7 @@ TclCompileFormatCmd( * Check if the number of things to concatenate will fit in a byte. */ - if (i+2 != (int)parsePtr->numWords || i > 125) { + if (i+2 != parsePtr->numWords || i > 125) { Tcl_DecrRefCount(formatObj); return TCL_ERROR; } @@ -3424,7 +3339,7 @@ TclCompileFormatCmd( * Returns the non-negative integer index value into the table of * compiled locals corresponding to a local scalar variable name. * If the arguments passed in do not identify a local scalar variable - * then return TCL_INDEX_NONE. + * then return -1. * * Side effects: * May add an entry into the table of compiled locals. @@ -3432,12 +3347,13 @@ TclCompileFormatCmd( *---------------------------------------------------------------------- */ -size_t +Tcl_Size TclLocalScalarFromToken( Tcl_Token *tokenPtr, CompileEnv *envPtr) { - int isScalar, index; + int isScalar; + Tcl_Size index; TclPushVarName(NULL, tokenPtr, envPtr, TCL_NO_ELEMENT, &index, &isScalar); if (!isScalar) { @@ -3446,16 +3362,14 @@ TclLocalScalarFromToken( return index; } -size_t +Tcl_Size TclLocalScalar( const char *bytes, - size_t numBytes, + TCL_HASH_TYPE numBytes, CompileEnv *envPtr) { - Tcl_Token token[2] = { - {TCL_TOKEN_SIMPLE_WORD, NULL, 0, 1}, - {TCL_TOKEN_TEXT, NULL, 0, 0} - }; + Tcl_Token token[2] = {{TCL_TOKEN_SIMPLE_WORD, NULL, 0, 1}, + {TCL_TOKEN_TEXT, NULL, 0, 0}}; token[1].start = bytes; token[1].size = numBytes; @@ -3502,10 +3416,9 @@ TclPushVarName( { const char *p; const char *last, *name, *elName; - size_t n; + int n; Tcl_Token *elemTokenPtr = NULL; - size_t nameLen, elNameLen; - int simpleVarName, localIndex; + int nameLen, elNameLen, simpleVarName, localIndex; int elemTokenCount = 0, allocedTokens = 0, removedParen = 0; /* @@ -3572,15 +3485,15 @@ TclPushVarName( */ simpleVarName = 0; - for (p = varTokenPtr[1].start, last = p + varTokenPtr[1].size; - p < last; p++) { + for (p = varTokenPtr[1].start, + last = p + varTokenPtr[1].size; p < last; p++) { if (*p == '(') { simpleVarName = 1; break; } } if (simpleVarName) { - size_t remainingLen; + int remainingLen; /* * Check the last token: if it is just ')', do not count it. @@ -3642,7 +3555,7 @@ TclPushVarName( int hasNsQualifiers = 0; for (p = name, last = p + nameLen-1; p < last; p++) { - if ((p[0] == ':') && (p[1] == ':')) { + if ((*p == ':') && (*(p+1) == ':')) { hasNsQualifiers = 1; break; } diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 8e44f96..ea1e42d 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -49,8 +49,8 @@ static int IndexTailVarIfKnown(Tcl_Interp *interp, int TclGetIndexFromToken( Tcl_Token *tokenPtr, - size_t before, - size_t after, + Tcl_Size before, + Tcl_Size after, int *indexPtr) { Tcl_Obj *tmpObj; @@ -181,7 +181,7 @@ TclCompileIfCmd( * determined. */ Tcl_Token *tokenPtr, *testTokenPtr; int jumpIndex = 0; /* Avoid compiler warning. */ - size_t numBytes, j; + int numBytes, j; int jumpFalseDist, numWords, wordIdx, code; const char *word; int realCond = 1; /* Set to 0 for static conditions: @@ -498,7 +498,7 @@ TclCompileIncrCmd( incrTokenPtr = TokenAfter(varTokenPtr); if (incrTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { const char *word = incrTokenPtr[1].start; - size_t numBytes = incrTokenPtr[1].size; + int numBytes = incrTokenPtr[1].size; int code; Tcl_Obj *intObj = Tcl_NewStringObj(word, numBytes); @@ -1359,7 +1359,7 @@ TclCompileLinsertCmd( Tcl_Token *tokenPtr; int i; - if ((int)parsePtr->numWords < 3) { + if (parsePtr->numWords < 3) { return TCL_ERROR; } @@ -1370,7 +1370,7 @@ TclCompileLinsertCmd( CompileWord(envPtr, tokenPtr, interp, 2); /* Push new elements to be inserted */ - for (i=3 ; i<(int)parsePtr->numWords ; i++) { + for (i=3 ; i<parsePtr->numWords ; i++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, i); } @@ -1424,7 +1424,7 @@ TclCompileLreplaceCmd( CompileWord(envPtr, tokenPtr, interp, 3); /* Push new elements to be inserted */ - for (i=4 ; i< (int)parsePtr->numWords ; i++) { + for (i=4 ; i<parsePtr->numWords ; i++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, i); } @@ -1502,7 +1502,7 @@ TclCompileLsetCmd( */ /* TODO: Consider support for compiling expanded args. */ - if ((int)parsePtr->numWords < 3) { + if (parsePtr->numWords < 3) { /* * Fail at run time, not in compilation. */ @@ -1526,7 +1526,7 @@ TclCompileLsetCmd( * Push the "index" args and the new element value. */ - for (i=2 ; i<(int)parsePtr->numWords ; ++i) { + for (i=2 ; i<parsePtr->numWords ; ++i) { varTokenPtr = TokenAfter(varTokenPtr); CompileWord(envPtr, varTokenPtr, interp, i); } @@ -1811,7 +1811,7 @@ TclCompileNamespaceUpvarCmd( * Only compile [namespace upvar ...]: needs an even number of args, >=4 */ - numWords = (int)parsePtr->numWords; + numWords = parsePtr->numWords; if ((numWords % 2) || (numWords < 4)) { return TCL_ERROR; } @@ -1863,7 +1863,7 @@ TclCompileNamespaceWhichCmd( Tcl_Token *tokenPtr, *opt; int idx; - if ((int)parsePtr->numWords < 2 || (int)parsePtr->numWords > 3) { + if (parsePtr->numWords < 2 || parsePtr->numWords > 3) { return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -1925,7 +1925,7 @@ TclCompileRegexpCmd( DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr; /* Pointer to the Tcl_Token representing the * parse of the RE or string. */ - size_t len; + int len; int i, nocase, exact, sawLast, simple; const char *str; @@ -1936,7 +1936,7 @@ TclCompileRegexpCmd( * regexp ?-nocase? ?--? {^staticString$} $var */ - if ((int)parsePtr->numWords < 3) { + if (parsePtr->numWords < 3) { return TCL_ERROR; } @@ -1951,7 +1951,7 @@ TclCompileRegexpCmd( * handling, but satisfies our stricter needs. */ - for (i = 1; i < (int)parsePtr->numWords - 2; i++) { + for (i = 1; i < parsePtr->numWords - 2; i++) { varTokenPtr = TokenAfter(varTokenPtr); if (varTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { /* @@ -1977,7 +1977,7 @@ TclCompileRegexpCmd( } } - if (((int)parsePtr->numWords - i) != 2) { + if ((parsePtr->numWords - i) != 2) { /* * We don't support capturing to variables. */ @@ -2030,7 +2030,7 @@ TclCompileRegexpCmd( } if (!simple) { - CompileWord(envPtr, varTokenPtr, interp, (int)parsePtr->numWords - 2); + CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords - 2); } /* @@ -2038,7 +2038,7 @@ TclCompileRegexpCmd( */ varTokenPtr = TokenAfter(varTokenPtr); - CompileWord(envPtr, varTokenPtr, interp, (int)parsePtr->numWords - 1); + CompileWord(envPtr, varTokenPtr, interp, parsePtr->numWords - 1); if (simple) { if (exact && !nocase) { @@ -2115,7 +2115,7 @@ TclCompileRegsubCmd( int exact, quantified, result = TCL_ERROR; Tcl_Size len; - if ((int)parsePtr->numWords < 5 || (int)parsePtr->numWords > 6) { + if (parsePtr->numWords < 5 || parsePtr->numWords > 6) { return TCL_ERROR; } @@ -2191,7 +2191,7 @@ TclCompileRegsubCmd( */ len = Tcl_DStringLength(&pattern) - 2; - if (len + 2 > 2) { + if (len > 0) { goto isSimpleGlob; } @@ -2222,7 +2222,7 @@ TclCompileRegsubCmd( PushLiteral(envPtr, bytes, len); bytes = TclGetStringFromObj(replacementObj, &len); PushLiteral(envPtr, bytes, len); - CompileWord(envPtr, stringTokenPtr, interp, (int)parsePtr->numWords - 2); + CompileWord(envPtr, stringTokenPtr, interp, parsePtr->numWords - 2); TclEmitOpcode( INST_STR_MAP, envPtr); done: @@ -2267,11 +2267,11 @@ TclCompileReturnCmd( * General syntax: [return ?-option value ...? ?result?] * An even number of words means an explicit result argument is present. */ - int level, code, objc, status = TCL_OK; + int level, code, status = TCL_OK; Tcl_Size size; - int numWords = parsePtr->numWords; - int explicitResult = (0 == (numWords % 2)); - int numOptionWords = numWords - 1 - explicitResult; + Tcl_Size numWords = parsePtr->numWords; + Tcl_Size explicitResult = (0 == (numWords % 2)); + Tcl_Size objc, numOptionWords = numWords - 1 - explicitResult; Tcl_Obj *returnOpts, **objv; Tcl_Token *wordTokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -2754,7 +2754,7 @@ IndexTailVarIfKnown( */ for (p = tailName + len -1; p > tailName; p--) { - if ((p[0] == ':') && (p[- 1] == ':')) { + if ((*p == ':') && (*(p - 1) == ':')) { p++; break; } @@ -2798,11 +2798,11 @@ TclCompileObjectNextCmd( Tcl_Token *tokenPtr = parsePtr->tokenPtr; int i; - if ((int)parsePtr->numWords > 255) { + if (parsePtr->numWords > 255) { return TCL_ERROR; } - for (i=0 ; i<(int)parsePtr->numWords ; i++) { + for (i=0 ; i<parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } @@ -2822,11 +2822,11 @@ TclCompileObjectNextToCmd( Tcl_Token *tokenPtr = parsePtr->tokenPtr; int i; - if ((int)parsePtr->numWords < 2 || (int)parsePtr->numWords > 255) { + if (parsePtr->numWords < 2 || parsePtr->numWords > 255) { return TCL_ERROR; } - for (i=0 ; i<(int)parsePtr->numWords ; i++) { + for (i=0 ; i<parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 98a39f9..c3aba1e 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -41,12 +41,12 @@ static int CompileUnaryOpCmd(Tcl_Interp *interp, CompileEnv *envPtr); static void IssueSwitchChainedTests(Tcl_Interp *interp, CompileEnv *envPtr, int mode, int noCase, - Tcl_Size numWords, Tcl_Token **bodyToken, - Tcl_Size *bodyLines, Tcl_Size **bodyNext); + int numWords, Tcl_Token **bodyToken, + int *bodyLines, int **bodyNext); static void IssueSwitchJumpTable(Tcl_Interp *interp, CompileEnv *envPtr, int numWords, - Tcl_Token **bodyToken, Tcl_Size *bodyLines, - Tcl_Size **bodyContLines); + Tcl_Token **bodyToken, int *bodyLines, + int **bodyContLines); static int IssueTryClausesInstructions(Tcl_Interp *interp, CompileEnv *envPtr, Tcl_Token *bodyToken, int numHandlers, int *matchCodes, @@ -235,7 +235,7 @@ TclCompileStringCatCmd( } /* General case: issue CONCAT1's (by chunks of 254 if needed), folding - * contiguous constants along the way */ + contiguous constants along the way */ numArgs = 0; folded = NULL; @@ -252,7 +252,7 @@ TclCompileStringCatCmd( } else { Tcl_DecrRefCount(obj); if (folded) { - Tcl_Size len; + int len; const char *bytes = TclGetStringFromObj(folded, &len); PushLiteral(envPtr, bytes, len); @@ -270,7 +270,7 @@ TclCompileStringCatCmd( wordTokenPtr = TokenAfter(wordTokenPtr); } if (folded) { - Tcl_Size len; + int len; const char *bytes = TclGetStringFromObj(folded, &len); PushLiteral(envPtr, bytes, len); @@ -518,8 +518,8 @@ TclCompileStringIsCmd( 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 - } t; - int range, allowEmpty = 0, end; + }; + int t, range, allowEmpty = 0, end; InstStringClassType strClassType; Tcl_Obj *isClass; @@ -573,9 +573,9 @@ TclCompileStringIsCmd( * 5. Lists */ - CompileWord(envPtr, tokenPtr, interp, (int)parsePtr->numWords-1); + CompileWord(envPtr, tokenPtr, interp, parsePtr->numWords-1); - switch (t) { + switch ((enum isClassesEnum) t) { case STR_IS_ALNUM: strClassType = STR_CLASS_ALNUM; goto compileStrClass; @@ -680,8 +680,6 @@ TclCompileStringIsCmd( FIXJUMP1( over); OP( LNOT); return TCL_OK; - default: - break; } break; @@ -747,8 +745,6 @@ TclCompileStringIsCmd( PUSH( "3"); OP( LE); break; - default: - break; } FIXJUMP1( end); return TCL_OK; @@ -795,8 +791,7 @@ TclCompileStringMatchCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr; - size_t length; - int i, exactMatch = 0, nocase = 0; + int i, length, exactMatch = 0, nocase = 0; const char *str; if (parsePtr->numWords < 3 || parsePtr->numWords > 4) { @@ -892,9 +887,9 @@ TclCompileStringLenCmd( */ char buf[TCL_INTEGER_SPACE]; - size_t len = Tcl_GetCharLength(objPtr); + int len = TclGetCharLength(objPtr); - len = snprintf(buf, sizeof(buf), "%" TCL_Z_MODIFIER "u", len); + len = snprintf(buf, sizeof(buf), "%d", len); PushLiteral(envPtr, buf, len); } else { SetLineInformation(1); @@ -918,7 +913,7 @@ TclCompileStringMapCmd( Tcl_Token *mapTokenPtr, *stringTokenPtr; Tcl_Obj *mapObj, **objv; const char *bytes; - Tcl_Size len, slen; + int len; /* * We only handle the case: @@ -954,13 +949,13 @@ TclCompileStringMapCmd( * correct semantics for mapping. */ - bytes = TclGetStringFromObj(objv[0], &slen); - if (slen == 0) { + bytes = TclGetStringFromObj(objv[0], &len); + if (len == 0) { CompileWord(envPtr, stringTokenPtr, interp, 2); } else { - PushLiteral(envPtr, bytes, slen); - bytes = TclGetStringFromObj(objv[1], &slen); - PushLiteral(envPtr, bytes, slen); + PushLiteral(envPtr, bytes, len); + bytes = TclGetStringFromObj(objv[1], &len); + PushLiteral(envPtr, bytes, len); CompileWord(envPtr, stringTokenPtr, interp, 2); OP(STR_MAP); } @@ -1055,7 +1050,7 @@ TclCompileStringReplaceCmd( Tcl_Token *tokenPtr, *valueTokenPtr; int first, last; - if ((int)parsePtr->numWords < 4 || (int)parsePtr->numWords > 5) { + if (parsePtr->numWords < 4 || parsePtr->numWords > 5) { return TCL_ERROR; } @@ -1513,14 +1508,13 @@ void TclSubstCompile( Tcl_Interp *interp, const char *bytes, - Tcl_Size numBytes, + int numBytes, int flags, - Tcl_Size line, + int line, CompileEnv *envPtr) { Tcl_Token *endTokenPtr, *tokenPtr; - int breakOffset = 0, count = 0; - Tcl_Size bline = line; + int breakOffset = 0, count = 0, bline = line; Tcl_Parse parse; Tcl_InterpState state = NULL; @@ -1545,8 +1539,7 @@ TclSubstCompile( for (endTokenPtr = tokenPtr + parse.numTokens; tokenPtr < endTokenPtr; tokenPtr = TokenAfter(tokenPtr)) { - Tcl_Size length; - int literal, catchRange, breakJump; + int length, literal, catchRange, breakJump; char buf[4] = ""; JumpFixup startFixup, okFixup, returnFixup, breakFixup; JumpFixup continueFixup, otherFixup, endFixup; @@ -1577,8 +1570,7 @@ TclSubstCompile( */ if (tokenPtr->numComponents > 1) { - Tcl_Size i; - int foundCommand = 0; + int i, foundCommand = 0; for (i=2 ; i<=tokenPtr->numComponents ; i++) { if (tokenPtr[i].type == TCL_TOKEN_COMMAND) { @@ -1617,8 +1609,8 @@ TclSubstCompile( /* Start */ if (TclFixupForwardJumpToHere(envPtr, &startFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad start jump distance %" TCL_Z_MODIFIER "d", - CurrentOffset(envPtr) - startFixup.codeOffset); + Tcl_Panic("TclCompileSubstCmd: bad start jump distance %d", + (int) (CurrentOffset(envPtr) - startFixup.codeOffset)); } } @@ -1676,8 +1668,8 @@ TclSubstCompile( TclAdjustStackDepth(1, envPtr); /* BREAK destination */ if (TclFixupForwardJumpToHere(envPtr, &breakFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad break jump distance %" TCL_Z_MODIFIER "d", - CurrentOffset(envPtr) - breakFixup.codeOffset); + Tcl_Panic("TclCompileSubstCmd: bad break jump distance %d", + (int) (CurrentOffset(envPtr) - breakFixup.codeOffset)); } OP( POP); OP( POP); @@ -1692,8 +1684,8 @@ TclSubstCompile( TclAdjustStackDepth(2, envPtr); /* CONTINUE destination */ if (TclFixupForwardJumpToHere(envPtr, &continueFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad continue jump distance %" TCL_Z_MODIFIER "d", - CurrentOffset(envPtr) - continueFixup.codeOffset); + Tcl_Panic("TclCompileSubstCmd: bad continue jump distance %d", + (int) (CurrentOffset(envPtr) - continueFixup.codeOffset)); } OP( POP); OP( POP); @@ -1702,12 +1694,12 @@ TclSubstCompile( TclAdjustStackDepth(2, envPtr); /* RETURN + other destination */ if (TclFixupForwardJumpToHere(envPtr, &returnFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad return jump distance %" TCL_Z_MODIFIER "d", - CurrentOffset(envPtr) - returnFixup.codeOffset); + Tcl_Panic("TclCompileSubstCmd: bad return jump distance %d", + (int) (CurrentOffset(envPtr) - returnFixup.codeOffset)); } if (TclFixupForwardJumpToHere(envPtr, &otherFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad other jump distance %" TCL_Z_MODIFIER "d", - CurrentOffset(envPtr) - otherFixup.codeOffset); + Tcl_Panic("TclCompileSubstCmd: bad other jump distance %d", + (int) (CurrentOffset(envPtr) - otherFixup.codeOffset)); } /* @@ -1719,8 +1711,8 @@ TclSubstCompile( /* OK destination */ if (TclFixupForwardJumpToHere(envPtr, &okFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad ok jump distance %" TCL_Z_MODIFIER "d", - CurrentOffset(envPtr) - okFixup.codeOffset); + Tcl_Panic("TclCompileSubstCmd: bad ok jump distance %d", + (int) (CurrentOffset(envPtr) - okFixup.codeOffset)); } if (count > 1) { OP1(STR_CONCAT1, count); @@ -1729,8 +1721,8 @@ TclSubstCompile( /* CONTINUE jump to here */ if (TclFixupForwardJumpToHere(envPtr, &endFixup, 127)) { - Tcl_Panic("TclCompileSubstCmd: bad end jump distance %" TCL_Z_MODIFIER "d", - CurrentOffset(envPtr) - endFixup.codeOffset); + Tcl_Panic("TclCompileSubstCmd: bad end jump distance %d", + (int) (CurrentOffset(envPtr) - endFixup.codeOffset)); } bline = envPtr->line; } @@ -1796,14 +1788,14 @@ TclCompileSwitchCmd( Tcl_Token *bodyTokenArray; /* Array of real pattern list items. */ Tcl_Token **bodyToken; /* Array of pointers to pattern list items. */ - Tcl_Size *bodyLines; /* Array of line numbers for body list + int *bodyLines; /* Array of line numbers for body list * items. */ - Tcl_Size **bodyContLines; /* Array of continuation line info. */ + int **bodyContLines; /* Array of continuation line info. */ int noCase; /* Has the -nocase flag been given? */ int foundMode = 0; /* Have we seen a mode flag yet? */ int i, valueIndex; int result = TCL_ERROR; - Tcl_Size *clNext = envPtr->clNext; + int *clNext = envPtr->clNext; /* * Only handle the following versions: @@ -1850,7 +1842,7 @@ TclCompileSwitchCmd( */ for (; numWords>=3 ; tokenPtr=TokenAfter(tokenPtr),numWords--) { - size_t size = tokenPtr[1].size; + unsigned size = tokenPtr[1].size; const char *chrs = tokenPtr[1].start; /* @@ -1941,8 +1933,8 @@ TclCompileSwitchCmd( if (numWords == 1) { const char *bytes; - Tcl_Size maxLen, numBytes; - Tcl_Size bline; /* TIP #280: line of the pattern/action list, + int maxLen, numBytes; + int bline; /* TIP #280: line of the pattern/action list, * and start of list for when tracking the * location. This list comes immediately after * the value we switch on. */ @@ -1958,10 +1950,10 @@ TclCompileSwitchCmd( if (maxLen < 2) { return TCL_ERROR; } - bodyTokenArray = (Tcl_Token *)Tcl_Alloc(sizeof(Tcl_Token) * maxLen); - bodyToken = (Tcl_Token **)Tcl_Alloc(sizeof(Tcl_Token *) * maxLen); - bodyLines = (Tcl_Size *)Tcl_Alloc(sizeof(Tcl_Size) * maxLen); - bodyContLines = (Tcl_Size **)Tcl_Alloc(sizeof(Tcl_Size*) * maxLen); + bodyTokenArray = (Tcl_Token *)ckalloc(sizeof(Tcl_Token) * maxLen); + bodyToken = (Tcl_Token **)ckalloc(sizeof(Tcl_Token *) * maxLen); + bodyLines = (int *)ckalloc(sizeof(int) * maxLen); + bodyContLines = (int **)ckalloc(sizeof(int*) * maxLen); bline = mapPtr->loc[eclIndex].line[valueIndex+1]; numWords = 0; @@ -1999,10 +1991,10 @@ TclCompileSwitchCmd( } if (numWords % 2) { abort: - Tcl_Free(bodyToken); - Tcl_Free(bodyTokenArray); - Tcl_Free(bodyLines); - Tcl_Free(bodyContLines); + ckfree(bodyToken); + ckfree(bodyTokenArray); + ckfree(bodyLines); + ckfree(bodyContLines); return TCL_ERROR; } } else if (numWords % 2 || numWords == 0) { @@ -2020,9 +2012,9 @@ TclCompileSwitchCmd( * Multi-word definition of patterns & actions. */ - bodyToken = (Tcl_Token **)Tcl_Alloc(sizeof(Tcl_Token *) * numWords); - bodyLines = (Tcl_Size *)Tcl_Alloc(sizeof(Tcl_Size) * numWords); - bodyContLines = (Tcl_Size **)Tcl_Alloc(sizeof(Tcl_Size*) * numWords); + bodyToken = (Tcl_Token **)ckalloc(sizeof(Tcl_Token *) * numWords); + bodyLines = (int *)ckalloc(sizeof(int) * numWords); + bodyContLines = (int **)ckalloc(sizeof(int*) * numWords); bodyTokenArray = NULL; for (i=0 ; i<numWords ; i++) { /* @@ -2081,11 +2073,11 @@ TclCompileSwitchCmd( */ freeTemporaries: - Tcl_Free(bodyToken); - Tcl_Free(bodyLines); - Tcl_Free(bodyContLines); + ckfree(bodyToken); + ckfree(bodyLines); + ckfree(bodyContLines); if (bodyTokenArray != NULL) { - Tcl_Free(bodyTokenArray); + ckfree(bodyTokenArray); } return result; } @@ -2112,13 +2104,13 @@ IssueSwitchChainedTests( CompileEnv *envPtr, /* Holds resulting instructions. */ int mode, /* Exact, Glob or Regexp */ int noCase, /* Case-insensitivity flag. */ - Tcl_Size numBodyTokens, /* Number of tokens describing things the + int numBodyTokens, /* Number of tokens describing things the * switch can match against and bodies to * execute when the match succeeds. */ Tcl_Token **bodyToken, /* Array of pointers to pattern list items. */ - Tcl_Size *bodyLines, /* Array of line numbers for body list + int *bodyLines, /* Array of line numbers for body list * items. */ - Tcl_Size **bodyContLines) /* Array of continuation line info. */ + int **bodyContLines) /* Array of continuation line info. */ { enum {Switch_Exact, Switch_Glob, Switch_Regexp}; int foundDefault; /* Flag to indicate whether a "default" clause @@ -2364,9 +2356,9 @@ IssueSwitchJumpTable( * switch can match against and bodies to * execute when the match succeeds. */ Tcl_Token **bodyToken, /* Array of pointers to pattern list items. */ - Tcl_Size *bodyLines, /* Array of line numbers for body list + int *bodyLines, /* Array of line numbers for body list * items. */ - Tcl_Size **bodyContLines) /* Array of continuation line info. */ + int **bodyContLines) /* Array of continuation line info. */ { JumptableInfo *jtPtr; int infoIndex, isNew, *finalFixups, numRealBodies = 0, jumpLocation; @@ -2384,7 +2376,7 @@ IssueSwitchJumpTable( * Start by allocating the jump table itself, plus some workspace. */ - jtPtr = (JumptableInfo *)Tcl_Alloc(sizeof(JumptableInfo)); + jtPtr = (JumptableInfo *)ckalloc(sizeof(JumptableInfo)); Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS); infoIndex = TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr); finalFixups = (int *)TclStackAlloc(interp, sizeof(int) * (numBodyTokens/2)); @@ -2556,14 +2548,14 @@ DupJumptableInfo( void *clientData) { JumptableInfo *jtPtr = (JumptableInfo *)clientData; - JumptableInfo *newJtPtr = (JumptableInfo *)Tcl_Alloc(sizeof(JumptableInfo)); + JumptableInfo *newJtPtr = (JumptableInfo *)ckalloc(sizeof(JumptableInfo)); Tcl_HashEntry *hPtr, *newHPtr; Tcl_HashSearch search; int isNew; Tcl_InitHashTable(&newJtPtr->hashTable, TCL_STRING_KEYS); hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search); - for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) { + while (hPtr != NULL) { newHPtr = Tcl_CreateHashEntry(&newJtPtr->hashTable, Tcl_GetHashKey(&jtPtr->hashTable, hPtr), &isNew); Tcl_SetHashValue(newHPtr, Tcl_GetHashValue(hPtr)); @@ -2578,7 +2570,7 @@ FreeJumptableInfo( JumptableInfo *jtPtr = (JumptableInfo *)clientData; Tcl_DeleteHashTable(&jtPtr->hashTable); - Tcl_Free(jtPtr); + ckfree(jtPtr); } static void @@ -2586,13 +2578,13 @@ PrintJumptableInfo( void *clientData, Tcl_Obj *appendObj, TCL_UNUSED(ByteCode *), - size_t pcOffset) + unsigned int pcOffset) { JumptableInfo *jtPtr = (JumptableInfo *)clientData; Tcl_HashEntry *hPtr; Tcl_HashSearch search; const char *keyPtr; - size_t offset, i = 0; + int offset, i = 0; hPtr = Tcl_FirstHashEntry(&jtPtr->hashTable, &search); for (; hPtr ; hPtr = Tcl_NextHashEntry(&search)) { @@ -2605,7 +2597,7 @@ PrintJumptableInfo( Tcl_AppendToObj(appendObj, "\n\t\t", -1); } } - Tcl_AppendPrintfToObj(appendObj, "\"%s\"->pc %" TCL_Z_MODIFIER "u", + Tcl_AppendPrintfToObj(appendObj, "\"%s\"->pc %d", keyPtr, pcOffset + offset); } } @@ -2615,7 +2607,7 @@ DisassembleJumptableInfo( void *clientData, Tcl_Obj *dictObj, TCL_UNUSED(ByteCode *), - TCL_UNUSED(size_t)) + TCL_UNUSED(unsigned int)) { JumptableInfo *jtPtr = (JumptableInfo *)clientData; Tcl_Obj *mapping; @@ -2673,11 +2665,11 @@ TclCompileTailcallCmd( /* make room for the nsObjPtr */ /* TODO: Doesn't this have to be a known value? */ CompileWord(envPtr, tokenPtr, interp, 0); - for (i=1 ; i<(int)parsePtr->numWords ; i++) { + for (i=1 ; i<parsePtr->numWords ; i++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, i); } - TclEmitInstInt1( INST_TAILCALL, (int)parsePtr->numWords, envPtr); + TclEmitInstInt1( INST_TAILCALL, parsePtr->numWords, envPtr); return TCL_OK; } @@ -2711,8 +2703,7 @@ TclCompileThrowCmd( int numWords = parsePtr->numWords; Tcl_Token *codeToken, *msgToken; Tcl_Obj *objPtr; - int codeKnown, codeIsList, codeIsValid; - Tcl_Size len; + int codeKnown, codeIsList, codeIsValid, len; if (numWords != 3) { return TCL_ERROR; @@ -2853,7 +2844,7 @@ TclCompileTryCmd( for (i=0 ; i<numHandlers ; i++) { Tcl_Obj *tmpObj, **objv; - Tcl_Size objc; + int objc; if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { goto failedToCompile; @@ -2918,7 +2909,7 @@ TclCompileTryCmd( goto failedToCompile; } if (objc > 0) { - Tcl_Size len; + int len; const char *varname = TclGetStringFromObj(objv[0], &len); resultVarIndices[i] = LocalScalar(varname, len, envPtr); @@ -2930,7 +2921,7 @@ TclCompileTryCmd( resultVarIndices[i] = -1; } if (objc == 2) { - Tcl_Size len; + int len; const char *varname = TclGetStringFromObj(objv[1], &len); optionVarIndices[i] = LocalScalar(varname, len, envPtr); @@ -3051,8 +3042,7 @@ IssueTryClausesInstructions( { DefineLineInformation; /* TIP #280 */ int range, resultVar, optionsVar; - int i, j, forwardsNeedFixing = 0, trapZero = 0, afterBody = 0; - Tcl_Size slen, len; + int i, j, len, forwardsNeedFixing = 0, trapZero = 0, afterBody = 0; int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource; int *noError; char buf[TCL_INTEGER_SPACE]; @@ -3138,8 +3128,8 @@ IssueTryClausesInstructions( OP4( DICT_GET, 1); TclAdjustStackDepth(-1, envPtr); OP44( LIST_RANGE_IMM, 0, len-1); - p = TclGetStringFromObj(matchClauses[i], &slen); - PushLiteral(envPtr, p, slen); + p = TclGetStringFromObj(matchClauses[i], &len); + PushLiteral(envPtr, p, len); OP( STR_EQ); JUMP4( JUMP_FALSE, notECJumpSource); } else { @@ -3262,11 +3252,10 @@ IssueTryClausesFinallyInstructions( Tcl_Token *finallyToken) /* Not NULL */ { DefineLineInformation; /* TIP #280 */ - int range, resultVar, optionsVar, i, j, forwardsNeedFixing = 0; + int range, resultVar, optionsVar, i, j, len, forwardsNeedFixing = 0; int trapZero = 0, afterBody = 0, finalOK, finalError, noFinalError; int *addrsToFix, *forwardsToFix, notCodeJumpSource, notECJumpSource; char buf[TCL_INTEGER_SPACE]; - Tcl_Size slen, len; resultVar = AnonymousLocal(envPtr); optionsVar = AnonymousLocal(envPtr); @@ -3350,8 +3339,8 @@ IssueTryClausesFinallyInstructions( OP4( DICT_GET, 1); TclAdjustStackDepth(-1, envPtr); OP44( LIST_RANGE_IMM, 0, len-1); - p = TclGetStringFromObj(matchClauses[i], &slen); - PushLiteral(envPtr, p, slen); + p = TclGetStringFromObj(matchClauses[i], &len); + PushLiteral(envPtr, p, len); OP( STR_EQ); JUMP4( JUMP_FALSE, notECJumpSource); } else { @@ -3637,7 +3626,7 @@ TclCompileUnsetCmd( * push/rotate. [Bug 3970f54c4e] */ - for (i=1,varTokenPtr=parsePtr->tokenPtr ; i<(int)parsePtr->numWords ; i++) { + for (i=1,varTokenPtr=parsePtr->tokenPtr ; i<parsePtr->numWords ; i++) { Tcl_Obj *leadingWord; TclNewObj(leadingWord); @@ -3676,7 +3665,7 @@ TclCompileUnsetCmd( } if (varCount == 0) { const char *bytes; - Tcl_Size len; + int len; bytes = TclGetStringFromObj(leadingWord, &len); if (i == 1 && len == 11 && !strncmp("-nocomplain", bytes, 11)) { @@ -3701,7 +3690,7 @@ TclCompileUnsetCmd( for (i=0; i<haveFlags;i++) { varTokenPtr = TokenAfter(varTokenPtr); } - for (i=1+haveFlags ; i<(int)parsePtr->numWords ; i++) { + for (i=1+haveFlags ; i<parsePtr->numWords ; i++) { /* * Decide if we can use a frame slot for the var/array name or if we * need to emit code to compute and push the name at runtime. We use a @@ -3986,12 +3975,12 @@ TclCompileYieldToCmd( Tcl_Token *tokenPtr = TokenAfter(parsePtr->tokenPtr); int i; - if ((int)parsePtr->numWords < 2) { + if (parsePtr->numWords < 2) { return TCL_ERROR; } OP( NS_CURRENT); - for (i = 1 ; i < (int)parsePtr->numWords ; i++) { + for (i = 1 ; i < parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } @@ -4069,7 +4058,7 @@ CompileAssociativeBinaryOpCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = parsePtr->tokenPtr; - Tcl_Size words; + int words; /* TODO: Consider support for compiling expanded args. */ for (words=1 ; words<parsePtr->numWords ; words++) { @@ -4156,7 +4145,7 @@ CompileComparisonOpCmd( Tcl_Token *tokenPtr; /* TODO: Consider support for compiling expanded args. */ - if ((int)parsePtr->numWords < 3) { + if (parsePtr->numWords < 3) { PUSH("1"); } else if (parsePtr->numWords == 3) { tokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -4172,7 +4161,7 @@ CompileComparisonOpCmd( return TCL_ERROR; } else { int tmpIndex = AnonymousLocal(envPtr); - Tcl_Size words; + int words; tokenPtr = TokenAfter(parsePtr->tokenPtr); CompileWord(envPtr, tokenPtr, interp, 1); @@ -4308,7 +4297,7 @@ TclCompilePowOpCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = parsePtr->tokenPtr; - Tcl_Size words; + int words; /* * This one has its own implementation because the ** operator is the only @@ -4509,7 +4498,7 @@ TclCompileMinusOpCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = parsePtr->tokenPtr; - Tcl_Size words; + int words; /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords == 1) { @@ -4554,7 +4543,7 @@ TclCompileDivOpCmd( { DefineLineInformation; /* TIP #280 */ Tcl_Token *tokenPtr = parsePtr->tokenPtr; - Tcl_Size words; + int words; /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords == 1) { diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index c9f9ec5..7761ddd 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -22,7 +22,7 @@ * The tree is composed of OpNodes. */ -typedef struct { +typedef struct OpNode { int left; /* "Pointer" to the left operand. */ int right; /* "Pointer" to the right operand. */ union { @@ -511,16 +511,16 @@ static void CompileExprTree(Tcl_Interp *interp, OpNode *nodes, int index, Tcl_Obj *const **litObjvPtr, Tcl_Obj *const *funcObjv, Tcl_Token *tokenPtr, CompileEnv *envPtr, int optimize); -static void ConvertTreeToTokens(const char *start, Tcl_Size numBytes, +static void ConvertTreeToTokens(const char *start, int numBytes, OpNode *nodes, Tcl_Token *tokenPtr, Tcl_Parse *parsePtr); static int ExecConstantExprTree(Tcl_Interp *interp, OpNode *nodes, int index, Tcl_Obj * const **litObjvPtr); static int ParseExpr(Tcl_Interp *interp, const char *start, - Tcl_Size numBytes, OpNode **opTreePtr, + int numBytes, OpNode **opTreePtr, Tcl_Obj *litList, Tcl_Obj *funcList, Tcl_Parse *parsePtr, int parseOnly); -static Tcl_Size ParseLexeme(const char *start, Tcl_Size numBytes, +static int ParseLexeme(const char *start, int numBytes, unsigned char *lexemePtr, Tcl_Obj **literalPtr); /* @@ -546,7 +546,7 @@ static Tcl_Size ParseLexeme(const char *start, Tcl_Size numBytes, * Side effects: * Memory will be allocated. If TCL_OK is returned, the caller must clean * up the returned data structures. The (OpNode *) value written to - * opTreePtr should be passed to Tcl_Free() and the parsePtr argument + * opTreePtr should be passed to ckfree() and the parsePtr argument * should be passed to Tcl_FreeParse(). The elements appended to the * litList and funcList will automatically be freed whenever the refcount * on those lists indicates they can be freed. @@ -558,7 +558,7 @@ static int ParseExpr( Tcl_Interp *interp, /* Used for error reporting. */ const char *start, /* Start of source string to parse. */ - Tcl_Size numBytes, /* Number of bytes in string. */ + int numBytes, /* Number of bytes in string. */ OpNode **opTreePtr, /* Points to space where a pointer to the * allocated OpNode tree should go. */ Tcl_Obj *litList, /* List to append literals to. */ @@ -581,7 +581,7 @@ ParseExpr( * no need for array growth and * reallocation. */ unsigned int nodesUsed = 0; /* Number of OpNodes filled. */ - Tcl_Size scanned = 0; /* Capture number of byte scanned by parsing + int scanned = 0; /* Capture number of byte scanned by parsing * routines. */ int lastParsed; /* Stores info about what the lexeme parsed * the previous pass through the parsing loop @@ -633,7 +633,7 @@ ParseExpr( TclParseInit(interp, start, numBytes, parsePtr); - nodes = (OpNode *)Tcl_AttemptAlloc(nodesAvailable * sizeof(OpNode)); + nodes = (OpNode *)attemptckalloc(nodesAvailable * sizeof(OpNode)); if (nodes == NULL) { TclNewLiteralStringObj(msg, "not enough memory to parse expression"); errCode = "NOMEM"; @@ -677,7 +677,7 @@ ParseExpr( do { if (size <= UINT_MAX/sizeof(OpNode)) { - newPtr = (OpNode *) Tcl_AttemptRealloc(nodes, + newPtr = (OpNode *) attemptckrealloc(nodes, size * sizeof(OpNode)); } } while ((newPtr == NULL) @@ -717,12 +717,12 @@ ParseExpr( continue; case INVALID: msg = Tcl_ObjPrintf("invalid character \"%.*s\"", - (int)scanned, start); + scanned, start); errCode = "BADCHAR"; goto error; case INCOMPLETE: msg = Tcl_ObjPrintf("incomplete operator \"%.*s\"", - (int)scanned, start); + scanned, start); errCode = "PARTOP"; goto error; case BAREWORD: @@ -777,16 +777,16 @@ ParseExpr( Tcl_DecrRefCount(literal); msg = Tcl_ObjPrintf("invalid bareword \"%.*s%s\"", - (int)((scanned < limit) ? scanned : limit - 3), start, + (scanned < limit) ? scanned : limit - 3, start, (scanned < limit) ? "" : "..."); post = Tcl_ObjPrintf( "should be \"$%.*s%s\" or \"{%.*s%s}\"", - (int) ((scanned < limit) ? scanned : limit - 3), + (scanned < limit) ? scanned : limit - 3, start, (scanned < limit) ? "" : "...", - (int) ((scanned < limit) ? scanned : limit - 3), + (scanned < limit) ? scanned : limit - 3, start, (scanned < limit) ? "" : "..."); Tcl_AppendPrintfToObj(post, " or \"%.*s%s(...)\" or ...", - (int) ((scanned < limit) ? scanned : limit - 3), + (scanned < limit) ? scanned : limit - 3, start, (scanned < limit) ? "" : "..."); errCode = "BAREWORD"; if (start[0] == '0') { @@ -1418,7 +1418,7 @@ ParseExpr( */ if (nodes != NULL) { - Tcl_Free(nodes); + ckfree(nodes); } if (interp == NULL) { @@ -1447,13 +1447,13 @@ ParseExpr( Tcl_AppendPrintfToObj(msg, "\nin expression \"%s%.*s%.*s%s%s%.*s%s\"", ((start - limit) < parsePtr->string) ? "" : "...", ((start - limit) < parsePtr->string) - ? (int) (start - parsePtr->string) : (int)limit - 3, + ? (int) (start - parsePtr->string) : limit - 3, ((start - limit) < parsePtr->string) ? parsePtr->string : start - limit + 3, - (scanned < limit) ? (int)scanned : (int)limit - 3, start, + (scanned < limit) ? scanned : limit - 3, start, (scanned < limit) ? "" : "...", insertMark ? mark : "", (start + scanned + limit > parsePtr->end) - ? (int) (parsePtr->end - start) - (int)scanned : (int)limit-3, + ? (int) (parsePtr->end - start) - scanned : limit-3, start + scanned, (start + scanned + limit > parsePtr->end) ? "" : "..."); @@ -1475,7 +1475,7 @@ ParseExpr( numBytes = parsePtr->end - parsePtr->string; Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (parsing expression \"%.*s%s\")", - (numBytes < limit) ? (int)numBytes : (int)limit - 3, + (numBytes < limit) ? numBytes : limit - 3, parsePtr->string, (numBytes < limit) ? "" : "...")); if (errCode) { Tcl_SetErrorCode(interp, "TCL", "PARSE", "EXPR", errCode, @@ -1512,7 +1512,7 @@ ParseExpr( static void ConvertTreeToTokens( const char *start, - Tcl_Size numBytes, + int numBytes, OpNode *nodes, Tcl_Token *tokenPtr, Tcl_Parse *parsePtr) @@ -1601,7 +1601,7 @@ ConvertTreeToTokens( TclGrowParseTokenArray(parsePtr, toCopy); subExprTokenPtr = parsePtr->tokenPtr + parsePtr->numTokens; memcpy(subExprTokenPtr, tokenPtr, - toCopy * sizeof(Tcl_Token)); + (size_t) toCopy * sizeof(Tcl_Token)); subExprTokenPtr->type = TCL_TOKEN_SUB_EXPR; parsePtr->numTokens += toCopy; } else { @@ -1618,7 +1618,7 @@ ConvertTreeToTokens( subExprTokenPtr->numComponents++; subExprTokenPtr++; memcpy(subExprTokenPtr, tokenPtr, - toCopy * sizeof(Tcl_Token)); + (size_t) toCopy * sizeof(Tcl_Token)); parsePtr->numTokens += toCopy + 1; } @@ -1730,7 +1730,7 @@ ConvertTreeToTokens( scanned = ParseLexeme(start, numBytes, &lexeme, NULL); - switch (nodePtr->lexeme) { + switch(nodePtr->lexeme) { case OPEN_PAREN: case COMMA: case COLON: @@ -1806,7 +1806,7 @@ ConvertTreeToTokens( */ subExprTokenPtr->numComponents = - ((int)parsePtr->numTokens - subExprTokenIdx) - 1; + (parsePtr->numTokens - subExprTokenIdx) - 1; /* * Finally, as we return up the tree to our parent, pop the @@ -1860,7 +1860,7 @@ int Tcl_ParseExpr( Tcl_Interp *interp, /* Used for error reporting. */ const char *start, /* Start of source string to parse. */ - Tcl_Size numBytes, /* Number of bytes in string. If -1, the + int numBytes, /* Number of bytes in string. If < 0, the * string consists of all bytes up to the * first null character. */ Tcl_Parse *parsePtr) /* Structure to fill with information about @@ -1896,7 +1896,7 @@ Tcl_ParseExpr( Tcl_FreeParse(exprParsePtr); TclStackFree(interp, exprParsePtr); - Tcl_Free(opTree); + ckfree(opTree); return code; } @@ -1917,16 +1917,17 @@ Tcl_ParseExpr( *---------------------------------------------------------------------- */ -static Tcl_Size +static int ParseLexeme( const char *start, /* Start of lexeme to parse. */ - Tcl_Size numBytes, /* Number of bytes in string. */ + int numBytes, /* Number of bytes in string. */ unsigned char *lexemePtr, /* Write code of parsed lexeme to this * storage. */ Tcl_Obj **literalPtr) /* Write corresponding literal value to this storage, if non-NULL. */ { const char *end; + int scanned, size; int ch; Tcl_Obj *literal = NULL; unsigned char byte; @@ -1941,18 +1942,15 @@ ParseLexeme( return 1; } switch (byte) { - case '#': { + case '#': /* * Scan forward over the comment contents. */ - Tcl_Size size; - for (size = 0; byte != '\n' && byte != 0 && size < numBytes; size++) { byte = UCHAR(start[size]); } *lexemePtr = COMMENT; return size - (byte == '\n'); - } case '*': if ((numBytes > 1) && (start[1] == '*')) { @@ -2147,7 +2145,6 @@ ParseLexeme( */ if (!TclIsBareword(*start) || *start == '_') { - Tcl_Size scanned; if (Tcl_UtfCharComplete(start, numBytes)) { scanned = TclUtfToUniChar(start, &ch); } else { @@ -2197,7 +2194,7 @@ void TclCompileExpr( Tcl_Interp *interp, /* Used for error reporting. */ const char *script, /* The source script to compile. */ - Tcl_Size numBytes, /* Number of bytes in script. */ + int numBytes, /* Number of bytes in script. */ CompileEnv *envPtr, /* Holds resulting instructions. */ int optimize) /* 0 for one-off expressions. */ { @@ -2218,7 +2215,7 @@ TclCompileExpr( * Valid parse; compile the tree. */ - Tcl_Size objc; + int objc; Tcl_Obj *const *litObjv; Tcl_Obj **funcObjv; @@ -2238,7 +2235,7 @@ TclCompileExpr( TclStackFree(interp, parsePtr); Tcl_DecrRefCount(funcList); Tcl_DecrRefCount(litList); - Tcl_Free(opTree); + ckfree(opTree); } /* @@ -2348,7 +2345,7 @@ CompileExprTree( case FUNCTION: { Tcl_DString cmdName; const char *p; - Tcl_Size length; + int length; Tcl_DStringInit(&cmdName); TclDStringAppendLiteral(&cmdName, "tcl::mathfunc::"); @@ -2507,7 +2504,7 @@ CompileExprTree( Tcl_Obj *literal = *litObjv; if (optimize) { - Tcl_Size length; + int length; const char *bytes = TclGetStringFromObj(literal, &length); int idx = TclRegisterLiteral(envPtr, bytes, length, 0); Tcl_Obj *objPtr = TclFetchLiteral(envPtr, idx); @@ -2566,7 +2563,7 @@ CompileExprTree( if (TclHasStringRep(objPtr)) { Tcl_Obj *tableValue; - Tcl_Size numBytes; + int numBytes; const char *bytes = TclGetStringFromObj(objPtr, &numBytes); @@ -2619,7 +2616,7 @@ CompileExprTree( int TclSingleOpCmd( - void *clientData, + ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -2672,7 +2669,7 @@ TclSingleOpCmd( int TclSortingOpCmd( - void *clientData, + ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -2752,7 +2749,7 @@ TclSortingOpCmd( int TclVariadicOpCmd( - void *clientData, + ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -2871,7 +2868,7 @@ TclVariadicOpCmd( int TclNoIdentOpCmd( - void *clientData, + ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 38070b6..3e77231 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -129,6 +129,10 @@ InstructionDesc const tclInstructionTable[] = { {"jumpFalse4", 5, -1, 1, {OPERAND_OFFSET4}}, /* Jump relative to (pc + op4) if stktop expr object is false */ + {"lor", 1, -1, 0, {OPERAND_NONE}}, + /* Logical or: push (stknext || stktop) */ + {"land", 1, -1, 0, {OPERAND_NONE}}, + /* Logical and: push (stknext && stktop) */ {"bitor", 1, -1, 0, {OPERAND_NONE}}, /* Bitwise or: push (stknext | stktop) */ {"bitxor", 1, -1, 0, {OPERAND_NONE}}, @@ -169,6 +173,10 @@ InstructionDesc const tclInstructionTable[] = { /* Bitwise not: push ~stktop */ {"not", 1, 0, 0, {OPERAND_NONE}}, /* Logical not: push !stktop */ + {"callBuiltinFunc1", 2, 1, 1, {OPERAND_UINT1}}, + /* Call builtin math function with index op1; any args are on stk */ + {"callFunc1", 2, INT_MIN, 1, {OPERAND_UINT1}}, + /* Call non-builtin func objv[0]; <objc,objv>=<op1,top op1> */ {"tryCvtToNumeric", 1, 0, 0, {OPERAND_NONE}}, /* Try converting stktop to first int then double if possible. */ @@ -178,6 +186,13 @@ InstructionDesc const tclInstructionTable[] = { /* Skip to next iteration of closest enclosing loop; if none, return * TCL_CONTINUE code. */ + {"foreach_start4", 5, 0, 1, {OPERAND_AUX4}}, + /* Initialize execution of a foreach loop. Operand is aux data index + * of the ForeachInfo structure for the foreach command. */ + {"foreach_step4", 5, +1, 1, {OPERAND_AUX4}}, + /* "Step" or begin next iteration of foreach loop. Push 0 if to + * terminate loop, else push 1. */ + {"beginCatch4", 5, 0, 1, {OPERAND_UINT4}}, /* Record start of catch with the operand's exception index. Push the * current stack depth onto a special catch stack. */ @@ -325,6 +340,9 @@ InstructionDesc const tclInstructionTable[] = { {"dictNext", 5, +3, 1, {OPERAND_LVT4}}, /* Get the next iteration from the iterator in op4's local scalar. * Stack: ... => ... value key doneBool */ + {"dictDone", 5, 0, 1, {OPERAND_LVT4}}, + /* Terminate the iterator in op4's local scalar. Use unsetScalar + * instead (with 0 for flags). */ {"dictUpdateStart", 9, 0, 2, {OPERAND_LVT4, OPERAND_AUX4}}, /* Create the variables (described in the aux data referred to by the * second immediate argument) to mirror the state of the dictionary in @@ -665,13 +683,6 @@ InstructionDesc const tclInstructionTable[] = { * set in flags. */ - {"constImm", 5, -1, 1, {OPERAND_LVT4}}, - /* Create constant. Index into LVT is immediate, value is on stack. - * Stack: ... value => ... */ - {"constStk", 1, -2, 0, {OPERAND_NONE}}, - /* Create constant. Variable name and value on stack. - * Stack: ... varName value => ... */ - {NULL, 0, 0, 0, {OPERAND_NONE}} }; @@ -687,9 +698,9 @@ static void DupByteCodeInternalRep(Tcl_Obj *srcPtr, static unsigned char * EncodeCmdLocMap(CompileEnv *envPtr, ByteCode *codePtr, unsigned char *startPtr); static void EnterCmdExtentData(CompileEnv *envPtr, - Tcl_Size cmdNumber, Tcl_Size numSrcBytes, Tcl_Size numCodeBytes); + int cmdNumber, int numSrcBytes, int numCodeBytes); static void EnterCmdStartData(CompileEnv *envPtr, - Tcl_Size cmdNumber, Tcl_Size srcOffset, Tcl_Size codeOffset); + int cmdNumber, int srcOffset, int codeOffset); static void FreeByteCodeInternalRep(Tcl_Obj *objPtr); static void FreeSubstCodeInternalRep(Tcl_Obj *objPtr); static int GetCmdLocEncodingSize(CompileEnv *envPtr); @@ -706,10 +717,9 @@ static void StartExpanding(CompileEnv *envPtr); * TIP #280: Helper for building the per-word line information of all compiled * commands. */ -static void EnterCmdWordData(ExtCmdLoc *eclPtr, Tcl_Size srcOffset, +static void EnterCmdWordData(ExtCmdLoc *eclPtr, int srcOffset, Tcl_Token *tokenPtr, const char *cmd, - Tcl_Size numWords, Tcl_Size line, - Tcl_Size *clNext, Tcl_Size **lines, + int numWords, int line, int *clNext, int **lines, CompileEnv *envPtr); static void ReleaseCmdWordData(ExtCmdLoc *eclPtr); @@ -723,13 +733,12 @@ const Tcl_ObjType tclByteCodeType = { FreeByteCodeInternalRep, /* freeIntRepProc */ DupByteCodeInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ - SetByteCodeFromAny, /* setFromAnyProc */ - TCL_OBJTYPE_V0 + SetByteCodeFromAny /* setFromAnyProc */ }; /* - * substCodeType provides the standard type management procedures for the - * substcode type, which represents substitution within a Tcl value. + * subtCodeType provides the standard type managemnt procedures for the + * substcode type, which represents substiution within a Tcl value. */ static const Tcl_ObjType substCodeType = { @@ -738,7 +747,6 @@ static const Tcl_ObjType substCodeType = { DupByteCodeInternalRep, /* dupIntRepProc - shared with bytecode */ NULL, /* updateStringProc */ NULL, /* setFromAnyProc */ - TCL_OBJTYPE_V0 }; #define SubstFlags(objPtr) (objPtr)->internalRep.twoPtrValue.ptr2 @@ -784,7 +792,7 @@ TclSetByteCodeFromAny( Interp *iPtr = (Interp *) interp; CompileEnv compEnv; /* Compilation environment structure allocated * in frame. */ - Tcl_Size length; + int length; int result = TCL_OK; const char *stringPtr; Proc *procPtr = iPtr->compiledProcPtr; @@ -865,8 +873,8 @@ TclSetByteCodeFromAny( * instruction generator boundaries. */ - if (iPtr->optimizer) { - (iPtr->optimizer)(&compEnv); + if (iPtr->extra.optimizer) { + (iPtr->extra.optimizer)(&compEnv); } /* @@ -878,18 +886,6 @@ TclSetByteCodeFromAny( } /* - * After optimization is all done, check that byte code length limits - * are not exceeded. Bug [27b3ce2997]. - */ - if ((compEnv.codeNext - compEnv.codeStart) > INT_MAX) { - /* - * Cannot just return TCL_ERROR as callers ignore return value. - * TODO - May be use TclCompileSyntaxError here? - */ - Tcl_Panic("Maximum byte code length %d exceeded.", INT_MAX); - } - - /* * Change the object into a ByteCode object. Ownership of the literal * objects and aux data items passes to the ByteCode object. */ @@ -1164,7 +1160,7 @@ CleanupByteCode( } TclHandleRelease(codePtr->interpHandle); - Tcl_Free(codePtr); + ckfree(codePtr); } /* @@ -1348,7 +1344,7 @@ CompileSubstObj( } if (codePtr == NULL) { CompileEnv compEnv; - Tcl_Size numBytes; + int numBytes; const char *bytes = TclGetStringFromObj(objPtr, &numBytes); /* TODO: Check for more TIP 280 */ @@ -1411,20 +1407,20 @@ static void ReleaseCmdWordData( ExtCmdLoc *eclPtr) { - Tcl_Size i; + int i; if (eclPtr->type == TCL_LOCATION_SOURCE) { Tcl_DecrRefCount(eclPtr->path); } for (i=0 ; i<eclPtr->nuloc ; i++) { - Tcl_Free(eclPtr->loc[i].line); + ckfree(eclPtr->loc[i].line); } if (eclPtr->loc != NULL) { - Tcl_Free(eclPtr->loc); + ckfree(eclPtr->loc); } - Tcl_Free(eclPtr); + ckfree(eclPtr); } /* @@ -1451,14 +1447,14 @@ TclInitCompileEnv( CompileEnv *envPtr,/* Points to the CompileEnv structure to * initialize. */ const char *stringPtr, /* The source string to be compiled. */ - size_t numBytes, /* Number of bytes in source string. */ + TCL_HASH_TYPE numBytes, /* Number of bytes in source string. */ const CmdFrame *invoker, /* Location context invoking the bcc */ int word) /* Index of the word in that context getting * compiled */ { Interp *iPtr = (Interp *) interp; - assert(tclInstructionTable[LAST_INST_OPCODE].name == NULL); + assert(tclInstructionTable[LAST_INST_OPCODE+1].name == NULL); envPtr->iPtr = iPtr; envPtr->source = stringPtr; @@ -1503,7 +1499,7 @@ TclInitCompileEnv( * non-compiling evaluator */ - envPtr->extCmdMapPtr = (ExtCmdLoc *)Tcl_Alloc(sizeof(ExtCmdLoc)); + envPtr->extCmdMapPtr = (ExtCmdLoc *)ckalloc(sizeof(ExtCmdLoc)); envPtr->extCmdMapPtr->loc = NULL; envPtr->extCmdMapPtr->nloc = 0; envPtr->extCmdMapPtr->nuloc = 0; @@ -1658,7 +1654,7 @@ TclFreeCompileEnv( CompileEnv *envPtr)/* Points to the CompileEnv structure. */ { if (envPtr->localLitTable.buckets != envPtr->localLitTable.staticBuckets){ - Tcl_Free(envPtr->localLitTable.buckets); + ckfree(envPtr->localLitTable.buckets); envPtr->localLitTable.buckets = envPtr->localLitTable.staticBuckets; } if (envPtr->iPtr) { @@ -1667,7 +1663,7 @@ TclFreeCompileEnv( * have transferred to it. */ - Tcl_Size i; + int i; LiteralEntry *entryPtr = envPtr->literalArrayPtr; AuxData *auxDataPtr = envPtr->auxDataArrayPtr; @@ -1688,20 +1684,20 @@ TclFreeCompileEnv( } } if (envPtr->mallocedCodeArray) { - Tcl_Free(envPtr->codeStart); + ckfree(envPtr->codeStart); } if (envPtr->mallocedLiteralArray) { - Tcl_Free(envPtr->literalArrayPtr); + ckfree(envPtr->literalArrayPtr); } if (envPtr->mallocedExceptArray) { - Tcl_Free(envPtr->exceptArrayPtr); - Tcl_Free(envPtr->exceptAuxArrayPtr); + ckfree(envPtr->exceptArrayPtr); + ckfree(envPtr->exceptAuxArrayPtr); } if (envPtr->mallocedCmdMap) { - Tcl_Free(envPtr->cmdMapPtr); + ckfree(envPtr->cmdMapPtr); } if (envPtr->mallocedAuxDataArray) { - Tcl_Free(envPtr->auxDataArrayPtr); + ckfree(envPtr->auxDataArrayPtr); } if (envPtr->extCmdMapPtr) { ReleaseCmdWordData(envPtr->extCmdMapPtr); @@ -1768,7 +1764,7 @@ TclWordKnownAtCompileTime( case TCL_TOKEN_BS: if (tempPtr != NULL) { char utfBuf[4] = ""; - size_t length = TclParseBackslash(tokenPtr->start, + int length = TclParseBackslash(tokenPtr->start, tokenPtr->size, NULL, utfBuf); Tcl_AppendToObj(tempPtr, utfBuf, length); @@ -1811,7 +1807,7 @@ TclWordKnownAtCompileTime( static int ExpandRequested( Tcl_Token *tokenPtr, - size_t numWords) + int numWords) { /* Determine whether any words of the command require expansion */ while (numWords--) { @@ -1832,15 +1828,15 @@ CompileCmdLiteral( const char *bytes; Command *cmdPtr; int cmdLitIdx, extraLiteralFlags = LITERAL_CMD_NAME; - Tcl_Size length; + int numBytes; cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_VIA_RESOLVER)) { extraLiteralFlags |= LITERAL_UNSHARED; } - bytes = TclGetStringFromObj(cmdObj, &length); - cmdLitIdx = TclRegisterLiteral(envPtr, bytes, length, extraLiteralFlags); + bytes = TclGetStringFromObj(cmdObj, &numBytes); + cmdLitIdx = TclRegisterLiteral(envPtr, bytes, numBytes, extraLiteralFlags); if (cmdPtr && TclRoutineHasName(cmdPtr)) { TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr); @@ -1853,11 +1849,11 @@ TclCompileInvocation( Tcl_Interp *interp, Tcl_Token *tokenPtr, Tcl_Obj *cmdObj, - size_t numWords, + int numWords, CompileEnv *envPtr) { DefineLineInformation; - size_t wordIdx = 0; + int wordIdx = 0; int depth = TclGetStackDepth(envPtr); if (cmdObj) { @@ -1961,8 +1957,7 @@ CompileCmdCompileProc( CompileEnv *envPtr) { DefineLineInformation; - int unwind = 0; - Tcl_Size incrOffset = -1; + int unwind = 0, incrOffset = -1; int depth = TclGetStackDepth(envPtr); /* @@ -2023,7 +2018,7 @@ CompileCmdCompileProc( while (mapPtr->nuloc - 1 > eclIndex) { mapPtr->nuloc--; - Tcl_Free(mapPtr->loc[mapPtr->nuloc].line); + ckfree(mapPtr->loc[mapPtr->nuloc].line); mapPtr->loc[mapPtr->nuloc].line = NULL; } @@ -2049,14 +2044,14 @@ CompileCommandTokens( Command *cmdPtr = NULL; int code = TCL_ERROR; int cmdKnown, expand = -1; - Tcl_Size *wlines, wlineat; - Tcl_Size cmdLine = envPtr->line; - Tcl_Size *clNext = envPtr->clNext; - Tcl_Size cmdIdx = envPtr->numCommands; - Tcl_Size startCodeOffset = envPtr->codeNext - envPtr->codeStart; + int *wlines, wlineat; + int cmdLine = envPtr->line; + int *clNext = envPtr->clNext; + int cmdIdx = envPtr->numCommands; + int startCodeOffset = envPtr->codeNext - envPtr->codeStart; int depth = TclGetStackDepth(envPtr); - assert ((int)parsePtr->numWords > 0); + assert (parsePtr->numWords > 0); /* Precompile */ @@ -2101,7 +2096,7 @@ CompileCommandTokens( } } if (cmdPtr && !(cmdPtr->flags & CMD_COMPILES_EXPANDED)) { - expand = ExpandRequested(parsePtr->tokenPtr, (int)parsePtr->numWords); + expand = ExpandRequested(parsePtr->tokenPtr, parsePtr->numWords); if (expand) { /* We need to expand, but compileProc cannot. */ cmdPtr = NULL; @@ -2116,15 +2111,15 @@ CompileCommandTokens( if (code == TCL_ERROR) { if (expand < 0) { - expand = ExpandRequested(parsePtr->tokenPtr, (int)parsePtr->numWords); + expand = ExpandRequested(parsePtr->tokenPtr, parsePtr->numWords); } if (expand) { CompileExpanded(interp, parsePtr->tokenPtr, - cmdKnown ? cmdObj : NULL, (int)parsePtr->numWords, envPtr); + cmdKnown ? cmdObj : NULL, parsePtr->numWords, envPtr); } else { TclCompileInvocation(interp, parsePtr->tokenPtr, - cmdKnown ? cmdObj : NULL, (int)parsePtr->numWords, envPtr); + cmdKnown ? cmdObj : NULL, parsePtr->numWords, envPtr); } } @@ -2142,8 +2137,8 @@ CompileCommandTokens( envPtr->line = cmdLine; envPtr->clNext = clNext; - Tcl_Free(eclPtr->loc[wlineat].line); - Tcl_Free(eclPtr->loc[wlineat].next); + ckfree(eclPtr->loc[wlineat].line); + ckfree(eclPtr->loc[wlineat].next); eclPtr->loc[wlineat].line = wlines; eclPtr->loc[wlineat].next = NULL; @@ -2157,7 +2152,7 @@ TclCompileScript( * serves as context for finding and compiling * commands. May not be NULL. */ const char *script, /* The source script to compile. */ - Tcl_Size numBytes, /* Number of bytes in script. If < 0, the + int numBytes, /* Number of bytes in script. If < 0, the * script consists of all bytes up to the * first null character. */ CompileEnv *envPtr) /* Holds resulting instructions. */ @@ -2182,127 +2177,110 @@ TclCompileScript( */ if (iPtr->numLevels / 5 > iPtr->maxNestingDepth / 4) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "too many nested compilations (infinite loop?)", -1)); + "too many nested compilations (infinite loop?)", -1)); Tcl_SetErrorCode(interp, "TCL", "LIMIT", "STACK", (char *)NULL); TclCompileSyntaxError(interp, envPtr); return; } - if (numBytes < 0) { - numBytes = strlen(script); - } - /* Each iteration compiles one command from the script. */ if (numBytes > 0) { - if (numBytes >= INT_MAX) { + /* + * Don't use system stack (size of Tcl_Parse is ca. 400 bytes), so + * many nested compilations (body enclosed in body) can cause abnormal + * program termination with a stack overflow exception, bug [fec0c17d39]. + */ + Tcl_Parse *parsePtr = (Tcl_Parse *)ckalloc(sizeof(Tcl_Parse)); + + do { + const char *next; + + if (TCL_OK != Tcl_ParseCommand(interp, p, numBytes, 0, parsePtr)) { /* - * Note this gets -errorline as 1. Not worth figuring out which line - * crosses the limit to get -errorline for this error case. + * Compile bytecodes to report the parsePtr error at runtime. */ - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "Script length %" TCL_SIZE_MODIFIER - "d exceeds max permitted length %d.", - numBytes, INT_MAX-1)); - Tcl_SetErrorCode(interp, "TCL", "LIMIT", "SCRIPTLENGTH", (void *)NULL); + + Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, + parsePtr->term + 1 - parsePtr->commandStart); TclCompileSyntaxError(interp, envPtr); + ckfree(parsePtr); return; } - /* - * Don't use system stack (size of Tcl_Parse is ca. 400 bytes), so - * many nested compilations (body enclosed in body) can cause abnormal - * program termination with a stack overflow exception, bug [fec0c17d39]. - */ - Tcl_Parse *parsePtr = (Tcl_Parse *)Tcl_Alloc(sizeof(Tcl_Parse)); - - do { - const char *next; - - if (TCL_OK != Tcl_ParseCommand(interp, p, numBytes, 0, parsePtr)) { - /* - * Compile bytecodes to report the parsePtr error at runtime. - */ - - Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, - parsePtr->term + 1 - parsePtr->commandStart); - TclCompileSyntaxError(interp, envPtr); - Tcl_Free(parsePtr); - return; - } #ifdef TCL_COMPILE_DEBUG - /* - * If tracing, print a line for each top level command compiled. - * TODO: Suppress when numWords == 0 ? - */ + /* + * If tracing, print a line for each top level command compiled. + * TODO: Suppress when numWords == 0 ? + */ - if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) { - int commandLength = parsePtr->term - parsePtr->commandStart; - fprintf(stdout, " Compiling: "); - TclPrintSource(stdout, parsePtr->commandStart, - TclMin(commandLength, 55)); - fprintf(stdout, "\n"); - } + if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) { + int commandLength = parsePtr->term - parsePtr->commandStart; + fprintf(stdout, " Compiling: "); + TclPrintSource(stdout, parsePtr->commandStart, + TclMin(commandLength, 55)); + fprintf(stdout, "\n"); + } #endif - /* - * TIP #280: Count newlines before the command start. - * (See test info-30.33). - */ + /* + * TIP #280: Count newlines before the command start. + * (See test info-30.33). + */ - TclAdvanceLines(&envPtr->line, p, parsePtr->commandStart); - TclAdvanceContinuations(&envPtr->line, &envPtr->clNext, - parsePtr->commandStart - envPtr->source); + TclAdvanceLines(&envPtr->line, p, parsePtr->commandStart); + TclAdvanceContinuations(&envPtr->line, &envPtr->clNext, + parsePtr->commandStart - envPtr->source); - /* - * Advance parser to the next command in the script. - */ + /* + * Advance parser to the next command in the script. + */ - next = parsePtr->commandStart + parsePtr->commandSize; - numBytes -= next - p; - p = next; - - if (parsePtr->numWords == 0) { - /* - * The "command" parsed has no words. In this case we can skip - * the rest of the loop body. With no words, clearly - * CompileCommandTokens() has nothing to do. Since the parser - * aggressively sucks up leading comment and white space, - * including newlines, parsePtr->commandStart must be pointing at - * either the end of script, or a command-terminating semi-colon. - * In either case, the TclAdvance*() calls have nothing to do. - * Finally, when no words are parsed, no tokens have been - * allocated at parsePtr->tokenPtr so there's also nothing for - * Tcl_FreeParse() to do. - * - * The advantage of this shortcut is that CompileCommandTokens() - * can be written with an assumption that (int)parsePtr->numWords > 0, with - * the implication the CCT() always generates bytecode. - */ - continue; - } + next = parsePtr->commandStart + parsePtr->commandSize; + numBytes -= next - p; + p = next; + if (parsePtr->numWords == 0) { /* - * Avoid stack exhaustion by too many nested calls of TclCompileScript - * (considering interp recursionlimit). + * The "command" parsed has no words. In this case we can skip + * the rest of the loop body. With no words, clearly + * CompileCommandTokens() has nothing to do. Since the parser + * aggressively sucks up leading comment and white space, + * including newlines, parsePtr->commandStart must be pointing at + * either the end of script, or a command-terminating semi-colon. + * In either case, the TclAdvance*() calls have nothing to do. + * Finally, when no words are parsed, no tokens have been + * allocated at parsePtr->tokenPtr so there's also nothing for + * Tcl_FreeParse() to do. + * + * The advantage of this shortcut is that CompileCommandTokens() + * can be written with an assumption that parsePtr->numWords > 0, with + * the implication the CCT() always generates bytecode. */ - iPtr->numLevels++; + continue; + } + + /* + * Avoid stack exhaustion by too many nested calls of TclCompileScript + * (considering interp recursionlimit). + */ + iPtr->numLevels++; - lastCmdIdx = CompileCommandTokens(interp, parsePtr, envPtr); + lastCmdIdx = CompileCommandTokens(interp, parsePtr, envPtr); - iPtr->numLevels--; + iPtr->numLevels--; - /* - * TIP #280: Track lines in the just compiled command. - */ + /* + * TIP #280: Track lines in the just compiled command. + */ - TclAdvanceLines(&envPtr->line, parsePtr->commandStart, p); - TclAdvanceContinuations(&envPtr->line, &envPtr->clNext, - p - envPtr->source); - Tcl_FreeParse(parsePtr); - } while (numBytes > 0); + TclAdvanceLines(&envPtr->line, parsePtr->commandStart, p); + TclAdvanceContinuations(&envPtr->line, &envPtr->clNext, + p - envPtr->source); + Tcl_FreeParse(parsePtr); + } while (numBytes > 0); - Tcl_Free(parsePtr); + ckfree(parsePtr); } if (lastCmdIdx == -1) { @@ -2361,8 +2339,7 @@ TclCompileVarSubst( CompileEnv *envPtr) { const char *p, *name = tokenPtr[1].start; - Tcl_Size i, nameBytes = tokenPtr[1].size; - Tcl_Size localVar; + int i, localVar, nameBytes = tokenPtr[1].size; int localVarName = 1; /* @@ -2374,12 +2351,12 @@ TclCompileVarSubst( */ for (i = 0, p = name; i < nameBytes; i++, p++) { - if ((p[0] == ':') && (i < nameBytes-1) && (p[1] == ':')) { + if ((*p == ':') && (i < nameBytes-1) && (*(p+1) == ':')) { localVarName = -1; break; - } else if ((p[0] == '(') + } else if ((*p == '(') && (tokenPtr->numComponents == 1) - && (name[nameBytes - 1] == ')')) { + && (*(name + nameBytes - 1) == ')')) { localVarName = 0; break; } @@ -2390,7 +2367,7 @@ TclCompileVarSubst( * of local variables in a procedure frame. */ - localVar = -1; + localVar = TCL_INDEX_NONE; if (localVarName != -1) { localVar = TclFindCompiledLocal(name, nameBytes, localVarName, envPtr); } @@ -2430,22 +2407,20 @@ TclCompileTokens( Tcl_Interp *interp, /* Used for error and status reporting. */ Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to * compile. */ - size_t count1, /* Number of tokens to consider at tokenPtr. + int count, /* Number of tokens to consider at tokenPtr. * Must be at least 1. */ CompileEnv *envPtr) /* Holds the resulting instructions. */ { Tcl_DString textBuffer; /* Holds concatenated chars from adjacent * TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */ char buffer[4] = ""; - Tcl_Size i, numObjsToConcat, adjust; - size_t length; + int i, numObjsToConcat, adjust; + int length; unsigned char *entryCodeNext = envPtr->codeNext; #define NUM_STATIC_POS 20 - int isLiteral; - Tcl_Size maxNumCL, numCL; - Tcl_Size *clPosition = NULL; + int isLiteral, maxNumCL, numCL; + int *clPosition = NULL; int depth = TclGetStackDepth(envPtr); - int count = count1; /* * If this is actually a literal, handle continuation lines by @@ -2473,7 +2448,7 @@ TclCompileTokens( if (isLiteral) { maxNumCL = NUM_STATIC_POS; - clPosition = (Tcl_Size *)Tcl_Alloc(maxNumCL * sizeof(Tcl_Size)); + clPosition = (int *)ckalloc(maxNumCL * sizeof(int)); } adjust = 0; @@ -2507,14 +2482,14 @@ TclCompileTokens( */ if ((length == 1) && (buffer[0] == ' ') && - (tokenPtr->start[1] == '\n')) { + (tokenPtr->start[1] == '\n')) { if (isLiteral) { int clPos = Tcl_DStringLength(&textBuffer); if (numCL >= maxNumCL) { maxNumCL *= 2; - clPosition = (Tcl_Size *)Tcl_Realloc(clPosition, - maxNumCL * sizeof(Tcl_Size)); + clPosition = (int *)ckrealloc(clPosition, + maxNumCL * sizeof(int)); } clPosition[numCL] = clPos; numCL ++; @@ -2571,7 +2546,7 @@ TclCompileTokens( default: Tcl_Panic("Unexpected token type in TclCompileTokens: %d; %.*s", - tokenPtr->type, (int)tokenPtr->size, tokenPtr->start); + tokenPtr->type, tokenPtr->size, tokenPtr->start); } } @@ -2618,7 +2593,7 @@ TclCompileTokens( */ if (maxNumCL) { - Tcl_Free(clPosition); + ckfree(clPosition); } TclCheckStackDepth(depth+1, envPtr); } @@ -2649,12 +2624,10 @@ TclCompileCmdWord( Tcl_Interp *interp, /* Used for error and status reporting. */ Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens for * a command word to compile inline. */ - size_t count1, /* Number of tokens to consider at tokenPtr. + int count, /* Number of tokens to consider at tokenPtr. * Must be at least 1. */ CompileEnv *envPtr) /* Holds the resulting instructions. */ { - int count = count1; - if ((count == 1) && (tokenPtr->type == TCL_TOKEN_TEXT)) { /* * The common case that there is a single text token. Compile it @@ -2700,14 +2673,13 @@ TclCompileExprWords( Tcl_Token *tokenPtr, /* Points to first in an array of word tokens * tokens for the expression to compile * inline. */ - size_t numWords1, /* Number of word tokens starting at tokenPtr. + int numWords, /* Number of word tokens starting at tokenPtr. * Must be at least 1. Each word token * contains one or more subtokens. */ CompileEnv *envPtr) /* Holds the resulting instructions. */ { Tcl_Token *wordPtr; int i, concatItems; - int numWords = numWords1; /* * If the expression is a single word that doesn't require substitutions, @@ -2773,7 +2745,7 @@ TclCompileNoOp( int i; tokenPtr = parsePtr->tokenPtr; - for (i = 1; i < (int)parsePtr->numWords; i++) { + for (i = 1; i < parsePtr->numWords; i++) { tokenPtr = tokenPtr + tokenPtr->numComponents + 1; if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { @@ -2815,7 +2787,7 @@ PreventCycle( Tcl_Obj *objPtr, CompileEnv *envPtr) { - Tcl_Size i; + int i; for (i = 0; i < envPtr->literalArrayNext; i++) { if (objPtr == TclFetchLiteral(envPtr, i)) { @@ -2830,7 +2802,7 @@ PreventCycle( * can be sure we do not have any lingering cycles hiding in * the internalrep. */ - Tcl_Size numBytes; + int numBytes; const char *bytes = TclGetStringFromObj(objPtr, &numBytes); Tcl_Obj *copyPtr = Tcl_NewStringObj(bytes, numBytes); @@ -2892,7 +2864,7 @@ TclInitByteCode( namespacePtr = envPtr->iPtr->globalNsPtr; } - p = (unsigned char *)Tcl_Alloc(structureSize); + p = (unsigned char *)ckalloc(structureSize); codePtr = (ByteCode *) p; codePtr->interpHandle = TclHandlePreserve(iPtr->handle); codePtr->compileEpoch = iPtr->compileEpoch; @@ -3032,19 +3004,19 @@ TclInitByteCodeObj( *---------------------------------------------------------------------- */ -Tcl_Size +int TclFindCompiledLocal( const char *name, /* Points to first character of the name of a * scalar or array variable. If NULL, a * temporary var should be created. */ - Tcl_Size nameBytes, /* Number of bytes in the name. */ + int nameBytes, /* Number of bytes in the name. */ int create, /* If 1, allocate a local frame entry for the * variable if it is new. */ CompileEnv *envPtr) /* Points to the current compile environment*/ { CompiledLocal *localPtr; - Tcl_Size localVar = TCL_INDEX_NONE; - Tcl_Size i; + int localVar = TCL_INDEX_NONE; + int i; Proc *procPtr; /* @@ -3063,7 +3035,7 @@ TclFindCompiledLocal( LocalCache *cachePtr = envPtr->iPtr->varFramePtr->localCachePtr; const char *localName; Tcl_Obj **varNamePtr; - Tcl_Size len; + int len; if (!cachePtr || !name) { return TCL_INDEX_NONE; @@ -3082,7 +3054,7 @@ TclFindCompiledLocal( } if (name != NULL) { - Tcl_Size localCt = procPtr->numCompiledLocals; + int localCt = procPtr->numCompiledLocals; localPtr = procPtr->firstLocalPtr; for (i = 0; i < localCt; i++) { @@ -3090,7 +3062,7 @@ TclFindCompiledLocal( char *localName = localPtr->name; if ((nameBytes == localPtr->nameLength) && - (strncmp(name,localName,nameBytes) == 0)) { + (strncmp(name, localName, nameBytes) == 0)) { return i; } } @@ -3104,7 +3076,7 @@ TclFindCompiledLocal( if (create || (name == NULL)) { localVar = procPtr->numCompiledLocals; - localPtr = (CompiledLocal *)Tcl_Alloc(offsetof(CompiledLocal, name) + 1U + nameBytes); + localPtr = (CompiledLocal *)ckalloc(offsetof(CompiledLocal, name) + 1U + nameBytes); if (procPtr->firstLocalPtr == NULL) { procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; } else { @@ -3167,14 +3139,14 @@ TclExpandCodeArray( size_t newBytes = 2 * (envPtr->codeEnd - envPtr->codeStart); if (envPtr->mallocedCodeArray) { - envPtr->codeStart = (unsigned char *)Tcl_Realloc(envPtr->codeStart, newBytes); + envPtr->codeStart = (unsigned char *)ckrealloc(envPtr->codeStart, newBytes); } else { /* * envPtr->exceptArrayPtr isn't a Tcl_Alloc'd pointer, so * perform the equivalent of Tcl_Realloc directly. */ - unsigned char *newPtr = (unsigned char *)Tcl_Alloc(newBytes); + unsigned char *newPtr = (unsigned char *)ckalloc(newBytes); memcpy(newPtr, envPtr->codeStart, currBytes); envPtr->codeStart = newPtr; @@ -3210,15 +3182,15 @@ EnterCmdStartData( CompileEnv *envPtr, /* Points to the compilation environment * structure in which to enter command * location information. */ - Tcl_Size cmdIndex, /* Index of the command whose start data is + int cmdIndex, /* Index of the command whose start data is * being set. */ - Tcl_Size srcOffset, /* Offset of first char of the command. */ - Tcl_Size codeOffset) /* Offset of first byte of command code. */ + int srcOffset, /* Offset of first char of the command. */ + int codeOffset) /* Offset of first byte of command code. */ { CmdLocation *cmdLocPtr; - if (cmdIndex < 0 || cmdIndex >= envPtr->numCommands) { - Tcl_Panic("EnterCmdStartData: bad command index %" TCL_Z_MODIFIER "u", cmdIndex); + if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) { + Tcl_Panic("EnterCmdStartData: bad command index %d", cmdIndex); } if (cmdIndex >= envPtr->cmdMapEnd) { @@ -3234,14 +3206,14 @@ EnterCmdStartData( size_t newBytes = newElems * sizeof(CmdLocation); if (envPtr->mallocedCmdMap) { - envPtr->cmdMapPtr = (CmdLocation *)Tcl_Realloc(envPtr->cmdMapPtr, newBytes); + envPtr->cmdMapPtr = (CmdLocation *)ckrealloc(envPtr->cmdMapPtr, newBytes); } else { /* - * envPtr->cmdMapPtr isn't a Tcl_Alloc'd pointer, so we must code a - * Tcl_Realloc equivalent for ourselves. + * envPtr->cmdMapPtr isn't a ckalloc'd pointer, so we must code a + * ckrealloc equivalent for ourselves. */ - CmdLocation *newPtr = (CmdLocation *)Tcl_Alloc(newBytes); + CmdLocation *newPtr = (CmdLocation *)ckalloc(newBytes); memcpy(newPtr, envPtr->cmdMapPtr, currBytes); envPtr->cmdMapPtr = newPtr; @@ -3289,19 +3261,19 @@ EnterCmdExtentData( CompileEnv *envPtr, /* Points to the compilation environment * structure in which to enter command * location information. */ - Tcl_Size cmdIndex, /* Index of the command whose source and code + int cmdIndex, /* Index of the command whose source and code * length data is being set. */ - Tcl_Size numSrcBytes, /* Number of command source chars. */ - Tcl_Size numCodeBytes) /* Offset of last byte of command code. */ + int numSrcBytes, /* Number of command source chars. */ + int numCodeBytes) /* Offset of last byte of command code. */ { CmdLocation *cmdLocPtr; - if (cmdIndex < 0 || cmdIndex >= envPtr->numCommands) { - Tcl_Panic("EnterCmdExtentData: bad command index %" TCL_Z_MODIFIER "u", cmdIndex); + if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) { + Tcl_Panic("EnterCmdExtentData: bad command index %d", cmdIndex); } if (cmdIndex > envPtr->cmdMapEnd) { - Tcl_Panic("EnterCmdExtentData: missing start data for command %" TCL_Z_MODIFIER "u", + Tcl_Panic("EnterCmdExtentData: missing start data for command %d", cmdIndex); } @@ -3335,19 +3307,19 @@ EnterCmdWordData( ExtCmdLoc *eclPtr, /* Points to the map environment structure in * which to enter command location * information. */ - Tcl_Size srcOffset, /* Offset of first char of the command. */ + int srcOffset, /* Offset of first char of the command. */ Tcl_Token *tokenPtr, const char *cmd, - Tcl_Size numWords, - Tcl_Size line, - Tcl_Size *clNext, - Tcl_Size **wlines, + int numWords, + int line, + int *clNext, + int **wlines, CompileEnv *envPtr) { ECL *ePtr; const char *last; - Tcl_Size wordIdx, wordLine; - Tcl_Size *wwlines, *wordNext; + int wordIdx, wordLine; + int *wwlines, *wordNext; if (eclPtr->nuloc >= eclPtr->nloc) { /* @@ -3360,16 +3332,16 @@ EnterCmdWordData( size_t newElems = (currElems ? 2*currElems : 1); size_t newBytes = newElems * sizeof(ECL); - eclPtr->loc = (ECL *)Tcl_Realloc(eclPtr->loc, newBytes); + eclPtr->loc = (ECL *)ckrealloc(eclPtr->loc, newBytes); eclPtr->nloc = newElems; } ePtr = &eclPtr->loc[eclPtr->nuloc]; ePtr->srcOffset = srcOffset; - ePtr->line = (Tcl_Size *)Tcl_Alloc(numWords * sizeof(Tcl_Size)); - ePtr->next = (Tcl_Size **)Tcl_Alloc(numWords * sizeof(Tcl_Size *)); + ePtr->line = (int *)ckalloc(numWords * sizeof(int)); + ePtr->next = (int **)ckalloc(numWords * sizeof(int *)); ePtr->nline = numWords; - wwlines = (Tcl_Size *)Tcl_Alloc(numWords * sizeof(Tcl_Size)); + wwlines = (int *)ckalloc(numWords * sizeof(int)); last = cmd; wordLine = line; @@ -3382,7 +3354,7 @@ EnterCmdWordData( /* See Ticket 4b61afd660 */ wwlines[wordIdx] = ((wordIdx == 0) || TclWordKnownAtCompileTime(tokenPtr, NULL)) - ? wordLine : -1; + ? wordLine : TCL_INDEX_NONE; ePtr->line[wordIdx] = wordLine; ePtr->next[wordIdx] = wordNext; last = tokenPtr->start; @@ -3412,7 +3384,7 @@ EnterCmdWordData( *---------------------------------------------------------------------- */ -Tcl_Size +int TclCreateExceptRange( ExceptionRangeType type, /* The kind of ExceptionRange desired. */ CompileEnv *envPtr)/* Points to CompileEnv for which to create a @@ -3420,7 +3392,7 @@ TclCreateExceptRange( { ExceptionRange *rangePtr; ExceptionAux *auxPtr; - Tcl_Size index = envPtr->exceptArrayNext; + int index = envPtr->exceptArrayNext; if (index >= envPtr->exceptArrayEnd) { /* @@ -3438,17 +3410,17 @@ TclCreateExceptRange( if (envPtr->mallocedExceptArray) { envPtr->exceptArrayPtr = - (ExceptionRange *)Tcl_Realloc(envPtr->exceptArrayPtr, newBytes); + (ExceptionRange *)ckrealloc(envPtr->exceptArrayPtr, newBytes); envPtr->exceptAuxArrayPtr = - (ExceptionAux *)Tcl_Realloc(envPtr->exceptAuxArrayPtr, newBytes2); + (ExceptionAux *)ckrealloc(envPtr->exceptAuxArrayPtr, newBytes2); } else { /* - * envPtr->exceptArrayPtr isn't a Tcl_Alloc'd pointer, so we must - * code a Tcl_Realloc equivalent for ourselves. + * envPtr->exceptArrayPtr isn't a ckalloc'd pointer, so we must + * code a ckrealloc equivalent for ourselves. */ - ExceptionRange *newPtr = (ExceptionRange *)Tcl_Alloc(newBytes); - ExceptionAux *newPtr2 = (ExceptionAux *)Tcl_Alloc(newBytes2); + ExceptionRange *newPtr = (ExceptionRange *)ckalloc(newBytes); + ExceptionAux *newPtr2 = (ExceptionAux *)ckalloc(newBytes2); memcpy(newPtr, envPtr->exceptArrayPtr, currBytes); memcpy(newPtr2, envPtr->exceptAuxArrayPtr, currBytes2); @@ -3508,9 +3480,9 @@ TclGetInnermostExceptionRange( while (i > 0) { rangePtr--; i--; - if (CurrentOffset(envPtr) >= (int)rangePtr->codeOffset && + if (CurrentOffset(envPtr) >= rangePtr->codeOffset && (rangePtr->numCodeBytes == TCL_INDEX_NONE || CurrentOffset(envPtr) < - (int)rangePtr->codeOffset+(int)rangePtr->numCodeBytes) && + rangePtr->codeOffset+rangePtr->numCodeBytes) && (returnCode != TCL_CONTINUE || envPtr->exceptAuxArrayPtr[i].supportsContinue)) { @@ -3551,11 +3523,11 @@ TclAddLoopBreakFixup( auxPtr->allocBreakTargets *= 2; auxPtr->allocBreakTargets += 2; if (auxPtr->breakTargets) { - auxPtr->breakTargets = (size_t *)Tcl_Realloc(auxPtr->breakTargets, - sizeof(size_t) * auxPtr->allocBreakTargets); + auxPtr->breakTargets = (unsigned int *)ckrealloc(auxPtr->breakTargets, + sizeof(int) * auxPtr->allocBreakTargets); } else { auxPtr->breakTargets = - (size_t *)Tcl_Alloc(sizeof(size_t) * auxPtr->allocBreakTargets); + (unsigned int *)ckalloc(sizeof(int) * auxPtr->allocBreakTargets); } } auxPtr->breakTargets[auxPtr->numBreakTargets - 1] = CurrentOffset(envPtr); @@ -3577,11 +3549,11 @@ TclAddLoopContinueFixup( auxPtr->allocContinueTargets *= 2; auxPtr->allocContinueTargets += 2; if (auxPtr->continueTargets) { - auxPtr->continueTargets = (size_t *)Tcl_Realloc(auxPtr->continueTargets, - sizeof(size_t) * auxPtr->allocContinueTargets); + auxPtr->continueTargets = (unsigned int *)ckrealloc(auxPtr->continueTargets, + sizeof(int) * auxPtr->allocContinueTargets); } else { auxPtr->continueTargets = - (size_t *)Tcl_Alloc(sizeof(size_t) * auxPtr->allocContinueTargets); + (unsigned int *)ckalloc(sizeof(int) * auxPtr->allocContinueTargets); } } auxPtr->continueTargets[auxPtr->numContinueTargets - 1] = @@ -3613,7 +3585,7 @@ TclCleanupStackForBreakContinue( while (toPop --> 0) { TclEmitOpcode(INST_EXPAND_DROP, envPtr); } - TclAdjustStackDepth((int)(auxPtr->expandTargetDepth - envPtr->currStackDepth), + TclAdjustStackDepth(auxPtr->expandTargetDepth - envPtr->currStackDepth, envPtr); envPtr->currStackDepth = auxPtr->expandTargetDepth; } @@ -3649,7 +3621,7 @@ StartExpanding( * where this expansion started. */ - for (i=0 ; i<(int)envPtr->exceptArrayNext ; i++) { + for (i=0 ; i<envPtr->exceptArrayNext ; i++) { ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[i]; ExceptionAux *auxPtr = &envPtr->exceptAuxArrayPtr[i]; @@ -3657,7 +3629,7 @@ StartExpanding( * Ignore loops unless they're still being built. */ - if ((int)rangePtr->codeOffset > CurrentOffset(envPtr)) { + if (rangePtr->codeOffset > CurrentOffset(envPtr)) { continue; } if (rangePtr->numCodeBytes != TCL_INDEX_NONE) { @@ -3713,12 +3685,12 @@ TclFinalizeLoopExceptionRange( * there is no need to fuss around with updating code offsets. */ - for (i=0 ; i<(int)auxPtr->numBreakTargets ; i++) { + for (i=0 ; i<auxPtr->numBreakTargets ; i++) { site = envPtr->codeStart + auxPtr->breakTargets[i]; offset = rangePtr->breakOffset - auxPtr->breakTargets[i]; TclUpdateInstInt4AtPc(INST_JUMP4, offset, site); } - for (i=0 ; i<(int)auxPtr->numContinueTargets ; i++) { + for (i=0 ; i<auxPtr->numContinueTargets ; i++) { site = envPtr->codeStart + auxPtr->continueTargets[i]; if (rangePtr->continueOffset == TCL_INDEX_NONE) { int j; @@ -3743,12 +3715,12 @@ TclFinalizeLoopExceptionRange( */ if (auxPtr->breakTargets) { - Tcl_Free(auxPtr->breakTargets); + ckfree(auxPtr->breakTargets); auxPtr->breakTargets = NULL; auxPtr->numBreakTargets = 0; } if (auxPtr->continueTargets) { - Tcl_Free(auxPtr->continueTargets); + ckfree(auxPtr->continueTargets); auxPtr->continueTargets = NULL; auxPtr->numContinueTargets = 0; } @@ -3773,7 +3745,7 @@ TclFinalizeLoopExceptionRange( *---------------------------------------------------------------------- */ -Tcl_Size +int TclCreateAuxData( void *clientData, /* The compilation auxiliary data to store in * the new aux data record. */ @@ -3782,7 +3754,7 @@ TclCreateAuxData( CompileEnv *envPtr)/* Points to the CompileEnv for which a new * aux data structure is to be allocated. */ { - Tcl_Size index; /* Index for the new AuxData structure. */ + int index; /* Index for the new AuxData structure. */ AuxData *auxDataPtr; /* Points to the new AuxData structure */ @@ -3800,14 +3772,14 @@ TclCreateAuxData( if (envPtr->mallocedAuxDataArray) { envPtr->auxDataArrayPtr = - (AuxData *)Tcl_Realloc(envPtr->auxDataArrayPtr, newBytes); + (AuxData *)ckrealloc(envPtr->auxDataArrayPtr, newBytes); } else { /* - * envPtr->auxDataArrayPtr isn't a Tcl_Alloc'd pointer, so we must - * code a Tcl_Realloc equivalent for ourselves. + * envPtr->auxDataArrayPtr isn't a ckalloc'd pointer, so we must + * code a ckrealloc equivalent for ourselves. */ - AuxData *newPtr = (AuxData *)Tcl_Alloc(newBytes); + AuxData *newPtr = (AuxData *)ckalloc(newBytes); memcpy(newPtr, envPtr->auxDataArrayPtr, currBytes); envPtr->auxDataArrayPtr = newPtr; @@ -3888,14 +3860,14 @@ TclExpandJumpFixupArray( size_t newBytes = newElems * sizeof(JumpFixup); if (fixupArrayPtr->mallocedArray) { - fixupArrayPtr->fixup = (JumpFixup *)Tcl_Realloc(fixupArrayPtr->fixup, newBytes); + fixupArrayPtr->fixup = (JumpFixup *)ckrealloc(fixupArrayPtr->fixup, newBytes); } else { /* - * fixupArrayPtr->fixup isn't a Tcl_Alloc'd pointer, so we must code a - * Tcl_Realloc equivalent for ourselves. + * fixupArrayPtr->fixup isn't a ckalloc'd pointer, so we must code a + * ckrealloc equivalent for ourselves. */ - JumpFixup *newPtr = (JumpFixup *)Tcl_Alloc(newBytes); + JumpFixup *newPtr = (JumpFixup *)ckalloc(newBytes); memcpy(newPtr, fixupArrayPtr->fixup, currBytes); fixupArrayPtr->fixup = newPtr; @@ -3927,7 +3899,7 @@ TclFreeJumpFixupArray( * free. */ { if (fixupArrayPtr->mallocedArray) { - Tcl_Free(fixupArrayPtr->fixup); + ckfree(fixupArrayPtr->fixup); } } @@ -4111,16 +4083,16 @@ TclFixupForwardJump( } } - for (k = 0 ; k < (int)envPtr->exceptArrayNext ; k++) { + for (k = 0 ; k < envPtr->exceptArrayNext ; k++) { ExceptionAux *auxPtr = &envPtr->exceptAuxArrayPtr[k]; int i; - for (i=0 ; i<(int)auxPtr->numBreakTargets ; i++) { + for (i=0 ; i<auxPtr->numBreakTargets ; i++) { if (jumpFixupPtr->codeOffset < auxPtr->breakTargets[i]) { auxPtr->breakTargets[i] += 3; } } - for (i=0 ; i<(int)auxPtr->numContinueTargets ; i++) { + for (i=0 ; i<auxPtr->numContinueTargets ; i++) { if (jumpFixupPtr->codeOffset < auxPtr->continueTargets[i]) { auxPtr->continueTargets[i] += 3; } @@ -4272,8 +4244,8 @@ TclEmitInvoke( */ if (auxBreakPtr != NULL || auxContinuePtr != NULL) { - size_t savedStackDepth = envPtr->currStackDepth; - size_t savedExpandCount = envPtr->expandCount; + int savedStackDepth = envPtr->currStackDepth; + int savedExpandCount = envPtr->expandCount; JumpFixup nonTrapFixup; if (auxBreakPtr != NULL) { @@ -4455,10 +4427,10 @@ EncodeCmdLocMap( * is to be stored. */ { CmdLocation *mapPtr = envPtr->cmdMapPtr; - Tcl_Size i, codeDelta, codeLen, srcLen, prevOffset; - Tcl_Size numCmds = envPtr->numCommands; + int numCmds = envPtr->numCommands; unsigned char *p = startPtr; - int srcDelta; + int codeDelta, codeLen, srcDelta, srcLen, prevOffset; + int i; /* * Encode the code offset for each command as a sequence of deltas. @@ -4581,12 +4553,12 @@ RecordByteCodeStats( statsPtr = &(iPtr->stats); statsPtr->numCompilations++; - statsPtr->totalSrcBytes += (double)codePtr->numSrcBytes; + statsPtr->totalSrcBytes += (double) codePtr->numSrcBytes; statsPtr->totalByteCodeBytes += (double) codePtr->structureSize; - statsPtr->currentSrcBytes += (double) (int)codePtr->numSrcBytes; + statsPtr->currentSrcBytes += (double) codePtr->numSrcBytes; statsPtr->currentByteCodeBytes += (double) codePtr->structureSize; - statsPtr->srcCount[TclLog2((int)codePtr->numSrcBytes)]++; + statsPtr->srcCount[TclLog2(codePtr->numSrcBytes)]++; statsPtr->byteCodeCount[TclLog2((int) codePtr->structureSize)]++; statsPtr->currentInstBytes += (double) codePtr->numCodeBytes; diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 5bbbb8f..16bc972 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -316,10 +316,6 @@ typedef struct CompileEnv { * array byte. */ int mallocedCodeArray; /* Set 1 if code array was expanded and * codeStart points into the heap.*/ -#if TCL_MAJOR_VERSION > 8 - int mallocedExceptArray; /* 1 if ExceptionRange array was expanded and - * exceptArrayPtr points in heap, else 0. */ -#endif LiteralEntry *literalArrayPtr; /* Points to start of LiteralEntry array. */ Tcl_Size literalArrayNext; /* Index of next free object array entry. */ @@ -335,9 +331,8 @@ typedef struct CompileEnv { * current range's array entry. */ Tcl_Size exceptArrayEnd; /* Index after the last ExceptionRange array * entry. */ -#if TCL_MAJOR_VERSION < 9 - int mallocedExceptArray; -#endif + int mallocedExceptArray; /* 1 if ExceptionRange array was expanded and + * exceptArrayPtr points in heap, else 0. */ ExceptionAux *exceptAuxArrayPtr; /* Array of information used to restore the * state when processing BREAK/CONTINUE @@ -350,19 +345,14 @@ typedef struct CompileEnv { Tcl_Size cmdMapEnd; /* Index after last CmdLocation entry. */ int mallocedCmdMap; /* 1 if command map array was expanded and * cmdMapPtr points in the heap, else 0. */ -#if TCL_MAJOR_VERSION > 8 - int mallocedAuxDataArray; /* 1 if aux data array was expanded and - * auxDataArrayPtr points in heap else 0. */ -#endif AuxData *auxDataArrayPtr; /* Points to auxiliary data array start. */ Tcl_Size auxDataArrayNext; /* Next free compile aux data array index. * auxDataArrayNext is the number of aux data * items and (auxDataArrayNext-1) is index of * current aux data array entry. */ Tcl_Size auxDataArrayEnd; /* Index after last aux data array entry. */ -#if TCL_MAJOR_VERSION < 9 - int mallocedAuxDataArray; -#endif + int mallocedAuxDataArray; /* 1 if aux data array was expanded and + * auxDataArrayPtr points in heap else 0. */ unsigned char staticCodeSpace[COMPILEENV_INIT_CODE_BYTES]; /* Initial storage for code. */ LiteralEntry staticLiteralSpace[COMPILEENV_INIT_NUM_OBJECTS]; @@ -550,300 +540,318 @@ typedef struct ByteCode { * tclExecute.c. */ -enum TclInstruction { - /* Opcodes 0 to 9 */ - INST_DONE = 0, - INST_PUSH1, - INST_PUSH4, - INST_POP, - INST_DUP, - INST_STR_CONCAT1, - INST_INVOKE_STK1, - INST_INVOKE_STK4, - INST_EVAL_STK, - INST_EXPR_STK, - - /* Opcodes 10 to 23 */ - INST_LOAD_SCALAR1, - INST_LOAD_SCALAR4, - INST_LOAD_SCALAR_STK, - INST_LOAD_ARRAY1, - INST_LOAD_ARRAY4, - INST_LOAD_ARRAY_STK, - INST_LOAD_STK, - INST_STORE_SCALAR1, - INST_STORE_SCALAR4, - INST_STORE_SCALAR_STK, - INST_STORE_ARRAY1, - INST_STORE_ARRAY4, - INST_STORE_ARRAY_STK, - INST_STORE_STK, - - /* Opcodes 24 to 33 */ - INST_INCR_SCALAR1, - INST_INCR_SCALAR_STK, - INST_INCR_ARRAY1, - INST_INCR_ARRAY_STK, - INST_INCR_STK, - INST_INCR_SCALAR1_IMM, - INST_INCR_SCALAR_STK_IMM, - INST_INCR_ARRAY1_IMM, - INST_INCR_ARRAY_STK_IMM, - INST_INCR_STK_IMM, - - /* Opcodes 34 to 39 */ - INST_JUMP1, - INST_JUMP4, - INST_JUMP_TRUE1, - INST_JUMP_TRUE4, - INST_JUMP_FALSE1, - INST_JUMP_FALSE4, - - /* Opcodes 42 to 64 */ - INST_BITOR, - INST_BITXOR, - INST_BITAND, - INST_EQ, - INST_NEQ, - INST_LT, - INST_GT, - INST_LE, - INST_GE, - INST_LSHIFT, - INST_RSHIFT, - INST_ADD, - INST_SUB, - INST_MULT, - INST_DIV, - INST_MOD, - INST_UPLUS, - INST_UMINUS, - INST_BITNOT, - INST_LNOT, - INST_TRY_CVT_TO_NUMERIC, - - /* Opcodes 65 to 66 */ - INST_BREAK, - INST_CONTINUE, - - /* Opcodes 69 to 72 */ - INST_BEGIN_CATCH4, - INST_END_CATCH, - INST_PUSH_RESULT, - INST_PUSH_RETURN_CODE, - - /* Opcodes 73 to 78 */ - INST_STR_EQ, - INST_STR_NEQ, - INST_STR_CMP, - INST_STR_LEN, - INST_STR_INDEX, - INST_STR_MATCH, - - /* Opcodes 79 to 81 */ - INST_LIST, - INST_LIST_INDEX, - INST_LIST_LENGTH, - - /* Opcodes 82 to 87 */ - INST_APPEND_SCALAR1, - INST_APPEND_SCALAR4, - INST_APPEND_ARRAY1, - INST_APPEND_ARRAY4, - INST_APPEND_ARRAY_STK, - INST_APPEND_STK, - - /* Opcodes 88 to 93 */ - INST_LAPPEND_SCALAR1, - INST_LAPPEND_SCALAR4, - INST_LAPPEND_ARRAY1, - INST_LAPPEND_ARRAY4, - INST_LAPPEND_ARRAY_STK, - INST_LAPPEND_STK, - - /* TIP #22 - LINDEX operator with flat arg list */ - INST_LIST_INDEX_MULTI, - - /* - * TIP #33 - 'lset' command. Code gen also required a Forth-like - * OVER operation. - */ - INST_OVER, - INST_LSET_LIST, - INST_LSET_FLAT, - - /* TIP#90 - 'return' command. */ - INST_RETURN_IMM, - - /* TIP#123 - exponentiation operator. */ - INST_EXPON, - - /* TIP #157 - {*}... (word expansion) language syntax support. */ - INST_EXPAND_START, - INST_EXPAND_STKTOP, - INST_INVOKE_EXPANDED, - - /* - * TIP #57 - 'lassign' command. Code generation requires immediate - * LINDEX and LRANGE operators. - */ - INST_LIST_INDEX_IMM, - INST_LIST_RANGE_IMM, - INST_START_CMD, - INST_LIST_IN, - INST_LIST_NOT_IN, - INST_PUSH_RETURN_OPTIONS, - INST_RETURN_STK, - - /* - * Dictionary (TIP#111) related commands. - */ - INST_DICT_GET, - INST_DICT_SET, - INST_DICT_UNSET, - INST_DICT_INCR_IMM, - INST_DICT_APPEND, - INST_DICT_LAPPEND, - INST_DICT_FIRST, - INST_DICT_NEXT, - INST_DICT_UPDATE_START, - INST_DICT_UPDATE_END, - - /* - * Instruction to support jumps defined by tables (instead of the classic - * [switch] technique of chained comparisons). - */ - INST_JUMP_TABLE, - - /* - * Instructions to support compilation of global, variable, upvar and - * [namespace upvar]. - */ - INST_UPVAR, - INST_NSUPVAR, - INST_VARIABLE, - - /* Instruction to support compiling syntax error to bytecode */ - INST_SYNTAX, - - /* Instruction to reverse N items on top of stack */ - INST_REVERSE, - - /* regexp instruction */ - INST_REGEXP, - - /* For [info exists] compilation */ - INST_EXIST_SCALAR, - INST_EXIST_ARRAY, - INST_EXIST_ARRAY_STK, - INST_EXIST_STK, - - /* For [subst] compilation */ - INST_NOP, - INST_RETURN_CODE_BRANCH, - - /* For [unset] compilation */ - INST_UNSET_SCALAR, - INST_UNSET_ARRAY, - INST_UNSET_ARRAY_STK, - INST_UNSET_STK, - - /* For [dict with], [dict exists], [dict create] and [dict merge] */ - INST_DICT_EXPAND, - INST_DICT_RECOMBINE_STK, - INST_DICT_RECOMBINE_IMM, - INST_DICT_EXISTS, - INST_DICT_VERIFY, - - /* For [string map] and [regsub] compilation */ - INST_STR_MAP, - INST_STR_FIND, - INST_STR_FIND_LAST, - INST_STR_RANGE_IMM, - INST_STR_RANGE, - - /* For operations to do with coroutines and other NRE-manipulators */ - INST_YIELD, - INST_COROUTINE_NAME, - INST_TAILCALL, - - /* For compilation of basic information operations */ - INST_NS_CURRENT, - INST_INFO_LEVEL_NUM, - INST_INFO_LEVEL_ARGS, - INST_RESOLVE_COMMAND, - - /* For compilation relating to TclOO */ - INST_TCLOO_SELF, - INST_TCLOO_CLASS, - INST_TCLOO_NS, - INST_TCLOO_IS_OBJECT, - - /* For compilation of [array] subcommands */ - INST_ARRAY_EXISTS_STK, - INST_ARRAY_EXISTS_IMM, - INST_ARRAY_MAKE_STK, - INST_ARRAY_MAKE_IMM, - - INST_INVOKE_REPLACE, - - INST_LIST_CONCAT, - - INST_EXPAND_DROP, - - /* New foreach implementation */ - INST_FOREACH_START, - INST_FOREACH_STEP, - INST_FOREACH_END, - INST_LMAP_COLLECT, - - /* For compilation of [string trim] and related */ - INST_STR_TRIM, - INST_STR_TRIM_LEFT, - INST_STR_TRIM_RIGHT, - - INST_CONCAT_STK, - - INST_STR_UPPER, - INST_STR_LOWER, - INST_STR_TITLE, - INST_STR_REPLACE, - - INST_ORIGIN_COMMAND, - - INST_TCLOO_NEXT, - INST_TCLOO_NEXT_CLASS, - - INST_YIELD_TO_INVOKE, - - INST_NUM_TYPE, - INST_TRY_CVT_TO_BOOLEAN, - INST_STR_CLASS, - - INST_LAPPEND_LIST, - INST_LAPPEND_LIST_ARRAY, - INST_LAPPEND_LIST_ARRAY_STK, - INST_LAPPEND_LIST_STK, - - INST_CLOCK_READ, - - INST_DICT_GET_DEF, - - /* TIP 461 */ - INST_STR_LT, - INST_STR_GT, - INST_STR_LE, - INST_STR_GE, - - INST_LREPLACE4, - - /* TIP 667: const */ - INST_CONST_IMM, - INST_CONST_STK, - - /* The last opcode */ - LAST_INST_OPCODE -}; +/* Opcodes 0 to 9 */ +#define INST_DONE 0 +#define INST_PUSH1 1 +#define INST_PUSH4 2 +#define INST_POP 3 +#define INST_DUP 4 +#define INST_STR_CONCAT1 5 +#define INST_INVOKE_STK1 6 +#define INST_INVOKE_STK4 7 +#define INST_EVAL_STK 8 +#define INST_EXPR_STK 9 + +/* Opcodes 10 to 23 */ +#define INST_LOAD_SCALAR1 10 +#define INST_LOAD_SCALAR4 11 +#define INST_LOAD_SCALAR_STK 12 +#define INST_LOAD_ARRAY1 13 +#define INST_LOAD_ARRAY4 14 +#define INST_LOAD_ARRAY_STK 15 +#define INST_LOAD_STK 16 +#define INST_STORE_SCALAR1 17 +#define INST_STORE_SCALAR4 18 +#define INST_STORE_SCALAR_STK 19 +#define INST_STORE_ARRAY1 20 +#define INST_STORE_ARRAY4 21 +#define INST_STORE_ARRAY_STK 22 +#define INST_STORE_STK 23 + +/* Opcodes 24 to 33 */ +#define INST_INCR_SCALAR1 24 +#define INST_INCR_SCALAR_STK 25 +#define INST_INCR_ARRAY1 26 +#define INST_INCR_ARRAY_STK 27 +#define INST_INCR_STK 28 +#define INST_INCR_SCALAR1_IMM 29 +#define INST_INCR_SCALAR_STK_IMM 30 +#define INST_INCR_ARRAY1_IMM 31 +#define INST_INCR_ARRAY_STK_IMM 32 +#define INST_INCR_STK_IMM 33 + +/* Opcodes 34 to 39 */ +#define INST_JUMP1 34 +#define INST_JUMP4 35 +#define INST_JUMP_TRUE1 36 +#define INST_JUMP_TRUE4 37 +#define INST_JUMP_FALSE1 38 +#define INST_JUMP_FALSE4 39 + +/* Opcodes 40 to 64 */ +#define INST_LOR 40 +#define INST_LAND 41 +#define INST_BITOR 42 +#define INST_BITXOR 43 +#define INST_BITAND 44 +#define INST_EQ 45 +#define INST_NEQ 46 +#define INST_LT 47 +#define INST_GT 48 +#define INST_LE 49 +#define INST_GE 50 +#define INST_LSHIFT 51 +#define INST_RSHIFT 52 +#define INST_ADD 53 +#define INST_SUB 54 +#define INST_MULT 55 +#define INST_DIV 56 +#define INST_MOD 57 +#define INST_UPLUS 58 +#define INST_UMINUS 59 +#define INST_BITNOT 60 +#define INST_LNOT 61 +#define INST_CALL_BUILTIN_FUNC1 62 +#define INST_CALL_FUNC1 63 +#define INST_TRY_CVT_TO_NUMERIC 64 + +/* Opcodes 65 to 66 */ +#define INST_BREAK 65 +#define INST_CONTINUE 66 + +/* Opcodes 67 to 68 */ +#define INST_FOREACH_START4 67 /* DEPRECATED */ +#define INST_FOREACH_STEP4 68 /* DEPRECATED */ + +/* Opcodes 69 to 72 */ +#define INST_BEGIN_CATCH4 69 +#define INST_END_CATCH 70 +#define INST_PUSH_RESULT 71 +#define INST_PUSH_RETURN_CODE 72 + +/* Opcodes 73 to 78 */ +#define INST_STR_EQ 73 +#define INST_STR_NEQ 74 +#define INST_STR_CMP 75 +#define INST_STR_LEN 76 +#define INST_STR_INDEX 77 +#define INST_STR_MATCH 78 + +/* Opcodes 78 to 81 */ +#define INST_LIST 79 +#define INST_LIST_INDEX 80 +#define INST_LIST_LENGTH 81 + +/* Opcodes 82 to 87 */ +#define INST_APPEND_SCALAR1 82 +#define INST_APPEND_SCALAR4 83 +#define INST_APPEND_ARRAY1 84 +#define INST_APPEND_ARRAY4 85 +#define INST_APPEND_ARRAY_STK 86 +#define INST_APPEND_STK 87 + +/* Opcodes 88 to 93 */ +#define INST_LAPPEND_SCALAR1 88 +#define INST_LAPPEND_SCALAR4 89 +#define INST_LAPPEND_ARRAY1 90 +#define INST_LAPPEND_ARRAY4 91 +#define INST_LAPPEND_ARRAY_STK 92 +#define INST_LAPPEND_STK 93 + +/* TIP #22 - LINDEX operator with flat arg list */ + +#define INST_LIST_INDEX_MULTI 94 + +/* + * TIP #33 - 'lset' command. Code gen also required a Forth-like + * OVER operation. + */ + +#define INST_OVER 95 +#define INST_LSET_LIST 96 +#define INST_LSET_FLAT 97 + +/* TIP#90 - 'return' command. */ + +#define INST_RETURN_IMM 98 + +/* TIP#123 - exponentiation operator. */ + +#define INST_EXPON 99 + +/* TIP #157 - {*}... (word expansion) language syntax support. */ + +#define INST_EXPAND_START 100 +#define INST_EXPAND_STKTOP 101 +#define INST_INVOKE_EXPANDED 102 + +/* + * TIP #57 - 'lassign' command. Code generation requires immediate + * LINDEX and LRANGE operators. + */ + +#define INST_LIST_INDEX_IMM 103 +#define INST_LIST_RANGE_IMM 104 + +#define INST_START_CMD 105 + +#define INST_LIST_IN 106 +#define INST_LIST_NOT_IN 107 + +#define INST_PUSH_RETURN_OPTIONS 108 +#define INST_RETURN_STK 109 + +/* + * Dictionary (TIP#111) related commands. + */ + +#define INST_DICT_GET 110 +#define INST_DICT_SET 111 +#define INST_DICT_UNSET 112 +#define INST_DICT_INCR_IMM 113 +#define INST_DICT_APPEND 114 +#define INST_DICT_LAPPEND 115 +#define INST_DICT_FIRST 116 +#define INST_DICT_NEXT 117 +#define INST_DICT_DONE 118 +#define INST_DICT_UPDATE_START 119 +#define INST_DICT_UPDATE_END 120 + +/* + * Instruction to support jumps defined by tables (instead of the classic + * [switch] technique of chained comparisons). + */ + +#define INST_JUMP_TABLE 121 + +/* + * Instructions to support compilation of global, variable, upvar and + * [namespace upvar]. + */ + +#define INST_UPVAR 122 +#define INST_NSUPVAR 123 +#define INST_VARIABLE 124 + +/* Instruction to support compiling syntax error to bytecode */ + +#define INST_SYNTAX 125 + +/* Instruction to reverse N items on top of stack */ + +#define INST_REVERSE 126 + +/* regexp instruction */ + +#define INST_REGEXP 127 + +/* For [info exists] compilation */ +#define INST_EXIST_SCALAR 128 +#define INST_EXIST_ARRAY 129 +#define INST_EXIST_ARRAY_STK 130 +#define INST_EXIST_STK 131 + +/* For [subst] compilation */ +#define INST_NOP 132 +#define INST_RETURN_CODE_BRANCH 133 + +/* For [unset] compilation */ +#define INST_UNSET_SCALAR 134 +#define INST_UNSET_ARRAY 135 +#define INST_UNSET_ARRAY_STK 136 +#define INST_UNSET_STK 137 + +/* For [dict with], [dict exists], [dict create] and [dict merge] */ +#define INST_DICT_EXPAND 138 +#define INST_DICT_RECOMBINE_STK 139 +#define INST_DICT_RECOMBINE_IMM 140 +#define INST_DICT_EXISTS 141 +#define INST_DICT_VERIFY 142 + +/* For [string map] and [regsub] compilation */ +#define INST_STR_MAP 143 +#define INST_STR_FIND 144 +#define INST_STR_FIND_LAST 145 +#define INST_STR_RANGE_IMM 146 +#define INST_STR_RANGE 147 + +/* For operations to do with coroutines and other NRE-manipulators */ +#define INST_YIELD 148 +#define INST_COROUTINE_NAME 149 +#define INST_TAILCALL 150 + +/* For compilation of basic information operations */ +#define INST_NS_CURRENT 151 +#define INST_INFO_LEVEL_NUM 152 +#define INST_INFO_LEVEL_ARGS 153 +#define INST_RESOLVE_COMMAND 154 + +/* For compilation relating to TclOO */ +#define INST_TCLOO_SELF 155 +#define INST_TCLOO_CLASS 156 +#define INST_TCLOO_NS 157 +#define INST_TCLOO_IS_OBJECT 158 + +/* For compilation of [array] subcommands */ +#define INST_ARRAY_EXISTS_STK 159 +#define INST_ARRAY_EXISTS_IMM 160 +#define INST_ARRAY_MAKE_STK 161 +#define INST_ARRAY_MAKE_IMM 162 + +#define INST_INVOKE_REPLACE 163 + +#define INST_LIST_CONCAT 164 + +#define INST_EXPAND_DROP 165 + +/* New foreach implementation */ +#define INST_FOREACH_START 166 +#define INST_FOREACH_STEP 167 +#define INST_FOREACH_END 168 +#define INST_LMAP_COLLECT 169 + +/* For compilation of [string trim] and related */ +#define INST_STR_TRIM 170 +#define INST_STR_TRIM_LEFT 171 +#define INST_STR_TRIM_RIGHT 172 + +#define INST_CONCAT_STK 173 + +#define INST_STR_UPPER 174 +#define INST_STR_LOWER 175 +#define INST_STR_TITLE 176 +#define INST_STR_REPLACE 177 + +#define INST_ORIGIN_COMMAND 178 + +#define INST_TCLOO_NEXT 179 +#define INST_TCLOO_NEXT_CLASS 180 + +#define INST_YIELD_TO_INVOKE 181 + +#define INST_NUM_TYPE 182 +#define INST_TRY_CVT_TO_BOOLEAN 183 +#define INST_STR_CLASS 184 + +#define INST_LAPPEND_LIST 185 +#define INST_LAPPEND_LIST_ARRAY 186 +#define INST_LAPPEND_LIST_ARRAY_STK 187 +#define INST_LAPPEND_LIST_STK 188 + +#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 + +#define INST_LREPLACE4 195 + +/* The last opcode */ +#define LAST_INST_OPCODE 195 /* * Table describing the Tcl bytecode instructions: their name (for displaying @@ -1067,7 +1075,6 @@ typedef struct { *---------------------------------------------------------------- */ -#if TCL_MAJOR_VERSION > 8 MODULE_SCOPE Tcl_ObjCmdProc TclNRInterpCoroutine; /* @@ -1092,15 +1099,15 @@ MODULE_SCOPE int TclAttemptCompileProc(Tcl_Interp *interp, MODULE_SCOPE void TclCleanupStackForBreakContinue(CompileEnv *envPtr, ExceptionAux *auxPtr); MODULE_SCOPE void TclCompileCmdWord(Tcl_Interp *interp, - Tcl_Token *tokenPtr, size_t count, + Tcl_Token *tokenPtr, int count, CompileEnv *envPtr); MODULE_SCOPE void TclCompileExpr(Tcl_Interp *interp, const char *script, Tcl_Size numBytes, CompileEnv *envPtr, int optimize); MODULE_SCOPE void TclCompileExprWords(Tcl_Interp *interp, - Tcl_Token *tokenPtr, size_t numWords, + Tcl_Token *tokenPtr, int numWords, CompileEnv *envPtr); MODULE_SCOPE void TclCompileInvocation(Tcl_Interp *interp, - Tcl_Token *tokenPtr, Tcl_Obj *cmdObj, size_t numWords, + Tcl_Token *tokenPtr, Tcl_Obj *cmdObj, int numWords, CompileEnv *envPtr); MODULE_SCOPE void TclCompileScript(Tcl_Interp *interp, const char *script, Tcl_Size numBytes, @@ -1108,7 +1115,7 @@ MODULE_SCOPE void TclCompileScript(Tcl_Interp *interp, MODULE_SCOPE void TclCompileSyntaxError(Tcl_Interp *interp, CompileEnv *envPtr); MODULE_SCOPE void TclCompileTokens(Tcl_Interp *interp, - Tcl_Token *tokenPtr, size_t count, + Tcl_Token *tokenPtr, int count, CompileEnv *envPtr); MODULE_SCOPE void TclCompileVarSubst(Tcl_Interp *interp, Tcl_Token *tokenPtr, CompileEnv *envPtr); @@ -1116,9 +1123,9 @@ MODULE_SCOPE Tcl_Size TclCreateAuxData(void *clientData, const AuxDataType *typePtr, CompileEnv *envPtr); MODULE_SCOPE Tcl_Size TclCreateExceptRange(ExceptionRangeType type, CompileEnv *envPtr); -MODULE_SCOPE ExecEnv * TclCreateExecEnv(Tcl_Interp *interp, size_t size); +MODULE_SCOPE ExecEnv * TclCreateExecEnv(Tcl_Interp *interp, TCL_HASH_TYPE size); MODULE_SCOPE Tcl_Obj * TclCreateLiteral(Interp *iPtr, const char *bytes, - Tcl_Size length, size_t hash, int *newPtr, + Tcl_Size length, TCL_HASH_TYPE hash, int *newPtr, Namespace *nsPtr, int flags, LiteralEntry **globalPtrPtr); MODULE_SCOPE void TclDeleteExecEnv(ExecEnv *eePtr); @@ -1132,7 +1139,7 @@ MODULE_SCOPE ExceptionRange * TclGetExceptionRangeForPc(unsigned char *pc, MODULE_SCOPE void TclExpandJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE int TclNRExecuteByteCode(Tcl_Interp *interp, ByteCode *codePtr); -MODULE_SCOPE Tcl_Obj * TclFetchLiteral(CompileEnv *envPtr, Tcl_Size index); +MODULE_SCOPE Tcl_Obj * TclFetchLiteral(CompileEnv *envPtr, TCL_HASH_TYPE index); MODULE_SCOPE Tcl_Size TclFindCompiledLocal(const char *name, Tcl_Size nameChars, int create, CompileEnv *envPtr); MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr, @@ -1141,13 +1148,13 @@ MODULE_SCOPE int TclFixupForwardJump(CompileEnv *envPtr, MODULE_SCOPE void TclFreeCompileEnv(CompileEnv *envPtr); MODULE_SCOPE void TclFreeJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE int TclGetIndexFromToken(Tcl_Token *tokenPtr, - size_t before, size_t after, int *indexPtr); + int before, int after, int *indexPtr); 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, - size_t numBytes, const CmdFrame *invoker, int word); + TCL_HASH_TYPE numBytes, const CmdFrame *invoker, int word); MODULE_SCOPE void TclInitJumpFixupArray(JumpFixupArray *fixupArrayPtr); MODULE_SCOPE void TclInitLiteralTable(LiteralTable *tablePtr); MODULE_SCOPE ExceptionRange *TclGetInnermostExceptionRange(CompileEnv *envPtr, @@ -1162,9 +1169,9 @@ MODULE_SCOPE void TclFinalizeLoopExceptionRange(CompileEnv *envPtr, MODULE_SCOPE char * TclLiteralStats(LiteralTable *tablePtr); MODULE_SCOPE int TclLog2(int value); #endif -MODULE_SCOPE size_t TclLocalScalar(const char *bytes, size_t numBytes, +MODULE_SCOPE Tcl_Size TclLocalScalar(const char *bytes, TCL_HASH_TYPE numBytes, CompileEnv *envPtr); -MODULE_SCOPE size_t TclLocalScalarFromToken(Tcl_Token *tokenPtr, +MODULE_SCOPE Tcl_Size TclLocalScalarFromToken(Tcl_Token *tokenPtr, CompileEnv *envPtr); MODULE_SCOPE void TclOptimizeBytecode(void *envPtr); #ifdef TCL_COMPILE_DEBUG @@ -1206,8 +1213,6 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); MODULE_SCOPE int TclPushProcCallFrame(void *clientData, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], int isLambda); -#endif /* TCL_MAJOR_VERSION > 8 */ - /* *---------------------------------------------------------------- @@ -1240,7 +1245,7 @@ MODULE_SCOPE int TclPushProcCallFrame(void *clientData, #define TclAdjustStackDepth(delta, envPtr) \ do { \ if ((delta) < 0) { \ - if ((int)(envPtr)->maxStackDepth < (int)(envPtr)->currStackDepth) { \ + if ((envPtr)->maxStackDepth < (envPtr)->currStackDepth) { \ (envPtr)->maxStackDepth = (envPtr)->currStackDepth; \ } \ } \ @@ -1453,7 +1458,7 @@ MODULE_SCOPE int TclPushProcCallFrame(void *clientData, #define TclFixupForwardJumpToHere(envPtr, fixupPtr, threshold) \ TclFixupForwardJump((envPtr), (fixupPtr), \ - (envPtr)->codeNext-(envPtr)->codeStart-(int)(fixupPtr)->codeOffset, \ + (envPtr)->codeNext-(envPtr)->codeStart-(fixupPtr)->codeOffset, \ (threshold)) /* @@ -1503,12 +1508,12 @@ MODULE_SCOPE int TclPushProcCallFrame(void *clientData, * Macros used to compute the minimum and maximum of two values. The ANSI C * "prototypes" for these macros are: * - * size_t TclMin(size_t i, size_t j); - * size_t TclMax(size_t i, size_t j); + * int TclMin(int i, int j); + * int TclMax(int i, int j); */ -#define TclMin(i, j) ((((size_t) i) + 1 < ((size_t) j) + 1 )? (i) : (j)) -#define TclMax(i, j) ((((size_t) i) + 1 > ((size_t) j) + 1 )? (i) : (j)) +#define TclMin(i, j) ((((int) i) < ((int) j))? (i) : (j)) +#define TclMax(i, j) ((((int) i) > ((int) j))? (i) : (j)) /* * Convenience macros for use when compiling bodies of commands. The ANSI C @@ -1588,7 +1593,7 @@ MODULE_SCOPE int TclPushProcCallFrame(void *clientData, #define ExceptionRangeEnds(envPtr, index) \ (((envPtr)->exceptDepth--), \ ((envPtr)->exceptArrayPtr[(index)].numCodeBytes = \ - CurrentOffset(envPtr) - (int)(envPtr)->exceptArrayPtr[(index)].codeOffset)) + CurrentOffset(envPtr) - (envPtr)->exceptArrayPtr[(index)].codeOffset)) #define ExceptionRangeTarget(envPtr, index, targetType) \ ((envPtr)->exceptArrayPtr[(index)].targetType = CurrentOffset(envPtr)) @@ -1850,7 +1855,7 @@ MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, const char **args, Tcl_Size *args #define TCL_DTRACE_PROC_INFO_ENABLED() 1 #define TCL_DTRACE_PROC_ENTRY(a0, a1, a2) \ tclDTraceDebugIndent++; \ - TclDTraceDbgMsg("-> proc-entry", "%s %" TCL_SIZE_MODIFIER "d %p", a0, a1, a2) + TclDTraceDbgMsg("-> proc-entry", "%s %d %p", a0, a1, a2) #define TCL_DTRACE_PROC_RETURN(a0, a1) \ TclDTraceDbgMsg("<- proc-return", "%s %d", a0, a1); \ tclDTraceDebugIndent-- @@ -1870,7 +1875,7 @@ MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, const char **args, Tcl_Size *args #define TCL_DTRACE_CMD_INFO_ENABLED() 1 #define TCL_DTRACE_CMD_ENTRY(a0, a1, a2) \ tclDTraceDebugIndent++; \ - TclDTraceDbgMsg("-> cmd-entry", "%s %" TCL_SIZE_MODIFIER "d %p", a0, a1, a2) + TclDTraceDbgMsg("-> cmd-entry", "%s %d %p", a0, a1, a2) #define TCL_DTRACE_CMD_RETURN(a0, a1) \ TclDTraceDbgMsg("<- cmd-return", "%s %d", a0, a1); \ tclDTraceDebugIndent-- @@ -1880,7 +1885,7 @@ MODULE_SCOPE void TclDTraceInfo(Tcl_Obj *info, const char **args, Tcl_Size *args TclDTraceDbgMsg(" | cmd-args", "%s %s %s %s %s %s %s %s %s %s", a0, \ a1, a2, a3, a4, a5, a6, a7, a8, a9) #define TCL_DTRACE_CMD_INFO(a0, a1, a2, a3, a4, a5, a6, a7) \ - TclDTraceDbgMsg(" | cmd-info", "%s %s %s %s %" TCL_SIZE_MODIFIER "d %" TCL_SIZE_MODIFIER "d %s %s", a0, a1, \ + TclDTraceDbgMsg(" | cmd-info", "%s %s %s %s %d %d %s %s", a0, a1, \ a2, a3, a4, a5, a6, a7) #define TCL_DTRACE_INST_START_ENABLED() TCL_DTRACE_DEBUG_INST_PROBES diff --git a/generic/tclConfig.c b/generic/tclConfig.c index 9fb2fa7..28853a1 100644 --- a/generic/tclConfig.c +++ b/generic/tclConfig.c @@ -31,7 +31,7 @@ * the (Tcl_Interp *) in which it is stored, and the encoding. */ -typedef struct { +typedef struct QCCD { Tcl_Obj *pkg; Tcl_Interp *interp; char *encoding; @@ -76,11 +76,11 @@ Tcl_RegisterConfig( Tcl_Obj *pDB, *pkgDict; Tcl_DString cmdName; const Tcl_Config *cfg; - QCCD *cdPtr = (QCCD *)Tcl_Alloc(sizeof(QCCD)); + QCCD *cdPtr = (QCCD *)ckalloc(sizeof(QCCD)); cdPtr->interp = interp; if (valEncoding) { - cdPtr->encoding = (char *)Tcl_Alloc(strlen(valEncoding)+1); + cdPtr->encoding = (char *)ckalloc(strlen(valEncoding)+1); strcpy(cdPtr->encoding, valEncoding); } else { cdPtr->encoding = NULL; @@ -191,7 +191,7 @@ Tcl_RegisterConfig( static int QueryConfigObjCmd( - void *clientData, + ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -199,13 +199,13 @@ QueryConfigObjCmd( QCCD *cdPtr = (QCCD *)clientData; Tcl_Obj *pkgName = cdPtr->pkg; Tcl_Obj *pDB, *pkgDict, *val, *listPtr; - Tcl_Size m, n = 0; + int n, index; static const char *const subcmdStrings[] = { "get", "list", NULL }; enum subcmds { CFG_GET, CFG_LIST - } index; + }; Tcl_DString conv; Tcl_Encoding venc = NULL; const char *value; @@ -233,7 +233,7 @@ QueryConfigObjCmd( return TCL_ERROR; } - switch (index) { + switch ((enum subcmds) index) { case CFG_GET: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "key"); @@ -258,10 +258,7 @@ QueryConfigObjCmd( * Value is stored as-is in a byte array, see Bug [9b2e636361], * so we have to decode it first. */ - value = (const char *) Tcl_GetBytesFromObj(interp, val, &n); - if (value == NULL) { - return TCL_ERROR; - } + value = (const char *) Tcl_GetByteArrayFromObj(val, &n); value = Tcl_ExternalToUtfDString(venc, value, n, &conv); Tcl_SetObjResult(interp, Tcl_NewStringObj(value, Tcl_DStringLength(&conv))); @@ -274,8 +271,8 @@ QueryConfigObjCmd( return TCL_ERROR; } - Tcl_DictObjSize(interp, pkgDict, &m); - listPtr = Tcl_NewListObj(m, NULL); + Tcl_DictObjSize(interp, pkgDict, &n); + listPtr = Tcl_NewListObj(n, NULL); if (!listPtr) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -284,7 +281,7 @@ QueryConfigObjCmd( return TCL_ERROR; } - if (m) { + if (n) { Tcl_DictSearch s; Tcl_Obj *key; int done; @@ -324,7 +321,7 @@ QueryConfigObjCmd( static void QueryConfigDelete( - void *clientData) + ClientData clientData) { QCCD *cdPtr = (QCCD *)clientData; Tcl_Obj *pkgName = cdPtr->pkg; @@ -333,9 +330,9 @@ QueryConfigDelete( Tcl_DictObjRemove(NULL, pDB, pkgName); Tcl_DecrRefCount(pkgName); if (cdPtr->encoding) { - Tcl_Free(cdPtr->encoding); + ckfree(cdPtr->encoding); } - Tcl_Free(cdPtr); + ckfree(cdPtr); } /* @@ -391,7 +388,7 @@ GetConfigDict( static void ConfigDictDeleteProc( - void *clientData, /* Pointer to Tcl_Obj. */ + ClientData clientData, /* Pointer to Tcl_Obj. */ TCL_UNUSED(Tcl_Interp *)) { Tcl_DecrRefCount((Tcl_Obj *)clientData); diff --git a/generic/tclDTrace.d b/generic/tclDTrace.d index c0ef517..f5493b1 100644 --- a/generic/tclDTrace.d +++ b/generic/tclDTrace.d @@ -10,8 +10,6 @@ */ typedef struct Tcl_Obj Tcl_Obj; - -typedef ptrdiff_t Tcl_Size; /* * Tcl DTrace probes @@ -23,10 +21,10 @@ provider tcl { * tcl*:::proc-entry probe * triggered immediately before proc bytecode execution * arg0: proc name (string) - * arg1: number of arguments (Tcl_Size) + * arg1: number of arguments (int) * arg2: array of proc argument objects (Tcl_Obj**) */ - probe proc__entry(const char *name, Tcl_Size objc, struct Tcl_Obj **objv); + probe proc__entry(const char *name, int objc, struct Tcl_Obj **objv); /* * tcl*:::proc-return probe * triggered immediately after proc bytecode execution @@ -64,12 +62,12 @@ provider tcl { * arg2: TIP 280 proc (string) * arg3: TIP 280 file (string) * arg4: TIP 280 line (int) - * arg5: TIP 280 level (Tcl_Size) + * arg5: TIP 280 level (int) * arg6: TclOO method (string) * arg7: TclOO class/object (string) */ probe proc__info(const char *cmd, const char *type, const char *proc, - const char *file, int line, Tcl_Size level, const char *method, + const char *file, int line, int level, const char *method, const char *class); /***************************** cmd probes ******************************/ @@ -77,10 +75,10 @@ provider tcl { * tcl*:::cmd-entry probe * triggered immediately before commmand execution * arg0: command name (string) - * arg1: number of arguments (Tcl_Size) + * arg1: number of arguments (int) * arg2: array of command argument objects (Tcl_Obj**) */ - probe cmd__entry(const char *name, Tcl_Size objc, struct Tcl_Obj **objv); + probe cmd__entry(const char *name, int objc, struct Tcl_Obj **objv); /* * tcl*:::cmd-return probe * triggered immediately after commmand execution @@ -123,7 +121,7 @@ provider tcl { * arg7: TclOO class/object (string) */ probe cmd__info(const char *cmd, const char *type, const char *proc, - const char *file, int line, Tcl_Size level, const char *method, + const char *file, int line, int level, const char *method, const char *class); /***************************** inst probes *****************************/ @@ -131,18 +129,18 @@ provider tcl { * tcl*:::inst-start probe * triggered immediately before execution of a bytecode * arg0: bytecode name (string) - * arg1: depth of stack (Tcl_Size) + * arg1: depth of stack (int) * arg2: top of stack (Tcl_Obj**) */ - probe inst__start(const char *name, Tcl_Size depth, struct Tcl_Obj **stack); + probe inst__start(const char *name, int depth, struct Tcl_Obj **stack); /* * tcl*:::inst-done probe * triggered immediately after execution of a bytecode * arg0: bytecode name (string) - * arg1: depth of stack (Tcl_Size) + * arg1: depth of stack (int) * arg2: top of stack (Tcl_Obj**) */ - probe inst__done(const char *name, Tcl_Size depth, struct Tcl_Obj **stack); + probe inst__done(const char *name, int depth, struct Tcl_Obj **stack); /***************************** obj probes ******************************/ /* @@ -180,21 +178,12 @@ typedef struct Tcl_ObjType { void *dupIntRepProc; void *updateStringProc; void *setFromAnyProc; - size_t version; - void *lengthProc; - void *indexProc; - void *sliceProc; - void *reverseProc; - void *getElementsProc; - void *setElementProc; - void *replaceProc; - void *inOperProc; } Tcl_ObjType; struct Tcl_Obj { - Tcl_Size refCount; + int refCount; char *bytes; - Tcl_Size length; + int length; const Tcl_ObjType *typePtr; union { long longValue; diff --git a/generic/tclDate.c b/generic/tclDate.c index a22168f..7ce26ef 100644 --- a/generic/tclDate.c +++ b/generic/tclDate.c @@ -108,8 +108,8 @@ #include "tclDate.h" -#define YYMALLOC Tcl_Alloc -#define YYFREE(x) (Tcl_Free((void*) (x))) +#define YYMALLOC ckalloc +#define YYFREE(x) (ckfree((void*) (x))) #define EPOCH 1970 #define START_OF_TIME 1902 diff --git a/generic/tclDecls.h b/generic/tclDecls.h index ed95922..ddca33a 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -14,6 +14,10 @@ #include <stddef.h> /* for size_t */ +#ifdef TCL_NO_DEPRECATED +# define Tcl_SavedResult void +#endif /* TCL_NO_DEPRECATED */ + #undef TCL_STORAGE_CLASS #ifdef BUILD_tcl # define TCL_STORAGE_CLASS DLLEXPORT @@ -61,24 +65,37 @@ EXTERN const char * Tcl_PkgRequireEx(Tcl_Interp *interp, /* 2 */ EXTERN TCL_NORETURN void Tcl_Panic(const char *format, ...) TCL_FORMAT_PRINTF(1, 2); /* 3 */ -EXTERN void * Tcl_Alloc(TCL_HASH_TYPE size); +EXTERN char * Tcl_Alloc(TCL_HASH_TYPE size); /* 4 */ -EXTERN void Tcl_Free(void *ptr); +EXTERN void Tcl_Free(char *ptr); /* 5 */ -EXTERN void * Tcl_Realloc(void *ptr, TCL_HASH_TYPE size); +EXTERN char * Tcl_Realloc(char *ptr, TCL_HASH_TYPE size); /* 6 */ -EXTERN void * Tcl_DbCkalloc(TCL_HASH_TYPE size, const char *file, +EXTERN char * Tcl_DbCkalloc(TCL_HASH_TYPE size, const char *file, int line); /* 7 */ -EXTERN void Tcl_DbCkfree(void *ptr, const char *file, int line); +EXTERN void Tcl_DbCkfree(char *ptr, const char *file, int line); /* 8 */ -EXTERN void * Tcl_DbCkrealloc(void *ptr, TCL_HASH_TYPE size, +EXTERN char * Tcl_DbCkrealloc(char *ptr, TCL_HASH_TYPE size, const char *file, int line); +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ +/* 9 */ +EXTERN void Tcl_CreateFileHandler(int fd, int mask, + Tcl_FileProc *proc, void *clientData); +#endif /* UNIX */ +#ifdef MAC_OSX_TCL /* MACOSX */ /* 9 */ EXTERN void Tcl_CreateFileHandler(int fd, int mask, Tcl_FileProc *proc, void *clientData); +#endif /* MACOSX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ +/* 10 */ +EXTERN void Tcl_DeleteFileHandler(int fd); +#endif /* UNIX */ +#ifdef MAC_OSX_TCL /* MACOSX */ /* 10 */ EXTERN void Tcl_DeleteFileHandler(int fd); +#endif /* MACOSX */ /* 11 */ EXTERN void Tcl_SetTimer(const Tcl_Time *timePtr); /* 12 */ @@ -107,7 +124,10 @@ EXTERN void Tcl_DbIncrRefCount(Tcl_Obj *objPtr, const char *file, /* 21 */ EXTERN int Tcl_DbIsShared(Tcl_Obj *objPtr, const char *file, int line); -/* Slot 22 is reserved */ +/* 22 */ +TCL_DEPRECATED("No longer in use, changed to macro") +Tcl_Obj * Tcl_DbNewBooleanObj(int intValue, const char *file, + int line); /* 23 */ EXTERN Tcl_Obj * Tcl_DbNewByteArrayObj(const unsigned char *bytes, Tcl_Size numBytes, const char *file, @@ -118,7 +138,10 @@ EXTERN Tcl_Obj * Tcl_DbNewDoubleObj(double doubleValue, /* 25 */ EXTERN Tcl_Obj * Tcl_DbNewListObj(Tcl_Size objc, Tcl_Obj *const *objv, const char *file, int line); -/* Slot 26 is reserved */ +/* 26 */ +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); /* 28 */ @@ -143,7 +166,11 @@ EXTERN int Tcl_GetDouble(Tcl_Interp *interp, const char *src, /* 35 */ EXTERN int Tcl_GetDoubleFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, double *doublePtr); -/* Slot 36 is reserved */ +/* 36 */ +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, int *intPtr); @@ -154,9 +181,10 @@ EXTERN int Tcl_GetIntFromObj(Tcl_Interp *interp, EXTERN int Tcl_GetLongFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, long *longPtr); /* 40 */ -EXTERN const Tcl_ObjType * Tcl_GetObjType(const char *typeName); +EXTERN CONST86 Tcl_ObjType * Tcl_GetObjType(const char *typeName); /* 41 */ -EXTERN char * TclGetStringFromObj(Tcl_Obj *objPtr, void *lengthPtr); +EXTERN char * Tcl_GetStringFromObj(Tcl_Obj *objPtr, + Tcl_Size *lengthPtr); /* 42 */ EXTERN void Tcl_InvalidateStringRep(Tcl_Obj *objPtr); /* 43 */ @@ -166,36 +194,44 @@ EXTERN int Tcl_ListObjAppendList(Tcl_Interp *interp, EXTERN int Tcl_ListObjAppendElement(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *objPtr); /* 45 */ -EXTERN int TclListObjGetElements(Tcl_Interp *interp, - Tcl_Obj *listPtr, void *objcPtr, +EXTERN int Tcl_ListObjGetElements(Tcl_Interp *interp, + Tcl_Obj *listPtr, Tcl_Size *objcPtr, Tcl_Obj ***objvPtr); /* 46 */ EXTERN int Tcl_ListObjIndex(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size index, Tcl_Obj **objPtrPtr); /* 47 */ -EXTERN int TclListObjLength(Tcl_Interp *interp, - Tcl_Obj *listPtr, void *lengthPtr); +EXTERN int Tcl_ListObjLength(Tcl_Interp *interp, + Tcl_Obj *listPtr, Tcl_Size *lengthPtr); /* 48 */ EXTERN int Tcl_ListObjReplace(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size first, Tcl_Size count, Tcl_Size objc, Tcl_Obj *const objv[]); -/* Slot 49 is reserved */ +/* 49 */ +TCL_DEPRECATED("No longer in use, changed to macro") +Tcl_Obj * Tcl_NewBooleanObj(int intValue); /* 50 */ EXTERN Tcl_Obj * Tcl_NewByteArrayObj(const unsigned char *bytes, Tcl_Size numBytes); /* 51 */ EXTERN Tcl_Obj * Tcl_NewDoubleObj(double doubleValue); -/* Slot 52 is reserved */ +/* 52 */ +TCL_DEPRECATED("No longer in use, changed to macro") +Tcl_Obj * Tcl_NewIntObj(int intValue); /* 53 */ EXTERN Tcl_Obj * Tcl_NewListObj(Tcl_Size objc, Tcl_Obj *const objv[]); -/* Slot 54 is reserved */ +/* 54 */ +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, Tcl_Size length); -/* Slot 57 is reserved */ +/* 57 */ +TCL_DEPRECATED("No longer in use, changed to macro") +void Tcl_SetBooleanObj(Tcl_Obj *objPtr, int intValue); /* 58 */ EXTERN unsigned char * Tcl_SetByteArrayLength(Tcl_Obj *objPtr, Tcl_Size numBytes); @@ -205,18 +241,28 @@ EXTERN void Tcl_SetByteArrayObj(Tcl_Obj *objPtr, Tcl_Size numBytes); /* 60 */ EXTERN void Tcl_SetDoubleObj(Tcl_Obj *objPtr, double doubleValue); -/* Slot 61 is reserved */ +/* 61 */ +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, Tcl_Size objc, Tcl_Obj *const objv[]); -/* Slot 63 is reserved */ +/* 63 */ +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, Tcl_Size length); /* 65 */ EXTERN void Tcl_SetStringObj(Tcl_Obj *objPtr, const char *bytes, Tcl_Size length); -/* Slot 66 is reserved */ -/* Slot 67 is reserved */ +/* 66 */ +TCL_DEPRECATED("No longer in use, changed to macro") +void Tcl_AddErrorInfo(Tcl_Interp *interp, + const char *message); +/* 67 */ +TCL_DEPRECATED("No longer in use, changed to macro") +void Tcl_AddObjErrorInfo(Tcl_Interp *interp, + const char *message, Tcl_Size length); /* 68 */ EXTERN void Tcl_AllowExceptions(Tcl_Interp *interp); /* 69 */ @@ -235,8 +281,12 @@ EXTERN int Tcl_AsyncInvoke(Tcl_Interp *interp, int code); EXTERN void Tcl_AsyncMark(Tcl_AsyncHandler async); /* 75 */ EXTERN int Tcl_AsyncReady(void); -/* Slot 76 is reserved */ -/* Slot 77 is reserved */ +/* 76 */ +TCL_DEPRECATED("No longer in use, changed to macro") +void Tcl_BackgroundError(Tcl_Interp *interp); +/* 77 */ +TCL_DEPRECATED("Use Tcl_UtfBackslash") +char Tcl_Backslash(const char *src, int *readPtr); /* 78 */ EXTERN int Tcl_BadChannelOption(Tcl_Interp *interp, const char *optionName, @@ -293,7 +343,12 @@ EXTERN void Tcl_CreateExitHandler(Tcl_ExitProc *proc, void *clientData); /* 94 */ EXTERN Tcl_Interp * Tcl_CreateInterp(void); -/* Slot 95 is reserved */ +/* 95 */ +TCL_DEPRECATED("") +void Tcl_CreateMathFunc(Tcl_Interp *interp, + const char *name, int numArgs, + Tcl_ValueType *argTypes, Tcl_MathProc *proc, + void *clientData); /* 96 */ EXTERN Tcl_Command Tcl_CreateObjCommand(Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, @@ -381,11 +436,14 @@ EXTERN int Tcl_Eof(Tcl_Channel chan); EXTERN const char * Tcl_ErrnoId(void); /* 128 */ EXTERN const char * Tcl_ErrnoMsg(int err); -/* Slot 129 is reserved */ +/* 129 */ +EXTERN int Tcl_Eval(Tcl_Interp *interp, const char *script); /* 130 */ EXTERN int Tcl_EvalFile(Tcl_Interp *interp, const char *fileName); -/* Slot 131 is reserved */ +/* 131 */ +TCL_DEPRECATED("No longer in use, changed to macro") +int Tcl_EvalObj(Tcl_Interp *interp, Tcl_Obj *objPtr); /* 132 */ EXTERN void Tcl_EventuallyFree(void *clientData, Tcl_FreeProc *freeProc); @@ -420,16 +478,25 @@ EXTERN int Tcl_ExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr, EXTERN int Tcl_ExprString(Tcl_Interp *interp, const char *expr); /* 143 */ EXTERN void Tcl_Finalize(void); -/* Slot 144 is reserved */ +/* 144 */ +EXTERN const char * Tcl_FindExecutable(const char *argv0); /* 145 */ EXTERN Tcl_HashEntry * Tcl_FirstHashEntry(Tcl_HashTable *tablePtr, Tcl_HashSearch *searchPtr); /* 146 */ EXTERN int Tcl_Flush(Tcl_Channel chan); -/* Slot 147 is reserved */ -/* Slot 148 is reserved */ +/* 147 */ +TCL_DEPRECATED("see TIP #559. Use Tcl_ResetResult") +void Tcl_FreeResult(Tcl_Interp *interp); +/* 148 */ +TCL_DEPRECATED("Use Tcl_GetAliasObj") +int Tcl_GetAlias(Tcl_Interp *interp, + const char *childCmd, + Tcl_Interp **targetInterpPtr, + const char **targetCmdPtr, int *argcPtr, + const char ***argvPtr); /* 149 */ -EXTERN int TclGetAliasObj(Tcl_Interp *interp, +EXTERN int Tcl_GetAliasObj(Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, @@ -457,7 +524,7 @@ EXTERN int Tcl_GetChannelOption(Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, Tcl_DString *dsPtr); /* 158 */ -EXTERN const Tcl_ChannelType * Tcl_GetChannelType(Tcl_Channel chan); +EXTERN CONST86 Tcl_ChannelType * Tcl_GetChannelType(Tcl_Channel chan); /* 159 */ EXTERN int Tcl_GetCommandInfo(Tcl_Interp *interp, const char *cmdName, Tcl_CmdInfo *infoPtr); @@ -477,10 +544,18 @@ EXTERN Tcl_Interp * Tcl_GetParent(Tcl_Interp *interp); EXTERN const char * Tcl_GetNameOfExecutable(void); /* 166 */ EXTERN Tcl_Obj * Tcl_GetObjResult(Tcl_Interp *interp); +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ +/* 167 */ +EXTERN int Tcl_GetOpenFile(Tcl_Interp *interp, + const char *chanID, int forWriting, + int checkUsage, void **filePtr); +#endif /* UNIX */ +#ifdef MAC_OSX_TCL /* MACOSX */ /* 167 */ EXTERN int Tcl_GetOpenFile(Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, void **filePtr); +#endif /* MACOSX */ /* 168 */ EXTERN Tcl_PathType Tcl_GetPathType(const char *path); /* 169 */ @@ -493,13 +568,22 @@ EXTERN int Tcl_GetServiceMode(void); EXTERN Tcl_Interp * Tcl_GetChild(Tcl_Interp *interp, const char *name); /* 173 */ EXTERN Tcl_Channel Tcl_GetStdChannel(int type); -/* Slot 174 is reserved */ -/* Slot 175 is reserved */ +/* 174 */ +EXTERN const char * Tcl_GetStringResult(Tcl_Interp *interp); +/* 175 */ +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); -/* Slot 177 is reserved */ -/* Slot 178 is reserved */ +/* 177 */ +EXTERN int Tcl_GlobalEval(Tcl_Interp *interp, + const char *command); +/* 178 */ +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, const char *cmdName, @@ -526,7 +610,9 @@ EXTERN int Tcl_LinkVar(Tcl_Interp *interp, const char *varName, /* Slot 188 is reserved */ /* 189 */ EXTERN Tcl_Channel Tcl_MakeFileChannel(void *handle, int mode); -/* Slot 190 is reserved */ +/* 190 */ +TCL_DEPRECATED("") +int Tcl_MakeSafe(Tcl_Interp *interp); /* 191 */ EXTERN Tcl_Channel Tcl_MakeTcpClientChannel(void *tcpSocket); /* 192 */ @@ -606,7 +692,9 @@ EXTERN Tcl_Size Tcl_ScanElement(const char *src, int *flagPtr); /* 219 */ EXTERN Tcl_Size Tcl_ScanCountedElement(const char *src, Tcl_Size length, int *flagPtr); -/* Slot 220 is reserved */ +/* 220 */ +TCL_DEPRECATED("") +int Tcl_SeekOld(Tcl_Channel chan, int offset, int mode); /* 221 */ EXTERN int Tcl_ServiceAll(void); /* 222 */ @@ -632,11 +720,14 @@ EXTERN void Tcl_SetErrno(int err); EXTERN void Tcl_SetErrorCode(Tcl_Interp *interp, ...); /* 229 */ EXTERN void Tcl_SetMaxBlockTime(const Tcl_Time *timePtr); -/* Slot 230 is reserved */ +/* 230 */ +EXTERN const char * Tcl_SetPanicProc(Tcl_PanicProc *panicProc); /* 231 */ EXTERN Tcl_Size Tcl_SetRecursionLimit(Tcl_Interp *interp, Tcl_Size depth); -/* Slot 232 is reserved */ +/* 232 */ +EXTERN void Tcl_SetResult(Tcl_Interp *interp, char *result, + Tcl_FreeProc *freeProc); /* 233 */ EXTERN int Tcl_SetServiceMode(int mode); /* 234 */ @@ -647,7 +738,10 @@ EXTERN void Tcl_SetObjResult(Tcl_Interp *interp, Tcl_Obj *resultObjPtr); /* 236 */ EXTERN void Tcl_SetStdChannel(Tcl_Channel channel, int type); -/* Slot 237 is reserved */ +/* 237 */ +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, @@ -659,15 +753,28 @@ EXTERN const char * Tcl_SignalMsg(int sig); /* 241 */ EXTERN void Tcl_SourceRCFile(Tcl_Interp *interp); /* 242 */ -EXTERN int TclSplitList(Tcl_Interp *interp, const char *listStr, - void *argcPtr, const char ***argvPtr); +EXTERN int Tcl_SplitList(Tcl_Interp *interp, + const char *listStr, Tcl_Size *argcPtr, + const char ***argvPtr); /* 243 */ -EXTERN void TclSplitPath(const char *path, void *argcPtr, +EXTERN void Tcl_SplitPath(const char *path, Tcl_Size *argcPtr, const char ***argvPtr); -/* Slot 244 is reserved */ -/* Slot 245 is reserved */ -/* Slot 246 is reserved */ -/* Slot 247 is reserved */ +/* 244 */ +EXTERN void Tcl_StaticLibrary(Tcl_Interp *interp, + const char *prefix, + Tcl_LibraryInitProc *initProc, + Tcl_LibraryInitProc *safeInitProc); +/* 245 */ +TCL_DEPRECATED("No longer in use, changed to macro") +int Tcl_StringMatch(const char *str, const char *pattern); +/* 246 */ +TCL_DEPRECATED("") +int Tcl_TellOld(Tcl_Channel chan); +/* 247 */ +TCL_DEPRECATED("No longer in use, changed to macro") +int Tcl_TraceVar(Tcl_Interp *interp, const char *varName, + int flags, Tcl_VarTraceProc *proc, + void *clientData); /* 248 */ EXTERN int Tcl_TraceVar2(Tcl_Interp *interp, const char *part1, const char *part2, int flags, @@ -684,11 +791,18 @@ EXTERN void Tcl_UnlinkVar(Tcl_Interp *interp, /* 252 */ EXTERN int Tcl_UnregisterChannel(Tcl_Interp *interp, Tcl_Channel chan); -/* Slot 253 is reserved */ +/* 253 */ +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); -/* Slot 255 is reserved */ +/* 255 */ +TCL_DEPRECATED("No longer in use, changed to macro") +void Tcl_UntraceVar(Tcl_Interp *interp, + const char *varName, int flags, + Tcl_VarTraceProc *proc, void *clientData); /* 256 */ EXTERN void Tcl_UntraceVar2(Tcl_Interp *interp, const char *part1, const char *part2, @@ -697,14 +811,23 @@ EXTERN void Tcl_UntraceVar2(Tcl_Interp *interp, /* 257 */ EXTERN void Tcl_UpdateLinkedVar(Tcl_Interp *interp, const char *varName); -/* Slot 258 is reserved */ +/* 258 */ +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 */ EXTERN int Tcl_UpVar2(Tcl_Interp *interp, const char *frameName, const char *part1, const char *part2, const char *localName, int flags); /* 260 */ EXTERN int Tcl_VarEval(Tcl_Interp *interp, ...); -/* Slot 261 is reserved */ +/* 261 */ +TCL_DEPRECATED("No longer in use, changed to macro") +void * Tcl_VarTraceInfo(Tcl_Interp *interp, + const char *varName, int flags, + Tcl_VarTraceProc *procPtr, + void *prevClientData); /* 262 */ EXTERN void * Tcl_VarTraceInfo2(Tcl_Interp *interp, const char *part1, const char *part2, @@ -720,25 +843,47 @@ EXTERN void Tcl_WrongNumArgs(Tcl_Interp *interp, Tcl_Size objc, EXTERN int Tcl_DumpActiveMemory(const char *fileName); /* 266 */ EXTERN void Tcl_ValidateAllMemory(const char *file, int line); -/* Slot 267 is reserved */ -/* Slot 268 is reserved */ +/* 267 */ +TCL_DEPRECATED("see TIP #422") +void Tcl_AppendResultVA(Tcl_Interp *interp, + va_list argList); +/* 268 */ +TCL_DEPRECATED("see TIP #422") +void Tcl_AppendStringsToObjVA(Tcl_Obj *objPtr, + va_list argList); /* 269 */ EXTERN char * Tcl_HashStats(Tcl_HashTable *tablePtr); /* 270 */ EXTERN const char * Tcl_ParseVar(Tcl_Interp *interp, const char *start, const char **termPtr); -/* Slot 271 is reserved */ +/* 271 */ +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 const char * Tcl_PkgPresentEx(Tcl_Interp *interp, const char *name, const char *version, int exact, void *clientDataPtr); -/* Slot 273 is reserved */ -/* Slot 274 is reserved */ -/* Slot 275 is reserved */ -/* Slot 276 is reserved */ +/* 273 */ +TCL_DEPRECATED("No longer in use, changed to macro") +int Tcl_PkgProvide(Tcl_Interp *interp, const char *name, + const char *version); +/* 274 */ +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 */ +TCL_DEPRECATED("see TIP #422") +void Tcl_SetErrorCodeVA(Tcl_Interp *interp, + va_list argList); +/* 276 */ +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); -/* Slot 278 is reserved */ +/* 278 */ +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); @@ -756,12 +901,7 @@ EXTERN int Tcl_UnstackChannel(Tcl_Interp *interp, EXTERN Tcl_Channel Tcl_GetStackedChannel(Tcl_Channel chan); /* 284 */ EXTERN void Tcl_SetMainLoop(Tcl_MainLoopProc *proc); -/* 285 */ -EXTERN int Tcl_GetAliasObj(Tcl_Interp *interp, - const char *childCmd, - Tcl_Interp **targetInterpPtr, - const char **targetCmdPtr, Tcl_Size *objcPtr, - Tcl_Obj ***objvPtr); +/* Slot 285 is reserved */ /* 286 */ EXTERN void Tcl_AppendObjToObj(Tcl_Obj *objPtr, Tcl_Obj *appendObjPtr); @@ -773,7 +913,9 @@ EXTERN void Tcl_CreateThreadExitHandler(Tcl_ExitProc *proc, /* 289 */ EXTERN void Tcl_DeleteThreadExitHandler(Tcl_ExitProc *proc, void *clientData); -/* Slot 290 is reserved */ +/* 290 */ +TCL_DEPRECATED("Use Tcl_DiscardInterpState") +void Tcl_DiscardResult(Tcl_SavedResult *statePtr); /* 291 */ EXTERN int Tcl_EvalEx(Tcl_Interp *interp, const char *script, Tcl_Size numBytes, int flags); @@ -833,12 +975,18 @@ EXTERN void Tcl_ConditionNotify(Tcl_Condition *condPtr); EXTERN void Tcl_ConditionWait(Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr, const Tcl_Time *timePtr); /* 312 */ -EXTERN Tcl_Size TclNumUtfChars(const char *src, Tcl_Size length); +EXTERN Tcl_Size Tcl_NumUtfChars(const char *src, Tcl_Size length); /* 313 */ EXTERN Tcl_Size Tcl_ReadChars(Tcl_Channel channel, Tcl_Obj *objPtr, Tcl_Size charsToRead, int appendFlag); -/* Slot 314 is reserved */ -/* Slot 315 is reserved */ +/* 314 */ +TCL_DEPRECATED("Use Tcl_RestoreInterpState") +void Tcl_RestoreResult(Tcl_Interp *interp, + Tcl_SavedResult *statePtr); +/* 315 */ +TCL_DEPRECATED("Use Tcl_SaveInterpState") +void Tcl_SaveResult(Tcl_Interp *interp, + Tcl_SavedResult *statePtr); /* 316 */ EXTERN int Tcl_SetSystemEncoding(Tcl_Interp *interp, const char *name); @@ -862,7 +1010,7 @@ EXTERN int Tcl_UniCharToUpper(int ch); /* 324 */ EXTERN Tcl_Size Tcl_UniCharToUtf(int ch, char *buf); /* 325 */ -EXTERN const char * TclUtfAtIndex(const char *src, Tcl_Size index); +EXTERN const char * Tcl_UtfAtIndex(const char *src, Tcl_Size index); /* 326 */ EXTERN int TclUtfCharComplete(const char *src, Tcl_Size length); /* 327 */ @@ -903,8 +1051,12 @@ EXTERN Tcl_Size Tcl_WriteChars(Tcl_Channel chan, const char *src, EXTERN Tcl_Size Tcl_WriteObj(Tcl_Channel chan, Tcl_Obj *objPtr); /* 340 */ EXTERN char * Tcl_GetString(Tcl_Obj *objPtr); -/* Slot 341 is reserved */ -/* Slot 342 is reserved */ +/* 341 */ +TCL_DEPRECATED("Use Tcl_GetEncodingSearchPath") +const char * Tcl_GetDefaultEncodingDir(void); +/* 342 */ +TCL_DEPRECATED("Use Tcl_SetEncodingSearchPath") +void Tcl_SetDefaultEncodingDir(const char *path); /* 343 */ EXTERN void Tcl_AlertNotifier(void *clientData); /* 344 */ @@ -925,7 +1077,11 @@ EXTERN int Tcl_UniCharIsUpper(int ch); EXTERN int Tcl_UniCharIsWordChar(int ch); /* 352 */ EXTERN Tcl_Size Tcl_Char16Len(const unsigned short *uniStr); -/* Slot 353 is reserved */ +/* 353 */ +TCL_DEPRECATED("Use Tcl_UtfNcmp") +int Tcl_UniCharNcmp(const unsigned short *ucs, + const unsigned short *uct, + unsigned long numChars); /* 354 */ EXTERN char * Tcl_Char16ToUtfDString(const unsigned short *uniStr, Tcl_Size uniLength, Tcl_DString *dsPtr); @@ -935,7 +1091,10 @@ EXTERN unsigned short * Tcl_UtfToChar16DString(const char *src, /* 356 */ EXTERN Tcl_RegExp Tcl_GetRegExpFromObj(Tcl_Interp *interp, Tcl_Obj *patObj, int flags); -/* Slot 357 is reserved */ +/* 357 */ +TCL_DEPRECATED("Use Tcl_EvalTokensStandard") +Tcl_Obj * Tcl_EvalTokens(Tcl_Interp *interp, + Tcl_Token *tokenPtr, Tcl_Size count); /* 358 */ EXTERN void Tcl_FreeParse(Tcl_Parse *parsePtr); /* 359 */ @@ -972,10 +1131,11 @@ EXTERN int Tcl_Access(const char *path, int mode); /* 368 */ EXTERN int Tcl_Stat(const char *path, struct stat *bufPtr); /* 369 */ -EXTERN int TclUtfNcmp(const char *s1, const char *s2, size_t n); +EXTERN int Tcl_UtfNcmp(const char *s1, const char *s2, + unsigned long n); /* 370 */ -EXTERN int TclUtfNcasecmp(const char *s1, const char *s2, - size_t n); +EXTERN int Tcl_UtfNcasecmp(const char *s1, const char *s2, + unsigned long n); /* 371 */ EXTERN int Tcl_StringCaseMatch(const char *str, const char *pattern, int nocase); @@ -996,23 +1156,26 @@ EXTERN int Tcl_RegExpExecObj(Tcl_Interp *interp, EXTERN void Tcl_RegExpGetInfo(Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr); /* 378 */ -EXTERN Tcl_Obj * Tcl_NewUnicodeObj(const Tcl_UniChar *unicode, +EXTERN Tcl_Obj * Tcl_NewUnicodeObj(const unsigned short *unicode, Tcl_Size numChars); /* 379 */ EXTERN void Tcl_SetUnicodeObj(Tcl_Obj *objPtr, - const Tcl_UniChar *unicode, + const unsigned short *unicode, Tcl_Size numChars); /* 380 */ -EXTERN Tcl_Size TclGetCharLength(Tcl_Obj *objPtr); +EXTERN Tcl_Size Tcl_GetCharLength(Tcl_Obj *objPtr); /* 381 */ -EXTERN int TclGetUniChar(Tcl_Obj *objPtr, Tcl_Size index); -/* Slot 382 is reserved */ +EXTERN int Tcl_GetUniChar(Tcl_Obj *objPtr, Tcl_Size index); +/* 382 */ +TCL_DEPRECATED("No longer in use, changed to macro") +unsigned short * Tcl_GetUnicode(Tcl_Obj *objPtr); /* 383 */ -EXTERN Tcl_Obj * TclGetRange(Tcl_Obj *objPtr, Tcl_Size first, +EXTERN Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, Tcl_Size first, Tcl_Size last); /* 384 */ EXTERN void Tcl_AppendUnicodeToObj(Tcl_Obj *objPtr, - const Tcl_UniChar *unicode, Tcl_Size length); + const unsigned short *unicode, + Tcl_Size length); /* 385 */ EXTERN int Tcl_RegExpMatchObj(Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); @@ -1055,7 +1218,10 @@ EXTERN Tcl_ChannelTypeVersion Tcl_ChannelVersion( /* 400 */ EXTERN Tcl_DriverBlockModeProc * Tcl_ChannelBlockModeProc( const Tcl_ChannelType *chanTypePtr); -/* Slot 401 is reserved */ +/* 401 */ +TCL_DEPRECATED("Use Tcl_ChannelClose2Proc") +Tcl_DriverCloseProc * Tcl_ChannelCloseProc( + const Tcl_ChannelType *chanTypePtr); /* 402 */ EXTERN Tcl_DriverClose2Proc * Tcl_ChannelClose2Proc( const Tcl_ChannelType *chanTypePtr); @@ -1065,7 +1231,10 @@ EXTERN Tcl_DriverInputProc * Tcl_ChannelInputProc( /* 404 */ EXTERN Tcl_DriverOutputProc * Tcl_ChannelOutputProc( const Tcl_ChannelType *chanTypePtr); -/* Slot 405 is reserved */ +/* 405 */ +TCL_DEPRECATED("Use Tcl_ChannelWideSeekProc") +Tcl_DriverSeekProc * Tcl_ChannelSeekProc( + const Tcl_ChannelType *chanTypePtr); /* 406 */ EXTERN Tcl_DriverSetOptionProc * Tcl_ChannelSetOptionProc( const Tcl_ChannelType *chanTypePtr); @@ -1099,10 +1268,23 @@ EXTERN void Tcl_SpliceChannel(Tcl_Channel channel); EXTERN void Tcl_ClearChannelHandlers(Tcl_Channel channel); /* 418 */ EXTERN int Tcl_IsChannelExisting(const char *channelName); -/* Slot 419 is reserved */ -/* Slot 420 is reserved */ -/* Slot 421 is reserved */ -/* Slot 422 is reserved */ +/* 419 */ +TCL_DEPRECATED("Use Tcl_UtfNcasecmp") +int Tcl_UniCharNcasecmp(const unsigned short *ucs, + const unsigned short *uct, + unsigned long numChars); +/* 420 */ +TCL_DEPRECATED("Use Tcl_StringCaseMatch") +int Tcl_UniCharCaseMatch(const unsigned short *uniStr, + const unsigned short *uniPattern, int nocase); +/* 421 */ +TCL_DEPRECATED("") +Tcl_HashEntry * Tcl_FindHashEntry(Tcl_HashTable *tablePtr, + const void *key); +/* 422 */ +TCL_DEPRECATED("") +Tcl_HashEntry * Tcl_CreateHashEntry(Tcl_HashTable *tablePtr, + const void *key, int *newPtr); /* 423 */ EXTERN void Tcl_InitCustomHashTable(Tcl_HashTable *tablePtr, int keyType, const Tcl_HashKeyType *typePtr); @@ -1122,14 +1304,14 @@ EXTERN void Tcl_UntraceCommand(Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, void *clientData); /* 428 */ -EXTERN void * Tcl_AttemptAlloc(TCL_HASH_TYPE size); +EXTERN char * Tcl_AttemptAlloc(TCL_HASH_TYPE size); /* 429 */ -EXTERN void * Tcl_AttemptDbCkalloc(TCL_HASH_TYPE size, +EXTERN char * Tcl_AttemptDbCkalloc(TCL_HASH_TYPE size, const char *file, int line); /* 430 */ -EXTERN void * Tcl_AttemptRealloc(void *ptr, TCL_HASH_TYPE size); +EXTERN char * Tcl_AttemptRealloc(char *ptr, TCL_HASH_TYPE size); /* 431 */ -EXTERN void * Tcl_AttemptDbCkrealloc(void *ptr, TCL_HASH_TYPE size, +EXTERN char * Tcl_AttemptDbCkrealloc(char *ptr, TCL_HASH_TYPE size, const char *file, int line); /* 432 */ EXTERN int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, @@ -1137,10 +1319,18 @@ EXTERN int Tcl_AttemptSetObjLength(Tcl_Obj *objPtr, /* 433 */ EXTERN Tcl_ThreadId Tcl_GetChannelThread(Tcl_Channel channel); /* 434 */ -EXTERN Tcl_UniChar * TclGetUnicodeFromObj(Tcl_Obj *objPtr, - void *lengthPtr); -/* Slot 435 is reserved */ -/* Slot 436 is reserved */ +EXTERN unsigned short * Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, + Tcl_Size *lengthPtr); +/* 435 */ +TCL_DEPRECATED("") +int Tcl_GetMathFuncInfo(Tcl_Interp *interp, + const char *name, int *numArgsPtr, + Tcl_ValueType **argTypesPtr, + Tcl_MathProc **procPtr, void **clientDataPtr); +/* 436 */ +TCL_DEPRECATED("") +Tcl_Obj * Tcl_ListMathFuncs(Tcl_Interp *interp, + const char *pattern); /* 437 */ EXTERN Tcl_Obj * Tcl_SubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); @@ -1190,7 +1380,7 @@ EXTERN int Tcl_FSFileAttrsGet(Tcl_Interp *interp, int index, EXTERN int Tcl_FSFileAttrsSet(Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj *objPtr); /* 453 */ -EXTERN const char *const * Tcl_FSFileAttrStrings(Tcl_Obj *pathPtr, +EXTERN const char *CONST86 * Tcl_FSFileAttrStrings(Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); /* 454 */ EXTERN int Tcl_FSStat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf); @@ -1210,7 +1400,7 @@ EXTERN int Tcl_FSConvertToPathType(Tcl_Interp *interp, /* 460 */ EXTERN Tcl_Obj * Tcl_FSJoinPath(Tcl_Obj *listObj, Tcl_Size elements); /* 461 */ -EXTERN Tcl_Obj * TclFSSplitPath(Tcl_Obj *pathPtr, void *lenPtr); +EXTERN Tcl_Obj * Tcl_FSSplitPath(Tcl_Obj *pathPtr, Tcl_Size *lenPtr); /* 462 */ EXTERN int Tcl_FSEqualPaths(Tcl_Obj *firstPtr, Tcl_Obj *secondPtr); @@ -1251,7 +1441,7 @@ EXTERN void * Tcl_FSData(const Tcl_Filesystem *fsPtr); EXTERN const char * Tcl_FSGetTranslatedStringPath(Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 477 */ -EXTERN const Tcl_Filesystem * Tcl_FSGetFileSystemForPath(Tcl_Obj *pathPtr); +EXTERN CONST86 Tcl_Filesystem * Tcl_FSGetFileSystemForPath(Tcl_Obj *pathPtr); /* 478 */ EXTERN Tcl_PathType Tcl_FSGetPathType(Tcl_Obj *pathPtr); /* 479 */ @@ -1306,8 +1496,8 @@ EXTERN int Tcl_DictObjGet(Tcl_Interp *interp, Tcl_Obj *dictPtr, EXTERN int Tcl_DictObjRemove(Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Obj *keyPtr); /* 497 */ -EXTERN int TclDictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, - void *sizePtr); +EXTERN int Tcl_DictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, + Tcl_Size *sizePtr); /* 498 */ EXTERN int Tcl_DictObjFirst(Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_DictSearch *searchPtr, @@ -1374,7 +1564,8 @@ EXTERN void Tcl_GetCommandFullName(Tcl_Interp *interp, /* 518 */ EXTERN int Tcl_FSEvalFileEx(Tcl_Interp *interp, Tcl_Obj *fileName, const char *encodingName); -/* Slot 519 is reserved */ +/* 519 */ +EXTERN Tcl_ExitProc * Tcl_SetExitProc(Tcl_ExitProc *proc); /* 520 */ EXTERN void Tcl_LimitAddHandler(Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, @@ -1612,9 +1803,10 @@ EXTERN int Tcl_SetEnsembleParameterList(Tcl_Interp *interp, EXTERN int Tcl_GetEnsembleParameterList(Tcl_Interp *interp, Tcl_Command token, Tcl_Obj **paramListPtr); /* 604 */ -EXTERN int TclParseArgsObjv(Tcl_Interp *interp, - const Tcl_ArgvInfo *argTable, void *objcPtr, - Tcl_Obj *const *objv, Tcl_Obj ***remObjv); +EXTERN int Tcl_ParseArgsObjv(Tcl_Interp *interp, + const Tcl_ArgvInfo *argTable, + Tcl_Size *objcPtr, Tcl_Obj *const *objv, + Tcl_Obj ***remObjv); /* 605 */ EXTERN int Tcl_GetErrorLine(Tcl_Interp *interp); /* 606 */ @@ -1744,20 +1936,12 @@ EXTERN char * Tcl_UniCharToUtfDString(const int *uniStr, EXTERN int * Tcl_UtfToUniCharDString(const char *src, Tcl_Size length, Tcl_DString *dsPtr); /* 649 */ -EXTERN unsigned char * TclGetBytesFromObj(Tcl_Interp *interp, - Tcl_Obj *objPtr, void *numBytesPtr); -/* 650 */ EXTERN unsigned char * Tcl_GetBytesFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Size *numBytesPtr); -/* 651 */ -EXTERN char * Tcl_GetStringFromObj(Tcl_Obj *objPtr, - Tcl_Size *lengthPtr); -/* 652 */ -EXTERN Tcl_UniChar * Tcl_GetUnicodeFromObj(Tcl_Obj *objPtr, - Tcl_Size *lengthPtr); -/* 653 */ -EXTERN int Tcl_GetSizeIntFromObj(Tcl_Interp *interp, - Tcl_Obj *objPtr, Tcl_Size *sizePtr); +/* Slot 650 is reserved */ +/* Slot 651 is reserved */ +/* Slot 652 is reserved */ +/* Slot 653 is reserved */ /* 654 */ EXTERN int Tcl_UtfCharComplete(const char *src, Tcl_Size length); /* 655 */ @@ -1780,69 +1964,36 @@ EXTERN int Tcl_UtfToExternalDStringEx(Tcl_Interp *interp, /* 660 */ EXTERN int Tcl_AsyncMarkFromSignal(Tcl_AsyncHandler async, int sigNumber); -/* 661 */ -EXTERN int Tcl_ListObjGetElements(Tcl_Interp *interp, - Tcl_Obj *listPtr, Tcl_Size *objcPtr, - Tcl_Obj ***objvPtr); -/* 662 */ -EXTERN int Tcl_ListObjLength(Tcl_Interp *interp, - Tcl_Obj *listPtr, Tcl_Size *lengthPtr); -/* 663 */ -EXTERN int Tcl_DictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, - Tcl_Size *sizePtr); -/* 664 */ -EXTERN int Tcl_SplitList(Tcl_Interp *interp, - const char *listStr, Tcl_Size *argcPtr, - const char ***argvPtr); -/* 665 */ -EXTERN void Tcl_SplitPath(const char *path, Tcl_Size *argcPtr, - const char ***argvPtr); -/* 666 */ -EXTERN Tcl_Obj * Tcl_FSSplitPath(Tcl_Obj *pathPtr, Tcl_Size *lenPtr); -/* 667 */ -EXTERN int Tcl_ParseArgsObjv(Tcl_Interp *interp, - const Tcl_ArgvInfo *argTable, - Tcl_Size *objcPtr, Tcl_Obj *const *objv, - Tcl_Obj ***remObjv); +/* Slot 661 is reserved */ +/* Slot 662 is reserved */ +/* Slot 663 is reserved */ +/* Slot 664 is reserved */ +/* Slot 665 is reserved */ +/* Slot 666 is reserved */ +/* Slot 667 is reserved */ /* 668 */ EXTERN Tcl_Size Tcl_UniCharLen(const int *uniStr); /* 669 */ -EXTERN Tcl_Size Tcl_NumUtfChars(const char *src, Tcl_Size length); +EXTERN Tcl_Size TclNumUtfChars(const char *src, Tcl_Size length); /* 670 */ -EXTERN Tcl_Size Tcl_GetCharLength(Tcl_Obj *objPtr); +EXTERN Tcl_Size TclGetCharLength(Tcl_Obj *objPtr); /* 671 */ -EXTERN const char * Tcl_UtfAtIndex(const char *src, Tcl_Size index); +EXTERN const char * TclUtfAtIndex(const char *src, Tcl_Size index); /* 672 */ -EXTERN Tcl_Obj * Tcl_GetRange(Tcl_Obj *objPtr, Tcl_Size first, +EXTERN Tcl_Obj * TclGetRange(Tcl_Obj *objPtr, Tcl_Size first, Tcl_Size last); /* 673 */ -EXTERN int Tcl_GetUniChar(Tcl_Obj *objPtr, Tcl_Size index); +EXTERN int TclGetUniChar(Tcl_Obj *objPtr, Tcl_Size index); /* 674 */ EXTERN int Tcl_GetBool(Tcl_Interp *interp, const char *src, int flags, char *charPtr); /* 675 */ EXTERN int Tcl_GetBoolFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, char *charPtr); -/* 676 */ -EXTERN Tcl_Command Tcl_CreateObjCommand2(Tcl_Interp *interp, - const char *cmdName, Tcl_ObjCmdProc2 *proc2, - void *clientData, - Tcl_CmdDeleteProc *deleteProc); -/* 677 */ -EXTERN Tcl_Trace Tcl_CreateObjTrace2(Tcl_Interp *interp, - Tcl_Size level, int flags, - Tcl_CmdObjTraceProc2 *objProc2, - void *clientData, - Tcl_CmdObjTraceDeleteProc *delProc); -/* 678 */ -EXTERN Tcl_Command Tcl_NRCreateCommand2(Tcl_Interp *interp, - const char *cmdName, Tcl_ObjCmdProc2 *proc, - Tcl_ObjCmdProc2 *nreProc2, void *clientData, - Tcl_CmdDeleteProc *deleteProc); -/* 679 */ -EXTERN int Tcl_NRCallObjProc2(Tcl_Interp *interp, - Tcl_ObjCmdProc2 *objProc2, void *clientData, - Tcl_Size objc, Tcl_Obj *const objv[]); +/* Slot 676 is reserved */ +/* Slot 677 is reserved */ +/* Slot 678 is reserved */ +/* Slot 679 is reserved */ /* 680 */ EXTERN int Tcl_GetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr, void **clientDataPtr, @@ -1862,9 +2013,9 @@ EXTERN int Tcl_GetWideUIntFromObj(Tcl_Interp *interp, /* 685 */ EXTERN Tcl_Obj * Tcl_DStringToObj(Tcl_DString *dsPtr); /* 686 */ -EXTERN int Tcl_UtfNcmp(const char *s1, const char *s2, size_t n); +EXTERN int TclUtfNcmp(const char *s1, const char *s2, size_t n); /* 687 */ -EXTERN int Tcl_UtfNcasecmp(const char *s1, const char *s2, +EXTERN int TclUtfNcasecmp(const char *s1, const char *s2, size_t n); /* 688 */ EXTERN Tcl_Obj * Tcl_NewWideUIntObj(Tcl_WideUInt wideValue); @@ -1887,14 +2038,30 @@ typedef struct TclStubs { int (*tcl_PkgProvideEx) (Tcl_Interp *interp, const char *name, const char *version, const void *clientData); /* 0 */ 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 */ - void * (*tcl_Alloc) (TCL_HASH_TYPE size); /* 3 */ - void (*tcl_Free) (void *ptr); /* 4 */ - void * (*tcl_Realloc) (void *ptr, TCL_HASH_TYPE size); /* 5 */ - void * (*tcl_DbCkalloc) (TCL_HASH_TYPE size, const char *file, int line); /* 6 */ - void (*tcl_DbCkfree) (void *ptr, const char *file, int line); /* 7 */ - void * (*tcl_DbCkrealloc) (void *ptr, TCL_HASH_TYPE size, const char *file, int line); /* 8 */ + char * (*tcl_Alloc) (TCL_HASH_TYPE size); /* 3 */ + void (*tcl_Free) (char *ptr); /* 4 */ + char * (*tcl_Realloc) (char *ptr, TCL_HASH_TYPE size); /* 5 */ + char * (*tcl_DbCkalloc) (TCL_HASH_TYPE size, const char *file, int line); /* 6 */ + void (*tcl_DbCkfree) (char *ptr, const char *file, int line); /* 7 */ + char * (*tcl_DbCkrealloc) (char *ptr, TCL_HASH_TYPE size, const char *file, int line); /* 8 */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, void *clientData); /* 9 */ +#endif /* UNIX */ +#if defined(_WIN32) /* WIN */ + void (*reserved9)(void); +#endif /* WIN */ +#ifdef MAC_OSX_TCL /* MACOSX */ + void (*tcl_CreateFileHandler) (int fd, int mask, Tcl_FileProc *proc, void *clientData); /* 9 */ +#endif /* MACOSX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ + void (*tcl_DeleteFileHandler) (int fd); /* 10 */ +#endif /* UNIX */ +#if defined(_WIN32) /* WIN */ + void (*reserved10)(void); +#endif /* WIN */ +#ifdef MAC_OSX_TCL /* MACOSX */ void (*tcl_DeleteFileHandler) (int fd); /* 10 */ +#endif /* MACOSX */ void (*tcl_SetTimer) (const Tcl_Time *timePtr); /* 11 */ void (*tcl_Sleep) (int ms); /* 12 */ int (*tcl_WaitForEvent) (const Tcl_Time *timePtr); /* 13 */ @@ -1906,11 +2073,11 @@ 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 */ - void (*reserved22)(void); + TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_DbNewBooleanObj) (int intValue, const char *file, int line); /* 22 */ Tcl_Obj * (*tcl_DbNewByteArrayObj) (const unsigned char *bytes, Tcl_Size numBytes, const char *file, int line); /* 23 */ Tcl_Obj * (*tcl_DbNewDoubleObj) (double doubleValue, const char *file, int line); /* 24 */ Tcl_Obj * (*tcl_DbNewListObj) (Tcl_Size objc, Tcl_Obj *const *objv, const char *file, int line); /* 25 */ - void (*reserved26)(void); + 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, Tcl_Size length, const char *file, int line); /* 28 */ Tcl_Obj * (*tcl_DuplicateObj) (Tcl_Obj *objPtr); /* 29 */ @@ -1920,38 +2087,38 @@ typedef struct TclStubs { unsigned char * (*tcl_GetByteArrayFromObj) (Tcl_Obj *objPtr, Tcl_Size *numBytesPtr); /* 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 */ - void (*reserved36)(void); + 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 */ - const Tcl_ObjType * (*tcl_GetObjType) (const char *typeName); /* 40 */ - char * (*tclGetStringFromObj) (Tcl_Obj *objPtr, void *lengthPtr); /* 41 */ + CONST86 Tcl_ObjType * (*tcl_GetObjType) (const char *typeName); /* 40 */ + char * (*tcl_GetStringFromObj) (Tcl_Obj *objPtr, Tcl_Size *lengthPtr); /* 41 */ void (*tcl_InvalidateStringRep) (Tcl_Obj *objPtr); /* 42 */ int (*tcl_ListObjAppendList) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *elemListPtr); /* 43 */ int (*tcl_ListObjAppendElement) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *objPtr); /* 44 */ - int (*tclListObjGetElements) (Tcl_Interp *interp, Tcl_Obj *listPtr, void *objcPtr, Tcl_Obj ***objvPtr); /* 45 */ + int (*tcl_ListObjGetElements) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size *objcPtr, Tcl_Obj ***objvPtr); /* 45 */ int (*tcl_ListObjIndex) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size index, Tcl_Obj **objPtrPtr); /* 46 */ - int (*tclListObjLength) (Tcl_Interp *interp, Tcl_Obj *listPtr, void *lengthPtr); /* 47 */ + int (*tcl_ListObjLength) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size *lengthPtr); /* 47 */ int (*tcl_ListObjReplace) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size first, Tcl_Size count, Tcl_Size objc, Tcl_Obj *const objv[]); /* 48 */ - void (*reserved49)(void); + TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_NewBooleanObj) (int intValue); /* 49 */ Tcl_Obj * (*tcl_NewByteArrayObj) (const unsigned char *bytes, Tcl_Size numBytes); /* 50 */ Tcl_Obj * (*tcl_NewDoubleObj) (double doubleValue); /* 51 */ - void (*reserved52)(void); + TCL_DEPRECATED_API("No longer in use, changed to macro") Tcl_Obj * (*tcl_NewIntObj) (int intValue); /* 52 */ Tcl_Obj * (*tcl_NewListObj) (Tcl_Size objc, Tcl_Obj *const objv[]); /* 53 */ - void (*reserved54)(void); + 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, Tcl_Size length); /* 56 */ - void (*reserved57)(void); + TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_SetBooleanObj) (Tcl_Obj *objPtr, int intValue); /* 57 */ unsigned char * (*tcl_SetByteArrayLength) (Tcl_Obj *objPtr, Tcl_Size numBytes); /* 58 */ void (*tcl_SetByteArrayObj) (Tcl_Obj *objPtr, const unsigned char *bytes, Tcl_Size numBytes); /* 59 */ void (*tcl_SetDoubleObj) (Tcl_Obj *objPtr, double doubleValue); /* 60 */ - void (*reserved61)(void); + 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, Tcl_Size objc, Tcl_Obj *const objv[]); /* 62 */ - void (*reserved63)(void); + 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, Tcl_Size length); /* 64 */ void (*tcl_SetStringObj) (Tcl_Obj *objPtr, const char *bytes, Tcl_Size length); /* 65 */ - void (*reserved66)(void); - void (*reserved67)(void); + 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, Tcl_Size 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 */ @@ -1960,8 +2127,8 @@ 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 (*reserved76)(void); - void (*reserved77)(void); + 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, void *clientData); /* 79 */ void (*tcl_CancelIdleCall) (Tcl_IdleProc *idleProc, void *clientData); /* 80 */ @@ -1979,7 +2146,7 @@ typedef struct TclStubs { void (*tcl_CreateEventSource) (Tcl_EventSetupProc *setupProc, Tcl_EventCheckProc *checkProc, void *clientData); /* 92 */ void (*tcl_CreateExitHandler) (Tcl_ExitProc *proc, void *clientData); /* 93 */ Tcl_Interp * (*tcl_CreateInterp) (void); /* 94 */ - void (*reserved95)(void); + TCL_DEPRECATED_API("") void (*tcl_CreateMathFunc) (Tcl_Interp *interp, const char *name, int numArgs, Tcl_ValueType *argTypes, Tcl_MathProc *proc, void *clientData); /* 95 */ Tcl_Command (*tcl_CreateObjCommand) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc *proc, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 96 */ Tcl_Interp * (*tcl_CreateChild) (Tcl_Interp *interp, const char *name, int isSafe); /* 97 */ Tcl_TimerToken (*tcl_CreateTimerHandler) (int milliseconds, Tcl_TimerProc *proc, void *clientData); /* 98 */ @@ -2013,9 +2180,9 @@ typedef struct TclStubs { int (*tcl_Eof) (Tcl_Channel chan); /* 126 */ const char * (*tcl_ErrnoId) (void); /* 127 */ const char * (*tcl_ErrnoMsg) (int err); /* 128 */ - void (*reserved129)(void); + int (*tcl_Eval) (Tcl_Interp *interp, const char *script); /* 129 */ int (*tcl_EvalFile) (Tcl_Interp *interp, const char *fileName); /* 130 */ - void (*reserved131)(void); + TCL_DEPRECATED_API("No longer in use, changed to macro") int (*tcl_EvalObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 131 */ void (*tcl_EventuallyFree) (void *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 */ @@ -2028,12 +2195,12 @@ 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 (*reserved144)(void); + TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") const char * (*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 (*reserved147)(void); - void (*reserved148)(void); - int (*tclGetAliasObj) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objvPtr); /* 149 */ + TCL_DEPRECATED_API("see TIP #559. Use Tcl_ResetResult") void (*tcl_FreeResult) (Tcl_Interp *interp); /* 147 */ + TCL_DEPRECATED_API("Use Tcl_GetAliasObj") int (*tcl_GetAlias) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *argcPtr, const char ***argvPtr); /* 148 */ + int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, int *objcPtr, Tcl_Obj ***objvPtr); /* 149 */ void * (*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 */ Tcl_Size (*tcl_GetChannelBufferSize) (Tcl_Channel chan); /* 152 */ @@ -2042,7 +2209,7 @@ typedef struct TclStubs { int (*tcl_GetChannelMode) (Tcl_Channel chan); /* 155 */ const char * (*tcl_GetChannelName) (Tcl_Channel chan); /* 156 */ int (*tcl_GetChannelOption) (Tcl_Interp *interp, Tcl_Channel chan, const char *optionName, Tcl_DString *dsPtr); /* 157 */ - const Tcl_ChannelType * (*tcl_GetChannelType) (Tcl_Channel chan); /* 158 */ + CONST86 Tcl_ChannelType * (*tcl_GetChannelType) (Tcl_Channel chan); /* 158 */ int (*tcl_GetCommandInfo) (Tcl_Interp *interp, const char *cmdName, Tcl_CmdInfo *infoPtr); /* 159 */ const char * (*tcl_GetCommandName) (Tcl_Interp *interp, Tcl_Command command); /* 160 */ int (*tcl_GetErrno) (void); /* 161 */ @@ -2051,18 +2218,26 @@ typedef struct TclStubs { Tcl_Interp * (*tcl_GetParent) (Tcl_Interp *interp); /* 164 */ const char * (*tcl_GetNameOfExecutable) (void); /* 165 */ Tcl_Obj * (*tcl_GetObjResult) (Tcl_Interp *interp); /* 166 */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ + int (*tcl_GetOpenFile) (Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, void **filePtr); /* 167 */ +#endif /* UNIX */ +#if defined(_WIN32) /* WIN */ + void (*reserved167)(void); +#endif /* WIN */ +#ifdef MAC_OSX_TCL /* MACOSX */ int (*tcl_GetOpenFile) (Tcl_Interp *interp, const char *chanID, int forWriting, int checkUsage, void **filePtr); /* 167 */ +#endif /* MACOSX */ Tcl_PathType (*tcl_GetPathType) (const char *path); /* 168 */ Tcl_Size (*tcl_Gets) (Tcl_Channel chan, Tcl_DString *dsPtr); /* 169 */ Tcl_Size (*tcl_GetsObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 170 */ int (*tcl_GetServiceMode) (void); /* 171 */ Tcl_Interp * (*tcl_GetChild) (Tcl_Interp *interp, const char *name); /* 172 */ Tcl_Channel (*tcl_GetStdChannel) (int type); /* 173 */ - void (*reserved174)(void); - void (*reserved175)(void); + 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 */ - void (*reserved177)(void); - void (*reserved178)(void); + int (*tcl_GlobalEval) (Tcl_Interp *interp, const char *command); /* 177 */ + 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 */ @@ -2074,7 +2249,7 @@ typedef struct TclStubs { int (*tcl_LinkVar) (Tcl_Interp *interp, const char *varName, void *addr, int type); /* 187 */ void (*reserved188)(void); Tcl_Channel (*tcl_MakeFileChannel) (void *handle, int mode); /* 189 */ - void (*reserved190)(void); + TCL_DEPRECATED_API("") int (*tcl_MakeSafe) (Tcl_Interp *interp); /* 190 */ Tcl_Channel (*tcl_MakeTcpClientChannel) (void *tcpSocket); /* 191 */ char * (*tcl_Merge) (Tcl_Size argc, const char *const *argv); /* 192 */ Tcl_HashEntry * (*tcl_NextHashEntry) (Tcl_HashSearch *searchPtr); /* 193 */ @@ -2104,7 +2279,7 @@ typedef struct TclStubs { void (*tcl_ResetResult) (Tcl_Interp *interp); /* 217 */ Tcl_Size (*tcl_ScanElement) (const char *src, int *flagPtr); /* 218 */ Tcl_Size (*tcl_ScanCountedElement) (const char *src, Tcl_Size length, int *flagPtr); /* 219 */ - void (*reserved220)(void); + 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, void *clientData); /* 223 */ @@ -2114,67 +2289,67 @@ 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 (*reserved230)(void); + TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") const char * (*tcl_SetPanicProc) (Tcl_PanicProc *panicProc); /* 230 */ Tcl_Size (*tcl_SetRecursionLimit) (Tcl_Interp *interp, Tcl_Size depth); /* 231 */ - void (*reserved232)(void); + 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 */ - void (*reserved237)(void); + 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 (*tclSplitList) (Tcl_Interp *interp, const char *listStr, void *argcPtr, const char ***argvPtr); /* 242 */ - void (*tclSplitPath) (const char *path, void *argcPtr, const char ***argvPtr); /* 243 */ - void (*reserved244)(void); - void (*reserved245)(void); - void (*reserved246)(void); - void (*reserved247)(void); + int (*tcl_SplitList) (Tcl_Interp *interp, const char *listStr, Tcl_Size *argcPtr, const char ***argvPtr); /* 242 */ + void (*tcl_SplitPath) (const char *path, Tcl_Size *argcPtr, const char ***argvPtr); /* 243 */ + TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") void (*tcl_StaticLibrary) (Tcl_Interp *interp, const char *prefix, Tcl_LibraryInitProc *initProc, Tcl_LibraryInitProc *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, void *clientData); /* 247 */ int (*tcl_TraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, void *clientData); /* 248 */ char * (*tcl_TranslateFileName) (Tcl_Interp *interp, const char *name, Tcl_DString *bufferPtr); /* 249 */ Tcl_Size (*tcl_Ungets) (Tcl_Channel chan, const char *str, Tcl_Size len, int atHead); /* 250 */ void (*tcl_UnlinkVar) (Tcl_Interp *interp, const char *varName); /* 251 */ int (*tcl_UnregisterChannel) (Tcl_Interp *interp, Tcl_Channel chan); /* 252 */ - void (*reserved253)(void); + 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 (*reserved255)(void); + TCL_DEPRECATED_API("No longer in use, changed to macro") void (*tcl_UntraceVar) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *proc, void *clientData); /* 255 */ void (*tcl_UntraceVar2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *proc, void *clientData); /* 256 */ void (*tcl_UpdateLinkedVar) (Tcl_Interp *interp, const char *varName); /* 257 */ - void (*reserved258)(void); + 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 */ - void (*reserved261)(void); + TCL_DEPRECATED_API("No longer in use, changed to macro") void * (*tcl_VarTraceInfo) (Tcl_Interp *interp, const char *varName, int flags, Tcl_VarTraceProc *procPtr, void *prevClientData); /* 261 */ void * (*tcl_VarTraceInfo2) (Tcl_Interp *interp, const char *part1, const char *part2, int flags, Tcl_VarTraceProc *procPtr, void *prevClientData); /* 262 */ Tcl_Size (*tcl_Write) (Tcl_Channel chan, const char *s, Tcl_Size slen); /* 263 */ void (*tcl_WrongNumArgs) (Tcl_Interp *interp, Tcl_Size 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 (*reserved267)(void); - void (*reserved268)(void); + 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 */ const char * (*tcl_ParseVar) (Tcl_Interp *interp, const char *start, const char **termPtr); /* 270 */ - void (*reserved271)(void); + 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 */ - void (*reserved273)(void); - void (*reserved274)(void); - void (*reserved275)(void); - void (*reserved276)(void); + 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 */ - void (*reserved278)(void); + 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, void *instanceData, int mask, Tcl_Channel prevChan); /* 281 */ int (*tcl_UnstackChannel) (Tcl_Interp *interp, Tcl_Channel chan); /* 282 */ Tcl_Channel (*tcl_GetStackedChannel) (Tcl_Channel chan); /* 283 */ void (*tcl_SetMainLoop) (Tcl_MainLoopProc *proc); /* 284 */ - int (*tcl_GetAliasObj) (Tcl_Interp *interp, const char *childCmd, Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, Tcl_Size *objcPtr, Tcl_Obj ***objvPtr); /* 285 */ + void (*reserved285)(void); void (*tcl_AppendObjToObj) (Tcl_Obj *objPtr, Tcl_Obj *appendObjPtr); /* 286 */ Tcl_Encoding (*tcl_CreateEncoding) (const Tcl_EncodingType *typePtr); /* 287 */ void (*tcl_CreateThreadExitHandler) (Tcl_ExitProc *proc, void *clientData); /* 288 */ void (*tcl_DeleteThreadExitHandler) (Tcl_ExitProc *proc, void *clientData); /* 289 */ - void (*reserved290)(void); + TCL_DEPRECATED_API("Use Tcl_DiscardInterpState") void (*tcl_DiscardResult) (Tcl_SavedResult *statePtr); /* 290 */ int (*tcl_EvalEx) (Tcl_Interp *interp, const char *script, Tcl_Size numBytes, int flags); /* 291 */ int (*tcl_EvalObjv) (Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], int flags); /* 292 */ int (*tcl_EvalObjEx) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags); /* 293 */ @@ -2196,10 +2371,10 @@ typedef struct TclStubs { void (*tcl_MutexUnlock) (Tcl_Mutex *mutexPtr); /* 309 */ void (*tcl_ConditionNotify) (Tcl_Condition *condPtr); /* 310 */ void (*tcl_ConditionWait) (Tcl_Condition *condPtr, Tcl_Mutex *mutexPtr, const Tcl_Time *timePtr); /* 311 */ - Tcl_Size (*tclNumUtfChars) (const char *src, Tcl_Size length); /* 312 */ + Tcl_Size (*tcl_NumUtfChars) (const char *src, Tcl_Size length); /* 312 */ Tcl_Size (*tcl_ReadChars) (Tcl_Channel channel, Tcl_Obj *objPtr, Tcl_Size charsToRead, int appendFlag); /* 313 */ - void (*reserved314)(void); - void (*reserved315)(void); + TCL_DEPRECATED_API("Use Tcl_RestoreInterpState") void (*tcl_RestoreResult) (Tcl_Interp *interp, Tcl_SavedResult *statePtr); /* 314 */ + TCL_DEPRECATED_API("Use Tcl_SaveInterpState") void (*tcl_SaveResult) (Tcl_Interp *interp, Tcl_SavedResult *statePtr); /* 315 */ int (*tcl_SetSystemEncoding) (Tcl_Interp *interp, const char *name); /* 316 */ 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 */ @@ -2209,7 +2384,7 @@ typedef struct TclStubs { int (*tcl_UniCharToTitle) (int ch); /* 322 */ int (*tcl_UniCharToUpper) (int ch); /* 323 */ Tcl_Size (*tcl_UniCharToUtf) (int ch, char *buf); /* 324 */ - const char * (*tclUtfAtIndex) (const char *src, Tcl_Size index); /* 325 */ + const char * (*tcl_UtfAtIndex) (const char *src, Tcl_Size index); /* 325 */ int (*tclUtfCharComplete) (const char *src, Tcl_Size length); /* 326 */ Tcl_Size (*tcl_UtfBackslash) (const char *src, int *readPtr, char *dst); /* 327 */ const char * (*tcl_UtfFindFirst) (const char *src, int ch); /* 328 */ @@ -2225,8 +2400,8 @@ typedef struct TclStubs { Tcl_Size (*tcl_WriteChars) (Tcl_Channel chan, const char *src, Tcl_Size srcLen); /* 338 */ Tcl_Size (*tcl_WriteObj) (Tcl_Channel chan, Tcl_Obj *objPtr); /* 339 */ char * (*tcl_GetString) (Tcl_Obj *objPtr); /* 340 */ - void (*reserved341)(void); - void (*reserved342)(void); + 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) (void *clientData); /* 343 */ void (*tcl_ServiceModeHook) (int mode); /* 344 */ int (*tcl_UniCharIsAlnum) (int ch); /* 345 */ @@ -2237,11 +2412,11 @@ typedef struct TclStubs { int (*tcl_UniCharIsUpper) (int ch); /* 350 */ int (*tcl_UniCharIsWordChar) (int ch); /* 351 */ Tcl_Size (*tcl_Char16Len) (const unsigned short *uniStr); /* 352 */ - void (*reserved353)(void); + TCL_DEPRECATED_API("Use Tcl_UtfNcmp") int (*tcl_UniCharNcmp) (const unsigned short *ucs, const unsigned short *uct, unsigned long numChars); /* 353 */ char * (*tcl_Char16ToUtfDString) (const unsigned short *uniStr, Tcl_Size uniLength, Tcl_DString *dsPtr); /* 354 */ unsigned short * (*tcl_UtfToChar16DString) (const char *src, Tcl_Size length, Tcl_DString *dsPtr); /* 355 */ Tcl_RegExp (*tcl_GetRegExpFromObj) (Tcl_Interp *interp, Tcl_Obj *patObj, int flags); /* 356 */ - void (*reserved357)(void); + TCL_DEPRECATED_API("Use Tcl_EvalTokensStandard") Tcl_Obj * (*tcl_EvalTokens) (Tcl_Interp *interp, Tcl_Token *tokenPtr, Tcl_Size count); /* 357 */ void (*tcl_FreeParse) (Tcl_Parse *parsePtr); /* 358 */ void (*tcl_LogCommandInfo) (Tcl_Interp *interp, const char *script, const char *command, Tcl_Size length); /* 359 */ int (*tcl_ParseBraces) (Tcl_Interp *interp, const char *start, Tcl_Size numBytes, Tcl_Parse *parsePtr, int append, const char **termPtr); /* 360 */ @@ -2253,8 +2428,8 @@ typedef struct TclStubs { int (*tcl_Chdir) (const char *dirName); /* 366 */ int (*tcl_Access) (const char *path, int mode); /* 367 */ int (*tcl_Stat) (const char *path, struct stat *bufPtr); /* 368 */ - int (*tclUtfNcmp) (const char *s1, const char *s2, size_t n); /* 369 */ - int (*tclUtfNcasecmp) (const char *s1, const char *s2, size_t n); /* 370 */ + int (*tcl_UtfNcmp) (const char *s1, const char *s2, unsigned long n); /* 369 */ + int (*tcl_UtfNcasecmp) (const char *s1, const char *s2, unsigned long n); /* 370 */ int (*tcl_StringCaseMatch) (const char *str, const char *pattern, int nocase); /* 371 */ int (*tcl_UniCharIsControl) (int ch); /* 372 */ int (*tcl_UniCharIsGraph) (int ch); /* 373 */ @@ -2262,13 +2437,13 @@ typedef struct TclStubs { int (*tcl_UniCharIsPunct) (int ch); /* 375 */ int (*tcl_RegExpExecObj) (Tcl_Interp *interp, Tcl_RegExp regexp, Tcl_Obj *textObj, Tcl_Size offset, Tcl_Size nmatches, int flags); /* 376 */ void (*tcl_RegExpGetInfo) (Tcl_RegExp regexp, Tcl_RegExpInfo *infoPtr); /* 377 */ - Tcl_Obj * (*tcl_NewUnicodeObj) (const Tcl_UniChar *unicode, Tcl_Size numChars); /* 378 */ - void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, Tcl_Size numChars); /* 379 */ - Tcl_Size (*tclGetCharLength) (Tcl_Obj *objPtr); /* 380 */ - int (*tclGetUniChar) (Tcl_Obj *objPtr, Tcl_Size index); /* 381 */ - void (*reserved382)(void); - Tcl_Obj * (*tclGetRange) (Tcl_Obj *objPtr, Tcl_Size first, Tcl_Size last); /* 383 */ - void (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const Tcl_UniChar *unicode, Tcl_Size length); /* 384 */ + Tcl_Obj * (*tcl_NewUnicodeObj) (const unsigned short *unicode, Tcl_Size numChars); /* 378 */ + void (*tcl_SetUnicodeObj) (Tcl_Obj *objPtr, const unsigned short *unicode, Tcl_Size numChars); /* 379 */ + Tcl_Size (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 380 */ + int (*tcl_GetUniChar) (Tcl_Obj *objPtr, Tcl_Size index); /* 381 */ + TCL_DEPRECATED_API("No longer in use, changed to macro") unsigned short * (*tcl_GetUnicode) (Tcl_Obj *objPtr); /* 382 */ + Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, Tcl_Size first, Tcl_Size last); /* 383 */ + void (*tcl_AppendUnicodeToObj) (Tcl_Obj *objPtr, const unsigned short *unicode, Tcl_Size length); /* 384 */ int (*tcl_RegExpMatchObj) (Tcl_Interp *interp, Tcl_Obj *textObj, Tcl_Obj *patternObj); /* 385 */ void (*tcl_SetNotifier) (const Tcl_NotifierProcs *notifierProcPtr); /* 386 */ Tcl_Mutex * (*tcl_GetAllocMutex) (void); /* 387 */ @@ -2285,11 +2460,11 @@ typedef struct TclStubs { 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 */ - void (*reserved401)(void); + TCL_DEPRECATED_API("Use Tcl_ChannelClose2Proc") Tcl_DriverCloseProc * (*tcl_ChannelCloseProc) (const Tcl_ChannelType *chanTypePtr); /* 401 */ Tcl_DriverClose2Proc * (*tcl_ChannelClose2Proc) (const Tcl_ChannelType *chanTypePtr); /* 402 */ Tcl_DriverInputProc * (*tcl_ChannelInputProc) (const Tcl_ChannelType *chanTypePtr); /* 403 */ Tcl_DriverOutputProc * (*tcl_ChannelOutputProc) (const Tcl_ChannelType *chanTypePtr); /* 404 */ - void (*reserved405)(void); + TCL_DEPRECATED_API("Use Tcl_ChannelWideSeekProc") Tcl_DriverSeekProc * (*tcl_ChannelSeekProc) (const Tcl_ChannelType *chanTypePtr); /* 405 */ Tcl_DriverSetOptionProc * (*tcl_ChannelSetOptionProc) (const Tcl_ChannelType *chanTypePtr); /* 406 */ Tcl_DriverGetOptionProc * (*tcl_ChannelGetOptionProc) (const Tcl_ChannelType *chanTypePtr); /* 407 */ Tcl_DriverWatchProc * (*tcl_ChannelWatchProc) (const Tcl_ChannelType *chanTypePtr); /* 408 */ @@ -2303,24 +2478,24 @@ typedef struct TclStubs { void (*tcl_SpliceChannel) (Tcl_Channel channel); /* 416 */ void (*tcl_ClearChannelHandlers) (Tcl_Channel channel); /* 417 */ int (*tcl_IsChannelExisting) (const char *channelName); /* 418 */ - void (*reserved419)(void); - void (*reserved420)(void); - void (*reserved421)(void); - void (*reserved422)(void); + TCL_DEPRECATED_API("Use Tcl_UtfNcasecmp") int (*tcl_UniCharNcasecmp) (const unsigned short *ucs, const unsigned short *uct, unsigned long numChars); /* 419 */ + TCL_DEPRECATED_API("Use Tcl_StringCaseMatch") int (*tcl_UniCharCaseMatch) (const unsigned short *uniStr, const unsigned short *uniPattern, int nocase); /* 420 */ + TCL_DEPRECATED_API("") Tcl_HashEntry * (*tcl_FindHashEntry) (Tcl_HashTable *tablePtr, const void *key); /* 421 */ + TCL_DEPRECATED_API("") Tcl_HashEntry * (*tcl_CreateHashEntry) (Tcl_HashTable *tablePtr, const void *key, int *newPtr); /* 422 */ void (*tcl_InitCustomHashTable) (Tcl_HashTable *tablePtr, int keyType, const Tcl_HashKeyType *typePtr); /* 423 */ void (*tcl_InitObjHashTable) (Tcl_HashTable *tablePtr); /* 424 */ void * (*tcl_CommandTraceInfo) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *procPtr, void *prevClientData); /* 425 */ int (*tcl_TraceCommand) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, void *clientData); /* 426 */ void (*tcl_UntraceCommand) (Tcl_Interp *interp, const char *varName, int flags, Tcl_CommandTraceProc *proc, void *clientData); /* 427 */ - void * (*tcl_AttemptAlloc) (TCL_HASH_TYPE size); /* 428 */ - void * (*tcl_AttemptDbCkalloc) (TCL_HASH_TYPE size, const char *file, int line); /* 429 */ - void * (*tcl_AttemptRealloc) (void *ptr, TCL_HASH_TYPE size); /* 430 */ - void * (*tcl_AttemptDbCkrealloc) (void *ptr, TCL_HASH_TYPE size, const char *file, int line); /* 431 */ + char * (*tcl_AttemptAlloc) (TCL_HASH_TYPE size); /* 428 */ + char * (*tcl_AttemptDbCkalloc) (TCL_HASH_TYPE size, const char *file, int line); /* 429 */ + char * (*tcl_AttemptRealloc) (char *ptr, TCL_HASH_TYPE size); /* 430 */ + char * (*tcl_AttemptDbCkrealloc) (char *ptr, TCL_HASH_TYPE size, const char *file, int line); /* 431 */ int (*tcl_AttemptSetObjLength) (Tcl_Obj *objPtr, Tcl_Size length); /* 432 */ Tcl_ThreadId (*tcl_GetChannelThread) (Tcl_Channel channel); /* 433 */ - Tcl_UniChar * (*tclGetUnicodeFromObj) (Tcl_Obj *objPtr, void *lengthPtr); /* 434 */ - void (*reserved435)(void); - void (*reserved436)(void); + unsigned short * (*tcl_GetUnicodeFromObj) (Tcl_Obj *objPtr, Tcl_Size *lengthPtr); /* 434 */ + TCL_DEPRECATED_API("") int (*tcl_GetMathFuncInfo) (Tcl_Interp *interp, const char *name, int *numArgsPtr, Tcl_ValueType **argTypesPtr, Tcl_MathProc **procPtr, void **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 */ @@ -2337,7 +2512,7 @@ typedef struct TclStubs { int (*tcl_FSUtime) (Tcl_Obj *pathPtr, struct utimbuf *tval); /* 450 */ int (*tcl_FSFileAttrsGet) (Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); /* 451 */ int (*tcl_FSFileAttrsSet) (Tcl_Interp *interp, int index, Tcl_Obj *pathPtr, Tcl_Obj *objPtr); /* 452 */ - const char *const * (*tcl_FSFileAttrStrings) (Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); /* 453 */ + const char *CONST86 * (*tcl_FSFileAttrStrings) (Tcl_Obj *pathPtr, Tcl_Obj **objPtrRef); /* 453 */ int (*tcl_FSStat) (Tcl_Obj *pathPtr, Tcl_StatBuf *buf); /* 454 */ int (*tcl_FSAccess) (Tcl_Obj *pathPtr, int mode); /* 455 */ Tcl_Channel (*tcl_FSOpenFileChannel) (Tcl_Interp *interp, Tcl_Obj *pathPtr, const char *modeString, int permissions); /* 456 */ @@ -2345,7 +2520,7 @@ typedef struct TclStubs { int (*tcl_FSChdir) (Tcl_Obj *pathPtr); /* 458 */ int (*tcl_FSConvertToPathType) (Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 459 */ Tcl_Obj * (*tcl_FSJoinPath) (Tcl_Obj *listObj, Tcl_Size elements); /* 460 */ - Tcl_Obj * (*tclFSSplitPath) (Tcl_Obj *pathPtr, void *lenPtr); /* 461 */ + Tcl_Obj * (*tcl_FSSplitPath) (Tcl_Obj *pathPtr, Tcl_Size *lenPtr); /* 461 */ int (*tcl_FSEqualPaths) (Tcl_Obj *firstPtr, Tcl_Obj *secondPtr); /* 462 */ Tcl_Obj * (*tcl_FSGetNormalizedPath) (Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 463 */ Tcl_Obj * (*tcl_FSJoinToPath) (Tcl_Obj *pathPtr, Tcl_Size objc, Tcl_Obj *const objv[]); /* 464 */ @@ -2361,7 +2536,7 @@ typedef struct TclStubs { int (*tcl_FSUnregister) (const Tcl_Filesystem *fsPtr); /* 474 */ void * (*tcl_FSData) (const Tcl_Filesystem *fsPtr); /* 475 */ const char * (*tcl_FSGetTranslatedStringPath) (Tcl_Interp *interp, Tcl_Obj *pathPtr); /* 476 */ - const Tcl_Filesystem * (*tcl_FSGetFileSystemForPath) (Tcl_Obj *pathPtr); /* 477 */ + CONST86 Tcl_Filesystem * (*tcl_FSGetFileSystemForPath) (Tcl_Obj *pathPtr); /* 477 */ Tcl_PathType (*tcl_FSGetPathType) (Tcl_Obj *pathPtr); /* 478 */ int (*tcl_OutputBuffered) (Tcl_Channel chan); /* 479 */ void (*tcl_FSMountsChanged) (const Tcl_Filesystem *fsPtr); /* 480 */ @@ -2381,7 +2556,7 @@ typedef struct TclStubs { int (*tcl_DictObjPut) (Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Obj *keyPtr, Tcl_Obj *valuePtr); /* 494 */ int (*tcl_DictObjGet) (Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Obj *keyPtr, Tcl_Obj **valuePtrPtr); /* 495 */ int (*tcl_DictObjRemove) (Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Obj *keyPtr); /* 496 */ - int (*tclDictObjSize) (Tcl_Interp *interp, Tcl_Obj *dictPtr, void *sizePtr); /* 497 */ + int (*tcl_DictObjSize) (Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Size *sizePtr); /* 497 */ int (*tcl_DictObjFirst) (Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_DictSearch *searchPtr, Tcl_Obj **keyPtrPtr, Tcl_Obj **valuePtrPtr, int *donePtr); /* 498 */ void (*tcl_DictObjNext) (Tcl_DictSearch *searchPtr, Tcl_Obj **keyPtrPtr, Tcl_Obj **valuePtrPtr, int *donePtr); /* 499 */ void (*tcl_DictObjDone) (Tcl_DictSearch *searchPtr); /* 500 */ @@ -2403,7 +2578,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 */ - void (*reserved519)(void); + TCL_DEPRECATED_API("Don't use this function in a stub-enabled extension") Tcl_ExitProc * (*tcl_SetExitProc) (Tcl_ExitProc *proc); /* 519 */ void (*tcl_LimitAddHandler) (Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, void *clientData, Tcl_LimitHandlerDeleteProc *deleteProc); /* 520 */ void (*tcl_LimitRemoveHandler) (Tcl_Interp *interp, int type, Tcl_LimitHandlerProc *handlerProc, void *clientData); /* 521 */ int (*tcl_LimitReady) (Tcl_Interp *interp); /* 522 */ @@ -2488,7 +2663,7 @@ typedef struct TclStubs { unsigned (*tcl_GetBlockSizeFromStat) (const Tcl_StatBuf *statPtr); /* 601 */ int (*tcl_SetEnsembleParameterList) (Tcl_Interp *interp, Tcl_Command token, Tcl_Obj *paramList); /* 602 */ int (*tcl_GetEnsembleParameterList) (Tcl_Interp *interp, Tcl_Command token, Tcl_Obj **paramListPtr); /* 603 */ - int (*tclParseArgsObjv) (Tcl_Interp *interp, const Tcl_ArgvInfo *argTable, void *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv); /* 604 */ + int (*tcl_ParseArgsObjv) (Tcl_Interp *interp, const Tcl_ArgvInfo *argTable, Tcl_Size *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv); /* 604 */ int (*tcl_GetErrorLine) (Tcl_Interp *interp); /* 605 */ void (*tcl_SetErrorLine) (Tcl_Interp *interp, int lineNum); /* 606 */ void (*tcl_TransferResult) (Tcl_Interp *sourceInterp, int code, Tcl_Interp *targetInterp); /* 607 */ @@ -2533,11 +2708,11 @@ typedef struct TclStubs { Tcl_Size (*tcl_UtfToUniChar) (const char *src, int *chPtr); /* 646 */ char * (*tcl_UniCharToUtfDString) (const int *uniStr, Tcl_Size uniLength, Tcl_DString *dsPtr); /* 647 */ int * (*tcl_UtfToUniCharDString) (const char *src, Tcl_Size length, Tcl_DString *dsPtr); /* 648 */ - unsigned char * (*tclGetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, void *numBytesPtr); /* 649 */ - unsigned char * (*tcl_GetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Size *numBytesPtr); /* 650 */ - char * (*tcl_GetStringFromObj) (Tcl_Obj *objPtr, Tcl_Size *lengthPtr); /* 651 */ - Tcl_UniChar * (*tcl_GetUnicodeFromObj) (Tcl_Obj *objPtr, Tcl_Size *lengthPtr); /* 652 */ - int (*tcl_GetSizeIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Size *sizePtr); /* 653 */ + unsigned char * (*tcl_GetBytesFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Size *numBytesPtr); /* 649 */ + void (*reserved650)(void); + void (*reserved651)(void); + void (*reserved652)(void); + void (*reserved653)(void); int (*tcl_UtfCharComplete) (const char *src, Tcl_Size length); /* 654 */ const char * (*tcl_UtfNext) (const char *src); /* 655 */ const char * (*tcl_UtfPrev) (const char *src, const char *start); /* 656 */ @@ -2545,33 +2720,33 @@ typedef struct TclStubs { int (*tcl_ExternalToUtfDStringEx) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, int flags, Tcl_DString *dsPtr, Tcl_Size *errorLocationPtr); /* 658 */ int (*tcl_UtfToExternalDStringEx) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, int flags, Tcl_DString *dsPtr, Tcl_Size *errorLocationPtr); /* 659 */ int (*tcl_AsyncMarkFromSignal) (Tcl_AsyncHandler async, int sigNumber); /* 660 */ - int (*tcl_ListObjGetElements) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size *objcPtr, Tcl_Obj ***objvPtr); /* 661 */ - int (*tcl_ListObjLength) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size *lengthPtr); /* 662 */ - int (*tcl_DictObjSize) (Tcl_Interp *interp, Tcl_Obj *dictPtr, Tcl_Size *sizePtr); /* 663 */ - int (*tcl_SplitList) (Tcl_Interp *interp, const char *listStr, Tcl_Size *argcPtr, const char ***argvPtr); /* 664 */ - void (*tcl_SplitPath) (const char *path, Tcl_Size *argcPtr, const char ***argvPtr); /* 665 */ - Tcl_Obj * (*tcl_FSSplitPath) (Tcl_Obj *pathPtr, Tcl_Size *lenPtr); /* 666 */ - int (*tcl_ParseArgsObjv) (Tcl_Interp *interp, const Tcl_ArgvInfo *argTable, Tcl_Size *objcPtr, Tcl_Obj *const *objv, Tcl_Obj ***remObjv); /* 667 */ + void (*reserved661)(void); + void (*reserved662)(void); + void (*reserved663)(void); + void (*reserved664)(void); + void (*reserved665)(void); + void (*reserved666)(void); + void (*reserved667)(void); Tcl_Size (*tcl_UniCharLen) (const int *uniStr); /* 668 */ - Tcl_Size (*tcl_NumUtfChars) (const char *src, Tcl_Size length); /* 669 */ - Tcl_Size (*tcl_GetCharLength) (Tcl_Obj *objPtr); /* 670 */ - const char * (*tcl_UtfAtIndex) (const char *src, Tcl_Size index); /* 671 */ - Tcl_Obj * (*tcl_GetRange) (Tcl_Obj *objPtr, Tcl_Size first, Tcl_Size last); /* 672 */ - int (*tcl_GetUniChar) (Tcl_Obj *objPtr, Tcl_Size index); /* 673 */ + Tcl_Size (*tclNumUtfChars) (const char *src, Tcl_Size length); /* 669 */ + Tcl_Size (*tclGetCharLength) (Tcl_Obj *objPtr); /* 670 */ + const char * (*tclUtfAtIndex) (const char *src, Tcl_Size index); /* 671 */ + Tcl_Obj * (*tclGetRange) (Tcl_Obj *objPtr, Tcl_Size first, Tcl_Size last); /* 672 */ + int (*tclGetUniChar) (Tcl_Obj *objPtr, Tcl_Size index); /* 673 */ int (*tcl_GetBool) (Tcl_Interp *interp, const char *src, int flags, char *charPtr); /* 674 */ int (*tcl_GetBoolFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, int flags, char *charPtr); /* 675 */ - Tcl_Command (*tcl_CreateObjCommand2) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc2 *proc2, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 676 */ - Tcl_Trace (*tcl_CreateObjTrace2) (Tcl_Interp *interp, Tcl_Size level, int flags, Tcl_CmdObjTraceProc2 *objProc2, void *clientData, Tcl_CmdObjTraceDeleteProc *delProc); /* 677 */ - Tcl_Command (*tcl_NRCreateCommand2) (Tcl_Interp *interp, const char *cmdName, Tcl_ObjCmdProc2 *proc, Tcl_ObjCmdProc2 *nreProc2, void *clientData, Tcl_CmdDeleteProc *deleteProc); /* 678 */ - int (*tcl_NRCallObjProc2) (Tcl_Interp *interp, Tcl_ObjCmdProc2 *objProc2, void *clientData, Tcl_Size objc, Tcl_Obj *const objv[]); /* 679 */ + void (*reserved676)(void); + void (*reserved677)(void); + void (*reserved678)(void); + void (*reserved679)(void); int (*tcl_GetNumberFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, void **clientDataPtr, int *typePtr); /* 680 */ int (*tcl_GetNumber) (Tcl_Interp *interp, const char *bytes, Tcl_Size numBytes, void **clientDataPtr, int *typePtr); /* 681 */ int (*tcl_RemoveChannelMode) (Tcl_Interp *interp, Tcl_Channel chan, int mode); /* 682 */ Tcl_Size (*tcl_GetEncodingNulLength) (Tcl_Encoding encoding); /* 683 */ int (*tcl_GetWideUIntFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_WideUInt *uwidePtr); /* 684 */ Tcl_Obj * (*tcl_DStringToObj) (Tcl_DString *dsPtr); /* 685 */ - int (*tcl_UtfNcmp) (const char *s1, const char *s2, size_t n); /* 686 */ - int (*tcl_UtfNcasecmp) (const char *s1, const char *s2, size_t n); /* 687 */ + int (*tclUtfNcmp) (const char *s1, const char *s2, size_t n); /* 686 */ + int (*tclUtfNcasecmp) (const char *s1, const char *s2, size_t n); /* 687 */ Tcl_Obj * (*tcl_NewWideUIntObj) (Tcl_WideUInt wideValue); /* 688 */ void (*tcl_SetWideUIntObj) (Tcl_Obj *objPtr, Tcl_WideUInt uwideValue); /* 689 */ void (*tclUnusedStubEntry) (void); /* 690 */ @@ -2607,10 +2782,22 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_DbCkfree) /* 7 */ #define Tcl_DbCkrealloc \ (tclStubsPtr->tcl_DbCkrealloc) /* 8 */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ +#define Tcl_CreateFileHandler \ + (tclStubsPtr->tcl_CreateFileHandler) /* 9 */ +#endif /* UNIX */ +#ifdef MAC_OSX_TCL /* MACOSX */ #define Tcl_CreateFileHandler \ (tclStubsPtr->tcl_CreateFileHandler) /* 9 */ +#endif /* MACOSX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ #define Tcl_DeleteFileHandler \ (tclStubsPtr->tcl_DeleteFileHandler) /* 10 */ +#endif /* UNIX */ +#ifdef MAC_OSX_TCL /* MACOSX */ +#define Tcl_DeleteFileHandler \ + (tclStubsPtr->tcl_DeleteFileHandler) /* 10 */ +#endif /* MACOSX */ #define Tcl_SetTimer \ (tclStubsPtr->tcl_SetTimer) /* 11 */ #define Tcl_Sleep \ @@ -2633,14 +2820,16 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_DbIncrRefCount) /* 20 */ #define Tcl_DbIsShared \ (tclStubsPtr->tcl_DbIsShared) /* 21 */ -/* Slot 22 is reserved */ +#define Tcl_DbNewBooleanObj \ + (tclStubsPtr->tcl_DbNewBooleanObj) /* 22 */ #define Tcl_DbNewByteArrayObj \ (tclStubsPtr->tcl_DbNewByteArrayObj) /* 23 */ #define Tcl_DbNewDoubleObj \ (tclStubsPtr->tcl_DbNewDoubleObj) /* 24 */ #define Tcl_DbNewListObj \ (tclStubsPtr->tcl_DbNewListObj) /* 25 */ -/* Slot 26 is reserved */ +#define Tcl_DbNewLongObj \ + (tclStubsPtr->tcl_DbNewLongObj) /* 26 */ #define Tcl_DbNewObj \ (tclStubsPtr->tcl_DbNewObj) /* 27 */ #define Tcl_DbNewStringObj \ @@ -2659,7 +2848,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_GetDouble) /* 34 */ #define Tcl_GetDoubleFromObj \ (tclStubsPtr->tcl_GetDoubleFromObj) /* 35 */ -/* Slot 36 is reserved */ +#define Tcl_GetIndexFromObj \ + (tclStubsPtr->tcl_GetIndexFromObj) /* 36 */ #define Tcl_GetInt \ (tclStubsPtr->tcl_GetInt) /* 37 */ #define Tcl_GetIntFromObj \ @@ -2668,52 +2858,60 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_GetLongFromObj) /* 39 */ #define Tcl_GetObjType \ (tclStubsPtr->tcl_GetObjType) /* 40 */ -#define TclGetStringFromObj \ - (tclStubsPtr->tclGetStringFromObj) /* 41 */ +#define Tcl_GetStringFromObj \ + (tclStubsPtr->tcl_GetStringFromObj) /* 41 */ #define Tcl_InvalidateStringRep \ (tclStubsPtr->tcl_InvalidateStringRep) /* 42 */ #define Tcl_ListObjAppendList \ (tclStubsPtr->tcl_ListObjAppendList) /* 43 */ #define Tcl_ListObjAppendElement \ (tclStubsPtr->tcl_ListObjAppendElement) /* 44 */ -#define TclListObjGetElements \ - (tclStubsPtr->tclListObjGetElements) /* 45 */ +#define Tcl_ListObjGetElements \ + (tclStubsPtr->tcl_ListObjGetElements) /* 45 */ #define Tcl_ListObjIndex \ (tclStubsPtr->tcl_ListObjIndex) /* 46 */ -#define TclListObjLength \ - (tclStubsPtr->tclListObjLength) /* 47 */ +#define Tcl_ListObjLength \ + (tclStubsPtr->tcl_ListObjLength) /* 47 */ #define Tcl_ListObjReplace \ (tclStubsPtr->tcl_ListObjReplace) /* 48 */ -/* Slot 49 is reserved */ +#define Tcl_NewBooleanObj \ + (tclStubsPtr->tcl_NewBooleanObj) /* 49 */ #define Tcl_NewByteArrayObj \ (tclStubsPtr->tcl_NewByteArrayObj) /* 50 */ #define Tcl_NewDoubleObj \ (tclStubsPtr->tcl_NewDoubleObj) /* 51 */ -/* Slot 52 is reserved */ +#define Tcl_NewIntObj \ + (tclStubsPtr->tcl_NewIntObj) /* 52 */ #define Tcl_NewListObj \ (tclStubsPtr->tcl_NewListObj) /* 53 */ -/* Slot 54 is reserved */ +#define Tcl_NewLongObj \ + (tclStubsPtr->tcl_NewLongObj) /* 54 */ #define Tcl_NewObj \ (tclStubsPtr->tcl_NewObj) /* 55 */ #define Tcl_NewStringObj \ (tclStubsPtr->tcl_NewStringObj) /* 56 */ -/* Slot 57 is reserved */ +#define Tcl_SetBooleanObj \ + (tclStubsPtr->tcl_SetBooleanObj) /* 57 */ #define Tcl_SetByteArrayLength \ (tclStubsPtr->tcl_SetByteArrayLength) /* 58 */ #define Tcl_SetByteArrayObj \ (tclStubsPtr->tcl_SetByteArrayObj) /* 59 */ #define Tcl_SetDoubleObj \ (tclStubsPtr->tcl_SetDoubleObj) /* 60 */ -/* Slot 61 is reserved */ +#define Tcl_SetIntObj \ + (tclStubsPtr->tcl_SetIntObj) /* 61 */ #define Tcl_SetListObj \ (tclStubsPtr->tcl_SetListObj) /* 62 */ -/* Slot 63 is reserved */ +#define Tcl_SetLongObj \ + (tclStubsPtr->tcl_SetLongObj) /* 63 */ #define Tcl_SetObjLength \ (tclStubsPtr->tcl_SetObjLength) /* 64 */ #define Tcl_SetStringObj \ (tclStubsPtr->tcl_SetStringObj) /* 65 */ -/* Slot 66 is reserved */ -/* Slot 67 is reserved */ +#define Tcl_AddErrorInfo \ + (tclStubsPtr->tcl_AddErrorInfo) /* 66 */ +#define Tcl_AddObjErrorInfo \ + (tclStubsPtr->tcl_AddObjErrorInfo) /* 67 */ #define Tcl_AllowExceptions \ (tclStubsPtr->tcl_AllowExceptions) /* 68 */ #define Tcl_AppendElement \ @@ -2730,8 +2928,10 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_AsyncMark) /* 74 */ #define Tcl_AsyncReady \ (tclStubsPtr->tcl_AsyncReady) /* 75 */ -/* Slot 76 is reserved */ -/* Slot 77 is reserved */ +#define Tcl_BackgroundError \ + (tclStubsPtr->tcl_BackgroundError) /* 76 */ +#define Tcl_Backslash \ + (tclStubsPtr->tcl_Backslash) /* 77 */ #define Tcl_BadChannelOption \ (tclStubsPtr->tcl_BadChannelOption) /* 78 */ #define Tcl_CallWhenDeleted \ @@ -2766,7 +2966,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_CreateExitHandler) /* 93 */ #define Tcl_CreateInterp \ (tclStubsPtr->tcl_CreateInterp) /* 94 */ -/* Slot 95 is reserved */ +#define Tcl_CreateMathFunc \ + (tclStubsPtr->tcl_CreateMathFunc) /* 95 */ #define Tcl_CreateObjCommand \ (tclStubsPtr->tcl_CreateObjCommand) /* 96 */ #define Tcl_CreateChild \ @@ -2833,10 +3034,12 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_ErrnoId) /* 127 */ #define Tcl_ErrnoMsg \ (tclStubsPtr->tcl_ErrnoMsg) /* 128 */ -/* Slot 129 is reserved */ +#define Tcl_Eval \ + (tclStubsPtr->tcl_Eval) /* 129 */ #define Tcl_EvalFile \ (tclStubsPtr->tcl_EvalFile) /* 130 */ -/* Slot 131 is reserved */ +#define Tcl_EvalObj \ + (tclStubsPtr->tcl_EvalObj) /* 131 */ #define Tcl_EventuallyFree \ (tclStubsPtr->tcl_EventuallyFree) /* 132 */ #define Tcl_Exit \ @@ -2861,15 +3064,18 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_ExprString) /* 142 */ #define Tcl_Finalize \ (tclStubsPtr->tcl_Finalize) /* 143 */ -/* Slot 144 is reserved */ +#define Tcl_FindExecutable \ + (tclStubsPtr->tcl_FindExecutable) /* 144 */ #define Tcl_FirstHashEntry \ (tclStubsPtr->tcl_FirstHashEntry) /* 145 */ #define Tcl_Flush \ (tclStubsPtr->tcl_Flush) /* 146 */ -/* Slot 147 is reserved */ -/* Slot 148 is reserved */ -#define TclGetAliasObj \ - (tclStubsPtr->tclGetAliasObj) /* 149 */ +#define Tcl_FreeResult \ + (tclStubsPtr->tcl_FreeResult) /* 147 */ +#define Tcl_GetAlias \ + (tclStubsPtr->tcl_GetAlias) /* 148 */ +#define Tcl_GetAliasObj \ + (tclStubsPtr->tcl_GetAliasObj) /* 149 */ #define Tcl_GetAssocData \ (tclStubsPtr->tcl_GetAssocData) /* 150 */ #define Tcl_GetChannel \ @@ -2904,8 +3110,14 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_GetNameOfExecutable) /* 165 */ #define Tcl_GetObjResult \ (tclStubsPtr->tcl_GetObjResult) /* 166 */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ #define Tcl_GetOpenFile \ (tclStubsPtr->tcl_GetOpenFile) /* 167 */ +#endif /* UNIX */ +#ifdef MAC_OSX_TCL /* MACOSX */ +#define Tcl_GetOpenFile \ + (tclStubsPtr->tcl_GetOpenFile) /* 167 */ +#endif /* MACOSX */ #define Tcl_GetPathType \ (tclStubsPtr->tcl_GetPathType) /* 168 */ #define Tcl_Gets \ @@ -2918,12 +3130,16 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_GetChild) /* 172 */ #define Tcl_GetStdChannel \ (tclStubsPtr->tcl_GetStdChannel) /* 173 */ -/* Slot 174 is reserved */ -/* Slot 175 is reserved */ +#define Tcl_GetStringResult \ + (tclStubsPtr->tcl_GetStringResult) /* 174 */ +#define Tcl_GetVar \ + (tclStubsPtr->tcl_GetVar) /* 175 */ #define Tcl_GetVar2 \ (tclStubsPtr->tcl_GetVar2) /* 176 */ -/* Slot 177 is reserved */ -/* Slot 178 is reserved */ +#define Tcl_GlobalEval \ + (tclStubsPtr->tcl_GlobalEval) /* 177 */ +#define Tcl_GlobalEvalObj \ + (tclStubsPtr->tcl_GlobalEvalObj) /* 178 */ #define Tcl_HideCommand \ (tclStubsPtr->tcl_HideCommand) /* 179 */ #define Tcl_Init \ @@ -2945,7 +3161,8 @@ extern const TclStubs *tclStubsPtr; /* Slot 188 is reserved */ #define Tcl_MakeFileChannel \ (tclStubsPtr->tcl_MakeFileChannel) /* 189 */ -/* Slot 190 is reserved */ +#define Tcl_MakeSafe \ + (tclStubsPtr->tcl_MakeSafe) /* 190 */ #define Tcl_MakeTcpClientChannel \ (tclStubsPtr->tcl_MakeTcpClientChannel) /* 191 */ #define Tcl_Merge \ @@ -3004,7 +3221,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_ScanElement) /* 218 */ #define Tcl_ScanCountedElement \ (tclStubsPtr->tcl_ScanCountedElement) /* 219 */ -/* Slot 220 is reserved */ +#define Tcl_SeekOld \ + (tclStubsPtr->tcl_SeekOld) /* 220 */ #define Tcl_ServiceAll \ (tclStubsPtr->tcl_ServiceAll) /* 221 */ #define Tcl_ServiceEvent \ @@ -3023,10 +3241,12 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_SetErrorCode) /* 228 */ #define Tcl_SetMaxBlockTime \ (tclStubsPtr->tcl_SetMaxBlockTime) /* 229 */ -/* Slot 230 is reserved */ +#define Tcl_SetPanicProc \ + (tclStubsPtr->tcl_SetPanicProc) /* 230 */ #define Tcl_SetRecursionLimit \ (tclStubsPtr->tcl_SetRecursionLimit) /* 231 */ -/* Slot 232 is reserved */ +#define Tcl_SetResult \ + (tclStubsPtr->tcl_SetResult) /* 232 */ #define Tcl_SetServiceMode \ (tclStubsPtr->tcl_SetServiceMode) /* 233 */ #define Tcl_SetObjErrorCode \ @@ -3035,7 +3255,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_SetObjResult) /* 235 */ #define Tcl_SetStdChannel \ (tclStubsPtr->tcl_SetStdChannel) /* 236 */ -/* Slot 237 is reserved */ +#define Tcl_SetVar \ + (tclStubsPtr->tcl_SetVar) /* 237 */ #define Tcl_SetVar2 \ (tclStubsPtr->tcl_SetVar2) /* 238 */ #define Tcl_SignalId \ @@ -3044,14 +3265,18 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_SignalMsg) /* 240 */ #define Tcl_SourceRCFile \ (tclStubsPtr->tcl_SourceRCFile) /* 241 */ -#define TclSplitList \ - (tclStubsPtr->tclSplitList) /* 242 */ -#define TclSplitPath \ - (tclStubsPtr->tclSplitPath) /* 243 */ -/* Slot 244 is reserved */ -/* Slot 245 is reserved */ -/* Slot 246 is reserved */ -/* Slot 247 is reserved */ +#define Tcl_SplitList \ + (tclStubsPtr->tcl_SplitList) /* 242 */ +#define Tcl_SplitPath \ + (tclStubsPtr->tcl_SplitPath) /* 243 */ +#define Tcl_StaticLibrary \ + (tclStubsPtr->tcl_StaticLibrary) /* 244 */ +#define Tcl_StringMatch \ + (tclStubsPtr->tcl_StringMatch) /* 245 */ +#define Tcl_TellOld \ + (tclStubsPtr->tcl_TellOld) /* 246 */ +#define Tcl_TraceVar \ + (tclStubsPtr->tcl_TraceVar) /* 247 */ #define Tcl_TraceVar2 \ (tclStubsPtr->tcl_TraceVar2) /* 248 */ #define Tcl_TranslateFileName \ @@ -3062,20 +3287,24 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_UnlinkVar) /* 251 */ #define Tcl_UnregisterChannel \ (tclStubsPtr->tcl_UnregisterChannel) /* 252 */ -/* Slot 253 is reserved */ +#define Tcl_UnsetVar \ + (tclStubsPtr->tcl_UnsetVar) /* 253 */ #define Tcl_UnsetVar2 \ (tclStubsPtr->tcl_UnsetVar2) /* 254 */ -/* Slot 255 is reserved */ +#define Tcl_UntraceVar \ + (tclStubsPtr->tcl_UntraceVar) /* 255 */ #define Tcl_UntraceVar2 \ (tclStubsPtr->tcl_UntraceVar2) /* 256 */ #define Tcl_UpdateLinkedVar \ (tclStubsPtr->tcl_UpdateLinkedVar) /* 257 */ -/* Slot 258 is reserved */ +#define Tcl_UpVar \ + (tclStubsPtr->tcl_UpVar) /* 258 */ #define Tcl_UpVar2 \ (tclStubsPtr->tcl_UpVar2) /* 259 */ #define Tcl_VarEval \ (tclStubsPtr->tcl_VarEval) /* 260 */ -/* Slot 261 is reserved */ +#define Tcl_VarTraceInfo \ + (tclStubsPtr->tcl_VarTraceInfo) /* 261 */ #define Tcl_VarTraceInfo2 \ (tclStubsPtr->tcl_VarTraceInfo2) /* 262 */ #define Tcl_Write \ @@ -3086,22 +3315,30 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_DumpActiveMemory) /* 265 */ #define Tcl_ValidateAllMemory \ (tclStubsPtr->tcl_ValidateAllMemory) /* 266 */ -/* Slot 267 is reserved */ -/* Slot 268 is reserved */ +#define Tcl_AppendResultVA \ + (tclStubsPtr->tcl_AppendResultVA) /* 267 */ +#define Tcl_AppendStringsToObjVA \ + (tclStubsPtr->tcl_AppendStringsToObjVA) /* 268 */ #define Tcl_HashStats \ (tclStubsPtr->tcl_HashStats) /* 269 */ #define Tcl_ParseVar \ (tclStubsPtr->tcl_ParseVar) /* 270 */ -/* Slot 271 is reserved */ +#define Tcl_PkgPresent \ + (tclStubsPtr->tcl_PkgPresent) /* 271 */ #define Tcl_PkgPresentEx \ (tclStubsPtr->tcl_PkgPresentEx) /* 272 */ -/* Slot 273 is reserved */ -/* Slot 274 is reserved */ -/* Slot 275 is reserved */ -/* Slot 276 is reserved */ +#define Tcl_PkgProvide \ + (tclStubsPtr->tcl_PkgProvide) /* 273 */ +#define Tcl_PkgRequire \ + (tclStubsPtr->tcl_PkgRequire) /* 274 */ +#define Tcl_SetErrorCodeVA \ + (tclStubsPtr->tcl_SetErrorCodeVA) /* 275 */ +#define Tcl_VarEvalVA \ + (tclStubsPtr->tcl_VarEvalVA) /* 276 */ #define Tcl_WaitPid \ (tclStubsPtr->tcl_WaitPid) /* 277 */ -/* Slot 278 is reserved */ +#define Tcl_PanicVA \ + (tclStubsPtr->tcl_PanicVA) /* 278 */ #define Tcl_GetVersion \ (tclStubsPtr->tcl_GetVersion) /* 279 */ #define Tcl_InitMemory \ @@ -3114,8 +3351,7 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_GetStackedChannel) /* 283 */ #define Tcl_SetMainLoop \ (tclStubsPtr->tcl_SetMainLoop) /* 284 */ -#define Tcl_GetAliasObj \ - (tclStubsPtr->tcl_GetAliasObj) /* 285 */ +/* Slot 285 is reserved */ #define Tcl_AppendObjToObj \ (tclStubsPtr->tcl_AppendObjToObj) /* 286 */ #define Tcl_CreateEncoding \ @@ -3124,7 +3360,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_CreateThreadExitHandler) /* 288 */ #define Tcl_DeleteThreadExitHandler \ (tclStubsPtr->tcl_DeleteThreadExitHandler) /* 289 */ -/* Slot 290 is reserved */ +#define Tcl_DiscardResult \ + (tclStubsPtr->tcl_DiscardResult) /* 290 */ #define Tcl_EvalEx \ (tclStubsPtr->tcl_EvalEx) /* 291 */ #define Tcl_EvalObjv \ @@ -3167,12 +3404,14 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_ConditionNotify) /* 310 */ #define Tcl_ConditionWait \ (tclStubsPtr->tcl_ConditionWait) /* 311 */ -#define TclNumUtfChars \ - (tclStubsPtr->tclNumUtfChars) /* 312 */ +#define Tcl_NumUtfChars \ + (tclStubsPtr->tcl_NumUtfChars) /* 312 */ #define Tcl_ReadChars \ (tclStubsPtr->tcl_ReadChars) /* 313 */ -/* Slot 314 is reserved */ -/* Slot 315 is reserved */ +#define Tcl_RestoreResult \ + (tclStubsPtr->tcl_RestoreResult) /* 314 */ +#define Tcl_SaveResult \ + (tclStubsPtr->tcl_SaveResult) /* 315 */ #define Tcl_SetSystemEncoding \ (tclStubsPtr->tcl_SetSystemEncoding) /* 316 */ #define Tcl_SetVar2Ex \ @@ -3191,8 +3430,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_UniCharToUpper) /* 323 */ #define Tcl_UniCharToUtf \ (tclStubsPtr->tcl_UniCharToUtf) /* 324 */ -#define TclUtfAtIndex \ - (tclStubsPtr->tclUtfAtIndex) /* 325 */ +#define Tcl_UtfAtIndex \ + (tclStubsPtr->tcl_UtfAtIndex) /* 325 */ #define TclUtfCharComplete \ (tclStubsPtr->tclUtfCharComplete) /* 326 */ #define Tcl_UtfBackslash \ @@ -3223,8 +3462,10 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_WriteObj) /* 339 */ #define Tcl_GetString \ (tclStubsPtr->tcl_GetString) /* 340 */ -/* Slot 341 is reserved */ -/* Slot 342 is reserved */ +#define Tcl_GetDefaultEncodingDir \ + (tclStubsPtr->tcl_GetDefaultEncodingDir) /* 341 */ +#define Tcl_SetDefaultEncodingDir \ + (tclStubsPtr->tcl_SetDefaultEncodingDir) /* 342 */ #define Tcl_AlertNotifier \ (tclStubsPtr->tcl_AlertNotifier) /* 343 */ #define Tcl_ServiceModeHook \ @@ -3245,14 +3486,16 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_UniCharIsWordChar) /* 351 */ #define Tcl_Char16Len \ (tclStubsPtr->tcl_Char16Len) /* 352 */ -/* Slot 353 is reserved */ +#define Tcl_UniCharNcmp \ + (tclStubsPtr->tcl_UniCharNcmp) /* 353 */ #define Tcl_Char16ToUtfDString \ (tclStubsPtr->tcl_Char16ToUtfDString) /* 354 */ #define Tcl_UtfToChar16DString \ (tclStubsPtr->tcl_UtfToChar16DString) /* 355 */ #define Tcl_GetRegExpFromObj \ (tclStubsPtr->tcl_GetRegExpFromObj) /* 356 */ -/* Slot 357 is reserved */ +#define Tcl_EvalTokens \ + (tclStubsPtr->tcl_EvalTokens) /* 357 */ #define Tcl_FreeParse \ (tclStubsPtr->tcl_FreeParse) /* 358 */ #define Tcl_LogCommandInfo \ @@ -3275,10 +3518,10 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_Access) /* 367 */ #define Tcl_Stat \ (tclStubsPtr->tcl_Stat) /* 368 */ -#define TclUtfNcmp \ - (tclStubsPtr->tclUtfNcmp) /* 369 */ -#define TclUtfNcasecmp \ - (tclStubsPtr->tclUtfNcasecmp) /* 370 */ +#define Tcl_UtfNcmp \ + (tclStubsPtr->tcl_UtfNcmp) /* 369 */ +#define Tcl_UtfNcasecmp \ + (tclStubsPtr->tcl_UtfNcasecmp) /* 370 */ #define Tcl_StringCaseMatch \ (tclStubsPtr->tcl_StringCaseMatch) /* 371 */ #define Tcl_UniCharIsControl \ @@ -3297,13 +3540,14 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_NewUnicodeObj) /* 378 */ #define Tcl_SetUnicodeObj \ (tclStubsPtr->tcl_SetUnicodeObj) /* 379 */ -#define TclGetCharLength \ - (tclStubsPtr->tclGetCharLength) /* 380 */ -#define TclGetUniChar \ - (tclStubsPtr->tclGetUniChar) /* 381 */ -/* Slot 382 is reserved */ -#define TclGetRange \ - (tclStubsPtr->tclGetRange) /* 383 */ +#define Tcl_GetCharLength \ + (tclStubsPtr->tcl_GetCharLength) /* 380 */ +#define Tcl_GetUniChar \ + (tclStubsPtr->tcl_GetUniChar) /* 381 */ +#define Tcl_GetUnicode \ + (tclStubsPtr->tcl_GetUnicode) /* 382 */ +#define Tcl_GetRange \ + (tclStubsPtr->tcl_GetRange) /* 383 */ #define Tcl_AppendUnicodeToObj \ (tclStubsPtr->tcl_AppendUnicodeToObj) /* 384 */ #define Tcl_RegExpMatchObj \ @@ -3338,14 +3582,16 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_ChannelVersion) /* 399 */ #define Tcl_ChannelBlockModeProc \ (tclStubsPtr->tcl_ChannelBlockModeProc) /* 400 */ -/* Slot 401 is reserved */ +#define Tcl_ChannelCloseProc \ + (tclStubsPtr->tcl_ChannelCloseProc) /* 401 */ #define Tcl_ChannelClose2Proc \ (tclStubsPtr->tcl_ChannelClose2Proc) /* 402 */ #define Tcl_ChannelInputProc \ (tclStubsPtr->tcl_ChannelInputProc) /* 403 */ #define Tcl_ChannelOutputProc \ (tclStubsPtr->tcl_ChannelOutputProc) /* 404 */ -/* Slot 405 is reserved */ +#define Tcl_ChannelSeekProc \ + (tclStubsPtr->tcl_ChannelSeekProc) /* 405 */ #define Tcl_ChannelSetOptionProc \ (tclStubsPtr->tcl_ChannelSetOptionProc) /* 406 */ #define Tcl_ChannelGetOptionProc \ @@ -3372,10 +3618,14 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_ClearChannelHandlers) /* 417 */ #define Tcl_IsChannelExisting \ (tclStubsPtr->tcl_IsChannelExisting) /* 418 */ -/* Slot 419 is reserved */ -/* Slot 420 is reserved */ -/* Slot 421 is reserved */ -/* Slot 422 is reserved */ +#define Tcl_UniCharNcasecmp \ + (tclStubsPtr->tcl_UniCharNcasecmp) /* 419 */ +#define Tcl_UniCharCaseMatch \ + (tclStubsPtr->tcl_UniCharCaseMatch) /* 420 */ +#define Tcl_FindHashEntry \ + (tclStubsPtr->tcl_FindHashEntry) /* 421 */ +#define Tcl_CreateHashEntry \ + (tclStubsPtr->tcl_CreateHashEntry) /* 422 */ #define Tcl_InitCustomHashTable \ (tclStubsPtr->tcl_InitCustomHashTable) /* 423 */ #define Tcl_InitObjHashTable \ @@ -3398,10 +3648,12 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_AttemptSetObjLength) /* 432 */ #define Tcl_GetChannelThread \ (tclStubsPtr->tcl_GetChannelThread) /* 433 */ -#define TclGetUnicodeFromObj \ - (tclStubsPtr->tclGetUnicodeFromObj) /* 434 */ -/* Slot 435 is reserved */ -/* Slot 436 is reserved */ +#define Tcl_GetUnicodeFromObj \ + (tclStubsPtr->tcl_GetUnicodeFromObj) /* 434 */ +#define Tcl_GetMathFuncInfo \ + (tclStubsPtr->tcl_GetMathFuncInfo) /* 435 */ +#define Tcl_ListMathFuncs \ + (tclStubsPtr->tcl_ListMathFuncs) /* 436 */ #define Tcl_SubstObj \ (tclStubsPtr->tcl_SubstObj) /* 437 */ #define Tcl_DetachChannel \ @@ -3450,8 +3702,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_FSConvertToPathType) /* 459 */ #define Tcl_FSJoinPath \ (tclStubsPtr->tcl_FSJoinPath) /* 460 */ -#define TclFSSplitPath \ - (tclStubsPtr->tclFSSplitPath) /* 461 */ +#define Tcl_FSSplitPath \ + (tclStubsPtr->tcl_FSSplitPath) /* 461 */ #define Tcl_FSEqualPaths \ (tclStubsPtr->tcl_FSEqualPaths) /* 462 */ #define Tcl_FSGetNormalizedPath \ @@ -3522,8 +3774,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_DictObjGet) /* 495 */ #define Tcl_DictObjRemove \ (tclStubsPtr->tcl_DictObjRemove) /* 496 */ -#define TclDictObjSize \ - (tclStubsPtr->tclDictObjSize) /* 497 */ +#define Tcl_DictObjSize \ + (tclStubsPtr->tcl_DictObjSize) /* 497 */ #define Tcl_DictObjFirst \ (tclStubsPtr->tcl_DictObjFirst) /* 498 */ #define Tcl_DictObjNext \ @@ -3566,7 +3818,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_GetCommandFullName) /* 517 */ #define Tcl_FSEvalFileEx \ (tclStubsPtr->tcl_FSEvalFileEx) /* 518 */ -/* Slot 519 is reserved */ +#define Tcl_SetExitProc \ + (tclStubsPtr->tcl_SetExitProc) /* 519 */ #define Tcl_LimitAddHandler \ (tclStubsPtr->tcl_LimitAddHandler) /* 520 */ #define Tcl_LimitRemoveHandler \ @@ -3735,8 +3988,8 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_SetEnsembleParameterList) /* 602 */ #define Tcl_GetEnsembleParameterList \ (tclStubsPtr->tcl_GetEnsembleParameterList) /* 603 */ -#define TclParseArgsObjv \ - (tclStubsPtr->tclParseArgsObjv) /* 604 */ +#define Tcl_ParseArgsObjv \ + (tclStubsPtr->tcl_ParseArgsObjv) /* 604 */ #define Tcl_GetErrorLine \ (tclStubsPtr->tcl_GetErrorLine) /* 605 */ #define Tcl_SetErrorLine \ @@ -3825,16 +4078,12 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_UniCharToUtfDString) /* 647 */ #define Tcl_UtfToUniCharDString \ (tclStubsPtr->tcl_UtfToUniCharDString) /* 648 */ -#define TclGetBytesFromObj \ - (tclStubsPtr->tclGetBytesFromObj) /* 649 */ #define Tcl_GetBytesFromObj \ - (tclStubsPtr->tcl_GetBytesFromObj) /* 650 */ -#define Tcl_GetStringFromObj \ - (tclStubsPtr->tcl_GetStringFromObj) /* 651 */ -#define Tcl_GetUnicodeFromObj \ - (tclStubsPtr->tcl_GetUnicodeFromObj) /* 652 */ -#define Tcl_GetSizeIntFromObj \ - (tclStubsPtr->tcl_GetSizeIntFromObj) /* 653 */ + (tclStubsPtr->tcl_GetBytesFromObj) /* 649 */ +/* Slot 650 is reserved */ +/* Slot 651 is reserved */ +/* Slot 652 is reserved */ +/* Slot 653 is reserved */ #define Tcl_UtfCharComplete \ (tclStubsPtr->tcl_UtfCharComplete) /* 654 */ #define Tcl_UtfNext \ @@ -3848,44 +4097,33 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_UtfToExternalDStringEx) /* 659 */ #define Tcl_AsyncMarkFromSignal \ (tclStubsPtr->tcl_AsyncMarkFromSignal) /* 660 */ -#define Tcl_ListObjGetElements \ - (tclStubsPtr->tcl_ListObjGetElements) /* 661 */ -#define Tcl_ListObjLength \ - (tclStubsPtr->tcl_ListObjLength) /* 662 */ -#define Tcl_DictObjSize \ - (tclStubsPtr->tcl_DictObjSize) /* 663 */ -#define Tcl_SplitList \ - (tclStubsPtr->tcl_SplitList) /* 664 */ -#define Tcl_SplitPath \ - (tclStubsPtr->tcl_SplitPath) /* 665 */ -#define Tcl_FSSplitPath \ - (tclStubsPtr->tcl_FSSplitPath) /* 666 */ -#define Tcl_ParseArgsObjv \ - (tclStubsPtr->tcl_ParseArgsObjv) /* 667 */ +/* Slot 661 is reserved */ +/* Slot 662 is reserved */ +/* Slot 663 is reserved */ +/* Slot 664 is reserved */ +/* Slot 665 is reserved */ +/* Slot 666 is reserved */ +/* Slot 667 is reserved */ #define Tcl_UniCharLen \ (tclStubsPtr->tcl_UniCharLen) /* 668 */ -#define Tcl_NumUtfChars \ - (tclStubsPtr->tcl_NumUtfChars) /* 669 */ -#define Tcl_GetCharLength \ - (tclStubsPtr->tcl_GetCharLength) /* 670 */ -#define Tcl_UtfAtIndex \ - (tclStubsPtr->tcl_UtfAtIndex) /* 671 */ -#define Tcl_GetRange \ - (tclStubsPtr->tcl_GetRange) /* 672 */ -#define Tcl_GetUniChar \ - (tclStubsPtr->tcl_GetUniChar) /* 673 */ +#define TclNumUtfChars \ + (tclStubsPtr->tclNumUtfChars) /* 669 */ +#define TclGetCharLength \ + (tclStubsPtr->tclGetCharLength) /* 670 */ +#define TclUtfAtIndex \ + (tclStubsPtr->tclUtfAtIndex) /* 671 */ +#define TclGetRange \ + (tclStubsPtr->tclGetRange) /* 672 */ +#define TclGetUniChar \ + (tclStubsPtr->tclGetUniChar) /* 673 */ #define Tcl_GetBool \ (tclStubsPtr->tcl_GetBool) /* 674 */ #define Tcl_GetBoolFromObj \ (tclStubsPtr->tcl_GetBoolFromObj) /* 675 */ -#define Tcl_CreateObjCommand2 \ - (tclStubsPtr->tcl_CreateObjCommand2) /* 676 */ -#define Tcl_CreateObjTrace2 \ - (tclStubsPtr->tcl_CreateObjTrace2) /* 677 */ -#define Tcl_NRCreateCommand2 \ - (tclStubsPtr->tcl_NRCreateCommand2) /* 678 */ -#define Tcl_NRCallObjProc2 \ - (tclStubsPtr->tcl_NRCallObjProc2) /* 679 */ +/* Slot 676 is reserved */ +/* Slot 677 is reserved */ +/* Slot 678 is reserved */ +/* Slot 679 is reserved */ #define Tcl_GetNumberFromObj \ (tclStubsPtr->tcl_GetNumberFromObj) /* 680 */ #define Tcl_GetNumber \ @@ -3898,10 +4136,10 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_GetWideUIntFromObj) /* 684 */ #define Tcl_DStringToObj \ (tclStubsPtr->tcl_DStringToObj) /* 685 */ -#define Tcl_UtfNcmp \ - (tclStubsPtr->tcl_UtfNcmp) /* 686 */ -#define Tcl_UtfNcasecmp \ - (tclStubsPtr->tcl_UtfNcasecmp) /* 687 */ +#define TclUtfNcmp \ + (tclStubsPtr->tclUtfNcmp) /* 686 */ +#define TclUtfNcasecmp \ + (tclStubsPtr->tclUtfNcasecmp) /* 687 */ #define Tcl_NewWideUIntObj \ (tclStubsPtr->tcl_NewWideUIntObj) /* 688 */ #define Tcl_SetWideUIntObj \ @@ -3915,71 +4153,138 @@ extern const TclStubs *tclStubsPtr; #undef TclUnusedStubEntry -#ifdef _WIN32 -# undef Tcl_CreateFileHandler -# undef Tcl_DeleteFileHandler -# undef Tcl_GetOpenFile +#if defined(USE_TCL_STUBS) +# undef Tcl_CreateInterp +# undef Tcl_FindExecutable +# undef Tcl_GetStringResult +# undef Tcl_Init +# undef Tcl_SetPanicProc +# undef Tcl_SetExitProc +# undef Tcl_ObjSetVar2 +# undef Tcl_StaticLibrary +# define Tcl_CreateInterp() (tclStubsPtr->tcl_CreateInterp()) +# define Tcl_GetStringResult(interp) (tclStubsPtr->tcl_GetStringResult(interp)) +# define Tcl_Init(interp) (tclStubsPtr->tcl_Init(interp)) +# define Tcl_ObjSetVar2(interp, part1, part2, newValue, flags) \ + (tclStubsPtr->tcl_ObjSetVar2(interp, part1, part2, newValue, flags)) +#endif + +#if defined(_WIN32) && defined(UNICODE) +# if defined(TCL_NO_DEPRECATED) +# define Tcl_FindExecutable(arg) ((Tcl_FindExecutable)((const char *)(arg))) +# else +# define Tcl_FindExecutable(arg) ((void)((Tcl_FindExecutable)((const char *)(arg)))) +# define Tcl_SetPanicProc(arg) ((void)((Tcl_SetPanicProc)(arg))) +# endif +# define Tcl_MainEx Tcl_MainExW + EXTERN TCL_NORETURN void Tcl_MainExW(Tcl_Size argc, wchar_t **argv, + Tcl_AppInitProc *appInitProc, Tcl_Interp *interp); +#elif !defined(TCL_NO_DEPRECATED) +# define Tcl_FindExecutable(arg) ((void)((Tcl_FindExecutable)(arg))) +# define Tcl_SetPanicProc(arg) ((void)((Tcl_SetPanicProc)(arg))) #endif #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT +#undef Tcl_SeekOld +#undef Tcl_TellOld + +#undef Tcl_PkgPresent #define Tcl_PkgPresent(interp, name, version, exact) \ Tcl_PkgPresentEx(interp, name, version, exact, NULL) +#undef Tcl_PkgProvide #define Tcl_PkgProvide(interp, name, version) \ Tcl_PkgProvideEx(interp, name, version, NULL) +#undef Tcl_PkgRequire #define Tcl_PkgRequire(interp, name, version, exact) \ Tcl_PkgRequireEx(interp, name, version, exact, NULL) +#undef Tcl_GetIndexFromObj #define Tcl_GetIndexFromObj(interp, objPtr, tablePtr, msg, flags, indexPtr) \ Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, \ sizeof(char *), msg, flags, indexPtr) +#undef Tcl_NewBooleanObj #define Tcl_NewBooleanObj(intValue) \ Tcl_NewWideIntObj((intValue)!=0) +#undef Tcl_DbNewBooleanObj #define Tcl_DbNewBooleanObj(intValue, file, line) \ Tcl_DbNewWideIntObj((intValue)!=0, file, line) +#undef Tcl_SetBooleanObj #define Tcl_SetBooleanObj(objPtr, intValue) \ Tcl_SetWideIntObj(objPtr, (intValue)!=0) +#undef Tcl_SetVar #define Tcl_SetVar(interp, varName, newValue, flags) \ Tcl_SetVar2(interp, varName, NULL, newValue, flags) +#undef Tcl_UnsetVar #define Tcl_UnsetVar(interp, varName, flags) \ Tcl_UnsetVar2(interp, varName, NULL, flags) +#undef Tcl_GetVar #define Tcl_GetVar(interp, varName, flags) \ Tcl_GetVar2(interp, varName, NULL, flags) +#undef Tcl_TraceVar #define Tcl_TraceVar(interp, varName, flags, proc, clientData) \ Tcl_TraceVar2(interp, varName, NULL, flags, proc, clientData) +#undef Tcl_UntraceVar #define Tcl_UntraceVar(interp, varName, flags, proc, clientData) \ Tcl_UntraceVar2(interp, varName, NULL, flags, proc, clientData) +#undef Tcl_VarTraceInfo #define Tcl_VarTraceInfo(interp, varName, flags, proc, prevClientData) \ Tcl_VarTraceInfo2(interp, varName, NULL, flags, proc, prevClientData) +#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)) + Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, TCL_INDEX_NONE)) +#undef Tcl_AddObjErrorInfo #define Tcl_AddObjErrorInfo(interp, message, length) \ Tcl_AppendObjToErrorInfo(interp, Tcl_NewStringObj(message, length)) +#ifdef TCL_NO_DEPRECATED +#undef Tcl_FreeResult +#undef Tcl_AppendResultVA +#undef Tcl_AppendStringsToObjVA +#undef Tcl_SetErrorCodeVA +#undef Tcl_VarEvalVA +#undef Tcl_PanicVA +#undef Tcl_GetStringResult +#undef Tcl_GetDefaultEncodingDir +#undef Tcl_SetDefaultEncodingDir +#undef Tcl_UniCharNcmp +#undef Tcl_EvalTokens +#undef Tcl_UniCharNcasecmp +#undef Tcl_UniCharCaseMatch +#undef Tcl_GetMathFuncInfo +#undef Tcl_ListMathFuncs +#define Tcl_GetStringResult(interp) Tcl_GetString(Tcl_GetObjResult(interp)) +#undef Tcl_Eval #define Tcl_Eval(interp, objPtr) \ Tcl_EvalEx(interp, objPtr, TCL_INDEX_NONE, 0) +#undef Tcl_GlobalEval #define Tcl_GlobalEval(interp, objPtr) \ Tcl_EvalEx(interp, objPtr, TCL_INDEX_NONE, TCL_EVAL_GLOBAL) -#define Tcl_GetStringResult(interp) Tcl_GetString(Tcl_GetObjResult(interp)) +#undef Tcl_SaveResult +#undef Tcl_RestoreResult +#undef Tcl_DiscardResult +#undef Tcl_SetResult #define Tcl_SetResult(interp, result, freeProc) \ do { \ const char *__result = result; \ Tcl_FreeProc *__freeProc = freeProc; \ - Tcl_SetObjResult(interp, Tcl_NewStringObj(__result, -1)); \ + Tcl_SetObjResult(interp, Tcl_NewStringObj(__result, TCL_INDEX_NONE)); \ if (__result != NULL && __freeProc != NULL && __freeProc != TCL_VOLATILE) { \ if (__freeProc == TCL_DYNAMIC) { \ - Tcl_Free((char *)__result); \ + ckfree((char *)__result); \ } else { \ (*__freeProc)((char *)__result); \ } \ } \ } while(0) +#endif /* TCL_NO_DEPRECATED */ #if defined(USE_TCL_STUBS) -# if defined(_WIN32) && defined(_WIN64) && TCL_MAJOR_VERSION < 9 +# if defined(_WIN32) && defined(_WIN64) # undef Tcl_GetTime -/* Handle Win64 tk.dll being loaded in Cygwin64 (only needed for Tcl 8). */ +/* Handle Win64 tk.dll being loaded in Cygwin64. */ # define Tcl_GetTime(t) \ do { \ struct { \ @@ -4005,6 +4310,10 @@ extern const TclStubs *tclStubsPtr; # undef Tcl_GetLongFromObj # undef Tcl_ExprLong # undef Tcl_ExprLongObj +# undef Tcl_UniCharNcmp +# undef Tcl_UtfNcmp +# undef Tcl_UtfNcasecmp +# undef Tcl_UniCharNcasecmp # define Tcl_GetLongFromObj ((int(*)(Tcl_Interp*,Tcl_Obj*,long*))Tcl_GetWideIntFromObj) # define Tcl_ExprLong TclExprLong static inline int TclExprLong(Tcl_Interp *interp, const char *string, long *ptr){ @@ -4020,6 +4329,14 @@ extern const TclStubs *tclStubsPtr; if (result == TCL_OK) *ptr = (long)intValue; return result; } +# define Tcl_UniCharNcmp(ucs,uct,n) \ + ((int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned int))tclStubsPtr->tcl_UniCharNcmp)(ucs,uct,(unsigned int)(n)) +# define Tcl_UtfNcmp(s1,s2,n) \ + ((int(*)(const char*,const char*,unsigned int))(void *)tclStubsPtr->tcl_UtfNcmp)(s1,s2,(unsigned int)(n)) +# define Tcl_UtfNcasecmp(s1,s2,n) \ + ((int(*)(const char*,const char*,unsigned int))(void *)tclStubsPtr->tcl_UtfNcasecmp)(s1,s2,(unsigned int)(n)) +# define Tcl_UniCharNcasecmp(ucs,uct,n) \ + ((int(*)(const Tcl_UniChar*,const Tcl_UniChar*,unsigned int))(void *)tclStubsPtr->tcl_UniCharNcasecmp)(ucs,uct,(unsigned int)(n)) # endif #endif @@ -4037,7 +4354,7 @@ extern const TclStubs *tclStubsPtr; # define TCLBOOLWARNING(boolPtr) (void)(sizeof(struct {_Static_assert(sizeof(*(boolPtr)) <= sizeof(int), "sizeof(boolPtr) too large");int dummy;})), #elif defined(__GNUC__) && !defined(__STRICT_ANSI__) /* If this gives: "error: size of array ‘_bool_Var’ is negative", it means that sizeof(*boolPtr)>sizeof(int), which is not allowed */ -# define TCLBOOLWARNING(boolPtr) ({__attribute__((unused)) char _bool_Var[sizeof(*(boolPtr)) > sizeof(int) ? -1 : 1];}), +# define TCLBOOLWARNING(boolPtr) ({__attribute__((unused)) char _bool_Var[sizeof(*(boolPtr)) <= sizeof(int) ? 1 : -1];}), #else # define TCLBOOLWARNING(boolPtr) #endif @@ -4047,11 +4364,11 @@ extern const TclStubs *tclStubsPtr; (tclStubsPtr->tcl_GetIndexFromObjStruct((interp), (objPtr), (tablePtr), (offset), (msg), \ (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr))) #define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \ - ((sizeof(*(boolPtr)) == sizeof(int) && (TCL_MAJOR_VERSION == 8)) ? tclStubsPtr->tcl_GetBooleanFromObj(interp, objPtr, (int *)(boolPtr)) : \ + ((sizeof(*(boolPtr)) == sizeof(int)) ? tclStubsPtr->tcl_GetBooleanFromObj(interp, objPtr, (int *)(boolPtr)) : \ ((sizeof(*(boolPtr)) <= sizeof(int)) ? Tcl_GetBoolFromObj(interp, objPtr, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr)) : \ (TCLBOOLWARNING(boolPtr)Tcl_Panic("sizeof(%s) must be <= sizeof(int)", & #boolPtr [1]),TCL_ERROR))) #define Tcl_GetBoolean(interp, src, boolPtr) \ - ((sizeof(*(boolPtr)) == sizeof(int) && (TCL_MAJOR_VERSION == 8)) ? tclStubsPtr->tcl_GetBoolean(interp, src, (int *)(boolPtr)) : \ + ((sizeof(*(boolPtr)) == sizeof(int)) ? tclStubsPtr->tcl_GetBoolean(interp, src, (int *)(boolPtr)) : \ ((sizeof(*(boolPtr)) <= sizeof(int)) ? Tcl_GetBool(interp, src, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr)) : \ (TCLBOOLWARNING(boolPtr)Tcl_Panic("sizeof(%s) must be <= sizeof(int)", & #boolPtr [1]),TCL_ERROR))) #else @@ -4059,39 +4376,28 @@ extern const TclStubs *tclStubsPtr; ((Tcl_GetIndexFromObjStruct)((interp), (objPtr), (tablePtr), (offset), (msg), \ (flags)|(int)(sizeof(*(indexPtr))<<1), (indexPtr))) #define Tcl_GetBooleanFromObj(interp, objPtr, boolPtr) \ - ((sizeof(*(boolPtr)) == sizeof(int) && (TCL_MAJOR_VERSION == 8)) ? Tcl_GetBooleanFromObj(interp, objPtr, (int *)(boolPtr)) : \ + ((sizeof(*(boolPtr)) == sizeof(int)) ? Tcl_GetBooleanFromObj(interp, objPtr, (int *)(boolPtr)) : \ ((sizeof(*(boolPtr)) <= sizeof(int)) ? Tcl_GetBoolFromObj(interp, objPtr, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr)) : \ (TCLBOOLWARNING(boolPtr)Tcl_Panic("sizeof(%s) must be <= sizeof(int)", & #boolPtr [1]),TCL_ERROR))) #define Tcl_GetBoolean(interp, src, boolPtr) \ - ((sizeof(*(boolPtr)) == sizeof(int) && (TCL_MAJOR_VERSION == 8)) ? Tcl_GetBoolean(interp, src, (int *)(boolPtr)) : \ + ((sizeof(*(boolPtr)) == sizeof(int)) ? Tcl_GetBoolean(interp, src, (int *)(boolPtr)) : \ ((sizeof(*(boolPtr)) <= sizeof(int)) ? Tcl_GetBool(interp, src, (TCL_NULL_OK-2)&(int)sizeof((*(boolPtr))), (char *)(boolPtr)) : \ (TCLBOOLWARNING(boolPtr)Tcl_Panic("sizeof(%s) must be <= sizeof(int)", & #boolPtr [1]),TCL_ERROR))) #endif -#ifdef TCL_MEM_DEBUG -# undef Tcl_Alloc -# define Tcl_Alloc(x) \ - (Tcl_DbCkalloc((x), __FILE__, __LINE__)) -# undef Tcl_Free -# define Tcl_Free(x) \ - Tcl_DbCkfree((x), __FILE__, __LINE__) -# undef Tcl_Realloc -# define Tcl_Realloc(x,y) \ - (Tcl_DbCkrealloc((x), (y), __FILE__, __LINE__)) -# undef Tcl_AttemptAlloc -# define Tcl_AttemptAlloc(x) \ - (Tcl_AttemptDbCkalloc((x), __FILE__, __LINE__)) -# undef Tcl_AttemptRealloc -# define Tcl_AttemptRealloc(x,y) \ - (Tcl_AttemptDbCkrealloc((x), (y), __FILE__, __LINE__)) -#endif /* !TCL_MEM_DEBUG */ - +#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_BackgroundError #define Tcl_BackgroundError(interp) Tcl_BackgroundException((interp), TCL_ERROR) +#undef Tcl_StringMatch #define Tcl_StringMatch(str, pattern) Tcl_StringCaseMatch((str), (pattern), 0) #if TCL_UTF_MAX < 4 @@ -4103,14 +4409,7 @@ extern const TclStubs *tclStubsPtr; # define Tcl_UtfToUniChar Tcl_UtfToChar16 # undef Tcl_UniCharLen # define Tcl_UniCharLen Tcl_Char16Len -# undef Tcl_UniCharToUtf -# if defined(USE_TCL_STUBS) -# define Tcl_UniCharToUtf(c, p) \ - (tclStubsPtr->tcl_UniCharToUtf((c)|TCL_COMBINE, (p))) -# else -# define Tcl_UniCharToUtf(c, p) \ - ((Tcl_UniCharToUtf)((c)|TCL_COMBINE, (p))) -# endif +#elif !defined(BUILD_tcl) # undef Tcl_NumUtfChars # define Tcl_NumUtfChars TclNumUtfChars # undef Tcl_GetCharLength @@ -4139,7 +4438,7 @@ extern const TclStubs *tclStubsPtr; # define Tcl_WCharLen (sizeof(wchar_t) != sizeof(short) \ ? (Tcl_Size (*)(wchar_t *))tclStubsPtr->tcl_UniCharLen \ : (Tcl_Size (*)(wchar_t *))Tcl_Char16Len) -#else +#else /* !defined(USE_TCL_STUBS) */ # define Tcl_WCharToUtfDString (sizeof(wchar_t) != sizeof(short) \ ? (char *(*)(const wchar_t *, Tcl_Size, Tcl_DString *))Tcl_UniCharToUtfDString \ : (char *(*)(const wchar_t *, Tcl_Size, Tcl_DString *))Tcl_Char16ToUtfDString) @@ -4152,183 +4451,48 @@ extern const TclStubs *tclStubsPtr; # define Tcl_WCharLen (sizeof(wchar_t) != sizeof(short) \ ? (Tcl_Size (*)(wchar_t *))Tcl_UniCharLen \ : (Tcl_Size (*)(wchar_t *))Tcl_Char16Len) -#endif +#endif /* defined(USE_TCL_STUBS) */ /* * Deprecated Tcl procedures: */ +#ifdef TCL_NO_DEPRECATED +# undef Tcl_SavedResult +#endif /* TCL_NO_DEPRECATED */ +#undef Tcl_EvalObj #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) -#if TCL_MAJOR_VERSION > 8 -# undef Tcl_Close -# define Tcl_Close(interp, chan) Tcl_CloseEx(interp, chan, 0) +#if defined(TCL_NO_DEPRECATED) && defined(USE_TCL_STUBS) +#undef Tcl_Close +#define Tcl_Close(interp, chan) Tcl_CloseEx(interp, chan, 0) #endif #undef TclUtfCharComplete #undef TclUtfNext #undef TclUtfPrev -#ifndef TCL_NO_DEPRECATED -# define Tcl_CreateSlave Tcl_CreateChild -# define Tcl_GetSlave Tcl_GetChild -# define Tcl_GetMaster Tcl_GetParent +#if defined(USE_TCL_STUBS) && (TCL_UTF_MAX < 4) && !defined(TCL_NO_DEPRECATED) +# undef Tcl_UtfCharComplete +# undef Tcl_UtfNext +# undef Tcl_UtfPrev +# define Tcl_UtfCharComplete (tclStubsPtr->tclUtfCharComplete) +# define Tcl_UtfNext (tclStubsPtr->tclUtfNext) +# define Tcl_UtfPrev (tclStubsPtr->tclUtfPrev) #endif +#define Tcl_CreateSlave Tcl_CreateChild +#define Tcl_GetSlave Tcl_GetChild +#define Tcl_GetMaster Tcl_GetParent -/* Protect those 11 functions, make them useless through the stub table */ -#undef TclGetStringFromObj -#undef TclGetBytesFromObj -#undef TclGetUnicodeFromObj -#undef TclListObjGetElements -#undef TclListObjLength -#undef TclDictObjSize -#undef TclSplitList -#undef TclSplitPath -#undef TclFSSplitPath -#undef TclParseArgsObjv -#undef TclGetAliasObj - -#if TCL_MAJOR_VERSION < 9 - /* TIP #627 for 8.7 */ -# undef Tcl_CreateObjCommand2 -# define Tcl_CreateObjCommand2 Tcl_CreateObjCommand -# undef Tcl_CreateObjTrace2 -# define Tcl_CreateObjTrace2 Tcl_CreateObjTrace -# undef Tcl_NRCreateCommand2 -# define Tcl_NRCreateCommand2 Tcl_NRCreateCommand -# undef Tcl_NRCallObjProc2 -# define Tcl_NRCallObjProc2 Tcl_NRCallObjProc - /* TIP #660 for 8.7 */ -# undef Tcl_GetSizeIntFromObj -# define Tcl_GetSizeIntFromObj Tcl_GetIntFromObj +#define Tcl_NRCallObjProc2 Tcl_NRCallObjProc +#define Tcl_CreateObjCommand2 Tcl_CreateObjCommand +#define Tcl_CreateObjTrace2 Tcl_CreateObjTrace +#define Tcl_NRCreateCommand2 Tcl_NRCreateCommand -# undef Tcl_GetBytesFromObj -# define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) \ - tclStubsPtr->tclGetBytesFromObj((interp), (objPtr), (sizePtr)) -# undef Tcl_GetStringFromObj -# define Tcl_GetStringFromObj(objPtr, sizePtr) \ - tclStubsPtr->tclGetStringFromObj((objPtr), (sizePtr)) -# undef Tcl_GetUnicodeFromObj -# define Tcl_GetUnicodeFromObj(objPtr, sizePtr) \ - tclStubsPtr->tclGetUnicodeFromObj((objPtr), (sizePtr)) -# undef Tcl_ListObjGetElements -# define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) \ - tclStubsPtr->tclListObjGetElements((interp), (listPtr), (objcPtr), (objvPtr)) -# undef Tcl_ListObjLength -# define Tcl_ListObjLength(interp, listPtr, lengthPtr) \ - tclStubsPtr->tclListObjLength((interp), (listPtr), (lengthPtr)) -# undef Tcl_DictObjSize -# define Tcl_DictObjSize(interp, dictPtr, sizePtr) \ - tclStubsPtr->tclDictObjSize((interp), (dictPtr), (sizePtr)) -# undef Tcl_SplitList -# define Tcl_SplitList(interp, listStr, argcPtr, argvPtr) \ - tclStubsPtr->tclSplitList((interp), (listStr), (argcPtr), (argvPtr)) -# undef Tcl_SplitPath -# define Tcl_SplitPath(path, argcPtr, argvPtr) \ - tclStubsPtr->tclSplitPath((path), (argcPtr), (argvPtr)) -# undef Tcl_FSSplitPath -# define Tcl_FSSplitPath(pathPtr, lenPtr) \ - tclStubsPtr->tclFSSplitPath((pathPtr), (lenPtr)) -# undef Tcl_ParseArgsObjv -# define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) \ - tclStubsPtr->tclParseArgsObjv((interp), (argTable), (objcPtr), (objv), (remObjv)) -# undef Tcl_GetAliasObj -# define Tcl_GetAliasObj(interp, childCmd, targetInterpPtr, targetCmdPtr, objcPtr, objv) \ - tclStubsPtr->tclGetAliasObj((interp), (childCmd), (targetInterpPtr), (targetCmdPtr), (objcPtr), (objv)) -#elif defined(TCL_8_API) -# undef Tcl_GetByteArrayFromObj -# undef Tcl_GetBytesFromObj -# undef Tcl_GetStringFromObj -# undef Tcl_GetUnicodeFromObj -# undef Tcl_ListObjGetElements -# undef Tcl_ListObjLength -# undef Tcl_DictObjSize -# undef Tcl_SplitList -# undef Tcl_SplitPath -# undef Tcl_FSSplitPath -# undef Tcl_ParseArgsObjv -# undef Tcl_GetAliasObj -# if !defined(USE_TCL_STUBS) -# define Tcl_GetByteArrayFromObj(objPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \ - TclGetBytesFromObj(NULL, (objPtr), (sizePtr)) : \ - (Tcl_GetBytesFromObj)(NULL, (objPtr), (Tcl_Size *)(void *)(sizePtr))) -# define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \ - TclGetBytesFromObj((interp), (objPtr), (sizePtr)) : \ - (Tcl_GetBytesFromObj)((interp), (objPtr), (Tcl_Size *)(void *)(sizePtr))) -# define Tcl_GetStringFromObj(objPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \ - (TclGetStringFromObj)((objPtr), (sizePtr)) : \ - (Tcl_GetStringFromObj)((objPtr), (Tcl_Size *)(void *)(sizePtr))) -# define Tcl_GetUnicodeFromObj(objPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \ - TclGetUnicodeFromObj((objPtr), (sizePtr)) : \ - (Tcl_GetUnicodeFromObj)((objPtr), (Tcl_Size *)(void *)(sizePtr))) -# define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) (sizeof(*(objcPtr)) <= sizeof(int) ? \ - (TclListObjGetElements)((interp), (listPtr), (objcPtr), (objvPtr)) : \ - (Tcl_ListObjGetElements)((interp), (listPtr), (Tcl_Size *)(void *)(objcPtr), (objvPtr))) -# define Tcl_ListObjLength(interp, listPtr, lengthPtr) (sizeof(*(lengthPtr)) <= sizeof(int) ? \ - (TclListObjLength)((interp), (listPtr), (lengthPtr)) : \ - (Tcl_ListObjLength)((interp), (listPtr), (Tcl_Size *)(void *)(lengthPtr))) -# define Tcl_DictObjSize(interp, dictPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \ - TclDictObjSize((interp), (dictPtr), (sizePtr)) : \ - (Tcl_DictObjSize)((interp), (dictPtr), (Tcl_Size *)(void *)(sizePtr))) -# define Tcl_SplitList(interp, listStr, argcPtr, argvPtr) (sizeof(*(argcPtr)) <= sizeof(int) ? \ - TclSplitList((interp), (listStr), (argcPtr), (argvPtr)) : \ - (Tcl_SplitList)((interp), (listStr), (Tcl_Size *)(void *)(argcPtr), (argvPtr))) -# define Tcl_SplitPath(path, argcPtr, argvPtr) (sizeof(*(argcPtr)) <= sizeof(int) ? \ - TclSplitPath((path), (argcPtr), (argvPtr)) : \ - (Tcl_SplitPath)((path), (Tcl_Size *)(void *)(argcPtr), (argvPtr))) -# define Tcl_FSSplitPath(pathPtr, lenPtr) (sizeof(*(lenPtr)) <= sizeof(int) ? \ - TclFSSplitPath((pathPtr), (lenPtr)) : \ - (Tcl_FSSplitPath)((pathPtr), (Tcl_Size *)(void *)(lenPtr))) -# define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) (sizeof(*(objcPtr)) <= sizeof(int) ? \ - TclParseArgsObjv((interp), (argTable), (objcPtr), (objv), (remObjv)) : \ - (Tcl_ParseArgsObjv)((interp), (argTable), (Tcl_Size *)(void *)(objcPtr), (objv), (remObjv))) -# define Tcl_GetAliasObj(interp, childCmd, targetInterpPtr, targetCmdPtr, objcPtr, objv) (sizeof(*(objcPtr)) <= sizeof(int) ? \ - TclGetAliasObj((interp), (childCmd), (targetInterpPtr), (targetCmdPtr), (objcPtr), (objv)) : \ - (Tcl_GetAliasObj)((interp), (childCmd), (targetInterpPtr), (targetCmdPtr), (Tcl_Size *)(void *)(objcPtr), (objv))) -# elif !defined(BUILD_tcl) -# define Tcl_GetByteArrayFromObj(objPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \ - tclStubsPtr->tclGetBytesFromObj(NULL, (objPtr), (sizePtr)) : \ - tclStubsPtr->tcl_GetBytesFromObj(NULL, (objPtr), (Tcl_Size *)(void *)(sizePtr))) -# define Tcl_GetBytesFromObj(interp, objPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \ - tclStubsPtr->tclGetBytesFromObj((interp), (objPtr), (sizePtr)) : \ - tclStubsPtr->tcl_GetBytesFromObj((interp), (objPtr), (Tcl_Size *)(void *)(sizePtr))) -# define Tcl_GetStringFromObj(objPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \ - tclStubsPtr->tclGetStringFromObj((objPtr), (sizePtr)) : \ - tclStubsPtr->tcl_GetStringFromObj((objPtr), (Tcl_Size *)(void *)(sizePtr))) -# define Tcl_GetUnicodeFromObj(objPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \ - tclStubsPtr->tclGetUnicodeFromObj((objPtr), (sizePtr)) : \ - tclStubsPtr->tcl_GetUnicodeFromObj((objPtr), (Tcl_Size *)(void *)(sizePtr))) -# define Tcl_ListObjGetElements(interp, listPtr, objcPtr, objvPtr) (sizeof(*(objcPtr)) <= sizeof(int) ? \ - tclStubsPtr->tclListObjGetElements((interp), (listPtr), (objcPtr), (objvPtr)) : \ - tclStubsPtr->tcl_ListObjGetElements((interp), (listPtr), (Tcl_Size *)(void *)(objcPtr), (objvPtr))) -# define Tcl_ListObjLength(interp, listPtr, lengthPtr) (sizeof(*(lengthPtr)) <= sizeof(int) ? \ - tclStubsPtr->tclListObjLength((interp), (listPtr), (lengthPtr)) : \ - tclStubsPtr->tcl_ListObjLength((interp), (listPtr), (Tcl_Size *)(void *)(lengthPtr))) -# define Tcl_DictObjSize(interp, dictPtr, sizePtr) (sizeof(*(sizePtr)) <= sizeof(int) ? \ - tclStubsPtr->tclDictObjSize((interp), (dictPtr), (sizePtr)) : \ - tclStubsPtr->tcl_DictObjSize((interp), (dictPtr), (Tcl_Size *)(void *)(sizePtr))) -# define Tcl_SplitList(interp, listStr, argcPtr, argvPtr) (sizeof(*(argcPtr)) <= sizeof(int) ? \ - tclStubsPtr->tclSplitList((interp), (listStr), (argcPtr), (argvPtr)) : \ - tclStubsPtr->tcl_SplitList((interp), (listStr), (Tcl_Size *)(void *)(argcPtr), (argvPtr))) -# define Tcl_SplitPath(path, argcPtr, argvPtr) (sizeof(*(argcPtr)) <= sizeof(int) ? \ - tclStubsPtr->tclSplitPath((path), (argcPtr), (argvPtr)) : \ - tclStubsPtr->tcl_SplitPath((path), (Tcl_Size *)(void *)(argcPtr), (argvPtr))) -# define Tcl_FSSplitPath(pathPtr, lenPtr) (sizeof(*(lenPtr)) <= sizeof(int) ? \ - tclStubsPtr->tclFSSplitPath((pathPtr), (lenPtr)) : \ - tclStubsPtr->tcl_FSSplitPath((pathPtr), (Tcl_Size *)(void *)(lenPtr))) -# define Tcl_ParseArgsObjv(interp, argTable, objcPtr, objv, remObjv) (sizeof(*(objcPtr)) <= sizeof(int) ? \ - tclStubsPtr->tclParseArgsObjv((interp), (argTable), (objcPtr), (objv), (remObjv)) : \ - tclStubsPtr->tcl_ParseArgsObjv((interp), (argTable), (Tcl_Size *)(void *)(objcPtr), (objv), (remObjv))) -# define Tcl_GetAliasObj(interp, childCmd, targetInterpPtr, targetCmdPtr, objcPtr, objv) (sizeof(*(objcPtr)) <= sizeof(int) ? \ - tclStubsPtr->tclGetAliasObj((interp), (childCmd), (targetInterpPtr), (targetCmdPtr), (objcPtr), (objv)) : \ - tclStubsPtr->tcl_GetAliasObj((interp), (childCmd), (targetInterpPtr), (targetCmdPtr), (Tcl_Size *)(void *)(objcPtr), (objv))) -# endif /* defined(USE_TCL_STUBS) */ -#else /* !defined(TCL_8_API) */ -# undef Tcl_GetByteArrayFromObj -# define Tcl_GetByteArrayFromObj(objPtr, sizePtr) \ - Tcl_GetBytesFromObj(NULL, (objPtr), (sizePtr)) -#endif /* defined(TCL_8_API) */ +/* TIP #660 */ +#define Tcl_GetSizeIntFromObj Tcl_GetIntFromObj #endif /* _TCLDECLS */ diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c index 8c34bb8..2359e23 100644 --- a/generic/tclDictObj.c +++ b/generic/tclDictObj.c @@ -129,7 +129,7 @@ typedef struct Dict { * the dictionary. Used for doing traversal of * the entries in the order that they are * created. */ - size_t epoch; /* Epoch counter */ + TCL_HASH_TYPE epoch; /* Epoch counter */ size_t refCount; /* Reference counter (see above) */ Tcl_Obj *chain; /* Linked list used for invalidating the * string representations of updated nested @@ -143,26 +143,25 @@ typedef struct Dict { const Tcl_ObjType tclDictType = { "dict", - FreeDictInternalRep, /* freeIntRepProc */ - DupDictInternalRep, /* dupIntRepProc */ - UpdateStringOfDict, /* updateStringProc */ - SetDictFromAny, /* setFromAnyProc */ - TCL_OBJTYPE_V0 + FreeDictInternalRep, /* freeIntRepProc */ + DupDictInternalRep, /* dupIntRepProc */ + UpdateStringOfDict, /* updateStringProc */ + SetDictFromAny /* setFromAnyProc */ }; #define DictSetInternalRep(objPtr, dictRepPtr) \ do { \ - Tcl_ObjInternalRep ir; \ + Tcl_ObjInternalRep ir; \ ir.twoPtrValue.ptr1 = (dictRepPtr); \ ir.twoPtrValue.ptr2 = NULL; \ - Tcl_StoreInternalRep((objPtr), &tclDictType, &ir); \ + Tcl_StoreInternalRep((objPtr), &tclDictType, &ir); \ } while (0) #define DictGetInternalRep(objPtr, dictRepPtr) \ do { \ - const Tcl_ObjInternalRep *irPtr; \ - irPtr = TclFetchInternalRep((objPtr), &tclDictType); \ - (dictRepPtr) = irPtr ? (Dict *)irPtr->twoPtrValue.ptr1 : NULL; \ + const Tcl_ObjInternalRep *irPtr; \ + irPtr = TclFetchInternalRep((objPtr), &tclDictType); \ + (dictRepPtr) = irPtr ? (Dict *)irPtr->twoPtrValue.ptr1 : NULL; \ } while (0) /* @@ -229,7 +228,7 @@ AllocChainEntry( Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr; ChainEntry *cPtr; - cPtr = (ChainEntry *)Tcl_Alloc(sizeof(ChainEntry)); + cPtr = (ChainEntry *)ckalloc(sizeof(ChainEntry)); cPtr->entry.key.objPtr = objPtr; Tcl_IncrRefCount(objPtr); Tcl_SetHashValue(&cPtr->entry, NULL); @@ -360,7 +359,7 @@ DupDictInternalRep( Tcl_Obj *srcPtr, Tcl_Obj *copyPtr) { - Dict *oldDict, *newDict = (Dict *)Tcl_Alloc(sizeof(Dict)); + Dict *oldDict, *newDict = (Dict *)ckalloc(sizeof(Dict)); ChainEntry *cPtr; DictGetInternalRep(srcPtr, oldDict); @@ -455,7 +454,7 @@ DeleteDict( Dict *dict) { DeleteChainTable(dict); - Tcl_Free(dict); + ckfree(dict); } /* @@ -489,8 +488,8 @@ UpdateStringOfDict( Dict *dict; ChainEntry *cPtr; Tcl_Obj *keyPtr, *valuePtr; - Tcl_Size i, length; - size_t bytesNeeded = 0; + int i, length; + TCL_HASH_TYPE bytesNeeded = 0; const char *elem; char *dst; @@ -499,7 +498,7 @@ UpdateStringOfDict( * is not exposed by any API function... */ - Tcl_Size numElems; + int numElems; DictGetInternalRep(dictPtr, dict); @@ -520,7 +519,7 @@ UpdateStringOfDict( if (numElems <= LOCAL_SIZE) { flagPtr = localFlags; } else { - flagPtr = (char *)Tcl_Alloc(numElems); + flagPtr = (char *)ckalloc(numElems); } for (i=0,cPtr=dict->entryChainHead; i<numElems; i+=2,cPtr=cPtr->nextPtr) { /* @@ -532,10 +531,20 @@ UpdateStringOfDict( keyPtr = (Tcl_Obj *)Tcl_GetHashKey(&dict->table, &cPtr->entry); elem = TclGetStringFromObj(keyPtr, &length); bytesNeeded += TclScanElement(elem, length, flagPtr+i); + if (bytesNeeded > INT_MAX) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } + flagPtr[i+1] = TCL_DONT_QUOTE_HASH; valuePtr = (Tcl_Obj *)Tcl_GetHashValue(&cPtr->entry); elem = TclGetStringFromObj(valuePtr, &length); bytesNeeded += TclScanElement(elem, length, flagPtr+i+1); + if (bytesNeeded > INT_MAX) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } + } + if (bytesNeeded + numElems > INT_MAX + 1U) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } bytesNeeded += numElems; @@ -562,7 +571,7 @@ UpdateStringOfDict( (void)Tcl_InitStringRep(dictPtr, NULL, bytesNeeded - 1); if (flagPtr != localFlags) { - Tcl_Free(flagPtr); + ckfree(flagPtr); } } @@ -593,7 +602,7 @@ SetDictFromAny( { Tcl_HashEntry *hPtr; int isNew; - Dict *dict = (Dict *)Tcl_Alloc(sizeof(Dict)); + Dict *dict = (Dict *)ckalloc(sizeof(Dict)); InitChainTable(dict); @@ -604,7 +613,7 @@ SetDictFromAny( */ if (TclHasInternalRep(objPtr, &tclListType)) { - Tcl_Size objc, i; + int objc, i; Tcl_Obj **objv; /* Cannot fail, we already know the Tcl_ObjType is "list". */ @@ -634,14 +643,14 @@ SetDictFromAny( Tcl_IncrRefCount(objv[i+1]); /* Since hash now holds ref to it */ } } else { - Tcl_Size length; + int length; const char *nextElem = TclGetStringFromObj(objPtr, &length); const char *limit = (nextElem + length); while (nextElem < limit) { Tcl_Obj *keyPtr, *valuePtr; const char *elemStart; - Tcl_Size elemSize; + int elemSize; int literal; if (TclFindDictElement(interp, nextElem, (limit - nextElem), @@ -722,7 +731,7 @@ SetDictFromAny( } errorInFindDictElement: DeleteChainTable(dict); - Tcl_Free(dict); + ckfree(dict); return TCL_ERROR; } @@ -779,12 +788,12 @@ Tcl_Obj * TclTraceDictPath( Tcl_Interp *interp, Tcl_Obj *dictPtr, - Tcl_Size keyc, + int keyc, Tcl_Obj *const keyv[], int flags) { Dict *dict, *newDict; - Tcl_Size i; + int i; DictGetInternalRep(dictPtr, dict); if (dict == NULL) { @@ -1048,26 +1057,6 @@ Tcl_DictObjRemove( /* *---------------------------------------------------------------------- * - * Tcl_DictGetSize - * - * Returns the size of dictPtr. Caller must ensure that dictPtr has type - * 'tclDicttype'. - * - * - *---------------------------------------------------------------------- - */ - -Tcl_Size -TclDictGetSize(Tcl_Obj *dictPtr) -{ - Dict *dict; - DictGetInternalRep(dictPtr, dict); - return dict->table.numEntries; -} - -/* - *---------------------------------------------------------------------- - * * Tcl_DictObjSize -- * * How many key,value pairs are there in the dictionary? @@ -1088,7 +1077,7 @@ int Tcl_DictObjSize( Tcl_Interp *interp, Tcl_Obj *dictPtr, - Tcl_Size *sizePtr) + int *sizePtr) { Dict *dict; @@ -1301,7 +1290,7 @@ int Tcl_DictObjPutKeyList( Tcl_Interp *interp, Tcl_Obj *dictPtr, - Tcl_Size keyc, + int keyc, Tcl_Obj *const keyv[], Tcl_Obj *valuePtr) { @@ -1362,7 +1351,7 @@ int Tcl_DictObjRemoveKeyList( Tcl_Interp *interp, Tcl_Obj *dictPtr, - Tcl_Size keyc, + int keyc, Tcl_Obj *const keyv[]) { Dict *dict; @@ -1421,7 +1410,7 @@ Tcl_NewDictObj(void) TclNewObj(dictPtr); TclInvalidateStringRep(dictPtr); - dict = (Dict *)Tcl_Alloc(sizeof(Dict)); + dict = (Dict *)ckalloc(sizeof(Dict)); InitChainTable(dict); dict->epoch = 1; dict->chain = NULL; @@ -1469,7 +1458,7 @@ Tcl_DbNewDictObj( TclDbNewObj(dictPtr, file, line); TclInvalidateStringRep(dictPtr); - dict = (Dict *)Tcl_Alloc(sizeof(Dict)); + dict = (Dict *)ckalloc(sizeof(Dict)); InitChainTable(dict); dict->epoch = 1; dict->chain = NULL; @@ -2045,7 +2034,7 @@ DictSizeCmd( Tcl_Obj *const *objv) { int result; - Tcl_Size size; + int size; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "dictionary"); @@ -2194,7 +2183,7 @@ DictInfoCmd( statsStr = Tcl_HashStats(&dict->table); Tcl_SetObjResult(interp, Tcl_NewStringObj(statsStr, -1)); - Tcl_Free(statsStr); + ckfree(statsStr); return TCL_OK; } @@ -2537,7 +2526,7 @@ DictForNRCmd( Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj; Tcl_Obj **varv, *keyObj, *valueObj; Tcl_DictSearch *searchPtr; - Tcl_Size varc; + int varc; int done; if (objc != 4) { @@ -2732,7 +2721,7 @@ DictMapNRCmd( Interp *iPtr = (Interp *) interp; Tcl_Obj **varv, *keyObj, *valueObj; DictMapStorage *storagePtr; - Tcl_Size varc; + int varc; int done; if (objc != 4) { @@ -3067,12 +3056,12 @@ DictFilterCmd( }; enum FilterTypes { FILTER_KEYS, FILTER_SCRIPT, FILTER_VALUES - } index; + }; Tcl_Obj *scriptObj, *keyVarObj, *valueVarObj; Tcl_Obj **varv, *keyObj = NULL, *valueObj = NULL, *resultObj, *boolObj; Tcl_DictSearch search; - int done, result, satisfied; - Tcl_Size varc; + int index, done, result, satisfied; + int varc; const char *pattern; if (objc < 3) { @@ -3084,7 +3073,7 @@ DictFilterCmd( return TCL_ERROR; } - switch (index) { + switch ((enum FilterTypes) index) { case FILTER_KEYS: /* * Create a dictionary whose keys all match a certain pattern. @@ -3350,7 +3339,7 @@ DictUpdateCmd( Interp *iPtr = (Interp *) interp; Tcl_Obj *dictPtr, *objPtr; int i; - Tcl_Size dummy; + int dummy; if (objc < 5 || !(objc & 1)) { Tcl_WrongNumArgs(interp, 1, objv, @@ -3403,7 +3392,7 @@ FinalizeDictUpdate( { Tcl_Obj *dictPtr, *objPtr, **objv; Tcl_InterpState state; - Tcl_Size i, objc; + int i, objc; Tcl_Obj *varName = (Tcl_Obj *)data[0]; Tcl_Obj *argsObj = (Tcl_Obj *)data[1]; @@ -3553,7 +3542,7 @@ FinalizeDictWith( int result) { Tcl_Obj **pathv; - Tcl_Size pathc; + int pathc; Tcl_InterpState state; Tcl_Obj *varName = (Tcl_Obj *)data[0]; Tcl_Obj *keysPtr = (Tcl_Obj *)data[1]; @@ -3630,7 +3619,7 @@ Tcl_Obj * TclDictWithInit( Tcl_Interp *interp, Tcl_Obj *dictPtr, - Tcl_Size pathc, + int pathc, Tcl_Obj *const pathv[]) { Tcl_DictSearch s; @@ -3717,7 +3706,7 @@ TclDictWithFinish( * the result value from TclDictWithInit. */ { Tcl_Obj *dictPtr, *leafPtr, *valPtr; - Tcl_Size i, allocdict, keyc; + int i, allocdict, keyc; Tcl_Obj **keyv; /* @@ -3841,7 +3830,7 @@ TclInitDictCmd( { return TclMakeEnsemble(interp, "dict", implementationMap); } - + /* * Local Variables: * mode: c diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c index 7a8783c..a096a85 100644 --- a/generic/tclDisassemble.c +++ b/generic/tclDisassemble.c @@ -42,7 +42,6 @@ static const Tcl_ObjType instNameType = { NULL, /* dupIntRepProc */ UpdateStringOfInstName, /* updateStringProc */ NULL, /* setFromAnyProc */ - TCL_OBJTYPE_V0 }; #define InstNameSetInternalRep(objPtr, inst) \ @@ -354,10 +353,10 @@ DisassembleByteCodeObj( * Print the ExceptionRange array. */ - if ((int)codePtr->numExceptRanges > 0) { + if (codePtr->numExceptRanges > 0) { Tcl_AppendPrintfToObj(bufferObj, " Exception ranges %" TCL_SIZE_MODIFIER "d, depth %" TCL_SIZE_MODIFIER "d:\n", codePtr->numExceptRanges, codePtr->maxExceptDepth); - for (i = 0; i < (int)codePtr->numExceptRanges; i++) { + for (i = 0; i < codePtr->numExceptRanges; i++) { ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i]; Tcl_AppendPrintfToObj(bufferObj, @@ -778,9 +777,9 @@ TclGetInnerContext( if (!objPtr) { Tcl_Panic("InnerContext: bad tos -- appending null object"); } - if ((objPtr->refCount <= 0) + if ((objPtr->refCount<=0) #ifdef TCL_MEM_DEBUG - || (objPtr->refCount == 0x61616161) + || (objPtr->refCount==0x61616161) #endif ) { Tcl_Panic("InnerContext: bad tos -- appending freed object %p", @@ -834,7 +833,7 @@ UpdateStringOfInstName( InstNameGetInternalRep(objPtr, inst); - if (inst >= LAST_INST_OPCODE) { + if (inst > LAST_INST_OPCODE) { dst = Tcl_InitStringRep(objPtr, NULL, TCL_INTEGER_SPACE + 5); TclOOM(dst, TCL_INTEGER_SPACE + 5); snprintf(dst, TCL_INTEGER_SPACE + 5, "inst_%" TCL_Z_MODIFIER "u", inst); @@ -1114,7 +1113,7 @@ DisassembleByteCodeAsDicts( */ TclNewObj(aux); - for (i=0 ; i<(int)codePtr->numAuxDataItems ; i++) { + for (i=0 ; i<codePtr->numAuxDataItems ; i++) { AuxData *auxData = &codePtr->auxDataArrayPtr[i]; Tcl_Obj *auxDesc = Tcl_NewStringObj(auxData->type->name, -1); @@ -1141,7 +1140,7 @@ DisassembleByteCodeAsDicts( */ TclNewObj(exn); - for (i=0 ; i<(int)codePtr->numExceptRanges ; i++) { + for (i=0 ; i<codePtr->numExceptRanges ; i++) { ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i]; switch (rangePtr->type) { @@ -1181,7 +1180,7 @@ DisassembleByteCodeAsDicts( srcOffPtr = codePtr->srcDeltaStart; srcLenPtr = codePtr->srcLengthStart; codeOffset = sourceOffset = 0; - for (i=0 ; i<(int)codePtr->numCommands ; i++) { + for (i=0 ; i<codePtr->numCommands ; i++) { Tcl_Obj *cmd; codeOffset += Decode(codeOffPtr); @@ -1200,10 +1199,10 @@ DisassembleByteCodeAsDicts( */ Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("scriptfrom", -1), - Tcl_NewWideIntObj(Tcl_NumUtfChars(codePtr->source, + Tcl_NewWideIntObj(TclNumUtfChars(codePtr->source, sourceOffset))); Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("scriptto", -1), - Tcl_NewWideIntObj(Tcl_NumUtfChars(codePtr->source, + Tcl_NewWideIntObj(TclNumUtfChars(codePtr->source, sourceOffset + sourceLength - 1))); Tcl_DictObjPut(NULL, cmd, Tcl_NewStringObj("script", -1), Tcl_NewStringObj(codePtr->source+sourceOffset, sourceLength)); @@ -1282,8 +1281,8 @@ Tcl_DisassembleObjCmd( DISAS_CLASS_CONSTRUCTOR, DISAS_CLASS_DESTRUCTOR, DISAS_LAMBDA, DISAS_CLASS_METHOD, DISAS_OBJECT_METHOD, DISAS_PROC, DISAS_SCRIPT - } idx; - int result; + }; + int idx, result; Tcl_Obj *codeObjPtr = NULL; Proc *procPtr = NULL; Tcl_HashEntry *hPtr; @@ -1299,7 +1298,7 @@ Tcl_DisassembleObjCmd( return TCL_ERROR; } - switch (idx) { + switch ((enum Types) idx) { case DISAS_LAMBDA: { Command cmd; Tcl_Obj *nsObjPtr; @@ -1529,7 +1528,7 @@ Tcl_DisassembleObjCmd( return TCL_ERROR; } hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods, - objv[3]); + (char *)objv[3]); goto methodBody; case DISAS_OBJECT_METHOD: if (objc != 4) { @@ -1548,7 +1547,7 @@ Tcl_DisassembleObjCmd( if (oPtr->methodsPtr == NULL) { goto unknownMethod; } - hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, objv[3]); + hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *)objv[3]); /* * Compile (if necessary) and disassemble a method body. diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c index 4b1ef16..f156a0b 100644 --- a/generic/tclEncoding.c +++ b/generic/tclEncoding.c @@ -201,14 +201,14 @@ static const struct TclEncodingProfiles { {"tcl8", TCL_ENCODING_PROFILE_TCL8}, }; -#define PROFILE_TCL8(flags_) \ - (ENCODING_PROFILE_GET(flags_) == TCL_ENCODING_PROFILE_TCL8) +#define PROFILE_STRICT(flags_) \ + ((flags_) & TCL_ENCODING_PROFILE_STRICT) -#define PROFILE_REPLACE(flags_) \ - (ENCODING_PROFILE_GET(flags_) == TCL_ENCODING_PROFILE_REPLACE) +#define PROFILE_REPLACE(flags_) \ + ((ENCODING_PROFILE_GET(flags_) == TCL_ENCODING_PROFILE_REPLACE) && !PROFILE_STRICT(flags_)) -#define PROFILE_STRICT(flags_) \ - (!PROFILE_TCL8(flags_) && !PROFILE_REPLACE(flags_)) +#define PROFILE_TCL8(flags_) \ + ((ENCODING_PROFILE_GET(flags_) != TCL_ENCODING_PROFILE_REPLACE) && !PROFILE_STRICT(flags_)) #define UNICODE_REPLACE_CHAR 0xFFFD #define SURROGATE(c_) (((c_) & ~0x7FF) == 0xD800) @@ -270,8 +270,7 @@ static const Tcl_ObjType encodingType = { FreeEncodingInternalRep, DupEncodingInternalRep, NULL, - NULL, - TCL_OBJTYPE_V0 + NULL }; #define EncodingSetInternalRep(objPtr, encoding) \ @@ -414,6 +413,52 @@ Tcl_SetEncodingSearchPath( } /* + *---------------------------------------------------------------------- + * + * TclGetLibraryPath -- + * + * Keeps the per-thread copy of the library path current with changes to + * the global copy. + * + * Results: + * Returns a "list" (Tcl_Obj *) that contains the library path. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclGetLibraryPath(void) +{ + return TclGetProcessGlobalValue(&libraryPath); +} + +/* + *---------------------------------------------------------------------- + * + * TclSetLibraryPath -- + * + * Keeps the per-thread copy of the library path current with changes to + * the global copy. + * + * Since the result of this routine is void, if searchPath is not a valid + * list this routine silently does nothing. + * + *---------------------------------------------------------------------- + */ + +void +TclSetLibraryPath( + Tcl_Obj *path) +{ + Tcl_Size dummy; + + if (TCL_ERROR == TclListObjLength(NULL, path, &dummy)) { + return; + } + TclSetProcessGlobalValue(&libraryPath, path, NULL); +} + +/* *--------------------------------------------------------------------------- * * FillEncodingFileMap -- @@ -472,13 +517,13 @@ FillEncodingFileMap(void) TclListObjGetElements(NULL, matchFileList, &numFiles, &filev); for (j=0; j<numFiles; j++) { - Tcl_Obj *encoding, *fileObj; + Tcl_Obj *encodingName, *fileObj; fileObj = TclPathPart(NULL, filev[j], TCL_PATH_TAIL); - encoding = TclPathPart(NULL, fileObj, TCL_PATH_ROOT); - Tcl_DictObjPut(NULL, map, encoding, directory); + encodingName = TclPathPart(NULL, fileObj, TCL_PATH_ROOT); + Tcl_DictObjPut(NULL, map, encodingName, directory); Tcl_DecrRefCount(fileObj); - Tcl_DecrRefCount(encoding); + Tcl_DecrRefCount(encodingName); } Tcl_DecrRefCount(matchFileList); Tcl_DecrRefCount(directory); @@ -620,14 +665,14 @@ TclInitEncodingSubsystem(void) * code to duplicate the structure of a table encoding here. */ - dataPtr = (TableEncodingData *)Tcl_Alloc(sizeof(TableEncodingData)); + dataPtr = (TableEncodingData *)ckalloc(sizeof(TableEncodingData)); memset(dataPtr, 0, sizeof(TableEncodingData)); dataPtr->fallback = '?'; size = 256*(sizeof(unsigned short *) + sizeof(unsigned short)); - dataPtr->toUnicode = (unsigned short **)Tcl_Alloc(size); + dataPtr->toUnicode = (unsigned short **)ckalloc(size); memset(dataPtr->toUnicode, 0, size); - dataPtr->fromUnicode = (unsigned short **)Tcl_Alloc(size); + dataPtr->fromUnicode = (unsigned short **)ckalloc(size); memset(dataPtr->fromUnicode, 0, size); dataPtr->toUnicode[0] = (unsigned short *) (dataPtr->toUnicode + 256); @@ -706,6 +751,70 @@ TclFinalizeEncodingSubsystem(void) /* *------------------------------------------------------------------------- * + * Tcl_GetDefaultEncodingDir -- + * + * Legacy public interface to retrieve first directory in the encoding + * searchPath. + * + * Results: + * The directory pathname, as a string, or NULL for an empty encoding + * search path. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------- + */ + +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 +const char * +Tcl_GetDefaultEncodingDir(void) +{ + int numDirs; + Tcl_Obj *first, *searchPath = Tcl_GetEncodingSearchPath(); + + TclListObjLength(NULL, searchPath, &numDirs); + if (numDirs == 0) { + return NULL; + } + Tcl_ListObjIndex(NULL, searchPath, 0, &first); + + return TclGetString(first); +} + +/* + *------------------------------------------------------------------------- + * + * Tcl_SetDefaultEncodingDir -- + * + * Legacy public interface to set the first directory in the encoding + * search path. + * + * Results: + * None. + * + * Side effects: + * Modifies the encoding search path. + * + *------------------------------------------------------------------------- + */ + +void +Tcl_SetDefaultEncodingDir( + const char *path) +{ + Tcl_Obj *searchPath = Tcl_GetEncodingSearchPath(); + Tcl_Obj *directory = Tcl_NewStringObj(path, TCL_INDEX_NONE); + + searchPath = Tcl_DuplicateObj(searchPath); + Tcl_ListObjReplace(NULL, searchPath, 0, 0, 1, &directory); + Tcl_SetEncodingSearchPath(searchPath); +} +#endif + +/* + *------------------------------------------------------------------------- + * * Tcl_GetEncoding -- * * Given the name of a encoding, find the corresponding Tcl_Encoding @@ -815,9 +924,9 @@ FreeEncoding( Tcl_DeleteHashEntry(encodingPtr->hPtr); } if (encodingPtr->name) { - Tcl_Free(encodingPtr->name); + ckfree(encodingPtr->name); } - Tcl_Free(encodingPtr); + ckfree(encodingPtr); } } @@ -1032,7 +1141,7 @@ Tcl_CreateEncoding( const Tcl_EncodingType *typePtr) /* The encoding type. */ { - Encoding *encodingPtr = (Encoding *)Tcl_Alloc(sizeof(Encoding)); + Encoding *encodingPtr = (Encoding *)ckalloc(sizeof(Encoding)); encodingPtr->name = NULL; encodingPtr->toUtfProc = typePtr->toUtfProc; encodingPtr->fromUtfProc = typePtr->fromUtfProc; @@ -1049,30 +1158,30 @@ Tcl_CreateEncoding( encodingPtr->refCount = 1; encodingPtr->hPtr = NULL; - if (typePtr->encodingName) { - Tcl_HashEntry *hPtr; - int isNew; - char *name; + if (typePtr->encodingName) { + Tcl_HashEntry *hPtr; + int isNew; + char *name; - Tcl_MutexLock(&encodingMutex); - hPtr = Tcl_CreateHashEntry(&encodingTable, typePtr->encodingName, &isNew); - if (isNew == 0) { - /* - * Remove old encoding from hash table, but don't delete it until last - * reference goes away. - */ + Tcl_MutexLock(&encodingMutex); + hPtr = Tcl_CreateHashEntry(&encodingTable, typePtr->encodingName, &isNew); + if (isNew == 0) { + /* + * Remove old encoding from hash table, but don't delete it until last + * reference goes away. + */ - Encoding *replaceMe = (Encoding *)Tcl_GetHashValue(hPtr); - replaceMe->hPtr = NULL; - } + Encoding *replaceMe = (Encoding *)Tcl_GetHashValue(hPtr); + replaceMe->hPtr = NULL; + } - name = (char *) Tcl_Alloc(strlen(typePtr->encodingName) + 1); - encodingPtr->name = strcpy(name, typePtr->encodingName); - encodingPtr->hPtr = hPtr; - Tcl_SetHashValue(hPtr, encodingPtr); + name = (char *)ckalloc(strlen(typePtr->encodingName) + 1); + encodingPtr->name = strcpy(name, typePtr->encodingName); + encodingPtr->hPtr = hPtr; + Tcl_SetHashValue(hPtr, encodingPtr); - Tcl_MutexUnlock(&encodingMutex); - } + Tcl_MutexUnlock(&encodingMutex); + } return (Tcl_Encoding) encodingPtr; } @@ -1097,7 +1206,6 @@ Tcl_CreateEncoding( *------------------------------------------------------------------------- */ -#undef Tcl_ExternalToUtfDString char * Tcl_ExternalToUtfDString( Tcl_Encoding encoding, /* The encoding for the source string, or NULL @@ -1170,7 +1278,7 @@ Tcl_ExternalToUtfDStringEx( char *dst; Tcl_EncodingState state; const Encoding *encodingPtr; - int result; + int result, srcRead, dstWrote, dstChars; Tcl_Size dstLen, soFar; const char *srcStart = src; @@ -1187,45 +1295,23 @@ Tcl_ExternalToUtfDStringEx( if (src == NULL) { srcLen = 0; - } else if (srcLen == TCL_INDEX_NONE) { + } else if (srcLen < 0) { srcLen = encodingPtr->lengthProc(src); } - flags &= ~TCL_ENCODING_END; - flags |= TCL_ENCODING_START; + flags |= TCL_ENCODING_START | TCL_ENCODING_END; if (encodingPtr->toUtfProc == UtfToUtfProc) { flags |= ENCODING_INPUT; } while (1) { - int srcChunkLen, srcChunkRead; - int dstChunkLen, dstChunkWrote, dstChunkChars; - - if (srcLen > INT_MAX) { - srcChunkLen = INT_MAX; - } else { - srcChunkLen = srcLen; - flags |= TCL_ENCODING_END; /* Last chunk */ - } - dstChunkLen = dstLen > INT_MAX ? INT_MAX : dstLen; - result = encodingPtr->toUtfProc(encodingPtr->clientData, src, - srcChunkLen, flags, &state, dst, dstChunkLen, - &srcChunkRead, &dstChunkWrote, &dstChunkChars); - soFar = dst + dstChunkWrote - Tcl_DStringValue(dstPtr); + srcLen, flags, &state, dst, dstLen, + &srcRead, &dstWrote, &dstChars); + soFar = dst + dstWrote - Tcl_DStringValue(dstPtr); - src += srcChunkRead; - - /* - * Keep looping in two case - - * - our destination buffer did not have enough room - * - we had not passed in all the data and error indicated fragment - * of a multibyte character - * In both cases we have to grow buffer, move the input source pointer - * and loop. Otherwise, return the result we got. - */ - if ((result != TCL_CONVERT_NOSPACE) && - !(result == TCL_CONVERT_MULTIBYTE && (flags & TCL_ENCODING_END))) { + src += srcRead; + if (result != TCL_CONVERT_NOSPACE) { Tcl_Size nBytesProcessed = (src - srcStart); Tcl_DStringSetLength(dstPtr, soFar); @@ -1240,12 +1326,14 @@ Tcl_ExternalToUtfDStringEx( if (result != TCL_OK && interp != NULL) { char buf[TCL_INTEGER_SPACE]; snprintf(buf, sizeof(buf), "%" TCL_SIZE_MODIFIER "d", nBytesProcessed); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "unexpected byte sequence starting at index %" - TCL_SIZE_MODIFIER "d: '\\x%02X'", - nBytesProcessed, UCHAR(srcStart[nBytesProcessed]))); + Tcl_SetObjResult( + interp, + Tcl_ObjPrintf("unexpected byte sequence starting at index %" + TCL_SIZE_MODIFIER "d: '\\x%02X'", + nBytesProcessed, + UCHAR(srcStart[nBytesProcessed]))); Tcl_SetErrorCode( - interp, "TCL", "ENCODING", "ILLEGALSEQUENCE", buf, (void *)NULL); + interp, "TCL", "ENCODING", "ILLEGALSEQUENCE", buf, (char *)NULL); } } if (result != TCL_OK) { @@ -1256,7 +1344,7 @@ Tcl_ExternalToUtfDStringEx( /* Expand space and continue */ flags &= ~TCL_ENCODING_START; - srcLen -= srcChunkRead; + srcLen -= srcRead; if (Tcl_DStringLength(dstPtr) == 0) { Tcl_DStringSetLength(dstPtr, dstLen); } @@ -1290,7 +1378,7 @@ Tcl_ExternalToUtf( Tcl_Encoding encoding, /* The encoding for the source string, or NULL * for the default system encoding. */ const char *src, /* Source string in specified encoding. */ - Tcl_Size srcLen, /* Source string length in bytes, or TCL_INDEX_NONE for + Tcl_Size srcLen, /* Source string length in bytes, or < 0 for * encoding-specific string length. */ int flags, /* Conversion control flags. */ Tcl_EncodingState *statePtr,/* Place for conversion routine to store state @@ -1328,20 +1416,13 @@ Tcl_ExternalToUtf( if (src == NULL) { srcLen = 0; - } else if (srcLen == TCL_INDEX_NONE) { + } else if (srcLen < 0) { srcLen = encodingPtr->lengthProc(src); } if (statePtr == NULL) { flags |= TCL_ENCODING_START | TCL_ENCODING_END; statePtr = &state; } - if (srcLen > INT_MAX) { - srcLen = INT_MAX; - flags &= ~TCL_ENCODING_END; - } - if (dstLen > INT_MAX) { - dstLen = INT_MAX; - } if (srcReadPtr == NULL) { srcReadPtr = &srcRead; } @@ -1368,7 +1449,7 @@ Tcl_ExternalToUtf( dstLen--; } else { - if (dstLen <= 0 && srcLen > 0) { + if (dstLen < 0) { return TCL_CONVERT_NOSPACE; } } @@ -1384,7 +1465,7 @@ Tcl_ExternalToUtf( if (*dstCharsPtr <= maxChars) { break; } - dstLen = Tcl_UtfAtIndex(dst, maxChars) - dst + (TCL_UTF_MAX - 1); + dstLen = TclUtfAtIndex(dst, maxChars) - dst + (TCL_UTF_MAX - 1); *statePtr = savedState; } while (1); if (!noTerminate) { @@ -1415,7 +1496,7 @@ Tcl_ExternalToUtf( * *------------------------------------------------------------------------- */ -#undef Tcl_UtfToExternalDString + char * Tcl_UtfToExternalDString( Tcl_Encoding encoding, /* The encoding for the converted string, or @@ -1487,7 +1568,7 @@ Tcl_UtfToExternalDStringEx( char *dst; Tcl_EncodingState state; const Encoding *encodingPtr; - int result; + int result, srcRead, dstWrote, dstChars; const char *srcStart = src; Tcl_Size dstLen, soFar; @@ -1504,45 +1585,21 @@ Tcl_UtfToExternalDStringEx( if (src == NULL) { srcLen = 0; - } else if (srcLen == TCL_INDEX_NONE) { + } else if (srcLen < 0) { srcLen = strlen(src); } - flags &= ~TCL_ENCODING_END; - flags |= TCL_ENCODING_START; + flags |= TCL_ENCODING_START | TCL_ENCODING_END; while (1) { - int srcChunkLen, srcChunkRead; - int dstChunkLen, dstChunkWrote, dstChunkChars; - - if (srcLen > INT_MAX) { - srcChunkLen = INT_MAX; - } else { - srcChunkLen = srcLen; - flags |= TCL_ENCODING_END; /* Last chunk */ - } - dstChunkLen = dstLen > INT_MAX ? INT_MAX : dstLen; - result = encodingPtr->fromUtfProc(encodingPtr->clientData, src, - srcChunkLen, flags, &state, dst, dstChunkLen, - &srcChunkRead, &dstChunkWrote, &dstChunkChars); - soFar = dst + dstChunkWrote - Tcl_DStringValue(dstPtr); + srcLen, flags, &state, dst, dstLen, + &srcRead, &dstWrote, &dstChars); + soFar = dst + dstWrote - Tcl_DStringValue(dstPtr); - /* Move past the part processed in this go around */ - src += srcChunkRead; - - /* - * Keep looping in two case - - * - our destination buffer did not have enough room - * - we had not passed in all the data and error indicated fragment - * of a multibyte character - * In both cases we have to grow buffer, move the input source pointer - * and loop. Otherwise, return the result we got. - */ - if ((result != TCL_CONVERT_NOSPACE) && - !(result == TCL_CONVERT_MULTIBYTE && (flags & TCL_ENCODING_END))) { + src += srcRead; + if (result != TCL_CONVERT_NOSPACE) { Tcl_Size nBytesProcessed = (src - srcStart); - Tcl_Size i = soFar + encodingPtr->nullSize - 1; - /* Loop as DStringSetLength only stores one nul byte at a time */ + int i = soFar + encodingPtr->nullSize - 1; while (i >= soFar) { Tcl_DStringSetLength(dstPtr, i--); } @@ -1555,18 +1612,20 @@ Tcl_UtfToExternalDStringEx( } else { /* Caller wants error message on failure */ if (result != TCL_OK && interp != NULL) { - Tcl_Size pos = Tcl_NumUtfChars(srcStart, nBytesProcessed); + Tcl_Size pos = TclNumUtfChars(srcStart, nBytesProcessed); int ucs4; char buf[TCL_INTEGER_SPACE]; - TclUtfToUniChar(&srcStart[nBytesProcessed], &ucs4); snprintf(buf, sizeof(buf), "%" TCL_SIZE_MODIFIER "d", nBytesProcessed); - Tcl_SetObjResult(interp, Tcl_ObjPrintf( + Tcl_SetObjResult( + interp, + Tcl_ObjPrintf( "unexpected character at index %" TCL_SIZE_MODIFIER "u: 'U+%06X'", - pos, ucs4)); + pos, + ucs4)); Tcl_SetErrorCode(interp, "TCL", "ENCODING", "ILLEGALSEQUENCE", - buf, (void *)NULL); + buf, (char *)NULL); } } if (result != TCL_OK) { @@ -1576,8 +1635,7 @@ Tcl_UtfToExternalDStringEx( } flags &= ~TCL_ENCODING_START; - srcLen -= srcChunkRead; - + srcLen -= srcRead; if (Tcl_DStringLength(dstPtr) == 0) { Tcl_DStringSetLength(dstPtr, dstLen); } @@ -1611,7 +1669,7 @@ Tcl_UtfToExternal( Tcl_Encoding encoding, /* The encoding for the converted string, or * NULL for the default system encoding. */ const char *src, /* Source string in UTF-8. */ - Tcl_Size srcLen, /* Source string length in bytes, or TCL_INDEX_NONE for + Tcl_Size srcLen, /* Source string length in bytes, or < 0 for * strlen(). */ int flags, /* Conversion control flags. */ Tcl_EncodingState *statePtr,/* Place for conversion routine to store state @@ -1646,20 +1704,13 @@ Tcl_UtfToExternal( if (src == NULL) { srcLen = 0; - } else if (srcLen == TCL_INDEX_NONE) { + } else if (srcLen < 0) { srcLen = strlen(src); } if (statePtr == NULL) { flags |= TCL_ENCODING_START | TCL_ENCODING_END; statePtr = &state; } - if (srcLen > INT_MAX) { - srcLen = INT_MAX; - flags &= ~TCL_ENCODING_END; - } - if (dstLen > INT_MAX) { - dstLen = INT_MAX; - } if (srcReadPtr == NULL) { srcReadPtr = &srcRead; } @@ -1823,7 +1874,7 @@ OpenEncodingFileChannel( if ((NULL == chan) && (interp != NULL)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown encoding \"%s\"", name)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, (void *)NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, (char *)NULL); } Tcl_DecrRefCount(fileNameObj); Tcl_DecrRefCount(nameObj); @@ -1898,9 +1949,9 @@ LoadEncodingFile( if ((encoding == NULL) && (interp != NULL)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid encoding file \"%s\"", name)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, (void *)NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ENCODING", name, (char *)NULL); } - Tcl_CloseEx(NULL, chan, 0); + Tcl_Close(NULL, chan); return encoding; } @@ -1990,7 +2041,7 @@ LoadTableEncoding( #undef PAGESIZE #define PAGESIZE (256 * sizeof(unsigned short)) - dataPtr = (TableEncodingData *)Tcl_Alloc(sizeof(TableEncodingData)); + dataPtr = (TableEncodingData *)ckalloc(sizeof(TableEncodingData)); memset(dataPtr, 0, sizeof(TableEncodingData)); dataPtr->fallback = fallback; @@ -2002,7 +2053,7 @@ LoadTableEncoding( */ size = 256 * sizeof(unsigned short *) + numPages * PAGESIZE; - dataPtr->toUnicode = (unsigned short **)Tcl_Alloc(size); + dataPtr->toUnicode = (unsigned short **)ckalloc(size); memset(dataPtr->toUnicode, 0, size); pageMemPtr = (unsigned short *) (dataPtr->toUnicode + 256); @@ -2063,7 +2114,7 @@ LoadTableEncoding( } } size = 256 * sizeof(unsigned short *) + numPages * PAGESIZE; - dataPtr->fromUnicode = (unsigned short **)Tcl_Alloc(size); + dataPtr->fromUnicode = (unsigned short **)ckalloc(size); memset(dataPtr->fromUnicode, 0, size); pageMemPtr = (unsigned short *) (dataPtr->fromUnicode + 256); @@ -2159,7 +2210,7 @@ LoadTableEncoding( */ for (TclDStringClear(&lineString); - (len = Tcl_Gets(chan, &lineString)) != -1; + (len = Tcl_Gets(chan, &lineString)) >= 0; TclDStringClear(&lineString)) { const unsigned char *p; int to, from; @@ -2295,13 +2346,13 @@ LoadEscapeEncoding( Tcl_DStringAppend(&escapeData, (char *) &est, sizeof(est)); } } - Tcl_Free(argv); + ckfree(argv); Tcl_DStringFree(&lineString); } size = offsetof(EscapeEncodingData, subTables) + Tcl_DStringLength(&escapeData); - dataPtr = (EscapeEncodingData *)Tcl_Alloc(size); + dataPtr = (EscapeEncodingData *)ckalloc(size); dataPtr->initLen = strlen(init); memcpy(dataPtr->init, init, dataPtr->initLen + 1); dataPtr->finalLen = strlen(final); @@ -2533,6 +2584,7 @@ UtfToUtfProc( } dst += Tcl_UniCharToUtf(ch, dst); } else { + int low; size_t len = TclUtfToUniChar(src, &ch); if (flags & ENCODING_INPUT) { if (((len < 2) && (ch != 0)) || ((ch > 0xFFFF) && !(flags & ENCODING_UTF))) { @@ -2556,18 +2608,43 @@ UtfToUtfProc( *dst++ = (char) (((ch >> 10) & 0x3F) | 0x80); ch = (ch & 0x0CFF) | 0xDC00; } - *dst++ = (char)(((ch >> 12) | 0xE0) & 0xEF); - *dst++ = (char)(((ch >> 6) | 0x80) & 0xBF); - *dst++ = (char)((ch | 0x80) & 0xBF); - continue; - } else if (SURROGATE(ch)) { - if (PROFILE_STRICT(profile)) { - result = (flags & ENCODING_INPUT) ? TCL_CONVERT_SYNTAX : TCL_CONVERT_UNKNOWN; + goto cesu8; + } else if ((ch | 0x7FF) == 0xDFFF) { + /* + * A surrogate character is detected, handle especially. + */ + if (PROFILE_STRICT(profile) && (flags & ENCODING_UTF)) { + result = TCL_CONVERT_UNKNOWN; src = saveSrc; break; - } else if (PROFILE_REPLACE(profile)) { + } + if (PROFILE_REPLACE(profile)) { ch = UNICODE_REPLACE_CHAR; + } else { + low = ch; + len = (src <= srcEnd - 3) ? TclUtfToUniChar(src, &low) : 0; + + if ((!LOW_SURROGATE(low)) || (ch & 0x400)) { + + if (PROFILE_STRICT(profile)) { + result = TCL_CONVERT_UNKNOWN; + src = saveSrc; + break; + } +cesu8: + *dst++ = (char)(((ch >> 12) | 0xE0) & 0xEF); + *dst++ = (char)(((ch >> 6) | 0x80) & 0xBF); + *dst++ = (char)((ch | 0x80) & 0xBF); + continue; + } + src += len; + dst += Tcl_UniCharToUtf(ch, dst); + ch = low; } + } else if (SURROGATE(ch) && PROFILE_STRICT(profile)) { + result = (flags & ENCODING_INPUT) ? TCL_CONVERT_SYNTAX : TCL_CONVERT_UNKNOWN; + src = saveSrc; + break; } dst += Tcl_UniCharToUtf(ch, dst); } @@ -2638,6 +2715,19 @@ Utf32ToUtfProc( srcLen -= bytesLeft; } + /* + * If last code point is a high surrogate, we cannot handle that yet, + * unless we are at the end. + */ + + if (!(flags & TCL_ENCODING_END) && (srcLen >= 4) && + ((src[srcLen - ((flags & TCL_ENCODING_LE)?3:2)] & 0xFC) == 0xD8) && + ((src[srcLen - ((flags & TCL_ENCODING_LE)?2:3)]) == 0) && + ((src[srcLen - ((flags & TCL_ENCODING_LE)?1:4)]) == 0)) { + result = TCL_CONVERT_MULTIBYTE; + srcLen-= 4; + } + srcStart = src; srcEnd = src + srcLen; @@ -2650,11 +2740,17 @@ Utf32ToUtfProc( break; } + int prev = ch; if (flags & TCL_ENCODING_LE) { ch = (unsigned int)(src[3] & 0xFF) << 24 | (src[2] & 0xFF) << 16 | (src[1] & 0xFF) << 8 | (src[0] & 0xFF); } else { ch = (unsigned int)(src[0] & 0xFF) << 24 | (src[1] & 0xFF) << 16 | (src[2] & 0xFF) << 8 | (src[3] & 0xFF); } + if (HIGH_SURROGATE(prev) && !LOW_SURROGATE(ch)) { + /* Bug [10c2c17c32]. If Hi surrogate not followed by Lo surrogate, finish 3-byte UTF-8 */ + dst += Tcl_UniCharToUtf(-1, dst); + } + if ((unsigned)ch > 0x10FFFF) { if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_SYNTAX; @@ -2664,6 +2760,7 @@ Utf32ToUtfProc( } else if (SURROGATE(ch)) { if (PROFILE_STRICT(flags)) { result = TCL_CONVERT_SYNTAX; + ch = 0; break; } if (PROFILE_REPLACE(flags)) { @@ -2679,11 +2776,19 @@ Utf32ToUtfProc( if ((unsigned)ch - 1 < 0x7F) { *dst++ = (ch & 0xFF); } else { + if (!HIGH_SURROGATE(prev) && LOW_SURROGATE(ch)) { + *dst = 0; /* In case of lower surrogate, don't try to combine */ + } dst += Tcl_UniCharToUtf(ch, dst); } src += 4; } + if (HIGH_SURROGATE(ch)) { + /* Bug [10c2c17c32]. If Hi surrogate, finish 3-byte UTF-8 */ + dst += Tcl_UniCharToUtf(-1, dst); + } + if ((flags & TCL_ENCODING_END) && (result == TCL_CONVERT_MULTIBYTE)) { /* We have a code fragment left-over at the end */ if (dst > dstEnd) { @@ -2929,7 +3034,7 @@ Utf16ToUtfProc( if ((unsigned)ch - 1 < 0x7F) { *dst++ = (ch & 0xFF); } else if (HIGH_SURROGATE(prev) || HIGH_SURROGATE(ch)) { - dst += Tcl_UniCharToUtf(ch | TCL_COMBINE, dst); + dst += Tcl_UniCharToUtf(ch, dst); } else if (LOW_SURROGATE(ch) && !PROFILE_TCL8(flags)) { /* Lo surrogate not preceded by Hi surrogate and not tcl8 profile */ if (PROFILE_STRICT(flags)) { @@ -2940,6 +3045,7 @@ Utf16ToUtfProc( dst += Tcl_UniCharToUtf(UNICODE_REPLACE_CHAR, dst); } } else { + *dst = 0; /* In case of lower surrogate, don't try to combine */ dst += Tcl_UniCharToUtf(ch, dst); } } @@ -3644,11 +3750,11 @@ TableFreeProc( * Make sure we aren't freeing twice on shutdown. [Bug 219314] */ - Tcl_Free(dataPtr->toUnicode); + ckfree(dataPtr->toUnicode); dataPtr->toUnicode = NULL; - Tcl_Free(dataPtr->fromUnicode); + ckfree(dataPtr->fromUnicode); dataPtr->fromUnicode = NULL; - Tcl_Free(dataPtr); + ckfree(dataPtr); } /* @@ -4124,7 +4230,7 @@ EscapeFreeProc( subTablePtr++; } } - Tcl_Free(dataPtr); + ckfree(dataPtr); } /* @@ -4238,7 +4344,7 @@ unilen4( static void InitializeEncodingSearchPath( char **valuePtr, - size_t *lengthPtr, + TCL_HASH_TYPE *lengthPtr, Tcl_Encoding *encodingPtr) { const char *bytes; @@ -4249,7 +4355,7 @@ InitializeEncodingSearchPath( TclNewObj(searchPathObj); Tcl_IncrRefCount(encodingObj); Tcl_IncrRefCount(searchPathObj); - libPathObj = TclGetProcessGlobalValue(&libraryPath); + libPathObj = TclGetLibraryPath(); Tcl_IncrRefCount(libPathObj); TclListObjLength(NULL, libPathObj, &numDirs); @@ -4275,7 +4381,7 @@ InitializeEncodingSearchPath( bytes = TclGetStringFromObj(searchPathObj, &numBytes); *lengthPtr = numBytes; - *valuePtr = (char *)Tcl_Alloc(numBytes + 1); + *valuePtr = (char *)ckalloc(numBytes + 1); memcpy(*valuePtr, bytes, numBytes + 1); Tcl_DecrRefCount(searchPathObj); } @@ -4311,19 +4417,21 @@ TclEncodingProfileNameToId( } } if (interp) { + Tcl_Obj *errorObj; /* This code assumes at least two profiles :-) */ - Tcl_Obj *errorObj = Tcl_ObjPrintf("bad profile name \"%s\": must be", + errorObj = + Tcl_ObjPrintf("bad profile name \"%s\": must be", profileName); for (i = 0; i < (numProfiles - 1); ++i) { Tcl_AppendStringsToObj( - errorObj, " ", encodingProfiles[i].name, ",", (void *)NULL); + errorObj, " ", encodingProfiles[i].name, ",", (char *)NULL); } Tcl_AppendStringsToObj( - errorObj, " or ", encodingProfiles[numProfiles-1].name, (void *)NULL); + errorObj, " or ", encodingProfiles[numProfiles-1].name, (char *)NULL); Tcl_SetObjResult(interp, errorObj); Tcl_SetErrorCode( - interp, "TCL", "ENCODING", "PROFILE", profileName, (void *)NULL); + interp, "TCL", "ENCODING", "PROFILE", profileName, (char *)NULL); } return TCL_ERROR; } @@ -4356,11 +4464,13 @@ TclEncodingProfileIdToName( } } if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( + Tcl_SetObjResult( + interp, + Tcl_ObjPrintf( "Internal error. Bad profile id \"%d\".", profileValue)); Tcl_SetErrorCode( - interp, "TCL", "ENCODING", "PROFILEID", (void *)NULL); + interp, "TCL", "ENCODING", "PROFILEID", (char *)NULL); } return NULL; } diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index 1ff0921..fff41d0 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -81,8 +81,7 @@ static const Tcl_ObjType ensembleCmdType = { FreeEnsembleCmdRep, /* freeIntRepProc */ DupEnsembleCmdRep, /* dupIntRepProc */ NULL, /* updateStringProc */ - NULL, /* setFromAnyProc */ - TCL_OBJTYPE_V0 + NULL /* setFromAnyProc */ }; #define ECRSetInternalRep(objPtr, ecRepPtr) \ @@ -164,7 +163,7 @@ TclNamespaceEnsembleCmd( Tcl_DictSearch search; Tcl_Obj *listObj; const char *simpleName; - enum EnsSubcmds index; + int index; int done; if (nsPtr == NULL || nsPtr->flags & NS_DEAD) { @@ -186,7 +185,7 @@ TclNamespaceEnsembleCmd( return TCL_ERROR; } - switch (index) { + switch ((enum EnsSubcmds) index) { case ENS_CREATE: { const char *name; Tcl_Size len; @@ -222,15 +221,14 @@ TclNamespaceEnsembleCmd( */ for (; objc>1 ; objc-=2,objv+=2) { - enum EnsCreateOpts idx; if (Tcl_GetIndexFromObj(interp, objv[0], ensembleCreateOptions, - "option", 0, &idx) != TCL_OK) { + "option", 0, &index) != TCL_OK) { if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); } return TCL_ERROR; } - switch (idx) { + switch ((enum EnsCreateOpts) index) { case CRT_CMD: name = TclGetString(objv[1]); cxtPtr = nsPtr; @@ -403,14 +401,13 @@ TclNamespaceEnsembleCmd( } if (objc == 4) { - enum EnsConfigOpts idx; Tcl_Obj *resultObj = NULL; /* silence gcc 4 warning */ if (Tcl_GetIndexFromObj(interp, objv[3], ensembleConfigOptions, - "option", 0, &idx) != TCL_OK) { + "option", 0, &index) != TCL_OK) { return TCL_ERROR; } - switch (idx) { + switch ((enum EnsConfigOpts) index) { case CONF_SUBCMDS: Tcl_GetEnsembleSubcommandList(NULL, token, &resultObj); if (resultObj != NULL) { @@ -528,16 +525,15 @@ TclNamespaceEnsembleCmd( */ for (; objc>0 ; objc-=2,objv+=2) { - enum EnsConfigOpts idx; if (Tcl_GetIndexFromObj(interp, objv[0],ensembleConfigOptions, - "option", 0, &idx) != TCL_OK) { + "option", 0, &index) != TCL_OK) { freeMapAndError: if (allocatedMapFlag) { Tcl_DecrRefCount(mapObj); } return TCL_ERROR; } - switch (idx) { + switch ((enum EnsConfigOpts) index) { case CONF_SUBCMDS: if (TclListObjLength(interp, objv[1], &len) != TCL_OK) { goto freeMapAndError; @@ -567,7 +563,8 @@ TclNamespaceEnsembleCmd( continue; } do { - if (TclListObjLength(interp, listObj, &len) != TCL_OK) { + if (TclListObjLength(interp, listObj, &len + ) != TCL_OK) { Tcl_DictObjDone(&search); if (patchedDict) { Tcl_DecrRefCount(patchedDict); @@ -690,12 +687,12 @@ TclCreateEnsembleInNs( EnsembleConfig *ensemblePtr; Tcl_Command token; - ensemblePtr = (EnsembleConfig *)Tcl_Alloc(sizeof(EnsembleConfig)); + ensemblePtr = (EnsembleConfig *)ckalloc(sizeof(EnsembleConfig)); token = TclNRCreateCommandInNs(interp, name, (Tcl_Namespace *) nameNsPtr, TclEnsembleImplementationCmd, NsEnsembleImplementationCmdNR, ensemblePtr, DeleteEnsembleConfig); if (token == NULL) { - Tcl_Free(ensemblePtr); + ckfree(ensemblePtr); return NULL; } @@ -1662,7 +1659,7 @@ TclMakeEnsemble( Tcl_DStringFree(&buf); Tcl_DStringFree(&hiddenBuf); if (nameParts != NULL) { - Tcl_Free((void *)nameParts); + ckfree(nameParts); } return ensemble; } @@ -1818,7 +1815,8 @@ NsEnsembleImplementationCmdNR( */ const char *subcmdName; /* Name of the subcommand or unique prefix of - * it (a non-unique prefix produces an error). */ + * it (a non-unique prefix produces an error). + */ char *fullName = NULL; /* Full name of the subcommand. */ Tcl_Size stringLength, i; Tcl_Size tableLength = ensemblePtr->subcommandTable.numEntries; @@ -2109,8 +2107,8 @@ FreeER( Tcl_Obj **tmp = (Tcl_Obj **) data[0]; Tcl_Obj **store = (Tcl_Obj **) data[1]; - Tcl_Free(store); - Tcl_Free(tmp); + ckfree(store); + ckfree(tmp); return result; } @@ -2185,9 +2183,9 @@ TclSpellFix( if (search[0] == NULL) { store = (Tcl_Obj **) search[2]; } else { - Tcl_Obj **tmp = (Tcl_Obj **)Tcl_Alloc(3 * sizeof(Tcl_Obj *)); + Tcl_Obj **tmp = (Tcl_Obj **)ckalloc(3 * sizeof(Tcl_Obj *)); - store = (Tcl_Obj **)Tcl_Alloc(size * sizeof(Tcl_Obj *)); + store = (Tcl_Obj **)ckalloc(size * sizeof(Tcl_Obj *)); memcpy(store, iPtr->ensembleRewrite.sourceObjs, size * sizeof(Tcl_Obj *)); @@ -2210,9 +2208,9 @@ TclSpellFix( TclNRAddCallback(interp, TclNRReleaseValues, fix, NULL, NULL, NULL); } -Tcl_Obj *const * -TclEnsembleGetRewriteValues( - Tcl_Interp *interp) /* Current interpreter. */ +Tcl_Obj *const *TclEnsembleGetRewriteValues( + Tcl_Interp *interp /* Current interpreter. */ +) { Interp *iPtr = (Interp *) interp; Tcl_Obj *const *origObjv = iPtr->ensembleRewrite.sourceObjs; @@ -2440,7 +2438,7 @@ MakeCachedEnsembleCommand( * Replace any old internal representation with a new one. */ - ensembleCmd = (EnsembleCmdRep *)Tcl_Alloc(sizeof(EnsembleCmdRep)); + ensembleCmd = (EnsembleCmdRep *)ckalloc(sizeof(EnsembleCmdRep)); ECRSetInternalRep(objPtr, ensembleCmd); } @@ -2492,7 +2490,7 @@ ClearTable( Tcl_DecrRefCount(prefixObj); hPtr = Tcl_NextHashEntry(&search); } - Tcl_Free(ensemblePtr->subcommandArrayPtr); + ckfree((char *) ensemblePtr->subcommandArrayPtr); } Tcl_DeleteHashTable(hash); } @@ -2659,7 +2657,7 @@ BuildEnsembleConfig( * Target was not in the dictionary. Map onto the namespace. * In this case there is no guarantee that the command * is actually there. It is the responsibility of the - * programmer (or [::unknown] of course) to provide the procedure. + * programmer (or [::unknown] of course) to provide the procedure. */ cmdObj = Tcl_NewStringObj(name, -1); @@ -2754,7 +2752,7 @@ BuildEnsembleConfig( */ ensemblePtr->subcommandArrayPtr = - (char **)Tcl_Alloc(sizeof(char *) * hash->numEntries); + (char **)ckalloc(sizeof(char *) * hash->numEntries); /* * Fill the array from both ends as this reduces the likelihood of @@ -2847,7 +2845,7 @@ FreeEnsembleCmdRep( if (ensembleCmd->fix) { Tcl_DecrRefCount(ensembleCmd->fix); } - Tcl_Free(ensembleCmd); + ckfree(ensembleCmd); } /* @@ -2874,7 +2872,7 @@ DupEnsembleCmdRep( Tcl_Obj *copyPtr) { EnsembleCmdRep *ensembleCmd; - EnsembleCmdRep *ensembleCopy = (EnsembleCmdRep *)Tcl_Alloc(sizeof(EnsembleCmdRep)); + EnsembleCmdRep *ensembleCopy = (EnsembleCmdRep *)ckalloc(sizeof(EnsembleCmdRep)); ECRGetInternalRep(objPtr, ensembleCmd); ECRSetInternalRep(copyPtr, ensembleCopy); @@ -2927,7 +2925,8 @@ TclCompileEnsemble( Command *oldCmdPtr = cmdPtr, *newCmdPtr; int result, flags = 0, depth = 1, invokeAnyway = 0; int ourResult = TCL_ERROR; - Tcl_Size i, len, numBytes; + Tcl_Size i, len; + TCL_HASH_TYPE numBytes; const char *word; TclNewObj(replaced); @@ -3006,7 +3005,7 @@ TclCompileEnsemble( } for (i=0 ; i<len ; i++) { str = TclGetStringFromObj(elems[i], &sclen); - if ((sclen == numBytes) && !memcmp(word, str, numBytes)) { + if ((sclen == (int) numBytes) && !memcmp(word, str, numBytes)) { /* * Exact match! Excellent! */ @@ -3159,7 +3158,7 @@ TclCompileEnsemble( if (cmdPtr->compileProc == TclCompileEnsemble) { tokenPtr = TokenAfter(tokenPtr); - if ((int)parsePtr->numWords < depth + 1 + if (parsePtr->numWords < depth + 1 || tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { /* * Too hard because the user has done something unpleasant like @@ -3194,7 +3193,7 @@ TclCompileEnsemble( while (mapPtr->nuloc > eclIndex + 1) { mapPtr->nuloc--; - Tcl_Free(mapPtr->loc[mapPtr->nuloc].line); + ckfree(mapPtr->loc[mapPtr->nuloc].line); mapPtr->loc[mapPtr->nuloc].line = NULL; } @@ -3263,7 +3262,7 @@ TclAttemptCompileProc( Tcl_Size i; Tcl_Token *saveTokenPtr = parsePtr->tokenPtr; Tcl_Size savedStackDepth = envPtr->currStackDepth; - Tcl_Size savedCodeNext = envPtr->codeNext - envPtr->codeStart; + TCL_HASH_TYPE savedCodeNext = envPtr->codeNext - envPtr->codeStart; Tcl_Size savedAuxDataArrayNext = envPtr->auxDataArrayNext; Tcl_Size savedExceptArrayNext = envPtr->exceptArrayNext; #ifdef TCL_COMPILE_DEBUG @@ -3327,12 +3326,12 @@ TclAttemptCompileProc( for (i = 0; i < savedExceptArrayNext; i++) { while (auxPtr->numBreakTargets > 0 - && (Tcl_Size) auxPtr->breakTargets[auxPtr->numBreakTargets - 1] + && auxPtr->breakTargets[auxPtr->numBreakTargets - 1] >= savedCodeNext) { auxPtr->numBreakTargets--; } while (auxPtr->numContinueTargets > 0 - && (Tcl_Size) auxPtr->continueTargets[auxPtr->numContinueTargets - 1] + && auxPtr->continueTargets[auxPtr->numContinueTargets - 1] >= savedCodeNext) { auxPtr->numContinueTargets--; } @@ -3370,7 +3369,7 @@ TclAttemptCompileProc( if (diff != 1) { Tcl_Panic("bad stack adjustment when compiling" - " %.*s (was %d instead of 1)", (int)parsePtr->tokenPtr->size, + " %.*s (was %d instead of 1)", parsePtr->tokenPtr->size, parsePtr->tokenPtr->start, diff); } #endif @@ -3699,7 +3698,7 @@ TclCompileBasicMin0ArgCmd( * which is the only code that sees the shenanigans of ensemble dispatch. */ - if ((int)parsePtr->numWords < 1) { + if (parsePtr->numWords < 1) { return TCL_ERROR; } @@ -3721,7 +3720,7 @@ TclCompileBasicMin1ArgCmd( * which is the only code that sees the shenanigans of ensemble dispatch. */ - if ((int)parsePtr->numWords < 2) { + if (parsePtr->numWords < 2) { return TCL_ERROR; } @@ -3743,7 +3742,7 @@ TclCompileBasicMin2ArgCmd( * which is the only code that sees the shenanigans of ensemble dispatch. */ - if ((int)parsePtr->numWords < 3) { + if (parsePtr->numWords < 3) { return TCL_ERROR; } diff --git a/generic/tclEnv.c b/generic/tclEnv.c index ef4e946..ef5cfb7 100644 --- a/generic/tclEnv.c +++ b/generic/tclEnv.c @@ -280,11 +280,11 @@ TclSetEnv( */ if ((env.ourEnviron != tenviron) || (length+2 > env.ourEnvironSize)) { - techar **newEnviron = (techar **)Tcl_Alloc((length + 5) * sizeof(techar *)); + techar **newEnviron = (techar **)ckalloc((length + 5) * sizeof(techar *)); memcpy(newEnviron, tenviron, length * sizeof(techar *)); if ((env.ourEnvironSize != 0) && (env.ourEnviron != NULL)) { - Tcl_Free(env.ourEnviron); + ckfree(env.ourEnviron); } tenviron = (env.ourEnviron = newEnviron); env.ourEnvironSize = length + 5; @@ -324,14 +324,14 @@ TclSetEnv( */ valueLength = strlen(value); - p = (char *)Tcl_Alloc(nameLength + valueLength + 2); + p = (char *)ckalloc(nameLength + valueLength + 2); memcpy(p, name, nameLength); p[nameLength] = '='; memcpy(p+nameLength+1, value, valueLength+1); p2 = utf2tenvirondstr(p, &envString); if (p2 == NULL) { /* No way to signal error from here :-( but should not happen */ - Tcl_Free(p); + ckfree(p); Tcl_MutexUnlock(&envMutex); return; } @@ -340,7 +340,7 @@ TclSetEnv( * Copy the native string to heap memory. */ - p = (char *)Tcl_Realloc(p, Tcl_DStringLength(&envString) + tNTL); + p = (char *)ckrealloc(p, Tcl_DStringLength(&envString) + tNTL); memcpy(p, p2, Tcl_DStringLength(&envString) + tNTL); Tcl_DStringFree(&envString); @@ -369,11 +369,20 @@ TclSetEnv( * This putenv() copies instead of taking ownership. */ - Tcl_Free(p); + ckfree(p); #endif /* HAVE_PUTENV_THAT_COPIES */ } Tcl_MutexUnlock(&envMutex); + + if (!strcmp(name, "HOME")) { + /* + * If the user's home directory has changed, we must invalidate the + * filesystem cache, because '~' expansions will now be incorrect. + */ + + Tcl_FSMountsChanged(NULL); + } } /* @@ -502,12 +511,12 @@ TclUnsetEnv( */ #if defined(_WIN32) - string = (char *)Tcl_Alloc(length + 2); + string = (char *)ckalloc(length + 2); memcpy(string, name, length); string[length] = '='; string[length+1] = '\0'; #else - string = (char *)Tcl_Alloc(length + 1); + string = (char *)ckalloc(length + 1); memcpy(string, name, length); string[length] = '\0'; #endif /* _WIN32 */ @@ -517,7 +526,7 @@ TclUnsetEnv( Tcl_MutexUnlock(&envMutex); return; } - string = (char *)Tcl_Realloc(string, Tcl_DStringLength(&envString) + tNTL); + string = (char *)ckrealloc(string, Tcl_DStringLength(&envString) + tNTL); memcpy(string, Tcl_DStringValue(&envString), Tcl_DStringLength(&envString) + tNTL); Tcl_DStringFree(&envString); @@ -538,7 +547,7 @@ TclUnsetEnv( * This putenv() copies instead of taking ownership. */ - Tcl_Free(string); + ckfree(string); #endif /* HAVE_PUTENV_THAT_COPIES */ } #else /* !USE_PUTENV_FOR_UNSET */ @@ -664,19 +673,8 @@ EnvTraceProc( if (flags & TCL_TRACE_WRITES) { const char *value; - Tcl_DString ds; value = Tcl_GetVar2(interp, "env", name2, TCL_GLOBAL_ONLY); - Tcl_DStringInit(&ds); - if (Tcl_UtfToExternalDStringEx(NULL, TCLFSENCODING, name2, -1, 0, &ds, NULL) != TCL_OK) { - Tcl_DStringFree(&ds); - return (char *) "encoding error"; - } - if (Tcl_UtfToExternalDStringEx(NULL, TCLFSENCODING, value, -1, 0, &ds, NULL) != TCL_OK) { - Tcl_DStringFree(&ds); - return (char *) "encoding error"; - } - Tcl_DStringFree(&ds); TclSetEnv(name2, value); TclEnvEpoch++; } @@ -750,7 +748,7 @@ ReplaceString( */ if (env.cache[i]) { - Tcl_Free(env.cache[i]); + ckfree(env.cache[i]); } if (newStr) { @@ -768,11 +766,11 @@ ReplaceString( const int growth = 5; - env.cache = (char **)Tcl_Realloc(env.cache, + env.cache = (char **)ckrealloc(env.cache, (env.cacheSize + growth) * sizeof(char *)); env.cache[env.cacheSize] = newStr; (void) memset(env.cache+env.cacheSize+1, 0, - (growth-1) * sizeof(char *)); + (size_t) (growth-1) * sizeof(char *)); env.cacheSize += growth; } } @@ -811,15 +809,15 @@ TclFinalizeEnvironment(void) #ifdef PURIFY Tcl_Size i; for (i = 0; i < env.cacheSize; i++) { - Tcl_Free(env.cache[i]); + ckfree(env.cache[i]); } #endif - Tcl_Free(env.cache); + ckfree(env.cache); env.cache = NULL; env.cacheSize = 0; #ifndef USE_PUTENV if ((env.ourEnviron != NULL)) { - Tcl_Free(env.ourEnviron); + ckfree(env.ourEnviron); env.ourEnviron = NULL; } env.ourEnvironSize = 0; diff --git a/generic/tclEvent.c b/generic/tclEvent.c index 334cfae..e832422 100644 --- a/generic/tclEvent.c +++ b/generic/tclEvent.c @@ -143,7 +143,7 @@ static void FinalizeThread(int quick); /* *---------------------------------------------------------------------- * - * Tcl_BackgroundException -- + * Tcl_BackgroundError -- * * This function is invoked to handle errors that occur in Tcl commands * that are invoked in "background" (e.g. from event or timer bindings). @@ -158,6 +158,17 @@ 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 + * occurred. */ +{ + Tcl_BackgroundException(interp, TCL_ERROR); +} +#endif /* TCL_NO_DEPRECATED */ + void Tcl_BackgroundException( Tcl_Interp *interp, /* Interpreter in which an exception has @@ -171,7 +182,7 @@ Tcl_BackgroundException( return; } - errPtr = (BgError*)Tcl_Alloc(sizeof(BgError)); + errPtr = (BgError*)ckalloc(sizeof(BgError)); errPtr->errorMsg = Tcl_GetObjResult(interp); Tcl_IncrRefCount(errPtr->errorMsg); errPtr->returnOpts = Tcl_GetReturnOptions(interp, code); @@ -239,7 +250,7 @@ HandleBgErrors( errPtr = assocPtr->firstBgPtr; TclListObjGetElements(NULL, copyObj, &prefixObjc, &prefixObjv); - tempObjv = (Tcl_Obj**)Tcl_Alloc((prefixObjc+2) * sizeof(Tcl_Obj *)); + tempObjv = (Tcl_Obj**)ckalloc((prefixObjc+2) * sizeof(Tcl_Obj *)); memcpy(tempObjv, prefixObjv, prefixObjc*sizeof(Tcl_Obj *)); tempObjv[prefixObjc] = errPtr->errorMsg; tempObjv[prefixObjc+1] = errPtr->returnOpts; @@ -254,8 +265,8 @@ HandleBgErrors( Tcl_DecrRefCount(errPtr->errorMsg); Tcl_DecrRefCount(errPtr->returnOpts); assocPtr->firstBgPtr = errPtr->nextPtr; - Tcl_Free(errPtr); - Tcl_Free(tempObjv); + ckfree(errPtr); + ckfree(tempObjv); if (code == TCL_BREAK) { /* @@ -268,7 +279,7 @@ HandleBgErrors( assocPtr->firstBgPtr = errPtr->nextPtr; Tcl_DecrRefCount(errPtr->errorMsg); Tcl_DecrRefCount(errPtr->returnOpts); - Tcl_Free(errPtr); + ckfree(errPtr); } } else if ((code == TCL_ERROR) && !Tcl_IsSafe(interp)) { Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR); @@ -545,7 +556,7 @@ TclSetBgErrorHandler( * First access: initialize. */ - assocPtr = (ErrAssocData*)Tcl_Alloc(sizeof(ErrAssocData)); + assocPtr = (ErrAssocData*)ckalloc(sizeof(ErrAssocData)); assocPtr->interp = interp; assocPtr->cmdPrefix = NULL; assocPtr->firstBgPtr = NULL; @@ -624,7 +635,7 @@ BgErrorDeleteProc( assocPtr->firstBgPtr = errPtr->nextPtr; Tcl_DecrRefCount(errPtr->errorMsg); Tcl_DecrRefCount(errPtr->returnOpts); - Tcl_Free(errPtr); + ckfree(errPtr); } Tcl_CancelIdleCall(HandleBgErrors, assocPtr); Tcl_DecrRefCount(assocPtr->cmdPrefix); @@ -654,7 +665,7 @@ Tcl_CreateExitHandler( Tcl_ExitProc *proc, /* Function to invoke. */ void *clientData) /* Arbitrary value to pass to proc. */ { - ExitHandler *exitPtr = (ExitHandler*)Tcl_Alloc(sizeof(ExitHandler)); + ExitHandler *exitPtr = (ExitHandler*)ckalloc(sizeof(ExitHandler)); exitPtr->proc = proc; exitPtr->clientData = clientData; @@ -687,7 +698,7 @@ TclCreateLateExitHandler( Tcl_ExitProc *proc, /* Function to invoke. */ void *clientData) /* Arbitrary value to pass to proc. */ { - ExitHandler *exitPtr = (ExitHandler*)Tcl_Alloc(sizeof(ExitHandler)); + ExitHandler *exitPtr = (ExitHandler*)ckalloc(sizeof(ExitHandler)); exitPtr->proc = proc; exitPtr->clientData = clientData; @@ -732,7 +743,7 @@ Tcl_DeleteExitHandler( } else { prevPtr->nextPtr = exitPtr->nextPtr; } - Tcl_Free(exitPtr); + ckfree(exitPtr); break; } } @@ -775,7 +786,7 @@ TclDeleteLateExitHandler( } else { prevPtr->nextPtr = exitPtr->nextPtr; } - Tcl_Free(exitPtr); + ckfree(exitPtr); break; } } @@ -809,7 +820,7 @@ Tcl_CreateThreadExitHandler( ExitHandler *exitPtr; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - exitPtr = (ExitHandler*)Tcl_Alloc(sizeof(ExitHandler)); + exitPtr = (ExitHandler*)ckalloc(sizeof(ExitHandler)); exitPtr->proc = proc; exitPtr->clientData = clientData; exitPtr->nextPtr = tsdPtr->firstExitPtr; @@ -851,7 +862,7 @@ Tcl_DeleteThreadExitHandler( } else { prevPtr->nextPtr = exitPtr->nextPtr; } - Tcl_Free(exitPtr); + ckfree(exitPtr); return; } } @@ -929,7 +940,7 @@ InvokeExitHandlers(void) firstExitPtr = exitPtr->nextPtr; Tcl_MutexUnlock(&exitMutex); exitPtr->proc(exitPtr->clientData); - Tcl_Free(exitPtr); + ckfree(exitPtr); Tcl_MutexLock(&exitMutex); } firstExitPtr = NULL; @@ -1236,7 +1247,7 @@ Tcl_Finalize(void) firstLateExitPtr = exitPtr->nextPtr; Tcl_MutexUnlock(&exitMutex); exitPtr->proc(exitPtr->clientData); - Tcl_Free(exitPtr); + ckfree(exitPtr); Tcl_MutexLock(&exitMutex); } firstLateExitPtr = NULL; @@ -1347,7 +1358,7 @@ Tcl_Finalize(void) TclResetFilesystem(); /* - * At this point, there should no longer be any Tcl_Alloc'ed memory. + * At this point, there should no longer be any ckalloc'ed memory. */ TclFinalizeMemorySubsystem(); @@ -1406,7 +1417,7 @@ FinalizeThread( tsdPtr->firstExitPtr = exitPtr->nextPtr; exitPtr->proc(exitPtr->clientData); - Tcl_Free(exitPtr); + ckfree(exitPtr); } TclFinalizeIOSubsystem(); TclFinalizeNotifier(); @@ -1518,7 +1529,7 @@ Tcl_VwaitObjCmd( OPT_TIMEOUT, OPT_VARIABLE, OPT_WRITABLE, OPT_LAST } index; - if ((objc == 2) && (strcmp(Tcl_GetString(objv[1]), "--") != 0)) { + if ((objc == 2) && (strcmp(TclGetString(objv[1]), "--") != 0)) { /* * Legacy "vwait" syntax, skip option handling. */ @@ -1527,7 +1538,7 @@ Tcl_VwaitObjCmd( } if ((unsigned) objc - 1 > sizeof(localItems) / sizeof(localItems[0])) { - vwaitItems = (VwaitItem *) Tcl_Alloc(sizeof(VwaitItem) * (objc - 1)); + vwaitItems = (VwaitItem *) ckalloc(sizeof(VwaitItem) * (objc - 1)); } for (i = 1; i < objc; i++) { @@ -1592,8 +1603,8 @@ Tcl_VwaitObjCmd( goto needArg; } result = Tcl_TraceVar2(interp, TclGetString(objv[i]), NULL, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - VwaitVarProc, &vwaitItems[numItems]); + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + VwaitVarProc, &vwaitItems[numItems]); if (result != TCL_OK) { goto done; } @@ -1608,7 +1619,7 @@ Tcl_VwaitObjCmd( goto needArg; } if (TclGetChannelFromObj(interp, objv[i], &chan, &mode, 0) - != TCL_OK) { + != TCL_OK) { result = TCL_ERROR; goto done; } @@ -1632,7 +1643,7 @@ Tcl_VwaitObjCmd( goto needArg; } if (TclGetChannelFromObj(interp, objv[i], &chan, &mode, 0) - != TCL_OK) { + != TCL_OK) { result = TCL_ERROR; goto done; } @@ -1656,7 +1667,7 @@ Tcl_VwaitObjCmd( endOfOptionLoop: if ((mask & (TCL_FILE_EVENTS | TCL_IDLE_EVENTS | - TCL_TIMER_EVENTS | TCL_WINDOW_EVENTS)) == 0) { + TCL_TIMER_EVENTS | TCL_WINDOW_EVENTS)) == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "can't wait: would block forever", -1)); Tcl_SetErrorCode(interp, "TCL", "EVENT", "NO_SOURCES", (void *)NULL); @@ -1674,8 +1685,8 @@ Tcl_VwaitObjCmd( for (result = TCL_OK; i < objc; i++) { result = Tcl_TraceVar2(interp, TclGetString(objv[i]), NULL, - TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, - VwaitVarProc, &vwaitItems[numItems]); + TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS, + VwaitVarProc, &vwaitItems[numItems]); if (result != TCL_OK) { break; } @@ -1708,7 +1719,7 @@ Tcl_VwaitObjCmd( vwaitItems[numItems].mask = 0; vwaitItems[numItems].sourceObj = NULL; timer = Tcl_CreateTimerHandler(timeout, VwaitTimeoutProc, - &vwaitItems[numItems]); + &vwaitItems[numItems]); Tcl_GetTime(&before); } else { timeout = 0; @@ -1857,7 +1868,7 @@ Tcl_VwaitObjCmd( result = Tcl_RestoreInterpState(interp, saved); } if (vwaitItems != localItems) { - Tcl_Free(vwaitItems); + ckfree(vwaitItems); } return result; } @@ -1954,7 +1965,8 @@ Tcl_UpdateObjCmd( { int flags = 0; /* Initialized to avoid compiler warning. */ static const char *const updateOptions[] = {"idletasks", NULL}; - enum updateOptionsEnum {OPT_IDLETASKS} optionIndex; + enum updateOptionsEnum {OPT_IDLETASKS}; + int optionIndex; if (objc == 1) { flags = TCL_ALL_EVENTS|TCL_DONT_WAIT; @@ -1963,7 +1975,7 @@ Tcl_UpdateObjCmd( "option", 0, &optionIndex) != TCL_OK) { return TCL_ERROR; } - switch (optionIndex) { + switch ((enum updateOptionsEnum) optionIndex) { case OPT_IDLETASKS: flags = TCL_IDLE_EVENTS|TCL_DONT_WAIT; break; @@ -2022,7 +2034,7 @@ NewThreadProc( threadProc = cdPtr->proc; threadClientData = cdPtr->clientData; - Tcl_Free(clientData); /* Allocated in Tcl_CreateThread() */ + ckfree(clientData); /* Allocated in Tcl_CreateThread() */ threadProc(threadClientData); @@ -2054,19 +2066,19 @@ Tcl_CreateThread( Tcl_ThreadId *idPtr, /* Return, the ID of the thread */ Tcl_ThreadCreateProc *proc, /* Main() function of the thread */ void *clientData, /* The one argument to Main() */ - size_t stackSize, /* Size of stack for the new thread */ + TCL_HASH_TYPE stackSize, /* Size of stack for the new thread */ int flags) /* Flags controlling behaviour of the new * thread. */ { #if TCL_THREADS - ThreadClientData *cdPtr = (ThreadClientData *)Tcl_Alloc(sizeof(ThreadClientData)); + ThreadClientData *cdPtr = (ThreadClientData *)ckalloc(sizeof(ThreadClientData)); int result; cdPtr->proc = proc; cdPtr->clientData = clientData; result = TclpThreadCreate(idPtr, NewThreadProc, cdPtr, stackSize, flags); if (result != TCL_OK) { - Tcl_Free(cdPtr); + ckfree(cdPtr); } return result; #else diff --git a/generic/tclExecute.c b/generic/tclExecute.c index da08f3a..380a0a3 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -77,7 +77,7 @@ int tclTraceExec = 0; */ static const char *const operatorStrings[] = { - "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>", + "||", "&&", "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>", "+", "-", "*", "/", "%", "+", "-", "~", "!" }; @@ -101,6 +101,64 @@ 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 */ + +/* + * Support pre-8.5 bytecodes unless specifically requested otherwise. + */ + +#ifndef TCL_SUPPORT_84_BYTECODE +#define TCL_SUPPORT_84_BYTECODE 1 +#endif + +#if TCL_SUPPORT_84_BYTECODE +/* + * We need to know the tclBuiltinFuncTable to support translation of pre-8.5 + * math functions to the namespace-based ::tcl::mathfunc::op in 8.5+. + */ + +typedef struct { + const char *name; /* Name of function. */ + int numArgs; /* Number of arguments for function. */ +} BuiltinFunc; + +/* + * Table describing the built-in math functions. Entries in this table are + * indexed by the values of the INST_CALL_BUILTIN_FUNC instruction's + * operand byte. + */ + +static BuiltinFunc const tclBuiltinFuncTable[] = { + {"acos", 1}, + {"asin", 1}, + {"atan", 1}, + {"atan2", 2}, + {"ceil", 1}, + {"cos", 1}, + {"cosh", 1}, + {"exp", 1}, + {"floor", 1}, + {"fmod", 2}, + {"hypot", 2}, + {"log", 1}, + {"log10", 1}, + {"pow", 2}, + {"sin", 1}, + {"sinh", 1}, + {"sqrt", 1}, + {"tan", 1}, + {"tanh", 1}, + {"abs", 1}, + {"double", 1}, + {"int", 1}, + {"rand", 0}, + {"round", 1}, + {"srand", 1}, + {"wide", 1}, + {NULL, 0}, +}; + +#define LAST_BUILTIN_FUNC 25 +#endif /* * NR_TEBC @@ -361,9 +419,9 @@ VarHashCreateVar( #define OBJ_AT_TOS *tosPtr -#define OBJ_UNDER_TOS tosPtr[-1] +#define OBJ_UNDER_TOS *(tosPtr-1) -#define OBJ_AT_DEPTH(n) tosPtr[-(n)] +#define OBJ_AT_DEPTH(n) *(tosPtr-(n)) #define CURR_DEPTH (tosPtr - initTosPtr) @@ -379,8 +437,8 @@ VarHashCreateVar( # define TRACE(a) \ while (traceInstructions) { \ fprintf(stdout, "%2" TCL_SIZE_MODIFIER "d: %2" TCL_T_MODIFIER "d (%" TCL_T_MODIFIER "d) %s ", iPtr->numLevels, \ - CURR_DEPTH, \ - (pc - codePtr->codeStart), \ + CURR_DEPTH, \ + (pc - codePtr->codeStart), \ GetOpcodeName(pc)); \ printf a; \ break; \ @@ -395,8 +453,8 @@ VarHashCreateVar( # define TRACE_WITH_OBJ(a, objPtr) \ while (traceInstructions) { \ fprintf(stdout, "%2" TCL_SIZE_MODIFIER "d: %2" TCL_T_MODIFIER "d (%" TCL_T_MODIFIER "d) %s ", iPtr->numLevels, \ - CURR_DEPTH, \ - (pc - codePtr->codeStart), \ + CURR_DEPTH, \ + (pc - codePtr->codeStart), \ GetOpcodeName(pc)); \ printf a; \ TclPrintObject(stdout, objPtr, 30); \ @@ -450,15 +508,15 @@ VarHashCreateVar( */ #define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \ - ((TclHasInternalRep((objPtr), &tclIntType)) \ + ((TclHasInternalRep((objPtr), &tclIntType)) \ ? (*(tPtr) = TCL_NUMBER_INT, \ - *(ptrPtr) = (void *) \ + *(ptrPtr) = (void *) \ (&((objPtr)->internalRep.wideValue)), TCL_OK) : \ TclHasInternalRep((objPtr), &tclDoubleType) \ ? (((isnan((objPtr)->internalRep.doubleValue)) \ ? (*(tPtr) = TCL_NUMBER_NAN) \ : (*(tPtr) = TCL_NUMBER_DOUBLE)), \ - *(ptrPtr) = (void *) \ + *(ptrPtr) = (void *) \ (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \ (((objPtr)->bytes != NULL) && ((objPtr)->length == 0)) \ ? TCL_ERROR : \ @@ -635,7 +693,7 @@ static ExceptionRange * GetExceptRangeForPc(const unsigned char *pc, static const char * GetSrcInfoForPc(const unsigned char *pc, ByteCode *codePtr, Tcl_Size *lengthPtr, const unsigned char **pcBeg, Tcl_Size *cmdIdxPtr); -static Tcl_Obj ** GrowEvaluationStack(ExecEnv *eePtr, size_t growth, +static Tcl_Obj ** GrowEvaluationStack(ExecEnv *eePtr, TCL_HASH_TYPE growth, int move); static void IllegalExprOperandType(Tcl_Interp *interp, const unsigned char *pc, Tcl_Obj *opndPtr); @@ -643,8 +701,8 @@ static void InitByteCodeExecution(Tcl_Interp *interp); static inline int wordSkip(void *ptr); static void ReleaseDictIterator(Tcl_Obj *objPtr); /* Useful elsewhere, make available in tclInt.h or stubs? */ -static Tcl_Obj ** StackAllocWords(Tcl_Interp *interp, size_t numWords); -static Tcl_Obj ** StackReallocWords(Tcl_Interp *interp, size_t numWords); +static Tcl_Obj ** StackAllocWords(Tcl_Interp *interp, TCL_HASH_TYPE numWords); +static Tcl_Obj ** StackReallocWords(Tcl_Interp *interp, TCL_HASH_TYPE numWords); static Tcl_NRPostProc CopyCallback; static Tcl_NRPostProc ExprObjCallback; static Tcl_NRPostProc FinalizeOONext; @@ -661,8 +719,7 @@ static const Tcl_ObjType exprCodeType = { FreeExprCodeInternalRep, /* freeIntRepProc */ DupExprCodeInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ - NULL, /* setFromAnyProc */ - TCL_OBJTYPE_V0 + NULL /* setFromAnyProc */ }; /* @@ -673,8 +730,7 @@ static const Tcl_ObjType exprCodeType = { static const Tcl_ObjType dictIteratorType = { "dictIterator", ReleaseDictIterator, - NULL, NULL, NULL, - TCL_OBJTYPE_V0 + NULL, NULL, NULL }; /* @@ -712,7 +768,7 @@ ReleaseDictIterator( searchPtr = (Tcl_DictSearch *)irPtr->twoPtrValue.ptr1; Tcl_DictObjDone(searchPtr); - Tcl_Free(searchPtr); + ckfree(searchPtr); dictPtr = (Tcl_Obj *)irPtr->twoPtrValue.ptr2; TclDecrRefCount(dictPtr); @@ -792,11 +848,11 @@ ExecEnv * TclCreateExecEnv( Tcl_Interp *interp, /* Interpreter for which the execution * environment is being created. */ - size_t size) /* The initial stack size, in number of words + TCL_HASH_TYPE size) /* The initial stack size, in number of words * [sizeof(Tcl_Obj*)] */ { - ExecEnv *eePtr = (ExecEnv *)Tcl_Alloc(sizeof(ExecEnv)); - ExecStack *esPtr = (ExecStack *)Tcl_Alloc(offsetof(ExecStack, stackWords) + ExecEnv *eePtr = (ExecEnv *)ckalloc(sizeof(ExecEnv)); + ExecStack *esPtr = (ExecStack *)ckalloc(offsetof(ExecStack, stackWords) + size * sizeof(Tcl_Obj *)); eePtr->execStackPtr = esPtr; @@ -856,7 +912,7 @@ DeleteExecStack( if (esPtr->nextPtr) { esPtr->nextPtr->prevPtr = esPtr->prevPtr; } - Tcl_Free(esPtr); + ckfree(esPtr); } void @@ -888,7 +944,7 @@ TclDeleteExecEnv( if (eePtr->corPtr && !cachedInExit) { Tcl_Panic("Deleting execEnv with existing coroutine"); } - Tcl_Free(eePtr); + ckfree(eePtr); } /* @@ -974,13 +1030,12 @@ static Tcl_Obj ** GrowEvaluationStack( ExecEnv *eePtr, /* Points to the ExecEnv with an evaluation * stack to enlarge. */ - size_t growth1, /* How much larger than the current used + TCL_HASH_TYPE growth, /* How much larger than the current used * size. */ int move) /* 1 if move words since last marker. */ { ExecStack *esPtr = eePtr->execStackPtr, *oldPtr = NULL; - size_t newBytes; - Tcl_Size growth = growth1; + TCL_HASH_TYPE newBytes; Tcl_Size newElems, currElems, needed = growth - (esPtr->endPtr - esPtr->tosPtr); Tcl_Obj **markerPtr = esPtr->markerPtr, **memStart; Tcl_Size moveWords = 0; @@ -1066,7 +1121,7 @@ GrowEvaluationStack( newBytes = offsetof(ExecStack, stackWords) + newElems * sizeof(Tcl_Obj *); oldPtr = esPtr; - esPtr = (ExecStack *)Tcl_Alloc(newBytes); + esPtr = (ExecStack *)ckalloc(newBytes); oldPtr->nextPtr = esPtr; esPtr->prevPtr = oldPtr; @@ -1126,7 +1181,7 @@ GrowEvaluationStack( static Tcl_Obj ** StackAllocWords( Tcl_Interp *interp, - size_t numWords) + TCL_HASH_TYPE numWords) { /* * Note that GrowEvaluationStack sets a marker in the stack. This marker @@ -1144,7 +1199,7 @@ StackAllocWords( static Tcl_Obj ** StackReallocWords( Tcl_Interp *interp, - size_t numWords) + TCL_HASH_TYPE numWords) { Interp *iPtr = (Interp *) interp; ExecEnv *eePtr = iPtr->execEnvPtr; @@ -1165,7 +1220,7 @@ TclStackFree( Tcl_Obj **markerPtr, *marker; if (iPtr == NULL || iPtr->execEnvPtr == NULL) { - Tcl_Free(freePtr); + ckfree(freePtr); return; } @@ -1223,13 +1278,13 @@ TclStackFree( void * TclStackAlloc( Tcl_Interp *interp, - size_t numBytes) + TCL_HASH_TYPE numBytes) { Interp *iPtr = (Interp *) interp; - size_t numWords; + TCL_HASH_TYPE numWords; if (iPtr == NULL || iPtr->execEnvPtr == NULL) { - return Tcl_Alloc(numBytes); + return ckalloc(numBytes); } numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *); return StackAllocWords(interp, numWords); @@ -1239,16 +1294,16 @@ void * TclStackRealloc( Tcl_Interp *interp, void *ptr, - size_t numBytes) + TCL_HASH_TYPE numBytes) { Interp *iPtr = (Interp *) interp; ExecEnv *eePtr; ExecStack *esPtr; Tcl_Obj **markerPtr; - size_t numWords; + TCL_HASH_TYPE numWords; if (iPtr == NULL || iPtr->execEnvPtr == NULL) { - return Tcl_Realloc(ptr, numBytes); + return ckrealloc((char *)ptr, numBytes); } eePtr = iPtr->execEnvPtr; @@ -1847,7 +1902,7 @@ ArgumentBCEnter( ByteCode *codePtr, TEBCdata *tdPtr, const unsigned char *pc, - int objc, + Tcl_Size objc, Tcl_Obj **objv) { Tcl_Size cmd; @@ -1888,10 +1943,10 @@ TclNRExecuteByteCode( { Interp *iPtr = (Interp *) interp; TEBCdata *TD; - size_t size = sizeof(TEBCdata) - 1 + TCL_HASH_TYPE size = sizeof(TEBCdata) - 1 + (codePtr->maxStackDepth + codePtr->maxExceptDepth) * sizeof(void *); - size_t numWords = (size + sizeof(Tcl_Obj *) - 1) / sizeof(Tcl_Obj *); + TCL_HASH_TYPE numWords = (size + sizeof(Tcl_Obj *) - 1) / sizeof(Tcl_Obj *); TclPreserveByteCode(codePtr); @@ -2281,7 +2336,7 @@ TEBCresume( goto instLoadScalar1; } else if (inst == INST_PUSH1) { PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]); - TRACE_WITH_OBJ(("%u => ", TclGetUInt1AtPtr(pc + 1)), OBJ_AT_TOS); + TRACE_WITH_OBJ(("%u => ", TclGetUInt1AtPtr(pc+1)), OBJ_AT_TOS); inst = *(pc += 2); goto peepholeStart; } else if (inst == INST_START_CMD) { @@ -2289,11 +2344,11 @@ TEBCresume( * Peephole: do not run INST_START_CMD, just skip it */ - iPtr->cmdCount += TclGetUInt4AtPtr(pc + 5); + iPtr->cmdCount += TclGetUInt4AtPtr(pc+5); if (checkInterp) { if (((codePtr->compileEpoch != iPtr->compileEpoch) || - (codePtr->nsEpoch != iPtr->varFramePtr->nsPtr->resolverEpoch)) && - !(codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { + (codePtr->nsEpoch != iPtr->varFramePtr->nsPtr->resolverEpoch)) && + !(codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { goto instStartCmdFailed; } checkInterp = 0; @@ -2598,16 +2653,13 @@ TEBCresume( case INST_STR_CONCAT1: opnd = TclGetUInt1AtPtr(pc+1); - DECACHE_STACK_INFO(); objResultPtr = TclStringCat(interp, opnd, &OBJ_AT_DEPTH(opnd-1), TCL_STRING_IN_PLACE); if (objResultPtr == NULL) { - CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; } - CACHE_STACK_INFO(); TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); NEXT_INST_V(2, opnd, 1); break; @@ -2631,7 +2683,7 @@ TEBCresume( * command starts. * * Use a Tcl_Obj as linked list element; slight mem waste, but faster - * allocation than Tcl_Alloc. This also abuses the Tcl_Obj structure, as + * allocation than ckalloc. This also abuses the Tcl_Obj structure, as * we do not define a special tclObjType for it. It is not dangerous * as the obj is never passed anywhere, so that all manipulations are * performed here and in INST_INVOKE_EXPANDED (in case of an expansion @@ -2666,7 +2718,7 @@ TEBCresume( case INST_EXPAND_STKTOP: { Tcl_Size i; TEBCdata *newTD; - Tcl_Size oldCatchTopOff, oldTosPtrOff; + ptrdiff_t oldCatchTopOff, oldTosPtrOff; /* * Make sure that the element at stackTop is a list; if not, just @@ -2827,12 +2879,93 @@ TEBCresume( pc += pcAdjustment; TEBC_YIELD(); - if (objc > INT_MAX) { - return TclCommandWordLimitError(interp, objc); - } else { - return TclNREvalObjv(interp, objc, objv, + return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NOERR | TCL_EVAL_SOURCE_IN_FRAME, NULL); + +#if TCL_SUPPORT_84_BYTECODE + case INST_CALL_BUILTIN_FUNC1: + /* + * Call one of the built-in pre-8.5 Tcl math functions. This + * translates to INST_INVOKE_STK1 with the first argument of + * ::tcl::mathfunc::$objv[0]. We need to insert the named math + * function into the stack. + */ + + opnd = TclGetUInt1AtPtr(pc+1); + if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) { + TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd)); + Tcl_Panic("TclNRExecuteByteCode: unrecognized builtin function code %d", opnd); + } + + TclNewLiteralStringObj(objPtr, "::tcl::mathfunc::"); + Tcl_AppendToObj(objPtr, tclBuiltinFuncTable[opnd].name, -1); + + /* + * Only 0, 1 or 2 args. + */ + + { + int numArgs = tclBuiltinFuncTable[opnd].numArgs; + Tcl_Obj *tmpPtr1, *tmpPtr2; + + if (numArgs == 0) { + PUSH_OBJECT(objPtr); + } else if (numArgs == 1) { + tmpPtr1 = POP_OBJECT(); + PUSH_OBJECT(objPtr); + PUSH_OBJECT(tmpPtr1); + Tcl_DecrRefCount(tmpPtr1); + } else { + tmpPtr2 = POP_OBJECT(); + tmpPtr1 = POP_OBJECT(); + PUSH_OBJECT(objPtr); + PUSH_OBJECT(tmpPtr1); + PUSH_OBJECT(tmpPtr2); + Tcl_DecrRefCount(tmpPtr1); + Tcl_DecrRefCount(tmpPtr2); + } + objc = numArgs + 1; } + pcAdjustment = 2; + goto doInvocation; + + case INST_CALL_FUNC1: + /* + * Call a non-builtin Tcl math function previously registered by a + * call to Tcl_CreateMathFunc pre-8.5. This is essentially + * INST_INVOKE_STK1 converting the first arg to + * ::tcl::mathfunc::$objv[0]. + */ + + objc = TclGetUInt1AtPtr(pc+1); /* Number of arguments. The function + * name is the 0-th argument. */ + + objPtr = OBJ_AT_DEPTH(objc-1); + TclNewLiteralStringObj(tmpPtr, "::tcl::mathfunc::"); + Tcl_AppendObjToObj(tmpPtr, objPtr); + Tcl_DecrRefCount(objPtr); + + /* + * Variation of PUSH_OBJECT. + */ + + OBJ_AT_DEPTH(objc-1) = tmpPtr; + Tcl_IncrRefCount(tmpPtr); + + pcAdjustment = 2; + goto doInvocation; +#else + /* + * INST_CALL_BUILTIN_FUNC1 and INST_CALL_FUNC1 were made obsolete by the + * changes to add a ::tcl::mathfunc namespace in 8.5. Optional support + * remains for existing bytecode precompiled files. + */ + + case INST_CALL_BUILTIN_FUNC1: + Tcl_Panic("TclNRExecuteByteCode: obsolete INST_CALL_BUILTIN_FUNC1 found"); + case INST_CALL_FUNC1: + Tcl_Panic("TclNRExecuteByteCode: obsolete INST_CALL_FUNC1 found"); +#endif case INST_INVOKE_REPLACE: objc = TclGetUInt4AtPtr(pc+1); @@ -2846,10 +2979,10 @@ TEBCresume( if (traceInstructions) { strncpy(cmdNameBuf, TclGetString(objv[0]), 20); - TRACE(("%" TCL_Z_MODIFIER "u => call (implementation %s) ", objc, O2S(objPtr))); + TRACE(("%" TCL_SIZE_MODIFIER "d => call (implementation %s) ", objc, O2S(objPtr))); } else { fprintf(stdout, - "%" TCL_Z_MODIFIER "d: (%" TCL_T_MODIFIER "u) invoking (using implementation %s) ", + "%" TCL_SIZE_MODIFIER "d: (%" TCL_T_MODIFIER "d) invoking (using implementation %s) ", iPtr->numLevels, (pc - codePtr->codeStart), O2S(objPtr)); } @@ -3123,7 +3256,7 @@ TEBCresume( objResultPtr = OBJ_AT_TOS; varPtr->value.objPtr = objResultPtr; #ifndef TCL_COMPILE_DEBUG - if (pc[pcAdjustment] == INST_POP) { + if (*(pc+pcAdjustment) == INST_POP) { tosPtr--; NEXT_INST_F((pcAdjustment+1), 0, 0); } @@ -3287,7 +3420,7 @@ TEBCresume( goto gotError; } #ifndef TCL_COMPILE_DEBUG - if (pc[pcAdjustment] == INST_POP) { + if (*(pc+pcAdjustment) == INST_POP) { NEXT_INST_V((pcAdjustment+1), cleanup, 0); } #endif @@ -3686,7 +3819,7 @@ TEBCresume( doneIncr: TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); #ifndef TCL_COMPILE_DEBUG - if (pc[pcAdjustment] == INST_POP) { + if (*(pc+pcAdjustment) == INST_POP) { NEXT_INST_V((pcAdjustment+1), cleanup, 0); } #endif @@ -3920,82 +4053,34 @@ TEBCresume( CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; - } - break; - /* - * End of INST_UNSET instructions. - * ----------------------------------------------------------------- - * Start of INST_CONST instructions. - */ - { - const char *msgPart; + /* + * This is really an unset operation these days. Do not issue. + */ - case INST_CONST_IMM: + case INST_DICT_DONE: opnd = TclGetUInt4AtPtr(pc+1); - pcAdjustment = 5; - cleanup = 1; - part1Ptr = NULL; - objPtr = OBJ_AT_TOS; - TRACE(("%u \"%.30s\" => \n", opnd, O2S(objPtr))); + TRACE(("%u => OK\n", opnd)); varPtr = LOCAL(opnd); - arrayPtr = NULL; while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; } - goto doConst; - case INST_CONST_STK: - opnd = -1; - pcAdjustment = 1; - cleanup = 2; - part1Ptr = OBJ_UNDER_TOS; - objPtr = OBJ_AT_TOS; - TRACE(("\"%.30s\" \"%.30s\" => ", O2S(part1Ptr), O2S(objPtr))); - varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, 0, NULL, - /*createPart1*/1, /*createPart2*/0, &arrayPtr); - doConst: - if (TclIsVarConstant(varPtr)) { - TRACE_APPEND(("\n")); - NEXT_INST_V(pcAdjustment, cleanup, 0); - } - if (TclIsVarArray(varPtr)) { - msgPart = "variable is array"; - goto constError; - } else if (TclIsVarArrayElement(varPtr)) { - msgPart = "name refers to an element in an array"; - goto constError; - } else if (!TclIsVarUndefined(varPtr)) { - msgPart = "variable already exists"; - goto constError; - } - if (TclIsVarDirectModifyable(varPtr)) { - varPtr->value.objPtr = objPtr; - Tcl_IncrRefCount(objPtr); + if (TclIsVarDirectUnsettable(varPtr) && !TclIsVarInHash(varPtr)) { + if (!TclIsVarUndefined(varPtr)) { + TclDecrRefCount(varPtr->value.objPtr); + } + varPtr->value.objPtr = NULL; } else { - Tcl_Obj *resPtr; - DECACHE_STACK_INFO(); - resPtr = TclPtrSetVarIdx(interp, varPtr, arrayPtr, part1Ptr, NULL, - objPtr, TCL_LEAVE_ERR_MSG, opnd); + TclPtrUnsetVarIdx(interp, varPtr, NULL, NULL, NULL, 0, opnd); CACHE_STACK_INFO(); - if (resPtr == NULL) { - TRACE_ERROR(interp); - goto gotError; - } } - TclSetVarConstant(varPtr); - TRACE_APPEND(("\n")); - NEXT_INST_V(pcAdjustment, cleanup, 0); - - constError: - TclObjVarErrMsg(interp, part1Ptr, NULL, "make constant", msgPart, opnd); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONST", (void *)NULL); - TRACE_ERROR(interp); - goto gotError; + NEXT_INST_F(5, 0, 0); } + break; /* - * End of INST_CONST instructions. + * End of INST_UNSET instructions. * ----------------------------------------------------------------- * Start of INST_ARRAY instructions. */ @@ -4314,6 +4399,51 @@ TEBCresume( break; /* + * These two instructions are now redundant: the complete logic of the LOR + * and LAND is now handled by the expression compiler. + */ + + case INST_LOR: + case INST_LAND: { + /* + * Operands must be boolean or numeric. No int->double conversions are + * performed. + */ + + int i1, i2, iResult; + + value2Ptr = OBJ_AT_TOS; + valuePtr = OBJ_UNDER_TOS; + if (TclGetBooleanFromObj(NULL, valuePtr, &i1) != TCL_OK) { + TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), + (valuePtr->typePtr? valuePtr->typePtr->name : "null"))); + DECACHE_STACK_INFO(); + IllegalExprOperandType(interp, pc, valuePtr); + CACHE_STACK_INFO(); + goto gotError; + } + + if (TclGetBooleanFromObj(NULL, value2Ptr, &i2) != TCL_OK) { + TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(value2Ptr), + (value2Ptr->typePtr? value2Ptr->typePtr->name : "null"))); + DECACHE_STACK_INFO(); + IllegalExprOperandType(interp, pc, value2Ptr); + CACHE_STACK_INFO(); + goto gotError; + } + + if (*pc == INST_LOR) { + iResult = (i1 || i2); + } else { + iResult = (i1 && i2); + } + objResultPtr = TCONST(iResult); + TRACE(("%.20s %.20s => %d\n", O2S(valuePtr),O2S(value2Ptr),iResult)); + NEXT_INST_F(1, 2, 1); + } + break; + + /* * ----------------------------------------------------------------- * Start of general introspector instructions. */ @@ -4344,7 +4474,7 @@ TEBCresume( } break; case INST_INFO_LEVEL_NUM: - TclNewIntObj(objResultPtr, (int)iPtr->varFramePtr->level); + TclNewIntObj(objResultPtr, iPtr->varFramePtr->level); TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(1, 0, 1); break; @@ -4361,7 +4491,7 @@ TEBCresume( if (level <= 0) { level += framePtr->level; } - for (; ((int)framePtr->level!=level) && (framePtr!=rootFramePtr) ; + for (; (framePtr->level!=level) && (framePtr!=rootFramePtr) ; framePtr = framePtr->callerVarPtr) { /* Empty loop body */ } @@ -4607,7 +4737,7 @@ TEBCresume( strncpy(cmdNameBuf, TclGetString(objv[0]), 20); } else { fprintf(stdout, "%" TCL_SIZE_MODIFIER "d: (%" TCL_Z_MODIFIER "u) invoking ", - iPtr->numLevels, (pc - codePtr->codeStart)); + iPtr->numLevels, (size_t)(pc - codePtr->codeStart)); } for (i = 0; i < opnd; i++) { TclPrintObject(stdout, objv[i], 15); @@ -4657,11 +4787,7 @@ TEBCresume( Method *const mPtr = contextPtr->callPtr->chain[newDepth].mPtr; - if (mPtr->typePtr->version < TCL_OO_METHOD_VERSION_2) { - return mPtr->typePtr->callProc(mPtr->clientData, interp, - (Tcl_ObjectContext) contextPtr, opnd, objv); - } - return ((Tcl_MethodCallProc2 *)(void *)(mPtr->typePtr->callProc))(mPtr->clientData, interp, + return mPtr->typePtr->callProc(mPtr->clientData, interp, (Tcl_ObjectContext) contextPtr, opnd, objv); } @@ -4704,7 +4830,7 @@ TEBCresume( { int numIndices, nocase, match, cflags; - Tcl_Size slength, length2, fromIdx, toIdx, index, s1len, s2len; + Tcl_Size length2, fromIdx, toIdx, index, s1len, s2len; const char *s1, *s2; case INST_LIST: @@ -4733,25 +4859,21 @@ TEBCresume( valuePtr = OBJ_UNDER_TOS; TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr))); - /* special case for AbstractList */ - if (TclObjTypeHasProc(valuePtr,indexProc)) { - DECACHE_STACK_INFO(); - length = TclObjTypeLength(valuePtr); + + /* special case for ArithSeries */ + if (TclHasInternalRep(valuePtr,&tclArithSeriesType)) { + length = TclArithSeriesObjLength(valuePtr); if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) { CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; } - if (TclObjTypeIndex(interp, valuePtr, index, &objResultPtr)!=TCL_OK) { + objResultPtr = TclArithSeriesObjIndex(interp, valuePtr, index); + if (objResultPtr == NULL) { CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; } - CACHE_STACK_INFO(); - if (objResultPtr == NULL) { - /* Index is out of range, return empty result. */ - TclNewObj(objResultPtr); - } Tcl_IncrRefCount(objResultPtr); // reference held here goto lindexDone; } @@ -4760,35 +4882,20 @@ TEBCresume( * Extract the desired list element. */ - { - Tcl_Size value2Length; - Tcl_Obj *indexListPtr = value2Ptr; - - if ((TclListObjGetElements(interp, valuePtr, &objc, &objv) == TCL_OK) - && (!TclHasInternalRep(value2Ptr, &tclListType) - || (Tcl_ListObjLength(interp, value2Ptr, &value2Length), - value2Length == 1 - ? (indexListPtr = TclListObjGetElement(value2Ptr, 0), 1) - : 0))) { - int code; - - /* increment the refCount of value2Ptr because TclListObjGetElement may - * have just extracted it from a list in the condition for this block. - */ - Tcl_IncrRefCount(indexListPtr); + if ((TclListObjGetElements(interp, valuePtr, &objc, &objv) == TCL_OK) + && !TclHasInternalRep(value2Ptr, &tclListType)) { + int code; - DECACHE_STACK_INFO(); - code = TclGetIntForIndexM(interp, indexListPtr, objc-1, &index); - TclDecrRefCount(indexListPtr); - CACHE_STACK_INFO(); - if (code == TCL_OK) { - Tcl_DecrRefCount(value2Ptr); - tosPtr--; - pcAdjustment = 1; - goto lindexFastPath; - } - Tcl_ResetResult(interp); + DECACHE_STACK_INFO(); + code = TclGetIntForIndexM(interp, value2Ptr, objc-1, &index); + CACHE_STACK_INFO(); + if (code == TCL_OK) { + TclDecrRefCount(value2Ptr); + tosPtr--; + pcAdjustment = 1; + goto lindexFastPath; } + Tcl_ResetResult(interp); } DECACHE_STACK_INFO(); @@ -4819,36 +4926,34 @@ TEBCresume( opnd = TclGetInt4AtPtr(pc+1); TRACE(("\"%.30s\" %d => ", O2S(valuePtr), opnd)); - /* - * Get the contents of the list, making sure that it really is a list - * in the process. - */ - - /* special case for AbstractList */ - if (TclObjTypeHasProc(valuePtr,indexProc)) { - length = TclObjTypeLength(valuePtr); + /* special case for ArithSeries */ + if (TclHasInternalRep(valuePtr,&tclArithSeriesType)) { + length = TclArithSeriesObjLength(valuePtr); /* Decode end-offset index values. */ + index = TclIndexDecode(opnd, length-1); + /* Compute value @ index */ if (index >= 0 && index < length) { - /* Compute value @ index */ - DECACHE_STACK_INFO(); - if (TclObjTypeIndex(interp, valuePtr, index, &objResultPtr)!=TCL_OK) { + objResultPtr = TclArithSeriesObjIndex(interp, valuePtr, index); + if (objResultPtr == NULL) { CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; } - CACHE_STACK_INFO(); } else { TclNewObj(objResultPtr); } - pcAdjustment = 5; goto lindexFastPath2; } - /* List case */ + /* + * Get the contents of the list, making sure that it really is a list + * in the process. + */ + if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) { TRACE_ERROR(interp); goto gotError; @@ -4921,17 +5026,9 @@ TEBCresume( * Compute the new variable value. */ - DECACHE_STACK_INFO(); - if (TclObjTypeHasProc(valuePtr, setElementProc)) { - objResultPtr = TclObjTypeSetElement(interp, - valuePtr, numIndices, - &OBJ_AT_DEPTH(numIndices), OBJ_AT_TOS); - } else { - objResultPtr = TclLsetFlat(interp, valuePtr, numIndices, + objResultPtr = TclLsetFlat(interp, valuePtr, numIndices, &OBJ_AT_DEPTH(numIndices), OBJ_AT_TOS); - } if (!objResultPtr) { - CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; } @@ -4939,7 +5036,7 @@ TEBCresume( /* * Set result. */ - CACHE_STACK_INFO(); + TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); NEXT_INST_V(5, numIndices+1, -1); @@ -5009,7 +5106,7 @@ TEBCresume( */ #ifndef TCL_COMPILE_DEBUG - if (pc[9] == INST_POP) { + if (*(pc+9) == INST_POP) { NEXT_INST_F(10, 1, 0); } #endif @@ -5033,7 +5130,7 @@ TEBCresume( NEXT_INST_F(9, 1, 1); } toIdx = TclIndexDecode(toIdx, objc - 1); - if (toIdx == TCL_INDEX_NONE) { + if (toIdx < 0) { goto emptyList; } else if (toIdx >= objc) { toIdx = objc - 1; @@ -5051,21 +5148,16 @@ TEBCresume( fromIdx = TclIndexDecode(fromIdx, objc - 1); - DECACHE_STACK_INFO(); - if (TclObjTypeHasProc(valuePtr, sliceProc)) { - if (TclObjTypeSlice(interp, valuePtr, fromIdx, toIdx, &objResultPtr) != TCL_OK) { - objResultPtr = NULL; - } + if (TclHasInternalRep(valuePtr,&tclArithSeriesType)) { + objResultPtr = TclArithSeriesObjRange(interp, valuePtr, fromIdx, toIdx); } else { objResultPtr = TclListObjRange(interp, valuePtr, fromIdx, toIdx); } if (objResultPtr == NULL) { - CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; } - CACHE_STACK_INFO(); TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr))); NEXT_INST_F(9, 1, 1); @@ -5074,60 +5166,42 @@ TEBCresume( value2Ptr = OBJ_AT_TOS; valuePtr = OBJ_UNDER_TOS; - s1 = TclGetStringFromObj(valuePtr, &s1len); - TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr))); - - if (TclObjTypeHasProc(value2Ptr,inOperProc) != NULL) { - int status = TclObjTypeInOperator(interp, valuePtr, value2Ptr, &match); - if (status != TCL_OK) { - TRACE_ERROR(interp); - goto gotError; - } - } else { - - if (TclListObjLength(interp, value2Ptr, &length) != TCL_OK) { - TRACE_ERROR(interp); - goto gotError; - } - match = 0; - if (length > 0) { - Tcl_Size i = 0; - Tcl_Obj *o; - int isAbstractList = TclObjTypeHasProc(value2Ptr,indexProc) != NULL; - - /* - * An empty list doesn't match anything. - */ - - do { - if (isAbstractList) { - DECACHE_STACK_INFO(); - if (TclObjTypeIndex(interp, value2Ptr, i, &o) != TCL_OK) { - CACHE_STACK_INFO(); - TRACE_ERROR(interp); - goto gotError; - } - CACHE_STACK_INFO(); - } else { - Tcl_ListObjIndex(NULL, value2Ptr, i, &o); - } - if (o != NULL) { - s2 = TclGetStringFromObj(o, &s2len); - } else { - s2 = ""; - s2len = 0; - } - if (s1len == s2len) { - match = (memcmp(s1, s2, s1len) == 0); - } - - /* Could be an ephemeral abstract obj */ - Tcl_BounceRefCount(o); - - i++; - } while (i < length && match == 0); - } - } + s1 = TclGetStringFromObj(valuePtr, &s1len); + TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr))); + if (TclListObjLength(interp, value2Ptr, &length) != TCL_OK) { + TRACE_ERROR(interp); + goto gotError; + } + match = 0; + if (length > 0) { + Tcl_Size i = 0; + Tcl_Obj *o; + int isArithSeries = TclHasInternalRep(value2Ptr,&tclArithSeriesType); + /* + * An empty list doesn't match anything. + */ + + do { + if (isArithSeries) { + o = TclArithSeriesObjIndex(NULL, value2Ptr, i); + } else { + Tcl_ListObjIndex(NULL, value2Ptr, i, &o); + } + if (o != NULL) { + s2 = TclGetStringFromObj(o, &s2len); + } else { + s2 = ""; + s2len = 0; + } + if (s1len == s2len) { + match = (memcmp(s1, s2, s1len) == 0); + } + if (isArithSeries) { + TclDecrRefCount(o); + } + i++; + } while (i < length && match == 0); + } if (*pc == INST_LIST_NOT_IN) { match = !match; @@ -5168,7 +5242,7 @@ TEBCresume( case INST_LREPLACE4: { - size_t numToDelete, numNewElems; + TCL_HASH_TYPE numToDelete, numNewElems; int end_indicator; int haveSecondIndex, flags; Tcl_Obj *fromIdxObj, *toIdxObj; @@ -5193,8 +5267,9 @@ TEBCresume( DECACHE_STACK_INFO(); - if (TclGetIntForIndexM(interp, fromIdxObj, length - end_indicator, - &fromIdx) != TCL_OK) { + if (TclGetIntForIndexM( + interp, fromIdxObj, length - end_indicator, &fromIdx) + != TCL_OK) { CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; @@ -5206,19 +5281,18 @@ TEBCresume( } numToDelete = 0; if (toIdxObj) { - if (TclGetIntForIndexM(interp, toIdxObj, length - end_indicator, - &toIdx) != TCL_OK) { + if (TclGetIntForIndexM( + interp, toIdxObj, length - end_indicator, &toIdx) + != TCL_OK) { CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; } - if (toIdx != TCL_INDEX_NONE) { - if (toIdx > length) { - toIdx = length; - } - if (toIdx >= fromIdx) { - numToDelete = (size_t)toIdx - (size_t)fromIdx + 1; - } + if (toIdx > length) { + toIdx = length; + } + if (toIdx >= fromIdx) { + numToDelete = (unsigned)toIdx - (unsigned)fromIdx + 1; /* See [3d3124d01d] */ } } @@ -5226,8 +5300,13 @@ TEBCresume( if (Tcl_IsShared(valuePtr)) { objResultPtr = Tcl_DuplicateObj(valuePtr); - if (Tcl_ListObjReplace(interp, objResultPtr, fromIdx, numToDelete, - numNewElems, &OBJ_AT_DEPTH(numNewElems - 1)) != TCL_OK) { + if (Tcl_ListObjReplace(interp, + objResultPtr, + fromIdx, + numToDelete, + numNewElems, + &OBJ_AT_DEPTH(numNewElems - 1)) + != TCL_OK) { TRACE_ERROR(interp); Tcl_DecrRefCount(objResultPtr); goto gotError; @@ -5235,8 +5314,13 @@ TEBCresume( TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); NEXT_INST_V(6, opnd, 1); } else { - if (Tcl_ListObjReplace(interp, valuePtr, fromIdx, numToDelete, - numNewElems, &OBJ_AT_DEPTH(numNewElems - 1)) != TCL_OK) { + if (Tcl_ListObjReplace(interp, + valuePtr, + fromIdx, + numToDelete, + numNewElems, + &OBJ_AT_DEPTH(numNewElems - 1)) + != TCL_OK) { TRACE_ERROR(interp); goto gotError; } @@ -5312,24 +5396,24 @@ TEBCresume( case INST_STR_LEN: valuePtr = OBJ_AT_TOS; - slength = Tcl_GetCharLength(valuePtr); - TclNewIntObj(objResultPtr, slength); - TRACE(("\"%.20s\" => %" TCL_Z_MODIFIER "u\n", O2S(valuePtr), slength)); + length = TclGetCharLength(valuePtr); + TclNewIntObj(objResultPtr, length); + TRACE(("\"%.20s\" => %" TCL_SIZE_MODIFIER "d\n", O2S(valuePtr), length)); NEXT_INST_F(1, 1, 1); case INST_STR_UPPER: valuePtr = OBJ_AT_TOS; TRACE(("\"%.20s\" => ", O2S(valuePtr))); if (Tcl_IsShared(valuePtr)) { - s1 = TclGetStringFromObj(valuePtr, &slength); - TclNewStringObj(objResultPtr, s1, slength); - slength = Tcl_UtfToUpper(TclGetString(objResultPtr)); - Tcl_SetObjLength(objResultPtr, slength); + s1 = TclGetStringFromObj(valuePtr, &length); + TclNewStringObj(objResultPtr, s1, length); + length = Tcl_UtfToUpper(TclGetString(objResultPtr)); + Tcl_SetObjLength(objResultPtr, length); TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } else { - slength = Tcl_UtfToUpper(TclGetString(valuePtr)); - Tcl_SetObjLength(valuePtr, slength); + length = Tcl_UtfToUpper(TclGetString(valuePtr)); + Tcl_SetObjLength(valuePtr, length); TclFreeInternalRep(valuePtr); TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); @@ -5338,15 +5422,15 @@ TEBCresume( valuePtr = OBJ_AT_TOS; TRACE(("\"%.20s\" => ", O2S(valuePtr))); if (Tcl_IsShared(valuePtr)) { - s1 = TclGetStringFromObj(valuePtr, &slength); - TclNewStringObj(objResultPtr, s1, slength); - slength = Tcl_UtfToLower(TclGetString(objResultPtr)); - Tcl_SetObjLength(objResultPtr, slength); + s1 = TclGetStringFromObj(valuePtr, &length); + TclNewStringObj(objResultPtr, s1, length); + length = Tcl_UtfToLower(TclGetString(objResultPtr)); + Tcl_SetObjLength(objResultPtr, length); TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } else { - slength = Tcl_UtfToLower(TclGetString(valuePtr)); - Tcl_SetObjLength(valuePtr, slength); + length = Tcl_UtfToLower(TclGetString(valuePtr)); + Tcl_SetObjLength(valuePtr, length); TclFreeInternalRep(valuePtr); TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); @@ -5355,15 +5439,15 @@ TEBCresume( valuePtr = OBJ_AT_TOS; TRACE(("\"%.20s\" => ", O2S(valuePtr))); if (Tcl_IsShared(valuePtr)) { - s1 = TclGetStringFromObj(valuePtr, &slength); - TclNewStringObj(objResultPtr, s1, slength); - slength = Tcl_UtfToTitle(TclGetString(objResultPtr)); - Tcl_SetObjLength(objResultPtr, slength); + s1 = TclGetStringFromObj(valuePtr, &length); + TclNewStringObj(objResultPtr, s1, length); + length = Tcl_UtfToTitle(TclGetString(objResultPtr)); + Tcl_SetObjLength(objResultPtr, length); TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr))); NEXT_INST_F(1, 1, 1); } else { - slength = Tcl_UtfToTitle(TclGetString(valuePtr)); - Tcl_SetObjLength(valuePtr, slength); + length = Tcl_UtfToTitle(TclGetString(valuePtr)); + Tcl_SetObjLength(valuePtr, length); TclFreeInternalRep(valuePtr); TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr))); NEXT_INST_F(1, 0, 0); @@ -5378,26 +5462,26 @@ TEBCresume( * Get char length to calculate what 'end' means. */ - slength = Tcl_GetCharLength(valuePtr); + length = TclGetCharLength(valuePtr); DECACHE_STACK_INFO(); - if (TclGetIntForIndexM(interp, value2Ptr, slength-1, &index)!=TCL_OK) { + if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) { CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; } CACHE_STACK_INFO(); - if (index < 0 || index >= slength) { + if ((index < 0) || (index >= length)) { TclNewObj(objResultPtr); } else if (TclIsPureByteArray(valuePtr)) { objResultPtr = Tcl_NewByteArrayObj( - Tcl_GetBytesFromObj(NULL, valuePtr, (Tcl_Size *)NULL)+index, 1); - } else if (valuePtr->bytes && slength == valuePtr->length) { + Tcl_GetByteArrayFromObj(valuePtr, NULL)+index, 1); + } else if (valuePtr->bytes && length == valuePtr->length) { objResultPtr = Tcl_NewStringObj((const char *) valuePtr->bytes+index, 1); } else { char buf[4] = ""; - int ch = Tcl_GetUniChar(valuePtr, index); + int ch = TclGetUniChar(valuePtr, index); /* * This could be: Tcl_NewUnicodeObj((const Tcl_UniChar *)&ch, 1) @@ -5407,8 +5491,11 @@ TEBCresume( if (ch == -1) { TclNewObj(objResultPtr); } else { - slength = Tcl_UniCharToUtf(ch, buf); - objResultPtr = Tcl_NewStringObj(buf, slength); + length = Tcl_UniCharToUtf(ch, buf); + if ((ch >= 0xD800) && (length < 3)) { + length += Tcl_UniCharToUtf(-1, buf + length); + } + objResultPtr = Tcl_NewStringObj(buf, length); } } @@ -5418,25 +5505,27 @@ TEBCresume( case INST_STR_RANGE: TRACE(("\"%.20s\" %.20s %.20s =>", O2S(OBJ_AT_DEPTH(2)), O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS))); - slength = Tcl_GetCharLength(OBJ_AT_DEPTH(2)) - 1; + length = TclGetCharLength(OBJ_AT_DEPTH(2)) - 1; DECACHE_STACK_INFO(); - if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, slength, &fromIdx) != TCL_OK) { + if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, length, + &fromIdx) != TCL_OK) { CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; } - if (TclGetIntForIndexM(interp, OBJ_AT_TOS, slength, &toIdx) != TCL_OK) { + if (TclGetIntForIndexM(interp, OBJ_AT_TOS, length, + &toIdx) != TCL_OK) { CACHE_STACK_INFO(); TRACE_ERROR(interp); goto gotError; } CACHE_STACK_INFO(); - if (toIdx == TCL_INDEX_NONE) { + if (toIdx < 0) { TclNewObj(objResultPtr); } else { - objResultPtr = Tcl_GetRange(OBJ_AT_DEPTH(2), fromIdx, toIdx); + objResultPtr = TclGetRange(OBJ_AT_DEPTH(2), fromIdx, toIdx); } TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr))); NEXT_INST_V(1, 3, 1); @@ -5445,41 +5534,60 @@ TEBCresume( valuePtr = OBJ_AT_TOS; fromIdx = TclGetInt4AtPtr(pc+1); toIdx = TclGetInt4AtPtr(pc+5); - slength = Tcl_GetCharLength(valuePtr); - TRACE(("\"%.20s\" %d %d => ", O2S(valuePtr), (int)(fromIdx), (int)(toIdx))); + length = TclGetCharLength(valuePtr); + TRACE(("\"%.20s\" %d %d => ", O2S(valuePtr), fromIdx, toIdx)); /* Every range of an empty value is an empty value */ - if (slength == 0) { + if (length == 0) { TRACE_APPEND(("\n")); NEXT_INST_F(9, 0, 0); } /* Decode index operands. */ - toIdx = TclIndexDecode(toIdx, slength - 1); - fromIdx = TclIndexDecode(fromIdx, slength - 1); + /* + assert ( toIdx != TCL_INDEX_NONE ); + * + * Extra safety for legacy bytecodes: + */ if (toIdx == TCL_INDEX_NONE) { TclNewObj(objResultPtr); } else { - objResultPtr = Tcl_GetRange(valuePtr, fromIdx, toIdx); + toIdx = TclIndexDecode(toIdx, length - 1); + /* + assert ( fromIdx != TCL_INDEX_NONE ); + * + * Extra safety for legacy bytecodes: + */ + if (fromIdx == TCL_INDEX_NONE) { + fromIdx = TCL_INDEX_START; + } + fromIdx = TclIndexDecode(fromIdx, length - 1); + if (toIdx < 0) { + TclNewObj(objResultPtr); + } else { + objResultPtr = TclGetRange(valuePtr, fromIdx, toIdx); + } } TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_F(9, 1, 1); { Tcl_UniChar *ustring1, *ustring2, *ustring3, *end, *p; - Tcl_Size length3; + Tcl_Size length3, endIdx; Tcl_Obj *value3Ptr; case INST_STR_REPLACE: value3Ptr = POP_OBJECT(); valuePtr = OBJ_AT_DEPTH(2); - slength = Tcl_GetCharLength(valuePtr) - 1; + endIdx = TclGetCharLength(valuePtr) - 1; TRACE(("\"%.20s\" %s %s \"%.20s\" => ", O2S(valuePtr), O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(value3Ptr))); DECACHE_STACK_INFO(); - if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, slength, &fromIdx) != TCL_OK - || TclGetIntForIndexM(interp, OBJ_AT_TOS, slength, &toIdx) != TCL_OK) { + if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, endIdx, + &fromIdx) != TCL_OK + || TclGetIntForIndexM(interp, OBJ_AT_TOS, endIdx, + &toIdx) != TCL_OK) { CACHE_STACK_INFO(); TclDecrRefCount(value3Ptr); TRACE_ERROR(interp); @@ -5491,7 +5599,9 @@ TEBCresume( TclDecrRefCount(OBJ_AT_TOS); (void) POP_OBJECT(); - if ((toIdx < 0) || (fromIdx > slength) || (toIdx < fromIdx)) { + if ((toIdx < 0) || + (fromIdx > endIdx) || + (toIdx < fromIdx)) { TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr))); TclDecrRefCount(value3Ptr); NEXT_INST_F(1, 0, 0); @@ -5501,11 +5611,11 @@ TEBCresume( fromIdx = 0; } - if (toIdx > slength) { - toIdx = slength; + if (toIdx > endIdx) { + toIdx = endIdx; } - if ((fromIdx == 0) && (toIdx == slength)) { + if ((fromIdx == 0) && (toIdx == endIdx)) { TclDecrRefCount(OBJ_AT_TOS); OBJ_AT_TOS = value3Ptr; TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr))); @@ -5537,43 +5647,43 @@ TEBCresume( objResultPtr = value3Ptr; goto doneStringMap; } - ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &slength); - if (slength == 0) { + ustring1 = TclGetUnicodeFromObj(valuePtr, &length); + if (length == 0) { objResultPtr = valuePtr; goto doneStringMap; } - ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2); - if (length2 > slength || length2 == 0) { + ustring2 = TclGetUnicodeFromObj(value2Ptr, &length2); + if (length2 > length || length2 == 0) { objResultPtr = valuePtr; goto doneStringMap; - } else if (length2 == slength) { - if (memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * slength)) { + } else if (length2 == length) { + if (memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * length)) { objResultPtr = valuePtr; } else { objResultPtr = value3Ptr; } goto doneStringMap; } - ustring3 = Tcl_GetUnicodeFromObj(value3Ptr, &length3); + ustring3 = TclGetUnicodeFromObj(value3Ptr, &length3); - objResultPtr = Tcl_NewUnicodeObj(ustring1, 0); + objResultPtr = TclNewUnicodeObj(ustring1, 0); p = ustring1; - end = ustring1 + slength; + end = ustring1 + length; for (; ustring1 < end; ustring1++) { if ((*ustring1 == *ustring2) && - /* Fix bug [69218ab7b]: restrict max compare length. */ - ((end - ustring1) >= length2) && (length2 == 1 || - memcmp(ustring1, ustring2, - sizeof(Tcl_UniChar) * length2) == 0)) { + /* Fix bug [69218ab7b]: restrict max compare length. */ + ((end-ustring1) >= length2) && (length2==1 || + memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * length2) + == 0)) { if (p != ustring1) { - Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1-p); + TclAppendUnicodeToObj(objResultPtr, p, ustring1-p); p = ustring1 + length2; } else { p += length2; } ustring1 = p - 1; - Tcl_AppendUnicodeToObj(objResultPtr, ustring3, length3); + TclAppendUnicodeToObj(objResultPtr, ustring3, length3); } } if (p != ustring1) { @@ -5581,7 +5691,7 @@ TEBCresume( * Put the rest of the unmapped chars onto result. */ - Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1 - p); + TclAppendUnicodeToObj(objResultPtr, p, ustring1 - p); } doneStringMap: TRACE_WITH_OBJ(("%.20s %.20s %.20s => ", @@ -5596,7 +5706,7 @@ TEBCresume( NEXT_INST_F(1, 2, 1); case INST_STR_FIND_LAST: - objResultPtr = TclStringLast(OBJ_UNDER_TOS, OBJ_AT_TOS, TCL_SIZE_MAX - 1); + objResultPtr = TclStringLast(OBJ_UNDER_TOS, OBJ_AT_TOS, INT_MAX - 1); TRACE(("%.20s %.20s => %s\n", O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(objResultPtr))); @@ -5607,11 +5717,11 @@ TEBCresume( valuePtr = OBJ_AT_TOS; TRACE(("%s \"%.30s\" => ", tclStringClassTable[opnd].name, O2S(valuePtr))); - ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &slength); + ustring1 = TclGetUnicodeFromObj(valuePtr, &length); match = 1; - if (slength > 0) { + if (length > 0) { int ch; - end = ustring1 + slength; + end = ustring1 + length; for (p=ustring1 ; p<end ; ) { ch = *p++; if (!tclStringClassTable[opnd].comparator(ch)) { @@ -5634,21 +5744,20 @@ TEBCresume( * both. */ - if (TclHasInternalRep(valuePtr, &tclStringType) - || TclHasInternalRep(value2Ptr, &tclStringType)) { + if (TclHasInternalRep(valuePtr, &tclUniCharStringType) + || TclHasInternalRep(value2Ptr, &tclUniCharStringType)) { Tcl_UniChar *ustring1, *ustring2; - ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &slength); - ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2); - match = TclUniCharMatch(ustring1, slength, ustring2, length2, + ustring1 = TclGetUnicodeFromObj(valuePtr, &length); + ustring2 = TclGetUnicodeFromObj(value2Ptr, &length2); + match = TclUniCharMatch(ustring1, length, ustring2, length2, nocase); - } else if (TclIsPureByteArray(valuePtr) && TclIsPureByteArray(value2Ptr) && !nocase) { + } else if (TclIsPureByteArray(valuePtr) && !nocase) { unsigned char *bytes1, *bytes2; - Tcl_Size wlen1 = 0, wlen2 = 0; - bytes1 = Tcl_GetBytesFromObj(NULL, valuePtr, &wlen1); - bytes2 = Tcl_GetBytesFromObj(NULL, value2Ptr, &wlen2); - match = TclByteArrayMatch(bytes1, wlen1, bytes2, wlen2, 0); + bytes1 = Tcl_GetByteArrayFromObj(valuePtr, &length); + bytes2 = Tcl_GetByteArrayFromObj(value2Ptr, &length2); + match = TclByteArrayMatch(bytes1, length, bytes2, length2, 0); } else { match = Tcl_StringCaseMatch(TclGetString(valuePtr), TclGetString(value2Ptr), nocase); @@ -5675,24 +5784,24 @@ TEBCresume( valuePtr = OBJ_UNDER_TOS; /* String */ value2Ptr = OBJ_AT_TOS; /* TrimSet */ string2 = TclGetStringFromObj(value2Ptr, &length2); - string1 = TclGetStringFromObj(valuePtr, &slength); - trim1 = TclTrimLeft(string1, slength, string2, length2); + string1 = TclGetStringFromObj(valuePtr, &length); + trim1 = TclTrimLeft(string1, length, string2, length2); trim2 = 0; goto createTrimmedString; case INST_STR_TRIM_RIGHT: valuePtr = OBJ_UNDER_TOS; /* String */ value2Ptr = OBJ_AT_TOS; /* TrimSet */ string2 = TclGetStringFromObj(value2Ptr, &length2); - string1 = TclGetStringFromObj(valuePtr, &slength); - trim2 = TclTrimRight(string1, slength, string2, length2); + string1 = TclGetStringFromObj(valuePtr, &length); + trim2 = TclTrimRight(string1, length, string2, length2); trim1 = 0; goto createTrimmedString; case INST_STR_TRIM: valuePtr = OBJ_UNDER_TOS; /* String */ value2Ptr = OBJ_AT_TOS; /* TrimSet */ string2 = TclGetStringFromObj(value2Ptr, &length2); - string1 = TclGetStringFromObj(valuePtr, &slength); - trim1 = TclTrim(string1, slength, string2, length2, &trim2); + string1 = TclGetStringFromObj(valuePtr, &length); + trim1 = TclTrim(string1, length, string2, length2, &trim2); createTrimmedString: /* * Careful here; trim set often contains non-ASCII characters so we @@ -5715,7 +5824,7 @@ TEBCresume( #endif NEXT_INST_F(1, 1, 0); } else { - objResultPtr = Tcl_NewStringObj(string1+trim1, slength-trim1-trim2); + objResultPtr = Tcl_NewStringObj(string1+trim1, length-trim1-trim2); #ifdef TCL_COMPILE_DEBUG if (traceInstructions) { TclPrintObject(stdout, objResultPtr, 30); @@ -6477,11 +6586,177 @@ TEBCresume( { ForeachInfo *infoPtr; + Var *iterVarPtr, *listVarPtr; + Tcl_Obj *oldValuePtr, *listPtr, **elements; + ForeachVarList *varListPtr; + int numLists, listTmpIndex, listLen, numVars; + size_t iterNum; + int varIndex, valIndex, continueLoop, j, iterTmpIndex; + long i; + + case INST_FOREACH_START4: /* DEPRECATED */ + /* + * Initialize the temporary local var that holds the count of the + * number of iterations of the loop body to -1. + */ + + opnd = TclGetUInt4AtPtr(pc+1); + infoPtr = (ForeachInfo *)codePtr->auxDataArrayPtr[opnd].clientData; + iterTmpIndex = infoPtr->loopCtTemp; + iterVarPtr = LOCAL(iterTmpIndex); + oldValuePtr = iterVarPtr->value.objPtr; + + if (oldValuePtr == NULL) { + TclNewIntObj(iterVarPtr->value.objPtr, -1); + Tcl_IncrRefCount(iterVarPtr->value.objPtr); + } else { + TclSetIntObj(oldValuePtr, -1); + } + TRACE(("%u => loop iter count temp %d\n", opnd, iterTmpIndex)); + +#ifndef TCL_COMPILE_DEBUG + /* + * Remark that the compiler ALWAYS sets INST_FOREACH_STEP4 immediately + * after INST_FOREACH_START4 - let us just fall through instead of + * jumping back to the top. + */ + + pc += 5; + TCL_DTRACE_INST_NEXT(); +#else + NEXT_INST_F(5, 0, 0); +#endif + + case INST_FOREACH_STEP4: /* DEPRECATED */ + /* + * "Step" a foreach loop (i.e., begin its next iteration) by assigning + * the next value list element to each loop var. + */ + + opnd = TclGetUInt4AtPtr(pc+1); + TRACE(("%u => ", opnd)); + infoPtr = (ForeachInfo *)codePtr->auxDataArrayPtr[opnd].clientData; + numLists = infoPtr->numLists; + + /* + * Increment the temp holding the loop iteration number. + */ + + iterVarPtr = LOCAL(infoPtr->loopCtTemp); + valuePtr = iterVarPtr->value.objPtr; + iterNum = (size_t)valuePtr->internalRep.wideValue + 1; + TclSetIntObj(valuePtr, iterNum); + + /* + * Check whether all value lists are exhausted and we should stop the + * loop. + */ + + continueLoop = 0; + listTmpIndex = infoPtr->firstValueTemp; + for (i = 0; i < numLists; i++) { + varListPtr = infoPtr->varLists[i]; + numVars = varListPtr->numVars; + + listVarPtr = LOCAL(listTmpIndex); + listPtr = listVarPtr->value.objPtr; + if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) { + TRACE_APPEND(("ERROR converting list %ld, \"%.30s\": %s\n", + i, O2S(listPtr), O2S(Tcl_GetObjResult(interp)))); + goto gotError; + } + if ((size_t)listLen > iterNum * numVars) { + continueLoop = 1; + } + listTmpIndex++; + } + + /* + * If some var in some var list still has a remaining list element + * iterate one more time. Assign to var the next element from its + * value list. We already checked above that each list temp holds a + * valid list object (by calling Tcl_ListObjLength), but cannot rely + * on that check remaining valid: one list could have been shimmered + * as a side effect of setting a traced variable. + */ + + if (continueLoop) { + listTmpIndex = infoPtr->firstValueTemp; + for (i = 0; i < numLists; i++) { + varListPtr = infoPtr->varLists[i]; + numVars = varListPtr->numVars; + + listVarPtr = LOCAL(listTmpIndex); + /* Do not use TclListObjCopy here - shimmers arithseries to list */ + listPtr = Tcl_DuplicateObj(listVarPtr->value.objPtr); + TclListObjGetElements(interp, listPtr, &listLen, &elements); + + valIndex = (iterNum * numVars); + for (j = 0; j < numVars; j++) { + if (valIndex >= listLen) { + TclNewObj(valuePtr); + } else { + valuePtr = elements[valIndex]; + } + + varIndex = varListPtr->varIndexes[j]; + varPtr = LOCAL(varIndex); + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + if (TclIsVarDirectWritable(varPtr)) { + value2Ptr = varPtr->value.objPtr; + if (valuePtr != value2Ptr) { + if (value2Ptr != NULL) { + TclDecrRefCount(value2Ptr); + } + varPtr->value.objPtr = valuePtr; + Tcl_IncrRefCount(valuePtr); + } + } else { + DECACHE_STACK_INFO(); + if (TclPtrSetVarIdx(interp, varPtr, NULL, NULL, NULL, + valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){ + CACHE_STACK_INFO(); + TRACE_APPEND(( + "ERROR init. index temp %d: %s\n", + varIndex, O2S(Tcl_GetObjResult(interp)))); + TclDecrRefCount(listPtr); + goto gotError; + } + CACHE_STACK_INFO(); + } + valIndex++; + } + TclDecrRefCount(listPtr); + listTmpIndex++; + } + } + TRACE_APPEND(("%d lists, iter %" TCL_Z_MODIFIER "u, %s loop\n", + numLists, iterNum, (continueLoop? "continue" : "exit"))); + + /* + * Run-time peep-hole optimisation: the compiler ALWAYS follows + * INST_FOREACH_STEP4 with an INST_JUMP_FALSE. We just skip that + * instruction and jump direct from here. + */ + + pc += 5; + if (*pc == INST_JUMP_FALSE1) { + NEXT_INST_F((continueLoop? 2 : TclGetInt1AtPtr(pc+1)), 0, 0); + } else { + NEXT_INST_F((continueLoop? 5 : TclGetInt4AtPtr(pc+1)), 0, 0); + } + + } + { + ForeachInfo *infoPtr; Tcl_Obj *listPtr, **elements; ForeachVarList *varListPtr; Tcl_Size numLists, listLen, numVars, listTmpDepth; - Tcl_Size iterNum, iterMax, iterTmp; - Tcl_Size varIndex, valIndex, i, j; + size_t iterNum, iterMax, iterTmp; + int varIndex, valIndex, j; + long i; case INST_FOREACH_START: /* @@ -6504,15 +6779,17 @@ TEBCresume( varListPtr = infoPtr->varLists[i]; numVars = varListPtr->numVars; listPtr = OBJ_AT_DEPTH(listTmpDepth); - DECACHE_STACK_INFO(); if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) { - CACHE_STACK_INFO(); - TRACE_APPEND(("ERROR converting list %" TCL_Z_MODIFIER "d, \"%s\": %s", + TRACE_APPEND(("ERROR converting list %ld, \"%s\": %s", i, O2S(listPtr), O2S(Tcl_GetObjResult(interp)))); goto gotError; } if (Tcl_IsShared(listPtr)) { - objPtr = TclListObjCopy(NULL, listPtr); + /* Do not use TclListObjCopy here - shimmers arithseries to list */ + objPtr = Tcl_DuplicateObj(listPtr); + if (!objPtr) { + goto gotError; + } Tcl_IncrRefCount(objPtr); Tcl_DecrRefCount(listPtr); OBJ_AT_DEPTH(listTmpDepth) = objPtr; @@ -6553,7 +6830,7 @@ TEBCresume( pc += 5 - infoPtr->loopCtTemp; - case INST_FOREACH_STEP: /* TODO: address abstract list indexing here! */ + case INST_FOREACH_STEP: /* * "Step" a foreach loop (i.e., begin its next iteration) by assigning * the next value list element to each loop var. @@ -6589,7 +6866,8 @@ TEBCresume( int hasAbstractList; listPtr = OBJ_AT_DEPTH(listTmpDepth); - hasAbstractList = TclObjTypeHasProc(listPtr, indexProc) != 0; + hasAbstractList = + TclHasInternalRep(listPtr, &tclArithSeriesType); DECACHE_STACK_INFO(); if (hasAbstractList) { status = Tcl_ListObjLength(interp, listPtr, &listLen); @@ -6604,29 +6882,22 @@ TEBCresume( } CACHE_STACK_INFO(); - valIndex = (iterNum * numVars); for (j = 0; j < numVars; j++) { if (valIndex >= listLen) { TclNewObj(valuePtr); } else { - DECACHE_STACK_INFO(); if (elements) { valuePtr = elements[valIndex]; } else { - status = Tcl_ListObjIndex( - interp, listPtr, valIndex, &valuePtr); - if (status != TCL_OK) { - /* Could happen for abstract lists */ - CACHE_STACK_INFO(); - goto gotError; - } + DECACHE_STACK_INFO(); + valuePtr = TclArithSeriesObjIndex( + NULL, listPtr, valIndex); if (valuePtr == NULL) { - /* Permitted for Tcl_LOI to return NULL */ TclNewObj(valuePtr); } + CACHE_STACK_INFO(); } - CACHE_STACK_INFO(); } varIndex = varListPtr->varIndexes[j]; @@ -6784,18 +7055,16 @@ TEBCresume( Tcl_DictSearch *searchPtr; DictUpdateInfo *duiPtr; - case INST_DICT_VERIFY: { - Tcl_Size size; + case INST_DICT_VERIFY: dictPtr = OBJ_AT_TOS; TRACE(("\"%.30s\" => ", O2S(dictPtr))); - if (Tcl_DictObjSize(interp, dictPtr, &size) != TCL_OK) { + if (Tcl_DictObjSize(interp, dictPtr, &done) != TCL_OK) { TRACE_APPEND(("ERROR verifying dictionary nature of \"%.30s\": %s\n", O2S(dictPtr), O2S(Tcl_GetObjResult(interp)))); goto gotError; } TRACE_APPEND(("OK\n")); NEXT_INST_F(1, 1, 0); - } break; case INST_DICT_EXISTS: { @@ -6993,7 +7262,7 @@ TEBCresume( } } #ifndef TCL_COMPILE_DEBUG - if (pc[9] == INST_POP) { + if (*(pc+9) == INST_POP) { NEXT_INST_V(10, cleanup, 0); } #endif @@ -7132,7 +7401,7 @@ TEBCresume( } } #ifndef TCL_COMPILE_DEBUG - if (pc[5] == INST_POP) { + if (*(pc+5) == INST_POP) { NEXT_INST_F(6, 2, 0); } #endif @@ -7143,9 +7412,10 @@ TEBCresume( opnd = TclGetUInt4AtPtr(pc+1); TRACE(("%u => ", opnd)); dictPtr = POP_OBJECT(); - searchPtr = (Tcl_DictSearch *)Tcl_Alloc(sizeof(Tcl_DictSearch)); + searchPtr = (Tcl_DictSearch *)ckalloc(sizeof(Tcl_DictSearch)); if (Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr, &valuePtr, &done) != TCL_OK) { + /* * dictPtr is no longer on the stack, and we're not * moving it into the internalrep of an iterator. We need @@ -7153,7 +7423,7 @@ TEBCresume( */ Tcl_DecrRefCount(dictPtr); - Tcl_Free(searchPtr); + ckfree(searchPtr); TRACE_ERROR(interp); goto gotError; } @@ -7607,12 +7877,11 @@ TEBCresume( } if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { const unsigned char *pcBeg; - Tcl_Size xxx1length; - bytes = GetSrcInfoForPc(pc, codePtr, &xxx1length, &pcBeg, NULL); + bytes = GetSrcInfoForPc(pc, codePtr, &length, &pcBeg, NULL); DECACHE_STACK_INFO(); TclLogCommandInfo(interp, codePtr->source, bytes, - bytes ? xxx1length : 0, pcBeg, tosPtr); + bytes ? length : 0, pcBeg, tosPtr); CACHE_STACK_INFO(); } iPtr->flags &= ~ERR_ALREADY_LOGGED; @@ -7774,9 +8043,8 @@ TEBCresume( instStartCmdFailed: { const char *bytes; - Tcl_Size xxx1length; - xxx1length = 0; + length = 0; if (TclInterpReady(interp) == TCL_ERROR) { goto gotError; @@ -7793,11 +8061,11 @@ TEBCresume( */ codePtr->flags |= TCL_BYTECODE_RECOMPILE; - bytes = GetSrcInfoForPc(pc, codePtr, &xxx1length, NULL, NULL); + bytes = GetSrcInfoForPc(pc, codePtr, &length, NULL, NULL); opnd = TclGetUInt4AtPtr(pc+1); pc += (opnd-1); assert(bytes); - PUSH_OBJECT(Tcl_NewStringObj(bytes, xxx1length)); + PUSH_OBJECT(Tcl_NewStringObj(bytes, length)); goto instEvalStk; } } @@ -8183,8 +8451,9 @@ ExecuteExtendedBinaryMathOp( if ((type1 == TCL_NUMBER_INT) && ((size_t)shift < CHAR_BIT*sizeof(Tcl_WideInt))) { w1 = *((const Tcl_WideInt *)ptr1); - if (!((w1 > 0 ? w1 : ~w1) & -( - ((Tcl_WideUInt)1) << (CHAR_BIT*sizeof(Tcl_WideInt) - 1 - shift)))) { + if (!((w1>0 ? w1 : ~w1) + & -(((Tcl_WideUInt)1) + << (CHAR_BIT*sizeof(Tcl_WideInt) - 1 - shift)))) { WIDE_RESULT((Tcl_WideUInt)w1 << shift); } } @@ -8505,7 +8774,7 @@ ExecuteExtendedBinaryMathOp( err = mp_init(&bigResult); if (err == MP_OKAY) { /* Don't use "mp_expt_n" directly here, it doesn't exist in libtommath 1.2 */ - err = TclBN_mp_expt_n(&big1, (int)w2, &bigResult); + err = TclBN_mp_expt_d(&big1, (int)w2, &bigResult); } if (err != MP_OKAY) { return OUT_OF_MEMORY; @@ -8576,7 +8845,8 @@ ExecuteExtendedBinaryMathOp( switch (opcode) { case INST_ADD: wResult = (Tcl_WideInt)((Tcl_WideUInt)w1 + (Tcl_WideUInt)w2); - if ((type1 == TCL_NUMBER_INT) || (type2 == TCL_NUMBER_INT)) { + if ((type1 == TCL_NUMBER_INT) || (type2 == TCL_NUMBER_INT)) + { /* * Check for overflow. */ @@ -8589,7 +8859,8 @@ ExecuteExtendedBinaryMathOp( case INST_SUB: wResult = (Tcl_WideInt)((Tcl_WideUInt)w1 - (Tcl_WideUInt)w2); - if ((type1 == TCL_NUMBER_INT) || (type2 == TCL_NUMBER_INT)) { + if ((type1 == TCL_NUMBER_INT) || (type2 == TCL_NUMBER_INT)) + { /* * Must check for overflow. The macro tests for overflows * in sums by looking at the sign bits. As we have a @@ -8966,13 +9237,13 @@ PrintByteCodeInfo( Proc *procPtr = codePtr->procPtr; Interp *iPtr = (Interp *) *codePtr->interpHandle; - fprintf(stdout, "\nExecuting ByteCode 0x%p, refCt %" TCL_Z_MODIFIER "u, epoch %" TCL_Z_MODIFIER "u, interp 0x%p (epoch %" TCL_Z_MODIFIER "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: "); TclPrintSource(stdout, codePtr->source, 60); - fprintf(stdout, "\n Cmds %" TCL_Z_MODIFIER "u, src %" TCL_Z_MODIFIER "u, inst %" TCL_Z_MODIFIER "u, litObjs %" TCL_Z_MODIFIER "u, aux %" TCL_Z_MODIFIER "u, stkDepth %" TCL_Z_MODIFIER "u, code/src %.2f\n", + fprintf(stdout, "\n Cmds %d, src %d, inst %u, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", codePtr->numCommands, codePtr->numSrcBytes, codePtr->numCodeBytes, codePtr->numLitObjects, codePtr->numAuxDataItems, codePtr->maxStackDepth, @@ -8983,9 +9254,8 @@ PrintByteCodeInfo( 0.0); #ifdef TCL_COMPILE_STATS - fprintf(stdout, " Code %" TCL_Z_MODIFIER "u = header %" TCL_Z_MODIFIER "u+inst %" TCL_Z_MODIFIER - "u+litObj %" TCL_Z_MODIFIER "u+exc %" TCL_Z_MODIFIER "u+aux %" TCL_Z_MODIFIER "u+cmdMap %" TCL_Z_MODIFIER "u\n", - codePtr->structureSize, + fprintf(stdout, " Code %lu = header %" TCL_Z_MODIFIER "u+inst %d+litObj %" TCL_Z_MODIFIER "u+exc %" TCL_Z_MODIFIER "u+aux %" TCL_Z_MODIFIER "u+cmdMap %d\n", + (unsigned long) codePtr->structureSize, offsetof(ByteCode, localCachePtr), codePtr->numCodeBytes, codePtr->numLitObjects * sizeof(Tcl_Obj *), @@ -8995,7 +9265,7 @@ PrintByteCodeInfo( #endif /* TCL_COMPILE_STATS */ if (procPtr != NULL) { fprintf(stdout, - " Proc 0x%p, refCt %" TCL_Z_MODIFIER "u, args %" TCL_Z_MODIFIER "u, compiled locals %" TCL_Z_MODIFIER "u\n", + " Proc 0x%p, refCt %d, args %d, compiled locals %d\n", procPtr, procPtr->refCount, procPtr->numArgs, procPtr->numCompiledLocals); } @@ -9047,13 +9317,14 @@ ValidatePcAndStackTop( pc); Tcl_Panic("TclNRExecuteByteCode execution failure: bad pc"); } - if (opCode >= LAST_INST_OPCODE) { - fprintf(stderr, "\nBad opcode %u at pc %" TCL_Z_MODIFIER "u in TclNRExecuteByteCode\n", - opCode, relativePc); + if ((unsigned) opCode > LAST_INST_OPCODE) { + fprintf(stderr, "\nBad opcode %d at pc %" TCL_Z_MODIFIER "u in TclNRExecuteByteCode\n", + (unsigned) opCode, relativePc); Tcl_Panic("TclNRExecuteByteCode execution failure: bad opcode"); } - if (checkStack && (stackTop > stackUpperBound)) { - Tcl_Size numChars; + if (checkStack && + (stackTop > stackUpperBound)) { + int numChars; const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL, NULL); fprintf(stderr, "\nBad stack top %" TCL_Z_MODIFIER "u at pc %" TCL_Z_MODIFIER "u in TclNRExecuteByteCode (min 0, max %" TCL_Z_MODIFIER "u)", @@ -9109,11 +9380,20 @@ IllegalExprOperandType( if (opcode == INST_EXPON) { op = "**"; } else if (opcode <= INST_LNOT) { - op = operatorStrings[opcode - INST_BITOR]; + op = operatorStrings[opcode - INST_LOR]; } if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) { - description = "non-numeric string"; + Tcl_Size numBytes; + const char *bytes = TclGetStringFromObj(opndPtr, &numBytes); + + if (numBytes == 0) { + description = "empty string"; + } else if (TclCheckBadOctal(NULL, bytes)) { + description = "invalid octal number"; + } else { + description = "non-numeric string"; + } } else if (type == TCL_NUMBER_NAN) { description = "non-numeric floating-point value"; } else if (type == TCL_NUMBER_DOUBLE) { @@ -9156,7 +9436,7 @@ IllegalExprOperandType( Tcl_Obj * TclGetSourceFromFrame( CmdFrame *cfPtr, - int objc, + Tcl_Size objc, Tcl_Obj *const objv[]) { if (cfPtr == NULL) { @@ -9203,7 +9483,7 @@ TclGetSrcInfoForPc( ExtCmdLoc *eclPtr; ECL *locPtr = NULL; Tcl_Size srcOffset; - Tcl_Size i; + int i; Interp *iPtr = (Interp *) *codePtr->interpHandle; Tcl_HashEntry *hePtr = Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr); @@ -9255,7 +9535,7 @@ GetSrcInfoForPc( const unsigned char **pcBeg,/* If non-NULL, the bytecode location * where the current instruction starts. * If NULL; no pointer is stored. */ - Tcl_Size *cmdIdxPtr) /* If non-NULL, the location where the index + Tcl_Size *cmdIdxPtr) /* If non-NULL, the location where the index * of the command containing the pc should * be stored. */ { @@ -9264,9 +9544,9 @@ GetSrcInfoForPc( unsigned char *codeDeltaNext, *codeLengthNext; unsigned char *srcDeltaNext, *srcLengthNext; Tcl_Size codeOffset, codeLen, codeEnd, srcOffset, srcLen, delta, i; - Tcl_Size bestDist = TCL_SIZE_MAX; /* Distance of pc to best cmd's start pc. */ - Tcl_Size bestSrcOffset = -1; /* Initialized to avoid compiler warning. */ - Tcl_Size bestSrcLength = -1; /* Initialized to avoid compiler warning. */ + int bestDist = INT_MAX; /* Distance of pc to best cmd's start pc. */ + Tcl_Size bestSrcOffset = -1; /* Initialized to avoid compiler warning. */ + Tcl_Size bestSrcLength = -1; /* Initialized to avoid compiler warning. */ Tcl_Size bestCmdIdx = -1; /* The pc must point within the bytecode */ @@ -9346,7 +9626,7 @@ GetSrcInfoForPc( * instructions. Stop when crossing pc; keep previous. */ - curr = ((bestDist == TCL_SIZE_MAX) ? codePtr->codeStart : pc - bestDist); + curr = ((bestDist == INT_MAX) ? codePtr->codeStart : pc - bestDist); prev = curr; while (curr <= pc) { prev = curr; @@ -9355,7 +9635,7 @@ GetSrcInfoForPc( *pcBeg = prev; } - if (bestDist == TCL_SIZE_MAX) { + if (bestDist == INT_MAX) { return NULL; } @@ -9411,10 +9691,10 @@ GetExceptRangeForPc( * for the enclosing ExceptionRange. */ { ExceptionRange *rangeArrayPtr; - size_t numRanges = codePtr->numExceptRanges; + int numRanges = codePtr->numExceptRanges; ExceptionRange *rangePtr; - size_t pcOffset = pc - codePtr->codeStart; - size_t start; + int pcOffset = pc - codePtr->codeStart; + int start; if (numRanges == 0) { return NULL; @@ -9592,10 +9872,9 @@ EvalStatsCmd( double strBytesSharedMultX, strBytesSharedOnce; double numInstructions, currentHeaderBytes; size_t numCurrentByteCodes, numByteCodeLits; - size_t refCountSum, literalMgmtBytes, sum, decadeHigh; - size_t numSharedMultX, numSharedOnce, minSizeDecade, maxSizeDecade; - Tcl_Size i, length; - size_t ui; + size_t refCountSum, literalMgmtBytes, sum; + size_t numSharedMultX, numSharedOnce, minSizeDecade, maxSizeDecade, i; + int decadeHigh, length; char *litTableStats; LiteralEntry *entryPtr; Tcl_Obj *objPtr; @@ -9731,7 +10010,7 @@ EvalStatsCmd( strBytesIfUnshared = 0.0; strBytesSharedMultX = 0.0; strBytesSharedOnce = 0.0; - for (ui = 0; ui < globalTablePtr->numBuckets; ui++) { + for (i = 0; i < globalTablePtr->numBuckets; i++) { for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL; entryPtr = entryPtr->nextPtr) { if (TclHasInternalRep(entryPtr->objPtr, &tclByteCodeType)) { @@ -9849,9 +10128,9 @@ EvalStatsCmd( } } sum = 0; - for (ui = 0; ui <= maxSizeDecade; ui++) { - decadeHigh = (1 << (ui+1)) - 1; - sum += statsPtr->literalCount[ui]; + for (i = 0; i <= maxSizeDecade; i++) { + decadeHigh = (1 << (i+1)) - 1; + sum += statsPtr->literalCount[i]; Tcl_AppendPrintfToObj(objPtr, "\t%10" TCL_SIZE_MODIFIER "d\t\t%8.0f%%\n", decadeHigh, Percent(sum, statsPtr->numLiteralsCreated)); } @@ -9859,7 +10138,7 @@ EvalStatsCmd( litTableStats = TclLiteralStats(globalTablePtr); Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal table statistics:\n%s\n", litTableStats); - Tcl_Free(litTableStats); + ckfree(litTableStats); /* * Source and ByteCode size distributions. @@ -9874,17 +10153,16 @@ EvalStatsCmd( break; } } - for (i = 31; i != TCL_INDEX_NONE; i--) { + for (i = 31; i != (size_t)-1; i--) { if (statsPtr->srcCount[i] > 0) { - break; /* maxSizeDecade to consume 'i' value - * below... */ + maxSizeDecade = i; + break; } } - maxSizeDecade = i; sum = 0; - for (ui = minSizeDecade; ui <= maxSizeDecade; ui++) { - decadeHigh = (1 << (ui+1)) - 1; - sum += statsPtr->srcCount[ui]; + for (i = minSizeDecade; i <= maxSizeDecade; i++) { + decadeHigh = (1 << (i+1)) - 1; + sum += statsPtr->srcCount[i]; Tcl_AppendPrintfToObj(objPtr, "\t%10" TCL_SIZE_MODIFIER "d\t\t%8.0f%%\n", decadeHigh, Percent(sum, statsPtr->numCompilations)); } @@ -9898,17 +10176,16 @@ EvalStatsCmd( break; } } - for (i = 31; i != TCL_INDEX_NONE; i--) { + for (i = 31; i != (size_t)-1; i--) { if (statsPtr->byteCodeCount[i] > 0) { - break; /* maxSizeDecade to consume 'i' value - * below... */ + maxSizeDecade = i; + break; } } - maxSizeDecade = i; sum = 0; - for (ui = minSizeDecade; ui <= maxSizeDecade; i++) { - decadeHigh = (1 << (ui+1)) - 1; - sum += statsPtr->byteCodeCount[ui]; + for (i = minSizeDecade; i <= maxSizeDecade; i++) { + decadeHigh = (1 << (i+1)) - 1; + sum += statsPtr->byteCodeCount[i]; Tcl_AppendPrintfToObj(objPtr, "\t%10" TCL_SIZE_MODIFIER "d\t\t%8.0f%%\n", decadeHigh, Percent(sum, statsPtr->numCompilations)); } @@ -9922,17 +10199,16 @@ EvalStatsCmd( break; } } - for (i = 31; i != TCL_INDEX_NONE; i--) { + for (i = 31; i != (size_t)-1; i--) { if (statsPtr->lifetimeCount[i] > 0) { - break; /* maxSizeDecade to consume 'i' value - * below... */ + maxSizeDecade = i; + break; } } - maxSizeDecade = i; sum = 0; - for (ui = minSizeDecade; ui <= maxSizeDecade; ui++) { - decadeHigh = (1 << (ui+1)) - 1; - sum += statsPtr->lifetimeCount[ui]; + for (i = minSizeDecade; i <= maxSizeDecade; i++) { + decadeHigh = (1 << (i+1)) - 1; + sum += statsPtr->lifetimeCount[i]; Tcl_AppendPrintfToObj(objPtr, "\t%12.3f\t\t%8.0f%%\n", decadeHigh/1000.0, Percent(sum, statsPtr->numByteCodesFreed)); } @@ -9942,7 +10218,7 @@ EvalStatsCmd( */ Tcl_AppendPrintfToObj(objPtr, "\nInstruction counts:\n"); - for (i = 0; i < LAST_INST_OPCODE; i++) { + for (i = 0; i <= LAST_INST_OPCODE; i++) { Tcl_AppendPrintfToObj(objPtr, "%20s %8" TCL_Z_MODIFIER "u ", tclInstructionTable[i].name, statsPtr->instructionCount[i]); if (statsPtr->instructionCount[i]) { diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c index b12162c..42f4c5a 100644 --- a/generic/tclFCmd.c +++ b/generic/tclFCmd.c @@ -47,7 +47,7 @@ static int FileForceOption(Tcl_Interp *interp, int TclFileRenameCmd( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, /* Interp for error reporting or recursive * calls in the case of a tricky rename. */ int objc, /* Number of arguments. */ @@ -76,7 +76,7 @@ TclFileRenameCmd( int TclFileCopyCmd( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, /* Used for error reporting or recursive calls * in the case of a tricky copy. */ int objc, /* Number of arguments. */ @@ -113,7 +113,6 @@ FileCopyRename( int i, result, force; Tcl_StatBuf statBuf; Tcl_Obj *target; - Tcl_DString ds; i = FileForceOption(interp, objc - 1, objv + 1, &force); if (i < 0) { @@ -135,12 +134,6 @@ FileCopyRename( if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) { return TCL_ERROR; } - if (Tcl_UtfToExternalDStringEx(interp, TCLFSENCODING, TclGetString(target), - TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { - Tcl_DStringFree(&ds); - return TCL_ERROR; - } - Tcl_DStringFree(&ds); result = TCL_OK; @@ -221,18 +214,16 @@ FileCopyRename( int TclFileMakeDirsCmd( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, /* Used for error reporting. */ int objc, /* Number of arguments */ Tcl_Obj *const objv[]) /* Argument strings passed to Tcl_FileCmd. */ { Tcl_Obj *errfile = NULL; - int result, i; - Tcl_Size j, pobjc; + int result, i, j, pobjc; Tcl_Obj *split = NULL; Tcl_Obj *target = NULL; Tcl_StatBuf statBuf; - Tcl_DString ds; result = TCL_OK; for (i = 1; i < objc; i++) { @@ -240,13 +231,6 @@ TclFileMakeDirsCmd( result = TCL_ERROR; break; } - if (Tcl_UtfToExternalDStringEx(interp, TCLFSENCODING, TclGetString(objv[i]), - TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { - Tcl_DStringFree(&ds); - result = TCL_ERROR; - break; - } - Tcl_DStringFree(&ds); split = Tcl_FSSplitPath(objv[i], &pobjc); Tcl_IncrRefCount(split); @@ -354,7 +338,7 @@ TclFileMakeDirsCmd( int TclFileDeleteCmd( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, /* Used for error reporting */ int objc, /* Number of arguments */ Tcl_Obj *const objv[]) /* Argument strings passed to Tcl_FileCmd. */ @@ -362,7 +346,6 @@ TclFileDeleteCmd( int i, force, result; Tcl_Obj *errfile; Tcl_Obj *errorBuffer = NULL; - Tcl_DString ds; i = FileForceOption(interp, objc - 1, objv + 1, &force); if (i < 0) { @@ -380,13 +363,6 @@ TclFileDeleteCmd( result = TCL_ERROR; goto done; } - if (Tcl_UtfToExternalDStringEx(interp, TCLFSENCODING, TclGetString(objv[i]), - TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { - Tcl_DStringFree(&ds); - result = TCL_ERROR; - goto done; - } - Tcl_DStringFree(&ds); /* * Call lstat() to get info so can delete symbolic link itself. @@ -506,26 +482,13 @@ CopyRenameOneFile( Tcl_Obj *actualSource=NULL; /* If source is a link, then this is the real * file/directory. */ Tcl_StatBuf sourceStatBuf, targetStatBuf; - Tcl_DString ds; if (Tcl_FSConvertToPathType(interp, source) != TCL_OK) { return TCL_ERROR; } - if (Tcl_UtfToExternalDStringEx(interp, TCLFSENCODING, TclGetString(source), - TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { - Tcl_DStringFree(&ds); - return TCL_ERROR; - } - Tcl_DStringFree(&ds); if (Tcl_FSConvertToPathType(interp, target) != TCL_OK) { return TCL_ERROR; } - if (Tcl_UtfToExternalDStringEx(interp, TCLFSENCODING, TclGetString(target), - TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { - Tcl_DStringFree(&ds); - return TCL_ERROR; - } - Tcl_DStringFree(&ds); errfile = NULL; errorBuffer = NULL; @@ -907,10 +870,10 @@ FileForceOption( static Tcl_Obj * FileBasename( - TCL_UNUSED(Tcl_Interp *), /* Interp, for error return. */ + Tcl_Interp *interp, /* Interp, for error return. */ Tcl_Obj *pathPtr) /* Path whose basename to extract. */ { - Tcl_Size objc; + int objc; Tcl_Obj *splitPtr; Tcl_Obj *resultPtr = NULL; @@ -918,8 +881,17 @@ FileBasename( Tcl_IncrRefCount(splitPtr); if (objc != 0) { - /* - * Return the last component, unless it is the only component, and it + if ((objc == 1) && (*TclGetString(pathPtr) == '~')) { + Tcl_DecrRefCount(splitPtr); + if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) { + return NULL; + } + splitPtr = Tcl_FSSplitPath(pathPtr, &objc); + Tcl_IncrRefCount(splitPtr); + } + + /* + * Return the last component, unless it is the only component, and it * is the root of an absolute path. */ @@ -974,7 +946,7 @@ FileBasename( int TclFileAttrsCmd( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, /* The interpreter for error reporting. */ int objc, /* Number of command line arguments. */ Tcl_Obj *const objv[]) /* The command line objects. */ @@ -983,9 +955,8 @@ TclFileAttrsCmd( const char *const *attributeStrings; const char **attributeStringsAllocated = NULL; Tcl_Obj *objStrings = NULL; - Tcl_Size numObjStrings = TCL_INDEX_NONE; + int numObjStrings = -1; Tcl_Obj *filePtr; - Tcl_DString ds; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "name ?-option value ...?"); @@ -996,12 +967,6 @@ TclFileAttrsCmd( if (Tcl_FSConvertToPathType(interp, filePtr) != TCL_OK) { return TCL_ERROR; } - if (Tcl_UtfToExternalDStringEx(interp, TCLFSENCODING, TclGetString(filePtr), - TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { - Tcl_DStringFree(&ds); - return TCL_ERROR; - } - Tcl_DStringFree(&ds); objc -= 2; objv += 2; @@ -1014,7 +979,7 @@ TclFileAttrsCmd( attributeStrings = Tcl_FSFileAttrStrings(filePtr, &objStrings); if (attributeStrings == NULL) { - Tcl_Size index; + int index; Tcl_Obj *objPtr; if (objStrings == NULL) { @@ -1197,14 +1162,13 @@ TclFileAttrsCmd( int TclFileLinkCmd( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Tcl_Obj *contents; int index; - Tcl_DString ds; if (objc < 2 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, "?-linktype? linkname ?target?"); @@ -1247,12 +1211,6 @@ TclFileLinkCmd( if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) { return TCL_ERROR; } - if (Tcl_UtfToExternalDStringEx(interp, TCLFSENCODING, TclGetString(objv[index]), - TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { - Tcl_DStringFree(&ds); - return TCL_ERROR; - } - Tcl_DStringFree(&ds); /* * Create link from source to target. @@ -1310,12 +1268,6 @@ TclFileLinkCmd( if (Tcl_FSConvertToPathType(interp, objv[index]) != TCL_OK) { return TCL_ERROR; } - if (Tcl_UtfToExternalDStringEx(interp, TCLFSENCODING, TclGetString(objv[index]), - TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { - Tcl_DStringFree(&ds); - return TCL_ERROR; - } - Tcl_DStringFree(&ds); /* * Read link @@ -1361,13 +1313,12 @@ TclFileLinkCmd( int TclFileReadLinkCmd( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Tcl_Obj *contents; - Tcl_DString ds; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "name"); @@ -1377,12 +1328,6 @@ TclFileReadLinkCmd( if (Tcl_FSConvertToPathType(interp, objv[1]) != TCL_OK) { return TCL_ERROR; } - if (Tcl_UtfToExternalDStringEx(interp, TCLFSENCODING, TclGetString(objv[1]), - TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { - Tcl_DStringFree(&ds); - return TCL_ERROR; - } - Tcl_DStringFree(&ds); contents = Tcl_FSLink(objv[1], NULL, 0); @@ -1419,7 +1364,7 @@ TclFileReadLinkCmd( int TclFileTemporaryCmd( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -1444,7 +1389,7 @@ TclFileTemporaryCmd( TclNewObj(nameObj); } if (objc > 2) { - Tcl_Size length; + int length; Tcl_Obj *templateObj = objv[2]; const char *string = TclGetStringFromObj(templateObj, &length); @@ -1578,7 +1523,7 @@ TclFileTemporaryCmd( int TclFileTempDirCmd( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) @@ -1596,7 +1541,7 @@ TclFileTempDirCmd( } if (objc > 1) { - Tcl_Size length; + int length; Tcl_Obj *templateObj = objv[1]; const char *string = TclGetStringFromObj(templateObj, &length); const int onWindows = (tclPlatform == TCL_PLATFORM_WINDOWS); @@ -1734,7 +1679,7 @@ TclFileHomeCmd( Tcl_WrongNumArgs(interp, 1, objv, "?user?"); return TCL_ERROR; } - homeDirObj = TclGetHomeDirObj(interp, objc == 1 ? NULL : Tcl_GetString(objv[1])); + homeDirObj = TclGetHomeDirObj(interp, objc == 1 ? NULL : TclGetString(objv[1])); if (homeDirObj == NULL) { return TCL_ERROR; } diff --git a/generic/tclFileName.c b/generic/tclFileName.c index c99244c..5679a6c 100644 --- a/generic/tclFileName.c +++ b/generic/tclFileName.c @@ -26,6 +26,8 @@ TclPlatformType tclPlatform = TCL_PLATFORM_UNIX; * Prototypes for local procedures defined in this file: */ +static const char * DoTildeSubst(Tcl_Interp *interp, + const char *user, Tcl_DString *resultPtr); static const char * ExtractWinRoot(const char *path, Tcl_DString *resultPtr, int offset, Tcl_PathType *typePtr); @@ -41,8 +43,11 @@ static int TclGlob(Tcl_Interp *interp, char *pattern, /* Flag values used by TclGlob() */ -#define TCL_GLOBMODE_DIR 4 -#define TCL_GLOBMODE_TAILS 8 +#ifdef TCL_NO_DEPRECATED +# define TCL_GLOBMODE_NO_COMPLAIN 1 +# define TCL_GLOBMODE_DIR 4 +# define TCL_GLOBMODE_TAILS 8 +#endif /* * When there is no support for getting the block size of a file in a stat() @@ -113,14 +118,14 @@ ExtractWinRoot( { int extended = 0; - if ( (path[0] == '/' || path[0] == '\\') - && (path[1] == '/' || path[1] == '\\') - && (path[2] == '?') - && (path[3] == '/' || path[3] == '\\')) { + if ( (path[0] == '/' || path[0] == '\\') + && (path[1] == '/' || path[1] == '\\') + && (path[2] == '?') + && (path[3] == '/' || path[3] == '\\')) { extended = 1; path = path + 4; if (path[0] == 'U' && path[1] == 'N' && path[2] == 'C' - && (path[3] == '/' || path[3] == '\\')) { + && (path[3] == '/' || path[3] == '\\')) { extended = 2; path = path + 4; } @@ -368,6 +373,12 @@ Tcl_GetPathType( * file). The exported function Tcl_FSGetPathType should be used by * extensions. * + * Note that '~' paths are always considered TCL_PATH_ABSOLUTE, even + * though expanding the '~' could lead to any possible path type. This + * function should therefore be considered a low-level, string + * manipulation function only -- it doesn't actually do any expansion in + * making its determination. + * * Results: * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or * TCL_PATH_VOLUME_RELATIVE. @@ -381,60 +392,76 @@ Tcl_GetPathType( Tcl_PathType TclpGetNativePathType( Tcl_Obj *pathPtr, /* Native path of interest */ - Tcl_Size *driveNameLengthPtr, /* Returns length of drive, if non-NULL and - * path was absolute */ + int *driveNameLengthPtr, /* Returns length of drive, if non-NULL and + * path was absolute */ Tcl_Obj **driveNameRef) { Tcl_PathType type = TCL_PATH_ABSOLUTE; - const char *path = TclGetString(pathPtr); + int pathLen; + const char *path = TclGetStringFromObj(pathPtr, &pathLen); - switch (tclPlatform) { - case TCL_PLATFORM_UNIX: { - const char *origPath = path; - - /* - * Paths that begin with / are absolute. - */ - - if (path[0] == '/') { - ++path; - /* - * Check for "//" network path prefix - */ - if ((*path == '/') && path[1] && (path[1] != '/')) { - path += 2; - while (*path && *path != '/') { - ++path; - } - } - if (driveNameLengthPtr != NULL) { - /* - * We need this addition in case the "//" code was used. - */ - - *driveNameLengthPtr = (path - origPath); - } - } else { - type = TCL_PATH_RELATIVE; - } - break; - } - case TCL_PLATFORM_WINDOWS: { - Tcl_DString ds; - const char *rootEnd; - - Tcl_DStringInit(&ds); - rootEnd = ExtractWinRoot(path, &ds, 0, &type); - if ((rootEnd != path) && (driveNameLengthPtr != NULL)) { - *driveNameLengthPtr = rootEnd - path; - if (driveNameRef != NULL) { - *driveNameRef = Tcl_DStringToObj(&ds); - Tcl_IncrRefCount(*driveNameRef); - } - } - Tcl_DStringFree(&ds); - break; - } + if (path[0] == '~') { + /* + * This case is common to all platforms. Paths that begin with ~ are + * absolute. + */ + + if (driveNameLengthPtr != NULL) { + const char *end = path + 1; + while ((*end != '\0') && (*end != '/')) { + end++; + } + *driveNameLengthPtr = end - path; + } + } else { + switch (tclPlatform) { + case TCL_PLATFORM_UNIX: { + const char *origPath = path; + + /* + * Paths that begin with / are absolute. + */ + + if (path[0] == '/') { + ++path; + /* + * Check for "//" network path prefix + */ + if ((*path == '/') && path[1] && (path[1] != '/')) { + path += 2; + while (*path && *path != '/') { + ++path; + } + } + if (driveNameLengthPtr != NULL) { + /* + * We need this addition in case the "//" code was used. + */ + + *driveNameLengthPtr = (path - origPath); + } + } else { + type = TCL_PATH_RELATIVE; + } + break; + } + case TCL_PLATFORM_WINDOWS: { + Tcl_DString ds; + const char *rootEnd; + + Tcl_DStringInit(&ds); + rootEnd = ExtractWinRoot(path, &ds, 0, &type); + if ((rootEnd != path) && (driveNameLengthPtr != NULL)) { + *driveNameLengthPtr = rootEnd - path; + if (driveNameRef != NULL) { + *driveNameRef = Tcl_DStringToObj(&ds); + Tcl_IncrRefCount(*driveNameRef); + } + } + Tcl_DStringFree(&ds); + break; + } + } } return type; } @@ -465,7 +492,7 @@ TclpGetNativePathType( Tcl_Obj * TclpNativeSplitPath( Tcl_Obj *pathPtr, /* Path to split. */ - Tcl_Size *lenPtr) /* int to store number of path elements. */ + int *lenPtr) /* int to store number of path elements. */ { Tcl_Obj *resultPtr = NULL; /* Needed only to prevent gcc warnings. */ @@ -508,7 +535,7 @@ TclpNativeSplitPath( * *argcPtr will get filled in with the number of valid elements in the * array. A single block of memory is dynamically allocated to hold both * the argv array and a copy of the path elements. The caller must - * eventually free this memory by calling Tcl_Free() on *argvPtr. Note: + * eventually free this memory by calling ckfree() on *argvPtr. Note: * *argvPtr and *argcPtr are only modified if the procedure returns * normally. * @@ -522,14 +549,14 @@ TclpNativeSplitPath( void Tcl_SplitPath( const char *path, /* Pointer to string containing a path. */ - Tcl_Size *argcPtr, /* Pointer to location to fill in with the + int *argcPtr, /* Pointer to location to fill in with the * number of elements in the path. */ const char ***argvPtr) /* Pointer to place to store pointer to array * of pointers to path elements. */ { Tcl_Obj *resultPtr = NULL; /* Needed only to prevent gcc warnings. */ Tcl_Obj *tmpPtr, *eltPtr; - Tcl_Size i, size, len; + int i, size, len; char *p; const char *str; @@ -550,7 +577,7 @@ Tcl_SplitPath( size = 1; for (i = 0; i < *argcPtr; i++) { Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr); - (void)TclGetStringFromObj(eltPtr, &len); + TclGetStringFromObj(eltPtr, &len); size += len + 1; } @@ -559,7 +586,7 @@ Tcl_SplitPath( * plus the argv pointers and the terminating NULL pointer. */ - *argvPtr = (const char **)Tcl_Alloc( + *argvPtr = (const char **)ckalloc( ((((*argcPtr) + 1) * sizeof(char *)) + size)); /* @@ -583,7 +610,7 @@ Tcl_SplitPath( for (i = 0; i < *argcPtr; i++) { (*argvPtr)[i] = p; - while (*(p++) != '\0'); + for (; *(p++)!='\0'; ); } (*argvPtr)[i] = NULL; @@ -615,7 +642,7 @@ static Tcl_Obj * SplitUnixPath( const char *path) /* Pointer to string containing a path. */ { - size_t length; + int length; const char *origPath = path, *elementStart; Tcl_Obj *result; @@ -644,7 +671,8 @@ SplitUnixPath( } /* - * Split on slashes. + * Split on slashes. Embedded elements that start with tilde will be + * prefixed with "./" so they are not affected by tilde substitution. */ for (;;) { @@ -655,8 +683,13 @@ SplitUnixPath( length = path - elementStart; if (length > 0) { Tcl_Obj *nextElt; - nextElt = Tcl_NewStringObj(elementStart, length); - Tcl_ListObjAppendElement(NULL, result, nextElt); + if ((elementStart[0] == '~') && (elementStart != origPath)) { + TclNewLiteralStringObj(nextElt, "./"); + Tcl_AppendToObj(nextElt, elementStart, length); + } else { + nextElt = Tcl_NewStringObj(elementStart, length); + } + Tcl_ListObjAppendElement(NULL, result, nextElt); } if (*path++ == '\0') { break; @@ -686,7 +719,7 @@ static Tcl_Obj * SplitWinPath( const char *path) /* Pointer to string containing a path. */ { - size_t length; + int length; const char *p, *elementStart; Tcl_PathType type = TCL_PATH_ABSOLUTE; Tcl_DString buf; @@ -706,7 +739,9 @@ SplitWinPath( Tcl_DStringFree(&buf); /* - * Split on slashes. + * Split on slashes. Embedded elements that start with tilde or a drive + * letter will be prefixed with "./" so they are not affected by tilde + * substitution. */ do { @@ -717,9 +752,9 @@ SplitWinPath( length = p - elementStart; if (length > 0) { Tcl_Obj *nextElt; - if ((elementStart != path) && - isalpha(UCHAR(elementStart[0])) && - (elementStart[1] == ':')) { + if ((elementStart != path) && ((elementStart[0] == '~') + || (isalpha(UCHAR(elementStart[0])) + && elementStart[1] == ':'))) { TclNewLiteralStringObj(nextElt, "./"); Tcl_AppendToObj(nextElt, elementStart, length); } else { @@ -758,7 +793,7 @@ SplitWinPath( Tcl_Obj * Tcl_FSJoinToPath( Tcl_Obj *pathPtr, /* Valid path or NULL. */ - Tcl_Size objc, /* Number of array elements to join */ + int objc, /* Number of array elements to join */ Tcl_Obj *const objv[]) /* Path elements to join. */ { if (pathPtr == NULL) { @@ -774,13 +809,13 @@ Tcl_FSJoinToPath( pair[1] = objv[0]; return TclJoinPath(2, pair, 0); } else { - Tcl_Size elemc = objc + 1; - Tcl_Obj *ret, **elemv = (Tcl_Obj**)Tcl_Alloc(elemc*sizeof(Tcl_Obj *)); + int elemc = objc + 1; + Tcl_Obj *ret, **elemv = (Tcl_Obj**)ckalloc(elemc*sizeof(Tcl_Obj *)); elemv[0] = pathPtr; memcpy(elemv+1, objv, objc*sizeof(Tcl_Obj *)); ret = TclJoinPath(elemc, elemv, 0); - Tcl_Free(elemv); + ckfree(elemv); return ret; } } @@ -806,8 +841,7 @@ TclpNativeJoinPath( Tcl_Obj *prefix, const char *joining) { - int needsSep; - Tcl_Size length; + int length, needsSep; char *dest; const char *p; const char *start; @@ -815,16 +849,16 @@ TclpNativeJoinPath( start = TclGetStringFromObj(prefix, &length); /* - * Remove the ./ from drive-letter prefixed + * Remove the ./ from tilde prefixed elements, and drive-letter prefixed * elements on Windows, unless it is the first component. */ p = joining; if (length != 0) { - if ((p[0] == '.') && (p[1] == '/') && - (tclPlatform==TCL_PLATFORM_WINDOWS) && isalpha(UCHAR(p[2])) - && (p[3] == ':')) { + if ((p[0] == '.') && (p[1] == '/') && ((p[2] == '~') + || (tclPlatform==TCL_PLATFORM_WINDOWS && isalpha(UCHAR(p[2])) + && (p[3] == ':')))) { p += 2; } } @@ -840,7 +874,7 @@ TclpNativeJoinPath( if (length > 0 && (start[length-1] != '/')) { Tcl_AppendToObj(prefix, "/", 1); - (void)TclGetStringFromObj(prefix, &length); + TclGetStringFromObj(prefix, &length); } needsSep = 0; @@ -848,7 +882,7 @@ TclpNativeJoinPath( * Append the element, eliminating duplicate and trailing slashes. */ - Tcl_SetObjLength(prefix, length + strlen(p)); + Tcl_SetObjLength(prefix, length + (int) strlen(p)); dest = TclGetString(prefix) + length; for (; *p != '\0'; p++) { @@ -876,7 +910,7 @@ TclpNativeJoinPath( if ((length > 0) && (start[length-1] != '/') && (start[length-1] != ':')) { Tcl_AppendToObj(prefix, "/", 1); - (void)TclGetStringFromObj(prefix, &length); + TclGetStringFromObj(prefix, &length); } needsSep = 0; @@ -927,11 +961,11 @@ TclpNativeJoinPath( char * Tcl_JoinPath( - Tcl_Size argc, + int argc, const char *const *argv, Tcl_DString *resultPtr) /* Pointer to previously initialized DString */ { - Tcl_Size i, len; + int i, len; Tcl_Obj *listObj; Tcl_Obj *resultObj; const char *resultStr; @@ -976,15 +1010,19 @@ Tcl_JoinPath( * Tcl_TranslateFileName -- * * Converts a file name into a form usable by the native system - * interfaces. + * interfaces. If the name starts with a tilde, it will produce a name + * where the tilde and following characters have been replaced by the + * home directory location for the named user. * * Results: - * The return value is a pointer to a string containing the name. - * This may either be the name pointer passed in or space allocated in - * bufferPtr. In all cases, if the return value is not NULL, the caller - * must call Tcl_DStringFree() to free the space. If there was an + * The return value is a pointer to a string containing the name after + * tilde substitution. If there was no tilde substitution, the return + * value is a pointer to a copy of the original string. If there was an * error in processing the name, then an error message is left in the * interp's result (if interp was not NULL) and the return value is NULL. + * Space for the return value is allocated in bufferPtr; the caller must + * call Tcl_DStringFree() to free the space if the return value was not + * NULL. * * Side effects: * None. @@ -1001,7 +1039,7 @@ Tcl_TranslateFileName( * "~<user>" (to indicate any user's home * directory). */ Tcl_DString *bufferPtr) /* Uninitialized or free DString filled with - * name. */ + * name after tilde substitution. */ { Tcl_Obj *path = Tcl_NewStringObj(name, -1); Tcl_Obj *transPtr; @@ -1096,6 +1134,65 @@ TclGetExtension( /* *---------------------------------------------------------------------- * + * DoTildeSubst -- + * + * Given a string following a tilde, this routine returns the + * corresponding home directory. + * + * Results: + * The result is a pointer to a static string containing the home + * directory in native format. If there was an error in processing the + * substitution, then an error message is left in the interp's result and + * the return value is NULL. On success, the results are appended to + * resultPtr, and the contents of resultPtr are returned. + * + * Side effects: + * Information may be left in resultPtr. + * + *---------------------------------------------------------------------- + */ + +static const char * +DoTildeSubst( + Tcl_Interp *interp, /* Interpreter in which to store error message + * (if necessary). */ + const char *user, /* Name of user whose home directory should be + * substituted, or "" for current user. */ + Tcl_DString *resultPtr) /* Initialized DString filled with name after + * tilde substitution. */ +{ + const char *dir; + + if (*user == '\0') { + Tcl_DString dirString; + + dir = TclGetEnv("HOME", &dirString); + if (dir == NULL) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "couldn't find HOME environment " + "variable to expand path", -1)); + Tcl_SetErrorCode(interp, "TCL", "FILENAME", "NO_HOME", (char *)NULL); + } + return NULL; + } + Tcl_JoinPath(1, &dir, resultPtr); + Tcl_DStringFree(&dirString); + } else if (TclpGetUserHome(user, resultPtr) == NULL) { + if (interp) { + Tcl_ResetResult(interp); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "user \"%s\" doesn't exist", user)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "USER", user, (char *)NULL); + } + return NULL; + } + return Tcl_DStringValue(resultPtr); +} + +/* + *---------------------------------------------------------------------- + * * Tcl_GlobObjCmd -- * * This procedure is invoked to process the "glob" Tcl command. See the @@ -1112,13 +1209,12 @@ TclGetExtension( int Tcl_GlobObjCmd( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int i, globFlags, join, dir, result; - Tcl_Size length; + int index, i, globFlags, length, join, dir, result; char *string; const char *separators; Tcl_Obj *typePtr, *look; @@ -1131,7 +1227,7 @@ Tcl_GlobObjCmd( enum globOptionsEnum { GLOB_DIR, GLOB_JOIN, GLOB_NOCOMPLAIN, GLOB_PATH, GLOB_TAILS, GLOB_TYPE, GLOB_LAST - } index; + }; enum pathDirOptions {PATH_NONE = -1 , PATH_GENERAL = 0, PATH_DIR = 1}; Tcl_GlobTypeData *globTypes = NULL; @@ -1140,9 +1236,9 @@ Tcl_GlobObjCmd( dir = PATH_NONE; typePtr = NULL; for (i = 1; i < objc; i++) { - if (Tcl_GetIndexFromObj(interp, objv[i], options, - "option", 0, &index) != TCL_OK) { - string = TclGetString(objv[i]); + if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, + &index) != TCL_OK) { + string = TclGetStringFromObj(objv[i], &length); if (string[0] == '-') { /* * It looks like the command contains an option so signal an @@ -1161,18 +1257,15 @@ Tcl_GlobObjCmd( } } - switch (index) { + switch ((enum globOptionsEnum) index) { case GLOB_NOCOMPLAIN: /* -nocomplain */ - /* - * Do nothing; This is normal operations in Tcl 9. - * Keep accepting as a no-op option to accommodate old scripts. - */ + globFlags |= TCL_GLOBMODE_NO_COMPLAIN; break; case GLOB_DIR: /* -dir */ if (i == (objc-1)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing argument to \"-directory\"", -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (void *)NULL); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (char *)NULL); return TCL_ERROR; } if (dir != PATH_NONE) { @@ -1182,7 +1275,7 @@ Tcl_GlobObjCmd( : "\"-directory\" cannot be used with \"-path\"", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", - "BADOPTIONCOMBINATION", (void *)NULL); + "BADOPTIONCOMBINATION", (char *)NULL); return TCL_ERROR; } dir = PATH_DIR; @@ -1200,7 +1293,7 @@ Tcl_GlobObjCmd( if (i == (objc-1)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing argument to \"-path\"", -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (void *)NULL); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (char *)NULL); return TCL_ERROR; } if (dir != PATH_NONE) { @@ -1210,7 +1303,7 @@ Tcl_GlobObjCmd( : "\"-path\" cannot be used with \"-dictionary\"", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", - "BADOPTIONCOMBINATION", (void *)NULL); + "BADOPTIONCOMBINATION", (char *)NULL); return TCL_ERROR; } dir = PATH_GENERAL; @@ -1221,7 +1314,7 @@ Tcl_GlobObjCmd( if (i == (objc-1)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "missing argument to \"-types\"", -1)); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (void *)NULL); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", (char *)NULL); return TCL_ERROR; } typePtr = objv[i+1]; @@ -1242,7 +1335,7 @@ Tcl_GlobObjCmd( "\"-tails\" must be used with either " "\"-directory\" or \"-path\"", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", - "BADOPTIONCOMBINATION", (void *)NULL); + "BADOPTIONCOMBINATION", (char *)NULL); return TCL_ERROR; } @@ -1257,7 +1350,7 @@ Tcl_GlobObjCmd( } if (dir == PATH_GENERAL) { - Tcl_Size pathlength; + int pathlength; const char *last; const char *first = TclGetStringFromObj(pathOrDir,&pathlength); @@ -1267,7 +1360,7 @@ Tcl_GlobObjCmd( last = first + pathlength; for (; last != first; last--) { - if (strchr(separators, last[-1]) != NULL) { + if (strchr(separators, *(last-1)) != NULL) { break; } } @@ -1352,7 +1445,7 @@ Tcl_GlobObjCmd( */ TclListObjLength(interp, typePtr, &length); - if (length == 0) { + if (length <= 0) { goto skipTypes; } globTypes = (Tcl_GlobTypeData *)TclStackAlloc(interp, sizeof(Tcl_GlobTypeData)); @@ -1361,8 +1454,8 @@ Tcl_GlobObjCmd( globTypes->macType = NULL; globTypes->macCreator = NULL; - while (length-- > 0) { - Tcl_Size len; + while (--length >= 0) { + int len; const char *str; Tcl_ListObjIndex(interp, typePtr, length, &look); @@ -1420,10 +1513,9 @@ Tcl_GlobObjCmd( } else { Tcl_Obj *item; - Tcl_Size llen; - if ((TclListObjLength(NULL, look, &llen) == TCL_OK) - && (llen == 3)) { + if ((TclListObjLength(NULL, look, &len) == TCL_OK) + && (len == 3)) { Tcl_ListObjIndex(interp, look, 0, &item); if (!strcmp("macintosh", TclGetString(item))) { Tcl_ListObjIndex(interp, look, 1, &item); @@ -1456,7 +1548,7 @@ Tcl_GlobObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad argument to \"-types\": %s", TclGetString(look))); - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", (void *)NULL); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", (char *)NULL); result = TCL_ERROR; join = 0; goto endOfGlob; @@ -1466,7 +1558,7 @@ Tcl_GlobObjCmd( "only one MacOS type or creator argument" " to \"-types\" allowed", -1)); result = TCL_ERROR; - Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", (void *)NULL); + Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", (char *)NULL); join = 0; goto endOfGlob; } @@ -1528,6 +1620,41 @@ Tcl_GlobObjCmd( } } + if ((globFlags & TCL_GLOBMODE_NO_COMPLAIN) == 0) { + if (TclListObjLength(interp, Tcl_GetObjResult(interp), + &length) != TCL_OK) { + /* + * This should never happen. Maybe we should be more dramatic. + */ + + result = TCL_ERROR; + goto endOfGlob; + } + + if (length == 0) { + Tcl_Obj *errorMsg = + Tcl_ObjPrintf("no files matched glob pattern%s \"", + (join || (objc == 1)) ? "" : "s"); + + if (join) { + Tcl_AppendToObj(errorMsg, Tcl_DStringValue(&prefix), -1); + } else { + const char *sep = ""; + + for (i = 0; i < objc; i++) { + Tcl_AppendPrintfToObj(errorMsg, "%s%s", + sep, TclGetString(objv[i])); + sep = " "; + } + } + Tcl_AppendToObj(errorMsg, "\"", -1); + Tcl_SetObjResult(interp, errorMsg); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "NOMATCH", + (char *)NULL); + result = TCL_ERROR; + } + } + endOfGlob: if (join || (dir == PATH_GENERAL)) { Tcl_DStringFree(&prefix); @@ -1552,7 +1679,8 @@ Tcl_GlobObjCmd( * * TclGlob -- * - * Sets the separator string based on the platform and calls DoGlob. + * Sets the separator string based on the platform, performs tilde + * substitution, and calls DoGlob. * * The interpreter's result, on entry to this function, must be a valid * Tcl list (e.g. it could be empty), since we will lappend any new @@ -1588,7 +1716,8 @@ TclGlob( * NULL. */ { const char *separators; - char *tail; + const char *head; + char *tail, *start; int result; Tcl_Obj *filenamesObj, *savedResultObj; @@ -1602,10 +1731,60 @@ TclGlob( break; } - if (pathPrefix != NULL) { + if (pathPrefix == NULL) { + char c; + Tcl_DString buffer; + Tcl_DStringInit(&buffer); + + start = pattern; + + /* + * Perform tilde substitution, if needed. + */ + + if (start[0] == '~') { + /* + * Find the first path separator after the tilde. + */ + + for (tail = start; *tail != '\0'; tail++) { + if (*tail == '\\') { + if (strchr(separators, tail[1]) != NULL) { + break; + } + } else if (strchr(separators, *tail) != NULL) { + break; + } + } + + /* + * Determine the home directory for the specified user. + */ + + c = *tail; + *tail = '\0'; + head = DoTildeSubst(interp, start+1, &buffer); + *tail = c; + if (head == NULL) { + return TCL_ERROR; + } + if (head != Tcl_DStringValue(&buffer)) { + Tcl_DStringAppend(&buffer, head, -1); + } + pathPrefix = Tcl_DStringToObj(&buffer); + Tcl_IncrRefCount(pathPrefix); + globFlags |= TCL_GLOBMODE_DIR; + if (c != '\0') { + tail++; + } + Tcl_DStringFree(&buffer); + } else { + tail = pattern; + } + } else { Tcl_IncrRefCount(pathPrefix); + tail = pattern; } - tail = pattern; /* * Handling empty path prefixes with glob patterns like 'C:' or @@ -1644,7 +1823,7 @@ TclGlob( Tcl_IncrRefCount(pathPrefix); } else if (pathPrefix == NULL && (tail[0] == '/' || (tail[0] == '\\' && tail[1] == '\\'))) { - Tcl_Size driveNameLen; + int driveNameLen; Tcl_Obj *driveName; Tcl_Obj *temp = Tcl_NewStringObj(tail, -1); Tcl_IncrRefCount(temp); @@ -1712,9 +1891,9 @@ TclGlob( */ if (pathPrefix == NULL) { - Tcl_Size driveNameLen; + int driveNameLen; Tcl_Obj *driveName; - if (TclFSNonnativePathType(tail, strlen(tail), NULL, + if (TclFSNonnativePathType(tail, (int) strlen(tail), NULL, &driveNameLen, &driveName) == TCL_PATH_ABSOLUTE) { pathPrefix = driveName; tail += driveNameLen; @@ -1797,9 +1976,9 @@ TclGlob( */ if (globFlags & TCL_GLOBMODE_TAILS) { - Tcl_Size objc, i; + int objc, i; Tcl_Obj **objv; - Tcl_Size prefixLen; + int prefixLen; const char *pre; /* @@ -1827,7 +2006,7 @@ TclGlob( TclListObjGetElements(NULL, filenamesObj, &objc, &objv); for (i = 0; i< objc; i++) { - Tcl_Size len; + int len; const char *oldStr = TclGetStringFromObj(objv[i], &len); Tcl_Obj *elem; @@ -2037,14 +2216,14 @@ DoGlob( Tcl_SetObjResult(interp, Tcl_NewStringObj( "unmatched open-brace in file name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BALANCE", - (void *)NULL); + (char *)NULL); return TCL_ERROR; } else if (*p == '}') { Tcl_SetObjResult(interp, Tcl_NewStringObj( "unmatched close-brace in file name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BALANCE", - (void *)NULL); + (char *)NULL); return TCL_ERROR; } } @@ -2149,7 +2328,7 @@ DoGlob( pattern, &dirOnly); *p = save; if (result == TCL_OK) { - Tcl_Size i, subdirc, repair = -1; + int subdirc, i, repair = -1; Tcl_Obj **subdirv; result = TclListObjGetElements(interp, subdirsPtr, @@ -2157,17 +2336,24 @@ DoGlob( for (i=0; result==TCL_OK && i<subdirc; i++) { Tcl_Obj *copy = NULL; + if (pathPtr == NULL && TclGetString(subdirv[i])[0] == '~') { + TclListObjLength(NULL, matchesObj, &repair); + copy = subdirv[i]; + subdirv[i] = Tcl_NewStringObj("./", 2); + Tcl_AppendObjToObj(subdirv[i], copy); + Tcl_IncrRefCount(subdirv[i]); + } result = DoGlob(interp, matchesObj, separators, subdirv[i], 1, p+1, types); if (copy) { - Tcl_Size end; + int end; Tcl_DecrRefCount(subdirv[i]); subdirv[i] = copy; TclListObjLength(NULL, matchesObj, &end); while (repair < end) { const char *bytes; - Tcl_Size numBytes; + int numBytes; Tcl_Obj *fixme, *newObj; Tcl_ListObjIndex(NULL, matchesObj, repair, &fixme); @@ -2177,7 +2363,7 @@ DoGlob( 1, &newObj); repair++; } - repair = TCL_INDEX_NONE; + repair = -1; } } } @@ -2190,7 +2376,7 @@ DoGlob( */ if (*p == '\0') { - Tcl_Size length; + int length; Tcl_DString append; /* @@ -2254,7 +2440,7 @@ DoGlob( * The current prefix must end in a separator. */ - Tcl_Size len; + int len; const char *joined = TclGetStringFromObj(joinedPtr,&len); if ((len > 0) && (strchr(separators, joined[len-1]) == NULL)) { @@ -2291,7 +2477,7 @@ DoGlob( * This behaviour is not currently tested for in the test suite. */ - Tcl_Size len; + int len; const char *joined = TclGetStringFromObj(joinedPtr,&len); if ((len > 0) && (strchr(separators, joined[len-1]) == NULL)) { @@ -2321,7 +2507,7 @@ DoGlob( * * Results: * A pointer to a Tcl_StatBuf which may be deallocated by being passed to - * Tcl_Free(). + * ckfree(). * * Side effects: * None. @@ -2332,7 +2518,7 @@ DoGlob( Tcl_StatBuf * Tcl_AllocStatBuf(void) { - return (Tcl_StatBuf *)Tcl_Alloc(sizeof(Tcl_StatBuf)); + return (Tcl_StatBuf *)ckalloc(sizeof(Tcl_StatBuf)); } /* @@ -2341,8 +2527,8 @@ Tcl_AllocStatBuf(void) * Access functions for Tcl_StatBuf -- * * These functions provide portable read-only access to the portable - * fields of the Tcl_StatBuf structure (really a 'struct stat' - * or something else related). [TIP #316] + * fields of the Tcl_StatBuf structure (really a 'struct stat', 'struct + * stat64' or something else related). [TIP #316] * * Results: * The value from the field being retrieved. diff --git a/generic/tclFileSystem.h b/generic/tclFileSystem.h index e986d34..503b204 100644 --- a/generic/tclFileSystem.h +++ b/generic/tclFileSystem.h @@ -48,13 +48,13 @@ MODULE_SCOPE const Tcl_Filesystem tclNativeFilesystem; MODULE_SCOPE Tcl_PathType TclFSGetPathType(Tcl_Obj *pathPtr, const Tcl_Filesystem **filesystemPtrPtr, - Tcl_Size *driveNameLengthPtr); + int *driveNameLengthPtr); MODULE_SCOPE Tcl_PathType TclFSNonnativePathType(const char *pathPtr, - Tcl_Size pathLen, const Tcl_Filesystem **filesystemPtrPtr, - Tcl_Size *driveNameLengthPtr, Tcl_Obj **driveNameRef); + int pathLen, const Tcl_Filesystem **filesystemPtrPtr, + int *driveNameLengthPtr, Tcl_Obj **driveNameRef); MODULE_SCOPE Tcl_PathType TclGetPathType(Tcl_Obj *pathPtr, const Tcl_Filesystem **filesystemPtrPtr, - Tcl_Size *driveNameLengthPtr, Tcl_Obj **driveNameRef); + int *driveNameLengthPtr, Tcl_Obj **driveNameRef); MODULE_SCOPE int TclFSEpochOk(size_t filesystemEpoch); MODULE_SCOPE int TclFSCwdIsNative(void); MODULE_SCOPE Tcl_Obj * TclWinVolumeRelativeNormalize(Tcl_Interp *interp, diff --git a/generic/tclGetDate.y b/generic/tclGetDate.y index 3b04de4..bfe1663 100644 --- a/generic/tclGetDate.y +++ b/generic/tclGetDate.y @@ -58,8 +58,8 @@ #include "tclDate.h" -#define YYMALLOC Tcl_Alloc -#define YYFREE(x) (Tcl_Free((void*) (x))) +#define YYMALLOC ckalloc +#define YYFREE(x) (ckree((void*) (x))) #define EPOCH 1970 #define START_OF_TIME 1902 diff --git a/generic/tclHash.c b/generic/tclHash.c index 5be07cb..c72dc6d 100644 --- a/generic/tclHash.c +++ b/generic/tclHash.c @@ -14,6 +14,13 @@ #include "tclInt.h" /* + * Prevent macros from clashing with function definitions. + */ + +#undef Tcl_FindHashEntry +#undef Tcl_CreateHashEntry + +/* * When there are this many entries per bucket, on average, rebuild the hash * table to make it larger. */ @@ -28,7 +35,7 @@ */ #define RANDOM_INDEX(tablePtr, i) \ - ((((i)*(size_t)1103515245) >> (tablePtr)->downShift) & (tablePtr)->mask) + ((((i)*1103515245UL) >> (tablePtr)->downShift) & (tablePtr)->mask) /* * Prototypes for the array hash key methods. @@ -36,7 +43,7 @@ static Tcl_HashEntry * AllocArrayEntry(Tcl_HashTable *tablePtr, void *keyPtr); static int CompareArrayKeys(void *keyPtr, Tcl_HashEntry *hPtr); -static size_t HashArrayKey(Tcl_HashTable *tablePtr, void *keyPtr); +static TCL_HASH_TYPE HashArrayKey(Tcl_HashTable *tablePtr, void *keyPtr); /* * Prototypes for the string hash key methods. @@ -45,7 +52,7 @@ static size_t HashArrayKey(Tcl_HashTable *tablePtr, void *keyPtr); static Tcl_HashEntry * AllocStringEntry(Tcl_HashTable *tablePtr, void *keyPtr); static int CompareStringKeys(void *keyPtr, Tcl_HashEntry *hPtr); -static size_t HashStringKey(Tcl_HashTable *tablePtr, void *keyPtr); +static TCL_HASH_TYPE HashStringKey(Tcl_HashTable *tablePtr, void *keyPtr); /* * Function prototypes for static functions in this file: @@ -193,7 +200,7 @@ Tcl_InitCustomHashTable( /* *---------------------------------------------------------------------- * - * FindHashEntry -- + * Tcl_FindHashEntry -- * * Given a hash table find the entry with a matching key. * @@ -207,6 +214,14 @@ Tcl_InitCustomHashTable( *---------------------------------------------------------------------- */ +Tcl_HashEntry * +Tcl_FindHashEntry( + Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */ + const void *key) /* Key to use to find matching entry. */ +{ + return (*((tablePtr)->findProc))(tablePtr, (const char *)key); +} + static Tcl_HashEntry * FindHashEntry( Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */ @@ -219,7 +234,7 @@ FindHashEntry( /* *---------------------------------------------------------------------- * - * CreateHashEntry -- + * Tcl_CreateHashEntry -- * * Given a hash table with string keys, and a string key, find the entry * with a matching key. If there is no matching entry, then create a new @@ -237,6 +252,17 @@ FindHashEntry( *---------------------------------------------------------------------- */ +Tcl_HashEntry * +Tcl_CreateHashEntry( + Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */ + const void *key, /* Key to use to find or create matching + * entry. */ + int *newPtr) /* Store info here telling whether a new entry + * was created. */ +{ + return (*((tablePtr)->createProc))(tablePtr, (const char *)key, newPtr); +} + static Tcl_HashEntry * CreateHashEntry( Tcl_HashTable *tablePtr, /* Table in which to lookup entry. */ @@ -247,7 +273,7 @@ CreateHashEntry( { Tcl_HashEntry *hPtr; const Tcl_HashKeyType *typePtr; - size_t hash, index; + TCL_HASH_TYPE hash, index; if (tablePtr->keyType == TCL_STRING_KEYS) { typePtr = &tclStringHashKeyType; @@ -281,12 +307,13 @@ CreateHashEntry( if (typePtr->flags & TCL_HASH_KEY_DIRECT_COMPARE) { for (hPtr = tablePtr->buckets[index]; hPtr != NULL; hPtr = hPtr->nextPtr) { - if (hash != hPtr->hash) { + if (hash != PTR2UINT(hPtr->hash)) { continue; } /* if keys pointers or values are equal */ if ((key == hPtr->key.oneWordValue) - || compareKeysProc((void *) key, hPtr)) { + || compareKeysProc((void *) key, hPtr) + ) { if (newPtr) { *newPtr = 0; } @@ -296,7 +323,7 @@ CreateHashEntry( } else { /* no direct compare - compare key addresses only */ for (hPtr = tablePtr->buckets[index]; hPtr != NULL; hPtr = hPtr->nextPtr) { - if (hash != hPtr->hash) { + if (hash != PTR2UINT(hPtr->hash)) { continue; } /* if needle pointer equals content pointer or values equal */ @@ -313,7 +340,7 @@ CreateHashEntry( } else { for (hPtr = tablePtr->buckets[index]; hPtr != NULL; hPtr = hPtr->nextPtr) { - if (hash != hPtr->hash) { + if (hash != PTR2UINT(hPtr->hash)) { continue; } if (key == hPtr->key.oneWordValue) { @@ -337,13 +364,13 @@ CreateHashEntry( if (typePtr->allocEntryProc) { hPtr = typePtr->allocEntryProc(tablePtr, (void *) key); } else { - hPtr = (Tcl_HashEntry *)Tcl_Alloc(sizeof(Tcl_HashEntry)); + hPtr = (Tcl_HashEntry *)ckalloc(sizeof(Tcl_HashEntry)); hPtr->key.oneWordValue = (char *) key; Tcl_SetHashValue(hPtr, NULL); } hPtr->tablePtr = tablePtr; - hPtr->hash = hash; + hPtr->hash = UINT2PTR(hash); hPtr->nextPtr = tablePtr->buckets[index]; tablePtr->buckets[index] = hPtr; tablePtr->numEntries++; @@ -385,7 +412,7 @@ Tcl_DeleteHashEntry( const Tcl_HashKeyType *typePtr; Tcl_HashTable *tablePtr; Tcl_HashEntry **bucketPtr; - size_t index; + TCL_HASH_TYPE index; tablePtr = entryPtr->tablePtr; @@ -402,9 +429,9 @@ Tcl_DeleteHashEntry( if (typePtr->hashKeyProc == NULL || typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) { - index = RANDOM_INDEX(tablePtr, entryPtr->hash); + index = RANDOM_INDEX(tablePtr, PTR2UINT(entryPtr->hash)); } else { - index = entryPtr->hash & tablePtr->mask; + index = PTR2UINT(entryPtr->hash) & tablePtr->mask; } bucketPtr = &tablePtr->buckets[index]; @@ -427,7 +454,7 @@ Tcl_DeleteHashEntry( if (typePtr->freeEntryProc) { typePtr->freeEntryProc(entryPtr); } else { - Tcl_Free(entryPtr); + ckfree(entryPtr); } } @@ -454,7 +481,7 @@ Tcl_DeleteHashTable( { Tcl_HashEntry *hPtr, *nextPtr; const Tcl_HashKeyType *typePtr; - Tcl_Size i; + int i; if (tablePtr->keyType == TCL_STRING_KEYS) { typePtr = &tclStringHashKeyType; @@ -478,7 +505,7 @@ Tcl_DeleteHashTable( if (typePtr->freeEntryProc) { typePtr->freeEntryProc(hPtr); } else { - Tcl_Free(hPtr); + ckfree(hPtr); } hPtr = nextPtr; } @@ -492,7 +519,7 @@ Tcl_DeleteHashTable( if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) { TclpSysFree((char *) tablePtr->buckets); } else { - Tcl_Free(tablePtr->buckets); + ckfree(tablePtr->buckets); } } @@ -603,8 +630,8 @@ Tcl_HashStats( Tcl_HashTable *tablePtr) /* Table for which to produce stats. */ { #define NUM_COUNTERS 10 - Tcl_Size i; - size_t count[NUM_COUNTERS], overflow, j; + int i; + TCL_HASH_TYPE count[NUM_COUNTERS], overflow, j; double average, tmp; Tcl_HashEntry *hPtr; char *result, *p; @@ -638,7 +665,7 @@ Tcl_HashStats( * Print out the histogram and a few other pieces of information. */ - result = (char *)Tcl_Alloc((NUM_COUNTERS * 60) + 300); + result = (char *)ckalloc((NUM_COUNTERS * 60) + 300); snprintf(result, 60, "%" TCL_SIZE_MODIFIER "u entries in table, %" TCL_SIZE_MODIFIER "u buckets\n", tablePtr->numEntries, tablePtr->numBuckets); p = result + strlen(result); @@ -676,13 +703,13 @@ AllocArrayEntry( void *keyPtr) /* Key to store in the hash table entry. */ { Tcl_HashEntry *hPtr; - size_t count = tablePtr->keyType * sizeof(int); - size_t size = offsetof(Tcl_HashEntry, key) + count; + TCL_HASH_TYPE count = tablePtr->keyType * sizeof(int); + TCL_HASH_TYPE size = offsetof(Tcl_HashEntry, key) + count; if (size < sizeof(Tcl_HashEntry)) { size = sizeof(Tcl_HashEntry); } - hPtr = (Tcl_HashEntry *)Tcl_Alloc(size); + hPtr = (Tcl_HashEntry *)ckalloc(size); memcpy(hPtr->key.string, keyPtr, count); Tcl_SetHashValue(hPtr, NULL); @@ -735,13 +762,13 @@ CompareArrayKeys( *---------------------------------------------------------------------- */ -static size_t +static TCL_HASH_TYPE HashArrayKey( Tcl_HashTable *tablePtr, /* Hash table. */ void *keyPtr) /* Key from which to compute hash value. */ { const int *array = (const int *) keyPtr; - size_t result; + TCL_HASH_TYPE result; int count; for (result = 0, count = tablePtr->keyType; count > 0; @@ -780,7 +807,7 @@ AllocStringEntry( if (size < sizeof(hPtr->key)) { allocsize = sizeof(hPtr->key); } - hPtr = (Tcl_HashEntry *)Tcl_Alloc(offsetof(Tcl_HashEntry, key) + allocsize); + hPtr = (Tcl_HashEntry *)ckalloc(offsetof(Tcl_HashEntry, key) + allocsize); memset(hPtr, 0, offsetof(Tcl_HashEntry, key) + allocsize); memcpy(hPtr->key.string, string, size); Tcl_SetHashValue(hPtr, NULL); @@ -829,13 +856,13 @@ CompareStringKeys( *---------------------------------------------------------------------- */ -static size_t +static TCL_HASH_TYPE HashStringKey( TCL_UNUSED(Tcl_HashTable *), void *keyPtr) /* Key from which to compute hash value. */ { const char *string = (const char *)keyPtr; - size_t result; + TCL_HASH_TYPE result; char c; /* @@ -953,7 +980,7 @@ static void RebuildTable( Tcl_HashTable *tablePtr) /* Table to enlarge. */ { - size_t count, index, oldSize = tablePtr->numBuckets; + TCL_HASH_TYPE count, index, oldSize = tablePtr->numBuckets; Tcl_HashEntry **oldBuckets = tablePtr->buckets; Tcl_HashEntry **oldChainPtr, **newChainPtr; Tcl_HashEntry *hPtr; @@ -984,10 +1011,10 @@ RebuildTable( tablePtr->numBuckets *= 4; if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) { tablePtr->buckets = (Tcl_HashEntry **)TclpSysAlloc( - tablePtr->numBuckets * sizeof(Tcl_HashEntry *)); + tablePtr->numBuckets * sizeof(Tcl_HashEntry *), 0); } else { tablePtr->buckets = - (Tcl_HashEntry **)Tcl_Alloc(tablePtr->numBuckets * sizeof(Tcl_HashEntry *)); + (Tcl_HashEntry **)ckalloc(tablePtr->numBuckets * sizeof(Tcl_HashEntry *)); } for (count = tablePtr->numBuckets, newChainPtr = tablePtr->buckets; count > 0; count--, newChainPtr++) { @@ -1008,9 +1035,9 @@ RebuildTable( *oldChainPtr = hPtr->nextPtr; if (typePtr->hashKeyProc == NULL || typePtr->flags & TCL_HASH_KEY_RANDOMIZE_HASH) { - index = RANDOM_INDEX(tablePtr, hPtr->hash); + index = RANDOM_INDEX(tablePtr, PTR2UINT(hPtr->hash)); } else { - index = hPtr->hash & tablePtr->mask; + index = PTR2UINT(hPtr->hash) & tablePtr->mask; } hPtr->nextPtr = tablePtr->buckets[index]; tablePtr->buckets[index] = hPtr; @@ -1025,7 +1052,7 @@ RebuildTable( if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) { TclpSysFree((char *) oldBuckets); } else { - Tcl_Free(oldBuckets); + ckfree(oldBuckets); } } } diff --git a/generic/tclHistory.c b/generic/tclHistory.c index dc5a67d..f7d9ec8 100644 --- a/generic/tclHistory.c +++ b/generic/tclHistory.c @@ -58,8 +58,9 @@ Tcl_RecordAndEval( const char *cmd, /* Command to record. */ int flags) /* Additional flags. TCL_NO_EVAL means only * record: don't execute command. - * TCL_EVAL_GLOBAL means use Tcl_GlobalEval - * instead of Tcl_Eval. */ + * TCL_EVAL_GLOBAL means evaluate the script + * in global variable context instead of the + * current procedure. */ { Tcl_Obj *cmdPtr; int result; @@ -74,6 +75,13 @@ Tcl_RecordAndEval( result = Tcl_RecordAndEvalObj(interp, cmdPtr, flags); /* + * Move the interpreter's object result to the string result, then + * reset the object result. + */ + + (void) Tcl_GetStringResult(interp); + + /* * Discard the Tcl object created to hold the command. */ @@ -130,7 +138,7 @@ Tcl_RecordAndEvalObj( */ if (histObjsPtr == NULL) { - histObjsPtr = (HistoryObjs *)Tcl_Alloc(sizeof(HistoryObjs)); + histObjsPtr = (HistoryObjs *)ckalloc(sizeof(HistoryObjs)); TclNewLiteralStringObj(histObjsPtr->historyObj, "::history"); TclNewLiteralStringObj(histObjsPtr->addObj, "add"); Tcl_IncrRefCount(histObjsPtr->historyObj); @@ -203,14 +211,14 @@ Tcl_RecordAndEvalObj( static void DeleteHistoryObjs( - void *clientData, + ClientData clientData, TCL_UNUSED(Tcl_Interp *)) { HistoryObjs *histObjsPtr = (HistoryObjs *)clientData; TclDecrRefCount(histObjsPtr->historyObj); TclDecrRefCount(histObjsPtr->addObj); - Tcl_Free(histObjsPtr); + ckfree(histObjsPtr); } /* diff --git a/generic/tclIO.c b/generic/tclIO.c index 78cda5c..9cdf1aa 100644 --- a/generic/tclIO.c +++ b/generic/tclIO.c @@ -176,8 +176,6 @@ static int CloseWrite(Tcl_Interp *interp, Channel *chanPtr); static void CommonGetsCleanup(Channel *chanPtr); static int CopyData(CopyState *csPtr, int mask); static void DeleteTimerHandler(ChannelState *statePtr); -static int Lossless(ChannelState *inStatePtr, - ChannelState *outStatePtr, long long toRead); static int MoveBytes(CopyState *csPtr); static void MBCallback(CopyState *csPtr, Tcl_Obj *errObj); @@ -207,7 +205,7 @@ static int FlushChannel(Tcl_Interp *interp, Channel *chanPtr, int calledFromAsyncFlush); static int TclGetsObjBinary(Tcl_Channel chan, Tcl_Obj *objPtr); static Tcl_Encoding GetBinaryEncoding(void); -static void FreeBinaryEncoding(void); +static Tcl_ExitProc FreeBinaryEncoding; static Tcl_HashTable * GetChannelTable(Tcl_Interp *interp); static int GetInput(Channel *chanPtr); static void PeekAhead(Channel *chanPtr, char **dstEndPtr, @@ -338,13 +336,9 @@ static const Tcl_ObjType chanObjType = { FreeChannelInternalRep, /* freeIntRepProc */ DupChannelInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ - NULL, /* setFromAnyProc */ - TCL_OBJTYPE_V0 + NULL /* setFromAnyProc */ }; -#define GetIso88591() \ - (binaryEncoding ? Tcl_GetEncoding(NULL, "iso8859-1") : binaryEncoding) - #define ChanSetInternalRep(objPtr, resPtr) \ do { \ Tcl_ObjInternalRep ir; \ @@ -384,6 +378,11 @@ ChanClose( Channel *chanPtr, Tcl_Interp *interp) { +#ifndef TCL_NO_DEPRECATED + if ((chanPtr->typePtr->closeProc != TCL_CLOSE2PROC) && (chanPtr->typePtr->closeProc != NULL)) { + return chanPtr->typePtr->closeProc(chanPtr->instanceData, interp); + } +#endif return chanPtr->typePtr->close2Proc(chanPtr->instanceData, interp, 0); } @@ -435,7 +434,7 @@ ChanRead( } ResetFlag(chanPtr->state, CHANNEL_BLOCKED | CHANNEL_EOF); chanPtr->state->inputEncodingFlags &= ~TCL_ENCODING_END; - if (WillRead(chanPtr) == -1) { + if (WillRead(chanPtr) < 0) { return -1; } @@ -451,7 +450,7 @@ ChanRead( } ResetFlag(chanPtr->state, CHANNEL_BLOCKED | CHANNEL_EOF); chanPtr->state->inputEncodingFlags &= ~TCL_ENCODING_END; - if (bytesRead == -1) { + if (bytesRead < 0) { if ((result == EWOULDBLOCK) || (result == EAGAIN)) { SetFlag(chanPtr->state, CHANNEL_BLOCKED); result = EAGAIN; @@ -488,8 +487,18 @@ ChanSeek( */ if (Tcl_ChannelWideSeekProc(chanPtr->typePtr) == NULL) { +#ifndef TCL_NO_DEPRECATED + if (offset<LONG_MIN || offset>LONG_MAX) { + *errnoPtr = EOVERFLOW; + return TCL_INDEX_NONE; + } + + return Tcl_ChannelSeekProc(chanPtr->typePtr)(chanPtr->instanceData, + offset, mode, errnoPtr); +#else *errnoPtr = EINVAL; return TCL_INDEX_NONE; +#endif } return Tcl_ChannelWideSeekProc(chanPtr->typePtr)(chanPtr->instanceData, @@ -668,7 +677,7 @@ TclFinalizeIOSubsystem(void) * interpreter will close the channel when it gets destroyed. */ - (void) Tcl_CloseEx(NULL, (Tcl_Channel) chanPtr, 0); + (void) Tcl_Close(NULL, (Tcl_Channel) chanPtr); } else { /* * The refcount is greater than zero, so flush the channel. @@ -697,7 +706,6 @@ TclFinalizeIOSubsystem(void) } } - FreeBinaryEncoding(); TclpFinalizeSockets(); TclpFinalizePipes(); } @@ -739,10 +747,6 @@ Tcl_SetStdChannel( case TCL_STDERR: tsdPtr->stderrInitialized = init; tsdPtr->stderrChannel = channel; - if (channel) { - ENCODING_PROFILE_SET(((Channel *)channel)->state->inputEncodingFlags, TCL_ENCODING_PROFILE_REPLACE); - ENCODING_PROFILE_SET(((Channel *)channel)->state->outputEncodingFlags, TCL_ENCODING_PROFILE_REPLACE); - } break; } } @@ -813,8 +817,6 @@ Tcl_GetStdChannel( tsdPtr->stderrInitialized = -1; tsdPtr->stderrChannel = TclpGetDefaultStdChannel(TCL_STDERR); if (tsdPtr->stderrChannel != NULL) { - ENCODING_PROFILE_SET(((Channel *)tsdPtr->stderrChannel)->state->inputEncodingFlags, TCL_ENCODING_PROFILE_REPLACE); - ENCODING_PROFILE_SET(((Channel *)tsdPtr->stderrChannel)->state->outputEncodingFlags, TCL_ENCODING_PROFILE_REPLACE); tsdPtr->stderrInitialized = 1; Tcl_RegisterChannel(NULL, tsdPtr->stderrChannel); } @@ -855,7 +857,7 @@ Tcl_CreateCloseHandler( ChannelState *statePtr = ((Channel *) chan)->state; CloseCallback *cbPtr; - cbPtr = (CloseCallback *)Tcl_Alloc(sizeof(CloseCallback)); + cbPtr = (CloseCallback *)ckalloc(sizeof(CloseCallback)); cbPtr->proc = proc; cbPtr->clientData = clientData; @@ -901,7 +903,7 @@ Tcl_DeleteCloseHandler( } else { cbPrevPtr->nextPtr = cbPtr->nextPtr; } - Tcl_Free(cbPtr); + ckfree(cbPtr); break; } cbPrevPtr = cbPtr; @@ -936,7 +938,7 @@ GetChannelTable( hTblPtr = (Tcl_HashTable *)Tcl_GetAssocData(interp, "tclIO", NULL); if (hTblPtr == NULL) { - hTblPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); + hTblPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(hTblPtr, TCL_STRING_KEYS); Tcl_SetAssocData(interp, "tclIO", (Tcl_InterpDeleteProc *) DeleteChannelTable, hTblPtr); @@ -1028,7 +1030,7 @@ DeleteChannelTable( TclChannelEventScriptInvoker, sPtr); TclDecrRefCount(sPtr->scriptPtr); - Tcl_Free(sPtr); + ckfree(sPtr); } else { prevPtr = sPtr; } @@ -1045,13 +1047,13 @@ DeleteChannelTable( statePtr->epoch++; if (statePtr->refCount-- <= 1) { if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED)) { - (void) Tcl_CloseEx(interp, (Tcl_Channel) chanPtr, 0); + (void) Tcl_Close(interp, (Tcl_Channel) chanPtr); } } } Tcl_DeleteHashTable(hTblPtr); - Tcl_Free(hTblPtr); + ckfree(hTblPtr); } /* @@ -1268,11 +1270,11 @@ Tcl_UnregisterChannel( Tcl_Preserve(statePtr); if (!GotFlag(statePtr, BG_FLUSH_SCHEDULED)) { /* - * We don't want to re-enter Tcl_CloseEx(). + * We don't want to re-enter Tcl_Close(). */ if (!GotFlag(statePtr, CHANNEL_CLOSED)) { - if (Tcl_CloseEx(interp, chan, 0) != TCL_OK) { + if (Tcl_Close(interp, chan) != TCL_OK) { SetFlag(statePtr, CHANNEL_CLOSED); Tcl_Release(statePtr); return TCL_ERROR; @@ -1555,16 +1557,16 @@ TclGetChannelFromObj( if (resPtr && resPtr->refCount == 1) { /* Re-use the ResolvedCmdName struct */ - Tcl_Release(resPtr->statePtr); + Tcl_Release((void *)resPtr->statePtr); } else { - resPtr = (ResolvedChanName *) Tcl_Alloc(sizeof(ResolvedChanName)); + resPtr = (ResolvedChanName *) ckalloc(sizeof(ResolvedChanName)); resPtr->refCount = 0; ChanSetInternalRep(objPtr, resPtr); /* Overwrites, if needed */ } statePtr = ((Channel *)chan)->state; resPtr->statePtr = statePtr; - Tcl_Preserve(statePtr); + Tcl_Preserve((void *) statePtr); resPtr->interp = interp; resPtr->epoch = statePtr->epoch; @@ -1609,15 +1611,30 @@ Tcl_CreateChannel( char *tmp; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - if (typePtr->typeName == NULL) { - Tcl_Panic("channel does not have a type name"); + /* + * With the change of the Tcl_ChannelType structure to use a version in + * 8.3.2+, we have to make sure that our assumption that the structure + * remains a binary compatible size is true. + * + * If this assertion fails on some system, then it can be removed only if + * the user recompiles code with older channel drivers in the new system + * as well. + */ + + assert(sizeof(Tcl_ChannelTypeVersion) == sizeof(Tcl_DriverBlockModeProc *)); + assert(typePtr->typeName != NULL); +#ifndef TCL_NO_DEPRECATED + if (((NULL == typePtr->closeProc) || (TCL_CLOSE2PROC == typePtr->closeProc)) && (typePtr->close2Proc == NULL)) { + Tcl_Panic("channel type %s must define closeProc or close2Proc", typePtr->typeName); } - if (Tcl_ChannelVersion(typePtr) != TCL_CHANNEL_VERSION_5) { +#else + if (Tcl_ChannelVersion(typePtr) < TCL_CHANNEL_VERSION_5) { Tcl_Panic("channel type %s must be version TCL_CHANNEL_VERSION_5", typePtr->typeName); } if (typePtr->close2Proc == NULL) { Tcl_Panic("channel type %s must define close2Proc", typePtr->typeName); } +#endif if ((TCL_READABLE & mask) && (NULL == typePtr->inputProc)) { Tcl_Panic("channel type %s must define inputProc when used for reader channel", typePtr->typeName); } @@ -1627,14 +1644,19 @@ Tcl_CreateChannel( if (NULL == typePtr->watchProc) { Tcl_Panic("channel type %s must define watchProc", typePtr->typeName); } +#ifndef TCL_NO_DEPRECATED + if ((NULL != typePtr->wideSeekProc) && (NULL == typePtr->seekProc)) { + Tcl_Panic("channel type %s must define seekProc if defining wideSeekProc", typePtr->typeName); + } +#endif /* * JH: We could subsequently memset these to 0 to avoid the numerous * assignments to 0/NULL below. */ - chanPtr = (Channel *)Tcl_Alloc(sizeof(Channel)); - statePtr = (ChannelState *)Tcl_Alloc(sizeof(ChannelState)); + chanPtr = (Channel *)ckalloc(sizeof(Channel)); + statePtr = (ChannelState *)ckalloc(sizeof(ChannelState)); chanPtr->state = statePtr; chanPtr->instanceData = instanceData; @@ -1653,10 +1675,10 @@ Tcl_CreateChannel( * later. */ - tmp = (char *)Tcl_Alloc((len < 7) ? 7 : len); + tmp = (char *)ckalloc((len < 7) ? 7 : len); strcpy(tmp, chanName); } else { - tmp = (char *)Tcl_Alloc(7); + tmp = (char *)ckalloc(7); tmp[0] = '\0'; } statePtr->channelName = tmp; @@ -1673,12 +1695,19 @@ Tcl_CreateChannel( * interpretation that Tcl_Channels give to the "-encoding binary" option. */ + statePtr->encoding = NULL; name = Tcl_GetEncodingName(NULL); - statePtr->encoding = Tcl_GetEncoding(NULL, name); + if (strcmp(name, "binary") != 0) { + statePtr->encoding = Tcl_GetEncoding(NULL, name); + } statePtr->inputEncodingState = NULL; statePtr->inputEncodingFlags = TCL_ENCODING_START; + ENCODING_PROFILE_SET(statePtr->inputEncodingFlags, + TCL_ENCODING_PROFILE_TCL8); statePtr->outputEncodingState = NULL; statePtr->outputEncodingFlags = TCL_ENCODING_START; + ENCODING_PROFILE_SET(statePtr->outputEncodingFlags, + TCL_ENCODING_PROFILE_TCL8); /* * Set the channel up initially in AUTO input translation mode to accept @@ -1691,6 +1720,7 @@ Tcl_CreateChannel( statePtr->inputTranslation = TCL_TRANSLATE_AUTO; statePtr->outputTranslation = TCL_PLATFORM_TRANSLATION; statePtr->inEofChar = 0; + statePtr->outEofChar = 0; statePtr->unreportedError = 0; statePtr->refCount = 0; @@ -1927,7 +1957,7 @@ Tcl_StackChannel( statePtr->inQueueTail = NULL; } - chanPtr = (Channel *)Tcl_Alloc(sizeof(Channel)); + chanPtr = (Channel *)ckalloc(sizeof(Channel)); /* * Save some of the current state into the new structure, reinitialize the @@ -1989,7 +2019,7 @@ TclChannelRelease( return; } if (chanPtr->typePtr == NULL) { - Tcl_Free(chanPtr); + ckfree(chanPtr); } } @@ -1998,7 +2028,7 @@ ChannelFree( Channel *chanPtr) { if (chanPtr->refCount == 0) { - Tcl_Free(chanPtr); + ckfree(chanPtr); return; } chanPtr->typePtr = NULL; @@ -2173,7 +2203,7 @@ Tcl_UnstackChannel( */ if (statePtr->refCount <= 0) { - if (Tcl_CloseEx(interp, chan, 0) != TCL_OK) { + if (Tcl_Close(interp, chan) != TCL_OK) { /* * TIP #219, Tcl Channel Reflection API. * "TclChanCaughtErrorBypass" is not required here, it was @@ -2507,7 +2537,7 @@ AllocChannelBuffer( Tcl_Size n; n = length + CHANNELBUFFER_HEADER_SIZE + BUFFER_PADDING + BUFFER_PADDING; - bufPtr = (ChannelBuffer *)Tcl_Alloc(n); + bufPtr = (ChannelBuffer *)ckalloc(n); bufPtr->nextAdded = BUFFER_PADDING; bufPtr->nextRemoved = BUFFER_PADDING; bufPtr->bufLength = length + BUFFER_PADDING; @@ -2533,7 +2563,7 @@ ReleaseChannelBuffer( if (--bufPtr->refCount) { return; } - Tcl_Free(bufPtr); + ckfree(bufPtr); } static int @@ -3080,6 +3110,18 @@ CloseChannel( } /* + * If the EOF character is set in the channel, append that to the output + * device. + */ + + if ((statePtr->outEofChar != 0) && GotFlag(statePtr, TCL_WRITABLE)) { + int dummy; + char c = (char) statePtr->outEofChar; + + (void) ChanWrite(chanPtr, &c, 1, &dummy); + } + + /* * TIP #219, Tcl Channel Reflection API. * Move a leftover error message in the channel bypass into the * interpreter bypass. Just clear it if there is no interpreter. @@ -3113,7 +3155,7 @@ CloseChannel( if (chanPtr == statePtr->bottomChanPtr) { if (statePtr->channelName != NULL) { - Tcl_Free(statePtr->channelName); + ckfree(statePtr->channelName); statePtr->channelName = NULL; } @@ -3170,7 +3212,7 @@ CloseChannel( ChannelFree(chanPtr); - return Tcl_CloseEx(interp, (Tcl_Channel) downChanPtr, 0); + return Tcl_Close(interp, (Tcl_Channel) downChanPtr); } /* @@ -3414,7 +3456,7 @@ Tcl_SpliceChannel( */ int -TclClose( +Tcl_Close( Tcl_Interp *interp, /* Interpreter for errors. */ Tcl_Channel chan) /* The channel being closed. Must not be * referenced in any interpreter. May be NULL, @@ -3471,8 +3513,7 @@ TclClose( stickyError = 0; - if (GotFlag(statePtr, TCL_WRITABLE) - && (statePtr->encoding != GetBinaryEncoding()) + if (GotFlag(statePtr, TCL_WRITABLE) && (statePtr->encoding != NULL) && !(statePtr->outputEncodingFlags & TCL_ENCODING_START)) { int code = CheckChannelErrors(statePtr, TCL_WRITABLE); @@ -3516,7 +3557,7 @@ TclClose( cbPtr = statePtr->closeCbPtr; statePtr->closeCbPtr = cbPtr->nextPtr; cbPtr->proc(cbPtr->clientData); - Tcl_Free(cbPtr); + ckfree(cbPtr); } ResetFlag(statePtr, CHANNEL_INCLOSE); @@ -3526,10 +3567,20 @@ TclClose( * it anymore and this will help avoid deadlocks on some channel types. */ +#ifndef TCL_NO_DEPRECATED + if ((chanPtr->typePtr->closeProc == TCL_CLOSE2PROC) || (chanPtr->typePtr->closeProc == NULL)) { + /* If this half-close gives a EINVAL or ENOTCONN, just continue the full close */ + result = chanPtr->typePtr->close2Proc(chanPtr->instanceData, interp, TCL_CLOSE_READ); + if ((result == EINVAL) || result == ENOTCONN) { + result = 0; + } + } +#else result = chanPtr->typePtr->close2Proc(chanPtr->instanceData, interp, TCL_CLOSE_READ); if ((result == EINVAL) || result == ENOTCONN) { result = 0; } +#endif /* * The call to FlushChannel will flush any queued output and invoke the @@ -3577,7 +3628,7 @@ TclClose( result = flushcode; } if ((result != 0) && (result != TCL_ERROR) && (interp != NULL) - && 0 == Tcl_GetCharLength(Tcl_GetObjResult(interp))) { + && 0 == TclGetCharLength(Tcl_GetObjResult(interp))) { Tcl_SetErrno(result); Tcl_SetObjResult(interp, Tcl_NewStringObj(Tcl_PosixError(interp), -1)); @@ -3626,7 +3677,7 @@ Tcl_CloseEx( statePtr = chanPtr->state; if ((flags & (TCL_READABLE | TCL_WRITABLE)) == 0) { - return TclClose(interp, chan); + return Tcl_Close(interp, chan); } if ((flags & (TCL_READABLE | TCL_WRITABLE)) == (TCL_READABLE | TCL_WRITABLE)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -3845,6 +3896,18 @@ CloseChannelPart( } /* + * If the EOF character is set in the channel, append that to the + * output device. + */ + + if ((statePtr->outEofChar != 0) && GotFlag(statePtr, TCL_WRITABLE)) { + int dummy; + char c = (char) statePtr->outEofChar; + + (void) ChanWrite(chanPtr, &c, 1, &dummy); + } + + /* * TIP #219, Tcl Channel Reflection API. * Move a leftover error message in the channel bypass into the * interpreter bypass. Just clear it if there is no interpreter. @@ -3981,7 +4044,7 @@ Tcl_ClearChannelHandlers( for (chPtr = statePtr->chPtr; chPtr != NULL; chPtr = chNext) { chNext = chPtr->nextPtr; - Tcl_Free(chPtr); + ckfree(chPtr); } statePtr->chPtr = NULL; @@ -4008,7 +4071,7 @@ Tcl_ClearChannelHandlers( for (ePtr = statePtr->scriptRecordPtr; ePtr != NULL; ePtr = eNextPtr) { eNextPtr = ePtr->nextPtr; TclDecrRefCount(ePtr->scriptPtr); - Tcl_Free(ePtr); + ckfree(ePtr); } statePtr->scriptRecordPtr = NULL; } @@ -4041,7 +4104,7 @@ Tcl_Size Tcl_Write( Tcl_Channel chan, /* The channel to buffer output for. */ const char *src, /* Data to queue in output buffer. */ - Tcl_Size srcLen) /* Length of data in bytes, or TCL_INDEX_NONE for + Tcl_Size srcLen) /* Length of data in bytes, or < 0 for * strlen(). */ { /* @@ -4058,10 +4121,10 @@ Tcl_Write( return TCL_INDEX_NONE; } - if (srcLen == TCL_INDEX_NONE) { + if (srcLen < 0) { srcLen = strlen(src); } - if (WriteBytes(chanPtr, src, srcLen) == -1) { + if (WriteBytes(chanPtr, src, srcLen) < 0) { return TCL_INDEX_NONE; } return srcLen; @@ -4108,7 +4171,7 @@ Tcl_WriteRaw( return TCL_INDEX_NONE; } - if (srcLen == TCL_INDEX_NONE) { + if (srcLen < 0) { srcLen = strlen(src); } @@ -4118,7 +4181,7 @@ Tcl_WriteRaw( */ written = ChanWrite(chanPtr, src, srcLen, &errorCode); - if (written == TCL_INDEX_NONE) { + if (written < 0) { Tcl_SetErrno(errorCode); } @@ -4167,7 +4230,7 @@ Tcl_WriteChars( chanPtr = statePtr->topChanPtr; - if (len == TCL_INDEX_NONE) { + if (len < 0) { len = strlen(src); } if (statePtr->encoding) { @@ -4186,13 +4249,8 @@ Tcl_WriteChars( } objPtr = Tcl_NewStringObj(src, len); - src = (char *) Tcl_GetBytesFromObj(NULL, objPtr, &len); - if (src == NULL) { - Tcl_SetErrno(EILSEQ); - result = TCL_INDEX_NONE; - } else { - result = WriteBytes(chanPtr, src, len); - } + src = (char *) Tcl_GetByteArrayFromObj(objPtr, &len); + result = WriteBytes(chanPtr, src, len); TclDecrRefCount(objPtr); return result; } @@ -4234,7 +4292,7 @@ Tcl_WriteObj( Channel *chanPtr; ChannelState *statePtr; /* State info for channel */ const char *src; - Tcl_Size srcLen = 0; + Tcl_Size srcLen; statePtr = ((Channel *) chan)->state; chanPtr = statePtr->topChanPtr; @@ -4243,16 +4301,8 @@ Tcl_WriteObj( return TCL_INDEX_NONE; } if (statePtr->encoding == NULL) { - Tcl_Size result; - - src = (char *) Tcl_GetBytesFromObj(NULL, objPtr, &srcLen); - if (src == NULL) { - Tcl_SetErrno(EILSEQ); - result = TCL_INDEX_NONE; - } else { - result = WriteBytes(chanPtr, src, srcLen); - } - return result; + src = (char *) Tcl_GetByteArrayFromObj(objPtr, &srcLen); + return WriteBytes(chanPtr, src, srcLen); } else { src = TclGetStringFromObj(objPtr, &srcLen); return WriteChars(chanPtr, src, srcLen); @@ -4265,8 +4315,11 @@ WillWrite( { int inputBuffered; - if ((Tcl_ChannelWideSeekProc(chanPtr->typePtr) != NULL) - && ((inputBuffered = Tcl_InputBuffered((Tcl_Channel) chanPtr)) > 0)){ + if (((Tcl_ChannelWideSeekProc(chanPtr->typePtr) != NULL) +#ifndef TCL_NO_DEPRECATED + || (Tcl_ChannelSeekProc(chanPtr->typePtr) != NULL) +#endif + ) && ((inputBuffered = Tcl_InputBuffered((Tcl_Channel) chanPtr)) > 0)){ int ignore; DiscardInputQueued(chanPtr->state, 0); @@ -4287,8 +4340,11 @@ WillRead( Tcl_SetErrno(EINVAL); return -1; } - if ((Tcl_ChannelWideSeekProc(chanPtr->typePtr) != NULL) - && (Tcl_OutputBuffered((Tcl_Channel) chanPtr) > 0)) { + if (((Tcl_ChannelWideSeekProc(chanPtr->typePtr) != NULL) +#ifndef TCL_NO_DEPRECATED + || (Tcl_ChannelSeekProc(chanPtr->typePtr) != NULL) +#endif + ) && (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 @@ -4404,11 +4460,16 @@ Write( * current output encoding and strict encoding is active. */ - if ((result == TCL_CONVERT_UNKNOWN || result == TCL_CONVERT_SYNTAX) || - /* - * We're reading from invalid/incomplete UTF-8. - */ - ((result != TCL_OK) && (srcRead + dstWrote == 0))) { + if (result == TCL_CONVERT_UNKNOWN || result == TCL_CONVERT_SYNTAX) { + encodingError = 1; + result = TCL_OK; + } + + if ((result != TCL_OK) && (srcRead + dstWrote == 0)) { + /* + * We're reading from invalid/incomplete UTF-8. + */ + encodingError = 1; result = TCL_OK; } @@ -4626,10 +4687,9 @@ Tcl_GetsObj( * done on objPtr. */ - if (statePtr->encoding == GetBinaryEncoding() + if ((statePtr->encoding == NULL) && ((statePtr->inputTranslation == TCL_TRANSLATE_LF) - || (statePtr->inputTranslation == TCL_TRANSLATE_CR)) - && Tcl_GetBytesFromObj(NULL, objPtr, (Tcl_Size *)NULL) != NULL) { + || (statePtr->inputTranslation == TCL_TRANSLATE_CR))) { return TclGetsObjBinary(chan, objPtr); } @@ -4657,6 +4717,15 @@ Tcl_GetsObj( } /* + * If there is no encoding, use "iso8859-1" -- Tcl_GetsObj() doesn't + * produce ByteArray objects. + */ + + if (encoding == NULL) { + encoding = GetBinaryEncoding(); + } + + /* * Object used by FilterInputBytes to keep track of how much data has been * consumed from the channel buffers. */ @@ -5039,7 +5108,7 @@ TclGetsObjBinary( /* State info for channel */ ChannelBuffer *bufPtr; int inEofChar, skip, copiedTotal, oldFlags, oldRemoved; - Tcl_Size rawLen, byteLen = 0, oldLength; + Tcl_Size rawLen, byteLen, oldLength; int eolChar; unsigned char *dst, *dstEnd, *eol, *eof, *byteArray; @@ -5057,11 +5126,7 @@ TclGetsObjBinary( * newline in the available input. */ - byteArray = Tcl_GetBytesFromObj(NULL, objPtr, &byteLen); - if (byteArray == NULL) { - Tcl_SetErrno(EILSEQ); - return -1; - } + byteArray = Tcl_GetByteArrayFromObj(objPtr, &byteLen); oldFlags = statePtr->inputEncodingFlags; oldRemoved = BUFFER_PADDING; oldLength = byteLen; @@ -5217,7 +5282,7 @@ TclGetsObjBinary( * XXX - unimplemented. */ - if (statePtr->encoding != GetBinaryEncoding()) { + if (statePtr->encoding != NULL) { } /* @@ -5295,7 +5360,8 @@ TclGetsObjBinary( */ static void -FreeBinaryEncoding(void) +FreeBinaryEncoding( + TCL_UNUSED(void *)) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -5312,6 +5378,7 @@ GetBinaryEncoding(void) if (tsdPtr->binaryEncoding == NULL) { tsdPtr->binaryEncoding = Tcl_GetEncoding(NULL, "iso8859-1"); + Tcl_CreateThreadExitHandler(FreeBinaryEncoding, NULL); } if (tsdPtr->binaryEncoding == NULL) { Tcl_Panic("binary encoding is not available"); @@ -5758,8 +5825,8 @@ Tcl_ReadRaw( while (chanPtr->inQueueHead && bytesToRead > 0) { ChannelBuffer *bufPtr = chanPtr->inQueueHead; int bytesInBuffer = BytesLeft(bufPtr); - int toCopy = (bytesInBuffer < (int)bytesToRead) ? bytesInBuffer - : (int)bytesToRead; + int toCopy = (bytesInBuffer < bytesToRead) ? bytesInBuffer + : bytesToRead; /* * Copy the current chunk into the read buffer. @@ -5802,7 +5869,7 @@ Tcl_ReadRaw( if (bytesToRead > 0) { int nread = ChanRead(chanPtr, readBuf, bytesToRead); - if (nread == -1) { + 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 @@ -5978,12 +6045,12 @@ DoReadChars( chanPtr = statePtr->topChanPtr; TclChannelPreserve((Tcl_Channel)chanPtr); - binaryMode = (encoding == GetBinaryEncoding()) + binaryMode = (encoding == NULL) && (statePtr->inputTranslation == TCL_TRANSLATE_LF) && (statePtr->inEofChar == '\0'); if (appendFlag) { - if (binaryMode && (NULL == Tcl_GetBytesFromObj(NULL, objPtr, (Tcl_Size *)NULL))) { + if (binaryMode && (NULL == Tcl_GetBytesFromObj(NULL, objPtr, NULL))) { binaryMode = 0; } } else { @@ -5991,6 +6058,16 @@ DoReadChars( Tcl_SetByteArrayLength(objPtr, 0); } else { Tcl_SetObjLength(objPtr, 0); + + /* + * We're going to access objPtr->bytes directly, so we must ensure + * that this is actually a string object (otherwise it might have + * been pure Unicode). + * + * Probably not needed anymore. + */ + + TclGetString(objPtr); } } @@ -6063,9 +6140,7 @@ DoReadChars( } } else { copied += copiedNow; - if (toRead != TCL_INDEX_NONE) { - toRead -= copiedNow; /* Only decr if not reading whole file */ - } + toRead -= copiedNow; } } @@ -6219,7 +6294,8 @@ ReadChars( * UTF-8. On output, contains another guess * based on the data seen so far. */ { - Tcl_Encoding encoding = statePtr->encoding; + Tcl_Encoding encoding = statePtr->encoding? statePtr->encoding + : GetBinaryEncoding(); Tcl_EncodingState savedState = statePtr->inputEncodingState; ChannelBuffer *bufPtr = statePtr->inQueueHead; int savedIEFlags = statePtr->inputEncodingFlags; @@ -6246,16 +6322,14 @@ ReadChars( int factor = *factorPtr; int dstLimit = TCL_UTF_MAX - 1 + toRead * factor / UTF_EXPANSION_FACTOR; - if (dstLimit <= 0) { - dstLimit = INT_MAX; /* avoid overflow */ - } + if (dstLimit <= 0) dstLimit = INT_MAX; /* avoid overflow */ (void) TclGetStringFromObj(objPtr, &numBytes); TclAppendUtfToUtf(objPtr, NULL, dstLimit); if (toRead == srcLen) { - Tcl_Size size; + unsigned int size; dst = TclGetStringStorage(objPtr, &size) + numBytes; - dstLimit = (size - numBytes) > INT_MAX ? INT_MAX : (size - numBytes); + dstLimit = size - numBytes; } else { dst = TclGetString(objPtr) + numBytes; } @@ -6486,7 +6560,7 @@ ReadChars( * bytes demanded by the Tcl_ExternalToUtf() call! */ - dstLimit = Tcl_UtfAtIndex(dst, charsToRead) - dst + (TCL_UTF_MAX - 1); + dstLimit = TclUtfAtIndex(dst, charsToRead) - dst + (TCL_UTF_MAX - 1); statePtr->flags = savedFlags; statePtr->inputEncodingFlags = savedIEFlags; statePtr->inputEncodingState = savedState; @@ -6725,7 +6799,7 @@ TranslateInputEOL( ResetFlag(statePtr, INPUT_SAW_CR); } lesser = (dstLen < srcLen) ? dstLen : srcLen; - while ((crFound = (const char *) memchr(src, '\r', lesser))) { + while ((crFound = (const char *)memchr(src, '\r', lesser))) { int numBytes = crFound - src; memmove(dst, src, numBytes); @@ -7068,7 +7142,7 @@ GetInput( bufPtr->nextPtr = NULL; toRead = SpaceLeft(bufPtr); - assert((Tcl_Size)toRead == statePtr->bufSize); + assert(toRead == statePtr->bufSize); if (statePtr->inQueueTail == NULL) { statePtr->inQueueHead = bufPtr; @@ -7158,7 +7232,11 @@ Tcl_Seek( * defined. This means that the channel does not support seeking. */ - if (Tcl_ChannelWideSeekProc(chanPtr->typePtr) == NULL) { + if ((Tcl_ChannelWideSeekProc(chanPtr->typePtr) == NULL) +#ifndef TCL_NO_DEPRECATED + && (Tcl_ChannelSeekProc(chanPtr->typePtr) == NULL) +#endif + ) { Tcl_SetErrno(EINVAL); return -1; } @@ -7322,7 +7400,11 @@ Tcl_Tell( * defined. This means that the channel does not support seeking. */ - if (Tcl_ChannelWideSeekProc(chanPtr->typePtr) == NULL) { + if ((Tcl_ChannelWideSeekProc(chanPtr->typePtr) == NULL) +#ifndef TCL_NO_DEPRECATED + && (Tcl_ChannelSeekProc(chanPtr->typePtr) == NULL) +#endif + ) { Tcl_SetErrno(EINVAL); return -1; } @@ -7408,7 +7490,7 @@ Tcl_TruncateChannel( WillWrite(chanPtr); - if (WillRead(chanPtr) == -1) { + if (WillRead(chanPtr) < 0) { return TCL_ERROR; } @@ -7865,7 +7947,7 @@ Tcl_BadChannelOption( Tcl_AppendPrintfToObj(errObj, "or -%s", argv[i]); Tcl_SetObjResult(interp, errObj); Tcl_DStringFree(&ds); - Tcl_Free((void *)argv); + ckfree(argv); } Tcl_SetErrno(EINVAL); return TCL_ERROR; @@ -7984,25 +8066,60 @@ Tcl_GetChannelOption( if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-encoding"); } - Tcl_DStringAppendElement(dsPtr, - Tcl_GetEncodingName(statePtr->encoding)); + if (statePtr->encoding == NULL) { + Tcl_DStringAppendElement(dsPtr, "binary"); + } else { + Tcl_DStringAppendElement(dsPtr, + Tcl_GetEncodingName(statePtr->encoding)); + } if (len > 0) { return TCL_OK; } } if (len == 0 || HaveOpt(2, "-eofchar")) { - char buf[4] = ""; if (len == 0) { Tcl_DStringAppendElement(dsPtr, "-eofchar"); } - if ((flags & TCL_READABLE) && (statePtr->inEofChar != 0)) { - snprintf(buf, sizeof(buf), "%c", statePtr->inEofChar); + if (((flags & (TCL_READABLE|TCL_WRITABLE)) == + (TCL_READABLE|TCL_WRITABLE)) && (len == 0)) { + Tcl_DStringStartSublist(dsPtr); + } + if (flags & TCL_READABLE) { + if (statePtr->inEofChar == 0) { + Tcl_DStringAppendElement(dsPtr, ""); + } else { + char buf[2]; + + buf[1] = '\0'; + buf[0] = statePtr->inEofChar; + Tcl_DStringAppendElement(dsPtr, buf); + } + } + if (flags & TCL_WRITABLE) { + if (statePtr->outEofChar == 0) { + Tcl_DStringAppendElement(dsPtr, ""); + } else { + char buf[2]; + + buf[1] = '\0'; + buf[0] = statePtr->outEofChar; + Tcl_DStringAppendElement(dsPtr, buf); + } + } + if (!(flags & (TCL_READABLE|TCL_WRITABLE))) { + /* + * Not readable or writable (e.g. server socket) + */ + + Tcl_DStringAppendElement(dsPtr, ""); + } + if (((flags & (TCL_READABLE|TCL_WRITABLE)) == + (TCL_READABLE|TCL_WRITABLE)) && (len == 0)) { + Tcl_DStringEndSublist(dsPtr); } if (len > 0) { - Tcl_DStringAppend(dsPtr, buf, -1); return TCL_OK; } - Tcl_DStringAppendElement(dsPtr, buf); } if (len == 0 || HaveOpt(1, "-profile")) { int profile; @@ -8183,19 +8300,9 @@ Tcl_SetChannelOption( } return TCL_OK; } else if (HaveOpt(7, "-buffersize")) { - Tcl_WideInt newBufferSize; - Tcl_Obj obj; - int code; - - obj.refCount = 1; - obj.bytes = (char *)newValue; - obj.length = strlen(newValue); - obj.typePtr = NULL; + int newBufferSize; - code = Tcl_GetWideIntFromObj(interp, &obj, &newBufferSize); - TclFreeInternalRep(&obj); - - if (code == TCL_ERROR) { + if (Tcl_GetInt(interp, newValue, &newBufferSize) == TCL_ERROR) { return TCL_ERROR; } Tcl_SetChannelBufferSize(chan, newBufferSize); @@ -8205,7 +8312,7 @@ Tcl_SetChannelOption( int profile; if ((newValue[0] == '\0') || (strcmp(newValue, "binary") == 0)) { - encoding = Tcl_GetEncoding(NULL, "iso8859-1"); + encoding = NULL; } else { encoding = Tcl_GetEncoding(interp, newValue); if (encoding == NULL) { @@ -8218,7 +8325,7 @@ Tcl_SetChannelOption( * iso2022, the terminated escape sequence must write to the buffer. */ - if ((statePtr->encoding != GetBinaryEncoding()) + if ((statePtr->encoding != NULL) && !(statePtr->outputEncodingFlags & TCL_ENCODING_START) && (CheckChannelErrors(statePtr, TCL_WRITABLE) == 0)) { statePtr->outputEncodingFlags |= TCL_ENCODING_END; @@ -8237,25 +8344,46 @@ Tcl_SetChannelOption( UpdateInterest(chanPtr); return TCL_OK; } else if (HaveOpt(2, "-eofchar")) { - if (!newValue[0] || (!(newValue[0] & 0x80) && (!newValue[1] -#ifndef TCL_NO_DEPRECATED - || !strcmp(newValue+1, " {}") -#endif - ))) { + if (!newValue[0] || (!(newValue[0] & 0x80) && !newValue[1])) { if (GotFlag(statePtr, TCL_READABLE)) { statePtr->inEofChar = newValue[0]; } + statePtr->outEofChar = 0; + } else if (Tcl_SplitList(interp, newValue, &argc, &argv) == TCL_ERROR) { + return TCL_ERROR; + } else if (argc == 0) { + statePtr->inEofChar = 0; + statePtr->outEofChar = 0; + } else if (argc == 1 || argc == 2) { + int inValue = (int) argv[0][0]; + int outValue = (argc == 2) ? (int) argv[1][0] : 0; + + if (inValue & 0x80 || outValue & 0x80) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "bad value for -eofchar: must be non-NUL ASCII" + " character", TCL_INDEX_NONE)); + } + ckfree(argv); + return TCL_ERROR; + } + if (GotFlag(statePtr, TCL_READABLE)) { + statePtr->inEofChar = inValue; + } + if (GotFlag(statePtr, TCL_WRITABLE)) { + statePtr->outEofChar = outValue; + } } else { if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "bad value for -eofchar: must be non-NUL ASCII" - " character", TCL_INDEX_NONE)); + "bad value for -eofchar: should be a list of zero," + " one, or two elements", TCL_INDEX_NONE)); } - Tcl_Free((void *)argv); + ckfree(argv); return TCL_ERROR; } if (argv != NULL) { - Tcl_Free((void *)argv); + ckfree(argv); } /* @@ -8298,7 +8426,7 @@ Tcl_SetChannelOption( "bad value for -translation: must be a one or two" " element list", -1)); } - Tcl_Free((void *)argv); + ckfree(argv); return TCL_ERROR; } @@ -8313,7 +8441,7 @@ Tcl_SetChannelOption( translation = TCL_TRANSLATE_LF; statePtr->inEofChar = 0; Tcl_FreeEncoding(statePtr->encoding); - statePtr->encoding = Tcl_GetEncoding(NULL, "iso8859-1"); + statePtr->encoding = NULL; } else if (strcmp(readMode, "lf") == 0) { translation = TCL_TRANSLATE_LF; } else if (strcmp(readMode, "cr") == 0) { @@ -8328,7 +8456,7 @@ Tcl_SetChannelOption( "bad value for -translation: must be one of " "auto, binary, cr, lf, crlf, or platform", -1)); } - Tcl_Free((void *)argv); + ckfree(argv); return TCL_ERROR; } @@ -8360,9 +8488,10 @@ Tcl_SetChannelOption( statePtr->outputTranslation = TCL_PLATFORM_TRANSLATION; } } else if (strcmp(writeMode, "binary") == 0) { + statePtr->outEofChar = 0; statePtr->outputTranslation = TCL_TRANSLATE_LF; Tcl_FreeEncoding(statePtr->encoding); - statePtr->encoding = Tcl_GetEncoding(NULL, "iso8859-1"); + statePtr->encoding = NULL; } else if (strcmp(writeMode, "lf") == 0) { statePtr->outputTranslation = TCL_TRANSLATE_LF; } else if (strcmp(writeMode, "cr") == 0) { @@ -8377,11 +8506,11 @@ Tcl_SetChannelOption( "bad value for -translation: must be one of " "auto, binary, cr, lf, crlf, or platform", -1)); } - Tcl_Free((void *)argv); + ckfree(argv); return TCL_ERROR; } } - Tcl_Free((void *)argv); + ckfree(argv); return TCL_OK; } else if (chanPtr->typePtr->setOptionProc != NULL) { return chanPtr->typePtr->setOptionProc(chanPtr->instanceData, interp, @@ -8440,7 +8569,7 @@ CleanupChannelHandlers( TclChannelEventScriptInvoker, sPtr); TclDecrRefCount(sPtr->scriptPtr); - Tcl_Free(sPtr); + ckfree(sPtr); } else { prevPtr = sPtr; } @@ -8866,7 +8995,7 @@ Tcl_CreateChannelHandler( } } if (chPtr == NULL) { - chPtr = (ChannelHandler *)Tcl_Alloc(sizeof(ChannelHandler)); + chPtr = (ChannelHandler *)ckalloc(sizeof(ChannelHandler)); chPtr->mask = 0; chPtr->proc = proc; chPtr->clientData = clientData; @@ -8970,7 +9099,7 @@ Tcl_DeleteChannelHandler( } else { prevChPtr->nextPtr = chPtr->nextPtr; } - Tcl_Free(chPtr); + ckfree(chPtr); /* * Recompute the interest list for the channel, so that infinite loops @@ -9029,7 +9158,7 @@ DeleteScriptRecord( TclChannelEventScriptInvoker, esPtr); TclDecrRefCount(esPtr->scriptPtr); - Tcl_Free(esPtr); + ckfree(esPtr); break; } @@ -9078,7 +9207,7 @@ CreateScriptRecord( makeCH = (esPtr == NULL); if (makeCH) { - esPtr = (EventScriptRecord *)Tcl_Alloc(sizeof(EventScriptRecord)); + esPtr = (EventScriptRecord *)ckalloc(sizeof(EventScriptRecord)); } /* @@ -9315,6 +9444,20 @@ ZeroTransferTimerProc( *---------------------------------------------------------------------- */ +#if !defined(TCL_NO_DEPRECATED) +int +TclCopyChannelOld( + Tcl_Interp *interp, /* Current interpreter. */ + Tcl_Channel inChan, /* Channel to read from. */ + Tcl_Channel outChan, /* Channel to write to. */ + int toRead, /* Amount of data to copy, or -1 for all. */ + Tcl_Obj *cmdPtr) /* Pointer to script to execute or NULL. */ +{ + return TclCopyChannel(interp, inChan, outChan, (Tcl_WideInt) toRead, + cmdPtr); +} +#endif + int TclCopyChannel( Tcl_Interp *interp, /* Current interpreter. */ @@ -9380,7 +9523,18 @@ TclCopyChannel( ResetFlag(outStatePtr, CHANNEL_LINEBUFFERED); SetFlag(outStatePtr, CHANNEL_UNBUFFERED); - moveBytes = Lossless(inStatePtr, outStatePtr, toRead); + /* + * Test for conditions where we know we can just move bytes from input + * channel to output channel with no transformation or even examination + * of the bytes themselves. + */ + + moveBytes = inStatePtr->inEofChar == '\0' /* No eofChar to stop input */ + && inStatePtr->inputTranslation == TCL_TRANSLATE_LF + && outStatePtr->outputTranslation == TCL_TRANSLATE_LF + && inStatePtr->encoding == outStatePtr->encoding + && ENCODING_PROFILE_GET(inStatePtr->inputEncodingFlags) == TCL_ENCODING_PROFILE_TCL8 + && ENCODING_PROFILE_GET(outStatePtr->outputEncodingFlags) == TCL_ENCODING_PROFILE_TCL8; /* * Allocate a new CopyState to maintain info about the current copy in @@ -9388,7 +9542,7 @@ TclCopyChannel( * completed. */ - csPtr = (CopyState *)Tcl_Alloc(offsetof(CopyState, buffer) + 1U + !moveBytes * inStatePtr->bufSize); + csPtr = (CopyState *)ckalloc(offsetof(CopyState, buffer) + 1U + !moveBytes * inStatePtr->bufSize); csPtr->bufSize = !moveBytes * inStatePtr->bufSize; csPtr->readPtr = inPtr; csPtr->writePtr = outPtr; @@ -9686,9 +9840,10 @@ CopyData( Tcl_Size sizeb; Tcl_Size sizePart; Tcl_WideInt total; - Tcl_WideInt size; + int size; const char *buffer; - int moveBytes; + int inBinary, outBinary, sameEncoding; + /* Encoding control */ int underflow; /* Input underflow */ inChan = (Tcl_Channel) csPtr->readPtr; @@ -9706,9 +9861,13 @@ CopyData( * the bottom of the stack. */ - moveBytes = Lossless(inStatePtr, outStatePtr, csPtr->toRead); + inBinary = (inStatePtr->encoding == NULL); + outBinary = (outStatePtr->encoding == NULL); + sameEncoding = inStatePtr->encoding == outStatePtr->encoding + && ENCODING_PROFILE_GET(inStatePtr->inputEncodingFlags) == TCL_ENCODING_PROFILE_TCL8 + && ENCODING_PROFILE_GET(outStatePtr->outputEncodingFlags) == TCL_ENCODING_PROFILE_TCL8; - if (!moveBytes) { + if (!(inBinary || sameEncoding)) { TclNewObj(bufObj); Tcl_IncrRefCount(bufObj); } @@ -9749,17 +9908,17 @@ CopyData( underflow = 1; } else { /* - * Read up to bufSize characters. + * Read up to bufSize bytes. */ if ((csPtr->toRead == (Tcl_WideInt) -1) || (csPtr->toRead > (Tcl_WideInt) csPtr->bufSize)) { sizeb = csPtr->bufSize; } else { - sizeb = csPtr->toRead; + sizeb = (int) csPtr->toRead; } - if (moveBytes) { + if (inBinary || sameEncoding) { size = DoRead(inStatePtr->topChanPtr, csPtr->buffer, sizeb, !GotFlag(inStatePtr, CHANNEL_NONBLOCKING)); } else { @@ -9843,20 +10002,25 @@ CopyData( * Now write the buffer out. */ - if (moveBytes) { + if (inBinary || sameEncoding) { buffer = csPtr->buffer; - sizeb = WriteBytes(outStatePtr->topChanPtr, buffer, size); + sizeb = size; } else { buffer = TclGetStringFromObj(bufObj, &sizeb); + } + + if (outBinary || sameEncoding) { + sizeb = WriteBytes(outStatePtr->topChanPtr, buffer, sizeb); + } else { sizeb = WriteChars(outStatePtr->topChanPtr, buffer, sizeb); } /* * [Bug 2895565]. At this point 'size' still contains the number of - * characters which have been read. We keep this to later to + * bytes or characters which have been read. We keep this to later to * update the totals and toRead information, see marker (UP) below. We * must not overwrite it with 'sizeb', which is the number of written - * characters, and both EOL translation and encoding + * bytes or characters, and both EOL translation and encoding * conversion may have changed this number unpredictably in relation * to 'size' (It can be smaller or larger, in the latter case able to * drive toRead below -1, causing infinite looping). Completely @@ -9883,10 +10047,10 @@ CopyData( } /* - * Update the current character count. Do it now so the count is valid + * Update the current byte count. Do it now so the count is valid * before a return or break takes us out of the loop. The invariant at * the top of the loop should be that csPtr->toRead holds the number - * of characters left to copy. + * of bytes left to copy. */ if (csPtr->toRead != -1) { @@ -9953,8 +10117,8 @@ CopyData( } /* - * Make the callback or return the number of characters transferred. The - * local total is used because StopCopy frees csPtr. + * Make the callback or return the number of bytes transferred. The local + * total is used because StopCopy frees csPtr. */ total = csPtr->total; @@ -10037,6 +10201,8 @@ DoRead( ChannelState *statePtr = chanPtr->state; char *p = dst; + assert(bytesToRead >= 0); + /* * Early out when we know a read will get the eofchar. * @@ -10095,7 +10261,7 @@ DoRead( while (!bufPtr || /* We got no buffer! OR */ (!IsBufferFull(bufPtr) && /* Our buffer has room AND */ - ((Tcl_Size) BytesLeft(bufPtr) < bytesToRead))) { + (BytesLeft(bufPtr) < bytesToRead))) { /* Not enough bytes in it yet * to fill the dst */ int code; @@ -10244,7 +10410,7 @@ DoRead( == (CHANNEL_EOF|CHANNEL_BLOCKED))); UpdateInterest(chanPtr); TclChannelRelease((Tcl_Channel)chanPtr); - return (Tcl_Size)(p - dst); + return (int)(p - dst); } /* @@ -10276,46 +10442,6 @@ CopyEventProc( /* *---------------------------------------------------------------------- * - * Lossless -- - * - * Determines whether copying characters between two channel states would - * be lossless, i.e. whether one byte corresponds to one character, every - * character appears in the Unicode character set, there are no - * translations to be performed, and no inline signals to respond to. - * - * Result: - * True if copying would be lossless. - * - *---------------------------------------------------------------------- - */ -int -Lossless( - ChannelState *inStatePtr, - ChannelState *outStatePtr, - long long toRead) -{ - return inStatePtr->inEofChar == '\0' /* No eofChar to stop input */ - && inStatePtr->inputTranslation == TCL_TRANSLATE_LF - && outStatePtr->outputTranslation == TCL_TRANSLATE_LF - && ( - ( - inStatePtr->encoding == GetBinaryEncoding() - && - outStatePtr->encoding == GetBinaryEncoding() - ) - || - ( - toRead == -1 - && inStatePtr->encoding == outStatePtr->encoding - && ENCODING_PROFILE_GET(inStatePtr->inputEncodingFlags) == TCL_ENCODING_PROFILE_TCL8 - && ENCODING_PROFILE_GET(outStatePtr->inputEncodingFlags) == TCL_ENCODING_PROFILE_TCL8 - ) - ); -} - -/* - *---------------------------------------------------------------------- - * * StopCopy -- * * This routine halts a copy that is in progress. @@ -10379,7 +10505,7 @@ StopCopy( } inStatePtr->csPtrR = NULL; outStatePtr->csPtrW = NULL; - Tcl_Free(csPtr); + ckfree(csPtr); } /* @@ -10777,6 +10903,16 @@ Tcl_ChannelVersion( const Tcl_ChannelType *chanTypePtr) /* Pointer to channel type. */ { +#ifndef TCL_NO_DEPRECATED + if ((chanTypePtr->version < TCL_CHANNEL_VERSION_2) + || (chanTypePtr->version > TCL_CHANNEL_VERSION_5)) { + /* + * In <v2 channel versions, the version field is occupied by the + * Tcl_DriverBlockModeProc + */ + return TCL_CHANNEL_VERSION_1; + } +#endif return chanTypePtr->version; } @@ -10800,12 +10936,46 @@ Tcl_ChannelBlockModeProc( const Tcl_ChannelType *chanTypePtr) /* Pointer to channel type. */ { +#ifndef TCL_NO_DEPRECATED + if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_2) { + /* + * The v1 structure had the blockModeProc in a different place. + */ + return (Tcl_DriverBlockModeProc *) chanTypePtr->version; + } +#endif return chanTypePtr->blockModeProc; } /* *---------------------------------------------------------------------- * + * Tcl_ChannelCloseProc -- + * + * Return the Tcl_DriverCloseProc of the channel type. + * + * Results: + * A pointer to the proc. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#ifndef TCL_NO_DEPRECATED +Tcl_DriverCloseProc * +Tcl_ChannelCloseProc( + const Tcl_ChannelType *chanTypePtr) + /* Pointer to channel type. */ +{ + return chanTypePtr->closeProc; +} +#endif + +/* + *---------------------------------------------------------------------- + * * Tcl_ChannelClose2Proc -- * * Return the Tcl_DriverClose2Proc of the channel type. @@ -10878,6 +11048,32 @@ Tcl_ChannelOutputProc( /* *---------------------------------------------------------------------- * + * Tcl_ChannelSeekProc -- + * + * Return the Tcl_DriverSeekProc of the channel type. + * + * Results: + * A pointer to the proc. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#ifndef TCL_NO_DEPRECATED +Tcl_DriverSeekProc * +Tcl_ChannelSeekProc( + const Tcl_ChannelType *chanTypePtr) + /* Pointer to channel type. */ +{ + return chanTypePtr->seekProc; +} +#endif + +/* + *---------------------------------------------------------------------- + * * Tcl_ChannelSetOptionProc -- * * Return the Tcl_DriverSetOptionProc of the channel type. @@ -10992,6 +11188,11 @@ Tcl_ChannelFlushProc( const Tcl_ChannelType *chanTypePtr) /* Pointer to channel type. */ { +#ifndef TCL_NO_DEPRECATED + if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_2) { + return NULL; + } +#endif return chanTypePtr->flushProc; } @@ -11016,6 +11217,11 @@ Tcl_ChannelHandlerProc( const Tcl_ChannelType *chanTypePtr) /* Pointer to channel type. */ { +#ifndef TCL_NO_DEPRECATED + if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_2) { + return NULL; + } +#endif return chanTypePtr->handlerProc; } @@ -11040,6 +11246,11 @@ Tcl_ChannelWideSeekProc( const Tcl_ChannelType *chanTypePtr) /* Pointer to channel type. */ { +#ifndef TCL_NO_DEPRECATED + if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_3) { + return NULL; + } +#endif return chanTypePtr->wideSeekProc; } @@ -11065,6 +11276,11 @@ Tcl_ChannelThreadActionProc( const Tcl_ChannelType *chanTypePtr) /* Pointer to channel type. */ { +#ifndef TCL_NO_DEPRECATED + if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_4) { + return NULL; + } +#endif return chanTypePtr->threadActionProc; } @@ -11247,7 +11463,7 @@ FixLevelCode( lcn += 2; } - lvn = (Tcl_Obj **)Tcl_Alloc(lcn * sizeof(Tcl_Obj *)); + lvn = (Tcl_Obj **)ckalloc(lcn * sizeof(Tcl_Obj *)); /* * New level/code information is spliced into the first occurrence of @@ -11300,7 +11516,7 @@ FixLevelCode( msg = Tcl_NewListObj(j, lvn); - Tcl_Free(lvn); + ckfree(lvn); return msg; } @@ -11382,6 +11598,9 @@ Tcl_ChannelTruncateProc( const Tcl_ChannelType *chanTypePtr) /* Pointer to channel type. */ { + if (Tcl_ChannelVersion(chanTypePtr) < TCL_CHANNEL_VERSION_5) { + return NULL; + } return chanTypePtr->truncateProc; } @@ -11445,7 +11664,7 @@ FreeChannelInternalRep( return; } Tcl_Release(resPtr->statePtr); - Tcl_Free(resPtr); + ckfree(resPtr); } #if 0 diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c index cb90059..23adc18 100644 --- a/generic/tclIOCmd.c +++ b/generic/tclIOCmd.c @@ -11,7 +11,6 @@ #include "tclInt.h" #include "tclIO.h" -#include "tclTomMath.h" /* * Callback structure for accept callback in a TCP server. @@ -134,6 +133,19 @@ Tcl_PutsObjCmd( chanObjPtr = objv[2]; string = objv[3]; break; +#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 + * form of the command that is no longer recommended or + * documented. See also [Bug #3151675]. Will be removed in Tcl 9, + * maybe even earlier. + */ + + chanObjPtr = objv[1]; + string = objv[2]; + break; +#endif } /* Fall through */ default: /* [puts] or @@ -369,7 +381,7 @@ Tcl_ReadObjCmd( { Tcl_Channel chan; /* The channel to read from. */ int newline, i; /* Discard newline at end? */ - Tcl_WideInt toRead; /* How many bytes to read? */ + int toRead; /* How many bytes to read? */ Tcl_Size charactersRead; /* How many characters were read? */ int mode; /* Mode in which channel is opened. */ Tcl_Obj *resultPtr, *chanObjPtr; @@ -420,13 +432,27 @@ Tcl_ReadObjCmd( toRead = -1; if (i < objc) { - if ((TclGetWideIntFromObj(NULL, objv[i], &toRead) != TCL_OK) + if ((TclGetIntFromObj(NULL, objv[i], &toRead) != TCL_OK) || (toRead < 0)) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "expected non-negative integer but got \"%s\"", - TclGetString(objv[i]))); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", (char *)NULL); - return TCL_ERROR; +#if !defined(TCL_NO_DEPRECATED) + /* + * The code below provides backwards compatibility with an old + * form of the command that is no longer recommended or + * documented. See also [Bug #3151675]. Will be removed in Tcl 9, + * maybe even earlier. + */ + + if (strcmp(TclGetString(objv[i]), "nonewline") != 0) { +#endif + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected non-negative integer but got \"%s\"", + TclGetString(objv[i]))); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", (char *)NULL); + return TCL_ERROR; +#if !defined(TCL_NO_DEPRECATED) + } + newline = 1; +#endif } } @@ -947,11 +973,6 @@ Tcl_ExecObjCmd( return TCL_ERROR; } - /* Bug [0f1ddc0df7] - encoding errors - use replace profile */ - if (Tcl_SetChannelOption(NULL, chan, "-profile", "replace") != TCL_OK) { - return TCL_ERROR; - } - if (background) { /* * Store the list of PIDs from the pipeline in interp's result and @@ -959,7 +980,7 @@ Tcl_ExecObjCmd( */ TclGetAndDetachPids(interp, chan); - if (Tcl_CloseEx(interp, chan, 0) != TCL_OK) { + if (Tcl_Close(interp, chan) != TCL_OK) { return TCL_ERROR; } return TCL_OK; @@ -991,7 +1012,7 @@ Tcl_ExecObjCmd( * string. */ - result = Tcl_CloseEx(interp, chan, 0); + result = Tcl_Close(interp, chan); Tcl_AppendObjToObj(resultPtr, Tcl_GetObjResult(interp)); /* @@ -1167,7 +1188,7 @@ Tcl_OpenObjCmd( Tcl_SetChannelOption(interp, chan, "-translation", "binary"); } } - Tcl_Free((void *)cmdArgv); + ckfree(cmdArgv); } if (chan == NULL) { return TCL_ERROR; @@ -1215,7 +1236,7 @@ TcpAcceptCallbacksDeleteProc( acceptCallbackPtr->interp = NULL; } Tcl_DeleteHashTable(hTblPtr); - Tcl_Free(hTblPtr); + ckfree(hTblPtr); } /* @@ -1255,7 +1276,7 @@ RegisterTcpServerInterpCleanup( hTblPtr = (Tcl_HashTable *)Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL); if (hTblPtr == NULL) { - hTblPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); + hTblPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(hTblPtr, TCL_ONE_WORD_KEYS); Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks", TcpAcceptCallbacksDeleteProc, hTblPtr); @@ -1303,7 +1324,7 @@ UnregisterTcpServerInterpCleanupProc( return; } - hPtr = Tcl_FindHashEntry(hTblPtr, acceptCallbackPtr); + hPtr = Tcl_FindHashEntry(hTblPtr, (char *)acceptCallbackPtr); if (hPtr != NULL) { Tcl_DeleteHashEntry(hPtr); } @@ -1392,7 +1413,7 @@ AcceptCallbackProc( * the client socket - just close it. */ - Tcl_CloseEx(NULL, chan, 0); + Tcl_Close(NULL, chan); } } @@ -1430,7 +1451,7 @@ TcpServerCloseProc( acceptCallbackPtr); } Tcl_DecrRefCount(acceptCallbackPtr->script); - Tcl_Free(acceptCallbackPtr); + ckfree(acceptCallbackPtr); } /* @@ -1464,8 +1485,8 @@ Tcl_SocketObjCmd( enum socketOptionsEnum { SKT_ASYNC, SKT_BACKLOG, SKT_MYADDR, SKT_MYPORT, SKT_REUSEADDR, SKT_REUSEPORT, SKT_SERVER - } optionIndex; - int a, server = 0, myport = 0, async = 0, reusep = -1, + }; + int a, server = 0, myport = 0, async = 0, reusep = -1, optionIndex, reusea = -1, backlog = -1; unsigned int flags = 0; const char *host, *port, *myaddr = NULL; @@ -1484,7 +1505,7 @@ Tcl_SocketObjCmd( TCL_EXACT, &optionIndex) != TCL_OK) { return TCL_ERROR; } - switch (optionIndex) { + switch ((enum socketOptionsEnum) optionIndex) { case SKT_ASYNC: if (server == 1) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -1635,7 +1656,7 @@ Tcl_SocketObjCmd( port = TclGetString(objv[a]); if (server) { - AcceptCallback *acceptCallbackPtr = (AcceptCallback *)Tcl_Alloc(sizeof(AcceptCallback)); + AcceptCallback *acceptCallbackPtr = (AcceptCallback *)ckalloc(sizeof(AcceptCallback)); Tcl_IncrRefCount(script); acceptCallbackPtr->script = script; @@ -1645,7 +1666,7 @@ Tcl_SocketObjCmd( AcceptCallbackProc, acceptCallbackPtr); if (chan == NULL) { Tcl_DecrRefCount(script); - Tcl_Free(acceptCallbackPtr); + ckfree(acceptCallbackPtr); return TCL_ERROR; } @@ -1805,8 +1826,8 @@ ChanPendingObjCmd( { Tcl_Channel chan; static const char *const options[] = {"input", "output", NULL}; - enum pendingOptionsEnum {PENDING_INPUT, PENDING_OUTPUT} index; - int mode; + enum pendingOptionsEnum {PENDING_INPUT, PENDING_OUTPUT}; + int mode, index; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "mode channelId"); @@ -1822,7 +1843,7 @@ ChanPendingObjCmd( return TCL_ERROR; } - switch (index) { + switch ((enum pendingOptionsEnum) index) { case PENDING_INPUT: if (!(mode & TCL_READABLE)) { Tcl_SetObjResult(interp, Tcl_NewWideIntObj(-1)); diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c index aa63cd0..4d5c0b3 100644 --- a/generic/tclIOGT.c +++ b/generic/tclIOGT.c @@ -19,25 +19,29 @@ * the transformation. */ -static int TransformBlockModeProc(void *instanceData, +static int TransformBlockModeProc(ClientData instanceData, int mode); -static int TransformCloseProc(void *instanceData, +static int TransformCloseProc(ClientData instanceData, Tcl_Interp *interp, int flags); -static int TransformInputProc(void *instanceData, char *buf, +static int TransformInputProc(ClientData instanceData, char *buf, int toRead, int *errorCodePtr); -static int TransformOutputProc(void *instanceData, +static int TransformOutputProc(ClientData instanceData, const char *buf, int toWrite, int *errorCodePtr); -static int TransformSetOptionProc(void *instanceData, +#ifndef TCL_NO_DEPRECATED +static int TransformSeekProc(ClientData instanceData, long offset, + int mode, int *errorCodePtr); +#endif +static int TransformSetOptionProc(ClientData instanceData, Tcl_Interp *interp, const char *optionName, const char *value); -static int TransformGetOptionProc(void *instanceData, +static int TransformGetOptionProc(ClientData instanceData, Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr); -static void TransformWatchProc(void *instanceData, int mask); -static int TransformGetFileHandleProc(void *instanceData, - int direction, void **handlePtr); -static int TransformNotifyProc(void *instanceData, int mask); -static long long TransformWideSeekProc(void *instanceData, +static void TransformWatchProc(ClientData instanceData, int mask); +static int TransformGetFileHandleProc(ClientData instanceData, + int direction, ClientData *handlePtr); +static int TransformNotifyProc(ClientData instanceData, int mask); +static long long TransformWideSeekProc(ClientData instanceData, long long offset, int mode, int *errorCodePtr); /* @@ -45,7 +49,7 @@ static long long TransformWideSeekProc(void *instanceData, * handling and generating fileeevents. */ -static void TransformChannelHandlerTimer(void *clientData); +static void TransformChannelHandlerTimer(ClientData clientData); /* * Forward declarations of internal procedures. Third, helper procedures @@ -117,10 +121,14 @@ static inline void ResultAdd(ResultBuffer *r, unsigned char *buf, static const Tcl_ChannelType transformChannelType = { "transform", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel */ - NULL, /* Close proc. */ + TCL_CLOSE2PROC, /* Close proc. */ TransformInputProc, /* Input proc. */ TransformOutputProc, /* Output proc. */ +#ifndef TCL_NO_DEPRECATED + TransformSeekProc, /* Seek proc. */ +#else NULL, /* Seek proc. */ +#endif TransformSetOptionProc, /* Set option proc. */ TransformGetOptionProc, /* Get option proc. */ TransformWatchProc, /* Initialize notifier. */ @@ -228,7 +236,7 @@ ReleaseData( } ResultClear(&dataPtr->result); Tcl_DecrRefCount(dataPtr->command); - Tcl_Free(dataPtr); + ckfree(dataPtr); } /* @@ -284,7 +292,7 @@ TclChannelTransform( * regime of the underlying channel and to use the same for us too. */ - dataPtr = (TransformChannelData *)Tcl_Alloc(sizeof(TransformChannelData)); + dataPtr = (TransformChannelData *)ckalloc(sizeof(TransformChannelData)); dataPtr->refCount = 1; Tcl_DStringInit(&ds); @@ -375,7 +383,7 @@ ExecuteCallback( * interpreters. */ { Tcl_Obj *resObj; /* See below, switch (transmit). */ - Tcl_Size resLen = 0; + Tcl_Size resLen; unsigned char *resBuf; Tcl_InterpState state = NULL; int res = TCL_OK; @@ -397,12 +405,7 @@ ExecuteCallback( } Tcl_IncrRefCount(command); - res = Tcl_ListObjAppendElement(NULL, command, Tcl_NewStringObj((char *) op, -1)); - if (res != TCL_OK) { - Tcl_DecrRefCount(command); - Tcl_Release(eval); - return res; - } + Tcl_ListObjAppendElement(NULL, command, Tcl_NewStringObj((char *) op, -1)); /* * Use a byte-array to prevent the misinterpretation of binary data coming @@ -445,38 +448,25 @@ ExecuteCallback( break; } resObj = Tcl_GetObjResult(eval); - resBuf = Tcl_GetBytesFromObj(NULL, resObj, &resLen); - if (resBuf) { - Tcl_WriteRaw(Tcl_GetStackedChannel(dataPtr->self), - (char *) resBuf, resLen); - break; - } - goto nonBytes; + resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen); + Tcl_WriteRaw(Tcl_GetStackedChannel(dataPtr->self), (char *) resBuf, + resLen); + break; case TRANSMIT_SELF: if (dataPtr->self == NULL) { break; } resObj = Tcl_GetObjResult(eval); - resBuf = Tcl_GetBytesFromObj(NULL, resObj, &resLen); - if (resBuf) { - Tcl_WriteRaw(dataPtr->self, (char *) resBuf, resLen); - break; - } - goto nonBytes; + resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen); + Tcl_WriteRaw(dataPtr->self, (char *) resBuf, resLen); + break; case TRANSMIT_IBUF: resObj = Tcl_GetObjResult(eval); - resBuf = Tcl_GetBytesFromObj(NULL, resObj, &resLen); - if (resBuf) { - ResultAdd(&dataPtr->result, resBuf, resLen); - break; - } - nonBytes: - Tcl_AppendResult(interp, "chan transform callback received non-bytes", - (void *)NULL); - Tcl_Release(eval); - return TCL_ERROR; + resBuf = Tcl_GetByteArrayFromObj(resObj, &resLen); + ResultAdd(&dataPtr->result, resBuf, resLen); + break; case TRANSMIT_NUM: /* @@ -515,7 +505,7 @@ ExecuteCallback( static int TransformBlockModeProc( - void *instanceData, /* State of transformation. */ + ClientData instanceData, /* State of transformation. */ int mode) /* New blocking mode. */ { TransformChannelData *dataPtr = (TransformChannelData *)instanceData; @@ -547,7 +537,7 @@ TransformBlockModeProc( static int TransformCloseProc( - void *instanceData, + ClientData instanceData, Tcl_Interp *interp, int flags) { @@ -631,7 +621,7 @@ TransformCloseProc( static int TransformInputProc( - void *instanceData, + ClientData instanceData, char *buf, int toRead, int *errorCodePtr) @@ -798,7 +788,7 @@ TransformInputProc( static int TransformOutputProc( - void *instanceData, + ClientData instanceData, const char *buf, int toWrite, int *errorCodePtr) @@ -831,6 +821,75 @@ TransformOutputProc( /* *---------------------------------------------------------------------- * + * TransformSeekProc -- + * + * This procedure is called by the generic IO level to move the access + * point in a channel. + * + * Side effects: + * Moves the location at which the channel will be accessed in future + * operations. Flushes all transformation buffers, then forwards it to + * the underlying channel. + * + * Result: + * -1 if failed, the new position if successful. An output argument + * contains the POSIX error code if an error occurred, or zero. + * + *---------------------------------------------------------------------- + */ + +#ifndef TCL_NO_DEPRECATED +static int +TransformSeekProc( + ClientData instanceData, /* The channel to manipulate. */ + long offset, /* Size of movement. */ + int mode, /* How to move. */ + int *errorCodePtr) /* Location of error flag. */ +{ + TransformChannelData *dataPtr = (TransformChannelData *)instanceData; + Tcl_Channel parent = Tcl_GetStackedChannel(dataPtr->self); + const Tcl_ChannelType *parentType = Tcl_GetChannelType(parent); + Tcl_DriverSeekProc *parentSeekProc = Tcl_ChannelSeekProc(parentType); + + 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. + */ + + return parentSeekProc(Tcl_GetChannelInstanceData(parent), offset, + mode, errorCodePtr); + } + + /* + * It is a real request to change the position. Flush all data waiting for + * output and discard everything in the input buffers. Then pass the + * request down, unchanged. + */ + + PreserveData(dataPtr); + if (dataPtr->mode & TCL_WRITABLE) { + ExecuteCallback(dataPtr, NULL, A_FLUSH_WRITE, NULL, 0, TRANSMIT_DOWN, + P_NO_PRESERVE); + } + + if (dataPtr->mode & TCL_READABLE) { + ExecuteCallback(dataPtr, NULL, A_CLEAR_READ, NULL, 0, TRANSMIT_DONT, + P_NO_PRESERVE); + ResultClear(&dataPtr->result); + dataPtr->readIsFlushed = 0; + dataPtr->eofPending = 0; + } + ReleaseData(dataPtr); + + return parentSeekProc(Tcl_GetChannelInstanceData(parent), offset, mode, + errorCodePtr); +} +#endif + +/* + *---------------------------------------------------------------------- + * * TransformWideSeekProc -- * * This procedure is called by the generic IO level to move the access @@ -850,7 +909,7 @@ TransformOutputProc( static long long TransformWideSeekProc( - void *instanceData, /* The channel to manipulate. */ + ClientData instanceData, /* The channel to manipulate. */ long long offset, /* Size of movement. */ int mode, /* How to move. */ int *errorCodePtr) /* Location of error flag. */ @@ -858,6 +917,9 @@ TransformWideSeekProc( TransformChannelData *dataPtr = (TransformChannelData *)instanceData; Tcl_Channel parent = Tcl_GetStackedChannel(dataPtr->self); const Tcl_ChannelType *parentType = Tcl_GetChannelType(parent); +#ifndef TCL_NO_DEPRECATED + Tcl_DriverSeekProc *parentSeekProc = Tcl_ChannelSeekProc(parentType); +#endif Tcl_DriverWideSeekProc *parentWideSeekProc = Tcl_ChannelWideSeekProc(parentType); void *parentData = Tcl_GetChannelInstanceData(parent); @@ -870,6 +932,10 @@ TransformWideSeekProc( if (parentWideSeekProc != NULL) { return parentWideSeekProc(parentData, offset, mode, errorCodePtr); +#ifndef TCL_NO_DEPRECATED + } else if (parentSeekProc) { + return parentSeekProc(parentData, 0, mode, errorCodePtr); +#endif } else { *errorCodePtr = EINVAL; return -1; @@ -902,8 +968,26 @@ TransformWideSeekProc( */ if (parentWideSeekProc == NULL) { + /* + * We're transferring to narrow seeks at this point; this is a bit complex + * because we have to check whether the seek is possible first (i.e. + * whether we are losing information in truncating the bits of the + * offset). Luckily, there's a defined error for what happens when trying + * to go out of the representable range. + */ + +#ifndef TCL_NO_DEPRECATED + if (offset<LONG_MIN || offset>LONG_MAX) { + *errorCodePtr = EOVERFLOW; + return -1; + } + + return parentSeekProc(parentData, offset, + mode, errorCodePtr); +#else *errorCodePtr = EINVAL; return -1; +#endif } return parentWideSeekProc(parentData, offset, mode, errorCodePtr); } @@ -928,7 +1012,7 @@ TransformWideSeekProc( static int TransformSetOptionProc( - void *instanceData, + ClientData instanceData, Tcl_Interp *interp, const char *optionName, const char *value) @@ -966,7 +1050,7 @@ TransformSetOptionProc( static int TransformGetOptionProc( - void *instanceData, + ClientData instanceData, Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr) @@ -1013,7 +1097,7 @@ TransformGetOptionProc( static void TransformWatchProc( - void *instanceData, /* Channel to watch. */ + ClientData instanceData, /* Channel to watch. */ int mask) /* Events of interest. */ { TransformChannelData *dataPtr = (TransformChannelData *)instanceData; @@ -1091,9 +1175,9 @@ TransformWatchProc( static int TransformGetFileHandleProc( - void *instanceData, /* Channel to query. */ + ClientData instanceData, /* Channel to query. */ int direction, /* Direction of interest. */ - void **handlePtr) /* Place to store the handle into. */ + ClientData *handlePtr) /* Place to store the handle into. */ { TransformChannelData *dataPtr = (TransformChannelData *)instanceData; @@ -1125,7 +1209,7 @@ TransformGetFileHandleProc( static int TransformNotifyProc( - void *clientData, /* The state of the notified + ClientData clientData, /* The state of the notified * transformation. */ int mask) /* The mask of occurring events. */ { @@ -1170,7 +1254,7 @@ TransformNotifyProc( static void TransformChannelHandlerTimer( - void *clientData) /* Transformation to query. */ + ClientData clientData) /* Transformation to query. */ { TransformChannelData *dataPtr = (TransformChannelData *)clientData; @@ -1210,7 +1294,7 @@ ResultClear( r->used = 0; if (r->allocated) { - Tcl_Free(r->buf); + ckfree(r->buf); r->buf = NULL; r->allocated = 0; } @@ -1354,10 +1438,10 @@ ResultAdd( if (r->allocated == 0) { r->allocated = toWrite + INCREMENT; - r->buf = (unsigned char *)Tcl_Alloc(r->allocated); + r->buf = (unsigned char *)ckalloc(r->allocated); } else { r->allocated += toWrite + INCREMENT; - r->buf = (unsigned char *)Tcl_Realloc(r->buf, r->allocated); + r->buf = (unsigned char *)ckrealloc(r->buf, r->allocated); } } diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c index fe54f65..58850a2 100644 --- a/generic/tclIORChan.c +++ b/generic/tclIORChan.c @@ -44,8 +44,12 @@ static void ReflectThread(void *clientData, int action); static int ReflectEventRun(Tcl_Event *ev, int flags); static int ReflectEventDelete(Tcl_Event *ev, void *cd); #endif -static long long ReflectSeekWide(void *clientData, +static long long ReflectSeekWide(void *clientData, long long offset, int mode, int *errorCodePtr); +#ifndef TCL_NO_DEPRECATED +static int ReflectSeek(void *clientData, long offset, + int mode, int *errorCodePtr); +#endif static int ReflectGetOption(void *clientData, Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr); @@ -54,8 +58,8 @@ static int ReflectSetOption(void *clientData, const char *newValue); static int ReflectTruncate(void *clientData, long long length); -static void TimerRunRead(void *clientData); -static void TimerRunWrite(void *clientData); +static void TimerRunRead(void *clientData); +static void TimerRunWrite(void *clientData); /* * The C layer channel type/driver definition used by the reflection. @@ -64,10 +68,14 @@ static void TimerRunWrite(void *clientData); static const Tcl_ChannelType tclRChannelType = { "tclrchannel", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel */ - NULL, /* Close channel, clean instance data */ + TCL_CLOSE2PROC, /* Close channel, clean instance data */ ReflectInput, /* Handle read request */ ReflectOutput, /* Handle write request */ +#ifndef TCL_NO_DEPRECATED + ReflectSeek, /* Move location of access point. NULL'able */ +#else NULL, +#endif ReflectSetOption, /* Set options. NULL'able */ ReflectGetOption, /* Get options. NULL'able */ ReflectWatch, /* Initialize notifier */ @@ -404,7 +412,7 @@ static void SrcExitProc(void *clientData); #define FreeReceivedError(p) \ if ((p)->base.mustFree) { \ - Tcl_Free((p)->base.msgStr); \ + ckfree((p)->base.msgStr); \ } #define PassReceivedErrorInterp(i,p) \ if ((i) != NULL) { \ @@ -466,7 +474,6 @@ static void MarkDead(ReflectedChannel *rcPtr); */ static const char *msg_read_toomuch = "{read delivered more than requested}"; -static const char *msg_read_nonbyte = "{read delivered nonbyte result}"; 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}"; @@ -692,7 +699,7 @@ TclChanCreateObjCmd( * as the actual channel type. */ - Tcl_ChannelType *clonePtr = (Tcl_ChannelType *)Tcl_Alloc(sizeof(Tcl_ChannelType)); + Tcl_ChannelType *clonePtr = (Tcl_ChannelType *)ckalloc(sizeof(Tcl_ChannelType)); memcpy(clonePtr, &tclRChannelType, sizeof(Tcl_ChannelType)); @@ -707,6 +714,9 @@ TclChanCreateObjCmd( clonePtr->blockModeProc = NULL; } if (!(methods & FLAG(METH_SEEK))) { +#ifndef TCL_NO_DEPRECATED + clonePtr->seekProc = NULL; +#endif clonePtr->wideSeekProc = NULL; } if (!(methods & FLAG(METH_TRUNCATE))) { @@ -749,7 +759,7 @@ TclChanCreateObjCmd( Tcl_DecrRefCount(rcPtr->name); Tcl_DecrRefCount(rcPtr->methods); Tcl_DecrRefCount(rcPtr->cmd); - Tcl_Free(rcPtr); + ckfree(rcPtr); return TCL_ERROR; #undef MODE @@ -963,7 +973,7 @@ TclChanPostEventObjCmd( } #if TCL_THREADS } else { - ReflectEvent *ev = (ReflectEvent *)Tcl_Alloc(sizeof(ReflectEvent)); + ReflectEvent *ev = (ReflectEvent *)ckalloc(sizeof(ReflectEvent)); ev->header.proc = ReflectEventRun; ev->events = events; @@ -1221,7 +1231,7 @@ ReflectClose( tctPtr = ((Channel *)rcPtr->chan)->typePtr; if (tctPtr && tctPtr != &tclRChannelType) { - Tcl_Free((void *)tctPtr); + ckfree(tctPtr); ((Channel *)rcPtr->chan)->typePtr = NULL; } if (rcPtr->readTimer != NULL) { @@ -1296,7 +1306,7 @@ ReflectClose( #endif tctPtr = ((Channel *)rcPtr->chan)->typePtr; if (tctPtr && tctPtr != &tclRChannelType) { - Tcl_Free((void *)tctPtr); + ckfree(tctPtr); ((Channel *)rcPtr->chan)->typePtr = NULL; } if (rcPtr->readTimer != NULL) { @@ -1334,7 +1344,7 @@ ReflectInput( { ReflectedChannel *rcPtr = (ReflectedChannel *)clientData; Tcl_Obj *toReadObj; - Tcl_Size bytec = 0; /* Number of returned bytes */ + Tcl_Size bytec; /* Number of returned bytes */ unsigned char *bytev; /* Array of returned bytes */ Tcl_Obj *resObj; /* Result data for 'read' */ @@ -1391,12 +1401,9 @@ ReflectInput( goto invalid; } - bytev = Tcl_GetBytesFromObj(NULL, resObj, &bytec); + bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); - if (bytev == NULL) { - SetChannelErrorStr(rcPtr->chan, msg_read_nonbyte); - goto invalid; - } else if (toRead < bytec) { + if (toRead < bytec) { SetChannelErrorStr(rcPtr->chan, msg_read_toomuch); goto invalid; } @@ -1639,6 +1646,26 @@ ReflectSeekWide( newLoc = -1; goto stop; } + +#ifndef TCL_NO_DEPRECATED +static int +ReflectSeek( + void *clientData, + long offset, + int seekMode, + int *errorCodePtr) +{ + /* + * This function can be invoked from a transformation which is based on + * standard seeking, i.e. non-wide. Because of this we have to implement + * it, a dummy is not enough. We simply delegate the call to the wide + * routine. + */ + + return ReflectSeekWide(clientData, offset, seekMode, + errorCodePtr); +} +#endif /* *---------------------------------------------------------------------- @@ -2246,7 +2273,7 @@ NewReflectedChannel( ReflectedChannel *rcPtr; int mn = 0; - rcPtr = (ReflectedChannel *)Tcl_Alloc(sizeof(ReflectedChannel)); + rcPtr = (ReflectedChannel *)ckalloc(sizeof(ReflectedChannel)); /* rcPtr->chan: Assigned by caller. Dummy data here. */ @@ -2318,7 +2345,7 @@ NextHandle(void) static void FreeReflectedChannel( - void *blockPtr) + char *blockPtr) { ReflectedChannel *rcPtr = (ReflectedChannel *) blockPtr; Channel *chanPtr = (Channel *) rcPtr->chan; @@ -2333,7 +2360,7 @@ FreeReflectedChannel( if (rcPtr->cmd) { Tcl_DecrRefCount(rcPtr->cmd); } - Tcl_Free(rcPtr); + ckfree(rcPtr); } /* @@ -2568,7 +2595,7 @@ GetReflectedChannelMap( ReflectedChannelMap *rcmPtr = (ReflectedChannelMap *)Tcl_GetAssocData(interp, RCMKEY, NULL); if (rcmPtr == NULL) { - rcmPtr = (ReflectedChannelMap *)Tcl_Alloc(sizeof(ReflectedChannelMap)); + rcmPtr = (ReflectedChannelMap *)ckalloc(sizeof(ReflectedChannelMap)); Tcl_InitHashTable(&rcmPtr->map, TCL_STRING_KEYS); Tcl_SetAssocData(interp, RCMKEY, DeleteReflectedChannelMap, rcmPtr); } @@ -2656,7 +2683,7 @@ DeleteReflectedChannelMap( Tcl_DeleteHashEntry(hPtr); } Tcl_DeleteHashTable(&rcmPtr->map); - Tcl_Free(&rcmPtr->map); + ckfree(&rcmPtr->map); #if TCL_THREADS /* @@ -2770,7 +2797,7 @@ GetThreadReflectedChannelMap(void) ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!tsdPtr->rcmPtr) { - tsdPtr->rcmPtr = (ReflectedChannelMap *)Tcl_Alloc(sizeof(ReflectedChannelMap)); + tsdPtr->rcmPtr = (ReflectedChannelMap *)ckalloc(sizeof(ReflectedChannelMap)); Tcl_InitHashTable(&tsdPtr->rcmPtr->map, TCL_STRING_KEYS); Tcl_CreateThreadExitHandler(DeleteThreadReflectedChannelMap, NULL); } @@ -2895,7 +2922,7 @@ DeleteThreadReflectedChannelMap( MarkDead(rcPtr); Tcl_DeleteHashEntry(hPtr); } - Tcl_Free(rcmPtr); + ckfree(rcmPtr); } static void @@ -2935,8 +2962,8 @@ ForwardOpToHandlerThread( * Create and initialize the event and data structures. */ - evPtr = (ForwardingEvent *)Tcl_Alloc(sizeof(ForwardingEvent)); - resultPtr = (ForwardingResult *)Tcl_Alloc(sizeof(ForwardingResult)); + evPtr = (ForwardingEvent *)ckalloc(sizeof(ForwardingEvent)); + resultPtr = (ForwardingResult *)ckalloc(sizeof(ForwardingResult)); evPtr->event.proc = ForwardProc; evPtr->resultPtr = resultPtr; @@ -3018,7 +3045,7 @@ ForwardOpToHandlerThread( Tcl_DeleteThreadExitHandler(SrcExitProc, evPtr); - Tcl_Free(resultPtr); + ckfree(resultPtr); } static int @@ -3126,15 +3153,12 @@ ForwardProc( * Process a regular result. */ - Tcl_Size bytec = 0; /* Number of returned bytes */ + Tcl_Size bytec; /* Number of returned bytes */ unsigned char *bytev; /* Array of returned bytes */ - bytev = Tcl_GetBytesFromObj(NULL, resObj, &bytec); + bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); - if (bytev == NULL) { - ForwardSetStaticError(paramPtr, msg_read_nonbyte); - paramPtr->input.toRead = -1; - } else if (paramPtr->input.toRead < bytec) { + if (paramPtr->input.toRead < bytec) { ForwardSetStaticError(paramPtr, msg_read_toomuch); paramPtr->input.toRead = TCL_IO_FAILURE; } else { @@ -3321,7 +3345,7 @@ ForwardProc( * Odd number of elements is wrong. [x]. */ - char *buf = (char *)Tcl_Alloc(200); + char *buf = (char *)ckalloc(200); snprintf(buf, 200, "{Expected list with even number of elements, got %" TCL_SIZE_MODIFIER "d %s instead}", listc, (listc == 1 ? "element" : "elements")); @@ -3444,7 +3468,7 @@ ForwardSetObjError( const char *msgStr = TclGetStringFromObj(obj, &len); len++; - ForwardSetDynamicError(paramPtr, Tcl_Alloc(len)); + ForwardSetDynamicError(paramPtr, ckalloc(len)); memcpy(paramPtr->base.msgStr, msgStr, len); } #endif diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c index c1e5c31..81345dc 100644 --- a/generic/tclIORTrans.c +++ b/generic/tclIORTrans.c @@ -41,6 +41,10 @@ static void ReflectWatch(void *clientData, int mask); static int ReflectBlock(void *clientData, int mode); static long long ReflectSeekWide(void *clientData, long long offset, int mode, int *errorCodePtr); +#ifndef TCL_NO_DEPRECATED +static int ReflectSeek(void *clientData, long offset, + int mode, int *errorCodePtr); +#endif static int ReflectGetOption(void *clientData, Tcl_Interp *interp, const char *optionName, Tcl_DString *dsPtr); @@ -58,10 +62,14 @@ static int ReflectNotify(void *clientData, int mask); static const Tcl_ChannelType tclRTransformType = { "tclrtransform", /* Type name. */ TCL_CHANNEL_VERSION_5, /* v5 channel. */ - NULL, /* Close channel, clean instance data. */ + TCL_CLOSE2PROC, /* Close channel, clean instance data. */ ReflectInput, /* Handle read request. */ ReflectOutput, /* Handle write request. */ +#ifndef TCL_NO_DEPRECATED + ReflectSeek, /* Move location of access point. */ +#else NULL, /* Move location of access point. */ +#endif ReflectSetOption, /* Set options. */ ReflectGetOption, /* Get options. */ ReflectWatch, /* Initialize notifier. */ @@ -84,16 +92,16 @@ static const Tcl_ChannelType tclRTransformType = { typedef struct { unsigned char *buf; /* Reference to the buffer area. */ size_t allocated; /* Allocated size of the buffer area. */ - size_t used; /* Number of bytes in the buffer, + size_t used; /* Number of bytes in the buffer, * <= allocated. */ } ResultBuffer; #define ResultLength(r) ((r)->used) /* static int ResultLength(ResultBuffer *r); */ -static inline void ResultClear(ResultBuffer *r); -static inline void ResultInit(ResultBuffer *r); -static inline void ResultAdd(ResultBuffer *r, unsigned char *buf, +static inline void ResultClear(ResultBuffer *r); +static inline void ResultInit(ResultBuffer *r); +static inline void ResultAdd(ResultBuffer *r, unsigned char *buf, size_t toWrite); static inline size_t ResultCopy(ResultBuffer *r, unsigned char *buf, size_t toRead); @@ -264,7 +272,7 @@ struct ForwardParamTransform { ForwardParamBase base; /* "Supertype". MUST COME FIRST. */ char *buf; /* I: Bytes to transform, * O: Bytes in transform result */ - Tcl_Size size; /* I: #bytes to transform, + int size; /* I: #bytes to transform, * O: #bytes in the transform result */ }; struct ForwardParamLimit { @@ -360,7 +368,7 @@ static void SrcExitProc(void *clientData); #define FreeReceivedError(p) \ do { \ if ((p)->base.mustFree) { \ - Tcl_Free((p)->base.msgStr); \ + ckfree((p)->base.msgStr); \ } \ } while (0) #define PassReceivedErrorInterp(i,p) \ @@ -511,7 +519,7 @@ TclChanPushObjCmd( Tcl_Obj *cmdNameObj; /* Command name */ Tcl_Obj *rtId; /* Handle of the new transform (channel) */ Tcl_Obj *modeObj; /* mode in obj form for method call */ - Tcl_Size listc; /* Result of 'initialize', and of */ + int listc; /* Result of 'initialize', and of */ Tcl_Obj **listv; /* its sublist in the 2nd element */ int methIndex; /* Encoded method name */ int result; /* Result code for 'initialize' */ @@ -614,7 +622,7 @@ TclChanPushObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "chan handler \"%s initialize\" returned %s", TclGetString(cmdObj), - Tcl_GetStringResult(interp))); + Tcl_GetString(Tcl_GetObjResult(interp)))); Tcl_DecrRefCount(resObj); goto error; } @@ -820,10 +828,10 @@ UnmarshallErrorResult( Tcl_Interp *interp, Tcl_Obj *msgObj) { - Tcl_Size lc; + int lc; Tcl_Obj **lv; int explicitResult; - Tcl_Size numOptions; + int numOptions; /* * Process the caught message. @@ -1374,8 +1382,19 @@ ReflectSeekWide( */ if (Tcl_ChannelWideSeekProc(parent->typePtr) == NULL) { +#ifndef TCL_NO_DEPRECATED + if (offset < LONG_MIN || offset > LONG_MAX) { + *errorCodePtr = EOVERFLOW; + curPos = -1; + } else { + curPos = Tcl_ChannelSeekProc(parent->typePtr)( + parent->instanceData, offset, seekMode, + errorCodePtr); + } +#else *errorCodePtr = EINVAL; curPos = -1; +#endif } else { curPos = Tcl_ChannelWideSeekProc(parent->typePtr)(parent->instanceData, offset, seekMode, errorCodePtr); @@ -1388,6 +1407,26 @@ ReflectSeekWide( Tcl_Release(rtPtr); return curPos; } + +#ifndef TCL_NO_DEPRECATED +static int +ReflectSeek( + void *clientData, + long offset, + int seekMode, + int *errorCodePtr) +{ + /* + * This function can be invoked from a transformation which is based on + * standard seeking, i.e. non-wide. Because of this we have to implement + * it, a dummy is not enough. We simply delegate the call to the wide + * routine. + */ + + return ReflectSeekWide(clientData, offset, seekMode, + errorCodePtr); +} +#endif /* *---------------------------------------------------------------------- @@ -1719,10 +1758,11 @@ NewReflectedTransform( Tcl_Channel parentChan) { ReflectedTransform *rtPtr; - Tcl_Size i, listc; + int listc; Tcl_Obj **listv; + int i; - rtPtr = (ReflectedTransform *)Tcl_Alloc(sizeof(ReflectedTransform)); + rtPtr = (ReflectedTransform *)ckalloc(sizeof(ReflectedTransform)); /* rtPtr->chan: Assigned by caller. Dummy data here. */ /* rtPtr->methods: Assigned by caller. Dummy data here. */ @@ -1769,7 +1809,7 @@ NewReflectedTransform( */ rtPtr->argc = listc + 2; - rtPtr->argv = (Tcl_Obj **)Tcl_Alloc(sizeof(Tcl_Obj *) * (listc+4)); + rtPtr->argv = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * (listc+4)); /* * Duplicate object references. @@ -1870,7 +1910,7 @@ FreeReflectedTransformArgs( static void FreeReflectedTransform( - void *blockPtr) + char *blockPtr) { ReflectedTransform *rtPtr = (ReflectedTransform *) blockPtr; TimerKill(rtPtr); @@ -1878,8 +1918,8 @@ FreeReflectedTransform( FreeReflectedTransformArgs(rtPtr); - Tcl_Free(rtPtr->argv); - Tcl_Free(rtPtr); + ckfree(rtPtr->argv); + ckfree(rtPtr); } /* @@ -2005,7 +2045,7 @@ InvokeTclMethod( */ if (result != TCL_ERROR) { Tcl_Obj *cmd = Tcl_NewListObj(cmdc, rtPtr->argv); - Tcl_Size cmdLen; + int cmdLen; const char *cmdString = TclGetStringFromObj(cmd, &cmdLen); Tcl_IncrRefCount(cmd); @@ -2078,7 +2118,7 @@ GetReflectedTransformMap( ReflectedTransformMap *rtmPtr = (ReflectedTransformMap *)Tcl_GetAssocData(interp, RTMKEY, NULL); if (rtmPtr == NULL) { - rtmPtr = (ReflectedTransformMap *)Tcl_Alloc(sizeof(ReflectedTransformMap)); + rtmPtr = (ReflectedTransformMap *)ckalloc(sizeof(ReflectedTransformMap)); Tcl_InitHashTable(&rtmPtr->map, TCL_STRING_KEYS); Tcl_SetAssocData(interp, RTMKEY, (Tcl_InterpDeleteProc *) DeleteReflectedTransformMap, rtmPtr); @@ -2145,7 +2185,7 @@ DeleteReflectedTransformMap( Tcl_DeleteHashEntry(hPtr); } Tcl_DeleteHashTable(&rtmPtr->map); - Tcl_Free(&rtmPtr->map); + ckfree(&rtmPtr->map); #if TCL_THREADS /* @@ -2243,7 +2283,7 @@ GetThreadReflectedTransformMap(void) ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!tsdPtr->rtmPtr) { - tsdPtr->rtmPtr = (ReflectedTransformMap *)Tcl_Alloc(sizeof(ReflectedTransformMap)); + tsdPtr->rtmPtr = (ReflectedTransformMap *)ckalloc(sizeof(ReflectedTransformMap)); Tcl_InitHashTable(&tsdPtr->rtmPtr->map, TCL_STRING_KEYS); Tcl_CreateThreadExitHandler(DeleteThreadReflectedTransformMap, NULL); } @@ -2301,7 +2341,7 @@ DeleteThreadReflectedTransformMap( FreeReflectedTransformArgs(rtPtr); Tcl_DeleteHashEntry(hPtr); } - Tcl_Free(rtmPtr); + ckfree(rtmPtr); /* * Go through the list of pending results and cancel all whose events were @@ -2378,8 +2418,8 @@ ForwardOpToOwnerThread( * Create and initialize the event and data structures. */ - evPtr = (ForwardingEvent *)Tcl_Alloc(sizeof(ForwardingEvent)); - resultPtr = (ForwardingResult *)Tcl_Alloc(sizeof(ForwardingResult)); + evPtr = (ForwardingEvent *)ckalloc(sizeof(ForwardingEvent)); + resultPtr = (ForwardingResult *)ckalloc(sizeof(ForwardingResult)); evPtr->event.proc = ForwardProc; evPtr->resultPtr = resultPtr; @@ -2459,7 +2499,7 @@ ForwardOpToOwnerThread( Tcl_DeleteThreadExitHandler(SrcExitProc, evPtr); - Tcl_Free(resultPtr); + ckfree(resultPtr); } static int @@ -2556,23 +2596,23 @@ ForwardProc( if (InvokeTclMethod(rtPtr, "read", bufObj, NULL, &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); - paramPtr->transform.size = TCL_INDEX_NONE; + paramPtr->transform.size = -1; } else { /* * Process a regular return. Contains the transformation result. * Sent it back to the request originator. */ - Tcl_Size bytec = 0; /* Number of returned bytes */ + int bytec; /* Number of returned bytes */ unsigned char *bytev; /* Array of returned bytes */ - bytev = Tcl_GetBytesFromObj(NULL, resObj, &bytec); + bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); paramPtr->transform.size = bytec; if (bytec > 0) { - paramPtr->transform.buf = (char *)Tcl_Alloc(bytec); + paramPtr->transform.buf = (char *)ckalloc(bytec); memcpy(paramPtr->transform.buf, bytev, bytec); } else { paramPtr->transform.buf = NULL; @@ -2590,23 +2630,23 @@ ForwardProc( if (InvokeTclMethod(rtPtr, "write", bufObj, NULL, &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); - paramPtr->transform.size = TCL_INDEX_NONE; + paramPtr->transform.size = -1; } else { /* * Process a regular return. Contains the transformation result. * Sent it back to the request originator. */ - Tcl_Size bytec = 0; /* Number of returned bytes */ + int bytec; /* Number of returned bytes */ unsigned char *bytev; /* Array of returned bytes */ - bytev = Tcl_GetBytesFromObj(NULL, resObj, &bytec); + bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); paramPtr->transform.size = bytec; if (bytec > 0) { - paramPtr->transform.buf = (char *)Tcl_Alloc(bytec); + paramPtr->transform.buf = (char *)ckalloc(bytec); memcpy(paramPtr->transform.buf, bytev, bytec); } else { paramPtr->transform.buf = NULL; @@ -2620,22 +2660,22 @@ ForwardProc( case ForwardedDrain: if (InvokeTclMethod(rtPtr, "drain", NULL, NULL, &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); - paramPtr->transform.size = TCL_INDEX_NONE; + paramPtr->transform.size = -1; } else { /* * Process a regular return. Contains the transformation result. * Sent it back to the request originator. */ - Tcl_Size bytec = 0; /* Number of returned bytes */ + int bytec; /* Number of returned bytes */ unsigned char *bytev; /* Array of returned bytes */ - bytev = Tcl_GetBytesFromObj(NULL, resObj, &bytec); + bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); paramPtr->transform.size = bytec; if (bytec > 0) { - paramPtr->transform.buf = (char *)Tcl_Alloc(bytec); + paramPtr->transform.buf = (char *)ckalloc(bytec); memcpy(paramPtr->transform.buf, bytev, bytec); } else { paramPtr->transform.buf = NULL; @@ -2646,23 +2686,23 @@ ForwardProc( case ForwardedFlush: if (InvokeTclMethod(rtPtr, "flush", NULL, NULL, &resObj) != TCL_OK) { ForwardSetObjError(paramPtr, resObj); - paramPtr->transform.size = TCL_INDEX_NONE; + paramPtr->transform.size = -1; } else { /* * Process a regular return. Contains the transformation result. * Sent it back to the request originator. */ - Tcl_Size bytec = 0; /* Number of returned bytes */ + int bytec; /* Number of returned bytes */ unsigned char *bytev; /* Array of returned bytes */ - bytev = Tcl_GetBytesFromObj(NULL, resObj, &bytec); + bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); paramPtr->transform.size = bytec; if (bytec > 0) { - paramPtr->transform.buf = (char *)Tcl_Alloc(bytec); + paramPtr->transform.buf = (char *)ckalloc(bytec); memcpy(paramPtr->transform.buf, bytev, bytec); } else { paramPtr->transform.buf = NULL; @@ -2771,11 +2811,11 @@ ForwardSetObjError( ForwardParam *paramPtr, Tcl_Obj *obj) { - Tcl_Size len; + int len; const char *msgStr = TclGetStringFromObj(obj, &len); len++; - ForwardSetDynamicError(paramPtr, Tcl_Alloc(len)); + ForwardSetDynamicError(paramPtr, ckalloc(len)); memcpy(paramPtr->base.msgStr, msgStr, len); } #endif /* TCL_THREADS */ @@ -2920,7 +2960,7 @@ ResultClear( return; } - Tcl_Free(rPtr->buf); + ckfree(rPtr->buf); rPtr->buf = NULL; rPtr->allocated = 0; } @@ -2955,10 +2995,10 @@ ResultAdd( if (rPtr->allocated == 0) { rPtr->allocated = toWrite + RB_INCREMENT; - rPtr->buf = UCHARP(Tcl_Alloc(rPtr->allocated)); + rPtr->buf = UCHARP(ckalloc(rPtr->allocated)); } else { rPtr->allocated += toWrite + RB_INCREMENT; - rPtr->buf = UCHARP(Tcl_Realloc((char *) rPtr->buf, + rPtr->buf = UCHARP(ckrealloc((char *) rPtr->buf, rPtr->allocated)); } } @@ -3003,7 +3043,7 @@ ResultCopy( */ copied = 0; - } else if (rPtr->used == (size_t)toRead) { + } else if (rPtr->used == toRead) { /* * We have just enough. Copy everything to the caller. */ @@ -3011,7 +3051,7 @@ ResultCopy( memcpy(buf, rPtr->buf, toRead); rPtr->used = 0; copied = toRead; - } else if (rPtr->used > (size_t)toRead) { + } else if (rPtr->used > toRead) { /* * The internal buffer contains more than requested. Copy the * requested subset to the caller, and shift the remaining bytes down. @@ -3046,7 +3086,7 @@ TransformRead( Tcl_Obj *bufObj) { Tcl_Obj *resObj; - Tcl_Size bytec = 0; /* Number of returned bytes */ + int bytec; /* Number of returned bytes */ unsigned char *bytev; /* Array of returned bytes */ /* @@ -3057,7 +3097,7 @@ TransformRead( if (rtPtr->thread != Tcl_GetCurrentThread()) { ForwardParam p; - p.transform.buf = (char *) Tcl_GetBytesFromObj(NULL, bufObj, + p.transform.buf = (char *) Tcl_GetByteArrayFromObj(bufObj, &(p.transform.size)); ForwardOpToOwnerThread(rtPtr, ForwardedInput, &p); @@ -3070,7 +3110,7 @@ TransformRead( *errorCodePtr = EOK; ResultAdd(&rtPtr->result, UCHARP(p.transform.buf), p.transform.size); - Tcl_Free(p.transform.buf); + ckfree(p.transform.buf); return 1; } #endif /* TCL_THREADS */ @@ -3085,7 +3125,7 @@ TransformRead( return 0; } - bytev = Tcl_GetBytesFromObj(NULL, resObj, &bytec); + bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); ResultAdd(&rtPtr->result, bytev, bytec); Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ @@ -3101,7 +3141,7 @@ TransformWrite( { Tcl_Obj *bufObj; Tcl_Obj *resObj; - Tcl_Size bytec = 0; /* Number of returned bytes */ + int bytec; /* Number of returned bytes */ unsigned char *bytev; /* Array of returned bytes */ int res; @@ -3127,7 +3167,7 @@ TransformWrite( *errorCodePtr = EOK; res = Tcl_WriteRaw(rtPtr->parent, (char *) p.transform.buf, p.transform.size); - Tcl_Free(p.transform.buf); + ckfree(p.transform.buf); } else #endif /* TCL_THREADS */ { @@ -3147,7 +3187,7 @@ TransformWrite( *errorCodePtr = EOK; - bytev = Tcl_GetBytesFromObj(NULL, resObj, &bytec); + bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); res = Tcl_WriteRaw(rtPtr->parent, (char *) bytev, bytec); Tcl_DecrRefCount(bufObj); @@ -3168,7 +3208,7 @@ TransformDrain( int *errorCodePtr) { Tcl_Obj *resObj; - Tcl_Size bytec = 0; /* Number of returned bytes */ + int bytec; /* Number of returned bytes */ unsigned char *bytev; /* Array of returned bytes */ /* @@ -3189,7 +3229,7 @@ TransformDrain( *errorCodePtr = EOK; ResultAdd(&rtPtr->result, UCHARP(p.transform.buf), p.transform.size); - Tcl_Free(p.transform.buf); + ckfree(p.transform.buf); } else #endif /* TCL_THREADS */ { @@ -3200,7 +3240,7 @@ TransformDrain( return 0; } - bytev = Tcl_GetBytesFromObj(NULL, resObj, &bytec); + bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); ResultAdd(&rtPtr->result, bytev, bytec); Tcl_DecrRefCount(resObj); /* Remove reference held from invoke */ @@ -3217,7 +3257,7 @@ TransformFlush( int op) { Tcl_Obj *resObj; - Tcl_Size bytec = 0; /* Number of returned bytes */ + int bytec; /* Number of returned bytes */ unsigned char *bytev; /* Array of returned bytes */ int res; @@ -3244,7 +3284,7 @@ TransformFlush( } else { res = 0; } - Tcl_Free(p.transform.buf); + ckfree(p.transform.buf); } else #endif /* TCL_THREADS */ { @@ -3256,7 +3296,7 @@ TransformFlush( } if (op == FLUSH_WRITE) { - bytev = Tcl_GetBytesFromObj(NULL, resObj, &bytec); + bytev = Tcl_GetByteArrayFromObj(resObj, &bytec); res = Tcl_WriteRaw(rtPtr->parent, (char *) bytev, bytec); } else { res = 0; diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c index 47fde36..eaa9cc8 100644 --- a/generic/tclIOSock.c +++ b/generic/tclIOSock.c @@ -75,11 +75,7 @@ TclSockGetPort( * Don't bother translating 'proto' to native. */ - if (Tcl_UtfToExternalDStringEx(interp, NULL, string, -1, 0, &ds, NULL) != TCL_OK) { - Tcl_DStringFree(&ds); - return TCL_ERROR; - } - native = Tcl_DStringValue(&ds); + native = Tcl_UtfToExternalDString(NULL, string, -1, &ds); sp = getservbyname(native, proto); /* INTL: Native. */ Tcl_DStringFree(&ds); if (sp != NULL) { @@ -121,15 +117,11 @@ TclSockGetPort( int TclSockMinimumBuffers( void *sock, /* Socket file descriptor */ - Tcl_Size size1) /* Minimum buffer size */ + int size) /* Minimum buffer size */ { int current; socklen_t len; - int size = size1; - if (size != size1) { - return TCL_ERROR; - } len = sizeof(int); getsockopt((SOCKET)(size_t) sock, SOL_SOCKET, SO_SNDBUF, (char *) ¤t, &len); @@ -188,11 +180,7 @@ TclCreateSocketAddress( int result; if (host != NULL) { - if (Tcl_UtfToExternalDStringEx(interp, NULL, host, -1, 0, &ds, NULL) != TCL_OK) { - Tcl_DStringFree(&ds); - return 0; - } - native = Tcl_DStringValue(&ds); + native = Tcl_UtfToExternalDString(NULL, host, -1, &ds); } /* @@ -236,7 +224,7 @@ TclCreateSocketAddress( * 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 NetBSD. + * Missing on: OpenBSD, NetBSD. * Causes failure when used on AIX 5.1 and HP-UX */ @@ -325,7 +313,7 @@ Tcl_OpenTcpServer( int port, const char *host, Tcl_TcpAcceptProc *acceptProc, - void *callbackData) + ClientData callbackData) { char portbuf[TCL_INTEGER_SPACE]; diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 6067282..da21664 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -440,7 +440,7 @@ FsThrExitProc( while (fsRecPtr != NULL) { tmpFsRecPtr = fsRecPtr->nextPtr; fsRecPtr->fsPtr = NULL; - Tcl_Free(fsRecPtr); + ckfree(fsRecPtr); fsRecPtr = tmpFsRecPtr; } tsdPtr->filesystemList = NULL; @@ -579,7 +579,7 @@ FsRecacheFilesystemList(void) list = NULL; fsRecPtr = tmpFsRecPtr; while (fsRecPtr != NULL) { - tmpFsRecPtr = (FilesystemRecord *)Tcl_Alloc(sizeof(FilesystemRecord)); + tmpFsRecPtr = (FilesystemRecord *)ckalloc(sizeof(FilesystemRecord)); *tmpFsRecPtr = *fsRecPtr; tmpFsRecPtr->nextPtr = list; tmpFsRecPtr->prevPtr = NULL; @@ -594,7 +594,7 @@ FsRecacheFilesystemList(void) FilesystemRecord *next = toFree->nextPtr; toFree->fsPtr = NULL; - Tcl_Free(toFree); + ckfree(toFree); toFree = next; } @@ -664,7 +664,7 @@ FsUpdateCwd( Tcl_Obj *cwdObj, void *clientData) { - Tcl_Size len = 0; + Tcl_Size len; const char *str = NULL; ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); @@ -772,7 +772,7 @@ TclFinalizeFilesystem(void) */ if (fsRecPtr != &nativeFilesystemRecord) { - Tcl_Free(fsRecPtr); + ckfree(fsRecPtr); } fsRecPtr = tmpFsRecPtr; } @@ -854,7 +854,7 @@ Tcl_FSRegister( return TCL_ERROR; } - newFilesystemPtr = (FilesystemRecord *)Tcl_Alloc(sizeof(FilesystemRecord)); + newFilesystemPtr = (FilesystemRecord *)ckalloc(sizeof(FilesystemRecord)); newFilesystemPtr->clientData = clientData; newFilesystemPtr->fsPtr = fsPtr; @@ -940,7 +940,7 @@ Tcl_FSUnregister( ++theFilesystemEpoch; } - Tcl_Free(fsRecPtr); + ckfree(fsRecPtr); retVal = TCL_OK; } else { @@ -1215,7 +1215,9 @@ FsAddMountsToGlobResult( * native file system; see note below). * * (4) The mapping from a string representation of a file to a full, - * normalized pathname changes. + * normalized pathname changes. For example, if 'env(HOME)' is modified, + * then any pathname containing '~' maps to a different item, possibly in + * a different filesystem. * * Tcl has no control over (2) and (3), so each registered filesystem must * call Tcl_FSMountsChnaged in each of those circumstances. @@ -1536,7 +1538,7 @@ TclGetOpenMode( Tcl_SetErrorCode(interp, "TCL", "OPENMODE", "INVALID", (char *)NULL); } if (modeArgv) { - Tcl_Free((void *)modeArgv); + ckfree((void *)modeArgv); } return -1; } @@ -1640,7 +1642,7 @@ TclGetOpenMode( } } - Tcl_Free((void *)modeArgv); + ckfree((void *)modeArgv); if (!gotRW) { if (interp != NULL) { @@ -1728,7 +1730,7 @@ Tcl_FSEvalFileEx( * for scripted documents. [Bug: 2040] */ - Tcl_SetChannelOption(interp, chan, "-eofchar", "\x1A"); + Tcl_SetChannelOption(interp, chan, "-eofchar", "\x1A {}"); /* * If the encoding is specified, set the channel to that encoding. @@ -1740,7 +1742,7 @@ Tcl_FSEvalFileEx( } if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName) != TCL_OK) { - Tcl_CloseEx(interp,chan,0); + Tcl_Close(interp,chan); return result; } @@ -1752,7 +1754,7 @@ Tcl_FSEvalFileEx( */ if (Tcl_ReadChars(chan, objPtr, 1, 0) == TCL_IO_FAILURE) { - Tcl_CloseEx(interp, chan, 0); + Tcl_Close(interp, chan); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", TclGetString(pathPtr), Tcl_PosixError(interp))); @@ -1767,14 +1769,14 @@ Tcl_FSEvalFileEx( if (Tcl_ReadChars(chan, objPtr, TCL_INDEX_NONE, memcmp(string, "\xEF\xBB\xBF", 3)) == TCL_IO_FAILURE) { - Tcl_CloseEx(interp, chan, 0); + Tcl_Close(interp, chan); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", TclGetString(pathPtr), Tcl_PosixError(interp))); goto end; } - if (Tcl_CloseEx(interp, chan, 0) != TCL_OK) { + if (Tcl_Close(interp, chan) != TCL_OK) { goto end; } @@ -1815,7 +1817,7 @@ Tcl_FSEvalFileEx( Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (file \"%.*s%s\" line %d)", - (overflow ? limit : (int)length), pathString, + (overflow ? limit : length), pathString, (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); } @@ -1864,7 +1866,7 @@ TclNREvalFile( * for scripted documents. [Bug: 2040] */ - Tcl_SetChannelOption(interp, chan, "-eofchar", "\x1A"); + Tcl_SetChannelOption(interp, chan, "-eofchar", "\x1A {}"); /* * If the encoding is specified, set the channel to that encoding. @@ -1876,7 +1878,7 @@ TclNREvalFile( } if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName) != TCL_OK) { - Tcl_CloseEx(interp, chan, 0); + Tcl_Close(interp, chan); return TCL_ERROR; } @@ -1888,7 +1890,7 @@ TclNREvalFile( */ if (Tcl_ReadChars(chan, objPtr, 1, 0) == TCL_IO_FAILURE) { - Tcl_CloseEx(interp, chan, 0); + Tcl_Close(interp, chan); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", TclGetString(pathPtr), Tcl_PosixError(interp))); @@ -1904,7 +1906,7 @@ TclNREvalFile( if (Tcl_ReadChars(chan, objPtr, TCL_INDEX_NONE, memcmp(string, "\xEF\xBB\xBF", 3)) == TCL_IO_FAILURE) { - Tcl_CloseEx(interp, chan, 0); + Tcl_Close(interp, chan); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "couldn't read file \"%s\": %s", TclGetString(pathPtr), Tcl_PosixError(interp))); @@ -1912,7 +1914,7 @@ TclNREvalFile( return TCL_ERROR; } - if (Tcl_CloseEx(interp, chan, 0) != TCL_OK) { + if (Tcl_Close(interp, chan) != TCL_OK) { Tcl_DecrRefCount(objPtr); return TCL_ERROR; } @@ -1968,7 +1970,7 @@ EvalFileCallback( Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (file \"%.*s%s\" line %d)", - (overflow ? limit : (int)length), pathString, + (overflow ? limit : length), pathString, (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); } @@ -2243,7 +2245,7 @@ Tcl_FSOpenFileChannel( "could not seek to end of file while opening \"%s\": %s", TclGetString(pathPtr), Tcl_PosixError(interp))); } - Tcl_CloseEx(NULL, retVal, 0); + Tcl_Close(NULL, retVal); return NULL; } if (modeFlags & CHANNEL_RAW_MODE) { @@ -3262,11 +3264,11 @@ Tcl_LoadFile( } buffer = TclpLoadMemoryGetBuffer(interp, size); if (!buffer) { - Tcl_CloseEx(interp, data, 0); + Tcl_Close(interp, data); goto mustCopyToTempAnyway; } ret = Tcl_Read(data, (char *)buffer, size); - Tcl_CloseEx(interp, data, 0); + Tcl_Close(interp, data); ret = TclpLoadMemory(interp, buffer, size, ret, handlePtr, &unloadProcPtr, flags); if (ret == TCL_OK && *handlePtr != NULL) { @@ -3380,7 +3382,7 @@ Tcl_LoadFile( * Divert the unloading in order to unload and cleanup the temporary file. */ - tvdlPtr = (FsDivertLoad *)Tcl_Alloc(sizeof(FsDivertLoad)); + tvdlPtr = (FsDivertLoad *)ckalloc(sizeof(FsDivertLoad)); /* * Remember three pieces of information in order to clean up the diverted @@ -3421,7 +3423,7 @@ Tcl_LoadFile( copyToPtr = NULL; - divertedLoadHandle = (Tcl_LoadHandle)Tcl_Alloc(sizeof(struct Tcl_LoadHandle_)); + divertedLoadHandle = (Tcl_LoadHandle)ckalloc(sizeof(struct Tcl_LoadHandle_)); divertedLoadHandle->clientData = tvdlPtr; divertedLoadHandle->findSymbolProcPtr = DivertFindSymbol; divertedLoadHandle->unloadFileProcPtr = DivertUnloadFile; @@ -3559,8 +3561,8 @@ DivertUnloadFile( Tcl_DecrRefCount(tvdlPtr->divertedFile); } - Tcl_Free(tvdlPtr); - Tcl_Free(loadHandle); + ckfree(tvdlPtr); + ckfree(loadHandle); } /* @@ -3869,7 +3871,13 @@ Tcl_FSSplitPath( length = p - elementStart; if (length > 0) { Tcl_Obj *nextElt; - nextElt = Tcl_NewStringObj(elementStart, length); + + if (elementStart[0] == '~') { + TclNewLiteralStringObj(nextElt, "./"); + Tcl_AppendToObj(nextElt, elementStart, length); + } else { + nextElt = Tcl_NewStringObj(elementStart, length); + } Tcl_ListObjAppendElement(NULL, result, nextElt); } if (*p++ == '\0') { @@ -4182,7 +4190,7 @@ TclCrossFilesystemCopy( * Could not open an input channel. Why didn't the caller check this? */ - Tcl_CloseEx(interp, out, 0); + Tcl_Close(interp, out); goto done; } @@ -4199,8 +4207,8 @@ TclCrossFilesystemCopy( * If the copy failed, assume that copy channel left an error message. */ - Tcl_CloseEx(interp, in, 0); - Tcl_CloseEx(interp, out, 0); + Tcl_Close(interp, in); + Tcl_Close(interp, out); /* * Set modification date of copied file. @@ -4524,7 +4532,7 @@ static void NativeFreeInternalRep( void *clientData) { - Tcl_Free(clientData); + ckfree(clientData); } /* diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c index 3e92b5a..135fe4a 100644 --- a/generic/tclIndexObj.c +++ b/generic/tclIndexObj.c @@ -41,8 +41,7 @@ const Tcl_ObjType tclIndexType = { FreeIndex, /* freeIntRepProc */ DupIndex, /* dupIntRepProc */ UpdateStringOfIndex, /* updateStringProc */ - NULL, /* setFromAnyProc */ - TCL_OBJTYPE_V0 + NULL /* setFromAnyProc */ }; /* @@ -68,7 +67,76 @@ typedef struct { #define NEXT_ENTRY(table, offset) \ (&(STRING_AT(table, offset))) #define EXPAND_OF(indexRep) \ - (((indexRep)->index != TCL_INDEX_NONE) ? STRING_AT((indexRep)->tablePtr, (indexRep)->offset*(indexRep)->index) : "") + (((indexRep)->index >= 0) ? STRING_AT((indexRep)->tablePtr, (indexRep)->offset*(indexRep)->index) : "") + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetIndexFromObj -- + * + * This function looks up an object's value in a table of strings and + * returns the index of the matching string, if any. + * + * Results: + * If the value of objPtr is identical to or a unique abbreviation for + * one of the entries in tablePtr, then the return value is TCL_OK and the + * index of the matching entry is stored at *indexPtr. If there isn't a + * proper match, then TCL_ERROR is returned and an error message is left + * in interp's result (unless interp is NULL). The msg argument is used + * in the error message; for example, if msg has the value "option" then + * the error message will say something flag 'bad option "foo": must be + * ...' + * + * Side effects: + * The result of the lookup is cached as the internal rep of objPtr, so + * that repeated lookups can be done quickly. + * + *---------------------------------------------------------------------- + */ + +#ifndef TCL_NO_DEPRECATED +#undef Tcl_GetIndexFromObj +int +Tcl_GetIndexFromObj( + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + Tcl_Obj *objPtr, /* Object containing the string to lookup. */ + const char *const *tablePtr, /* Array of strings to compare against the + * value of objPtr; last entry must be NULL + * and there must not be duplicate entries. */ + const char *msg, /* Identifying word to use in error + * messages. */ + int flags, /* 0 or TCL_EXACT */ + int *indexPtr) /* Place to store resulting integer index. */ +{ + if (!(flags & TCL_INDEX_TEMP_TABLE)) { + + /* + * See if there is a valid cached result from a previous lookup (doing the + * check here saves the overhead of calling Tcl_GetIndexFromObjStruct in + * the common case where the result is cached). + */ + + const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &tclIndexType); + + if (irPtr) { + IndexRep *indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1; + + /* + * Here's hoping we don't get hit by unfortunate packing constraints + * on odd platforms like a Cray PVP... + */ + + if (indexRep->tablePtr == (void *)tablePtr + && indexRep->offset == sizeof(char *)) { + *indexPtr = indexRep->index; + return TCL_OK; + } + } + } + return Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, sizeof(char *), + msg, flags, indexPtr); +} +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -126,14 +194,14 @@ GetIndexFromObjList( * Build a string table from the list. */ - tablePtr = (const char **)Tcl_Alloc((objc + 1) * sizeof(char *)); + tablePtr = (const char **)ckalloc((objc + 1) * sizeof(char *)); for (t = 0; t < objc; t++) { if (objv[t] == objPtr) { /* * An exact match is always chosen, so we can stop here. */ - Tcl_Free(tablePtr); + ckfree(tablePtr); *indexPtr = t; return TCL_OK; } @@ -145,7 +213,7 @@ GetIndexFromObjList( result = Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, sizeof(char *), msg, flags | TCL_INDEX_TEMP_TABLE, indexPtr); - Tcl_Free(tablePtr); + ckfree(tablePtr); return result; } @@ -201,30 +269,26 @@ Tcl_GetIndexFromObjStruct( IndexRep *indexRep; const Tcl_ObjInternalRep *irPtr; + /* Protect against invalid values, like -1 or 0. */ if (offset < (Tcl_Size)sizeof(char *)) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "Invalid %s value %" TCL_SIZE_MODIFIER "d.", - "struct offset", offset)); - } - return TCL_ERROR; + offset = (Tcl_Size)sizeof(char *); } /* * See if there is a valid cached result from a previous lookup. */ if (objPtr && !(flags & TCL_INDEX_TEMP_TABLE)) { - irPtr = TclFetchInternalRep(objPtr, &tclIndexType); - if (irPtr) { - indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1; - if ((indexRep->tablePtr == tablePtr) - && (indexRep->offset == offset) - && (indexRep->index != TCL_INDEX_NONE)) { - index = indexRep->index; - goto uncachedDone; - } + irPtr = TclFetchInternalRep(objPtr, &tclIndexType); + if (irPtr) { + indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1; + if ((indexRep->tablePtr == tablePtr) + && (indexRep->offset == offset) + && (indexRep->index >= 0)) { + index = indexRep->index; + goto uncachedDone; } } + } /* * Lookup the value of the object in the table. Accept unique @@ -282,14 +346,14 @@ Tcl_GetIndexFromObjStruct( * operation. */ - if (objPtr && (index != TCL_INDEX_NONE) && !(flags & TCL_INDEX_TEMP_TABLE)) { + if (objPtr && (index >= 0) && !(flags & TCL_INDEX_TEMP_TABLE)) { irPtr = TclFetchInternalRep(objPtr, &tclIndexType); if (irPtr) { indexRep = (IndexRep *)irPtr->twoPtrValue.ptr1; } else { Tcl_ObjInternalRep ir; - indexRep = (IndexRep*)Tcl_Alloc(sizeof(IndexRep)); + indexRep = (IndexRep*)ckalloc(sizeof(IndexRep)); ir.twoPtrValue.ptr1 = indexRep; Tcl_StoreInternalRep(objPtr, &tclIndexType, &ir); } @@ -416,7 +480,7 @@ DupIndex( Tcl_Obj *dupPtr) { Tcl_ObjInternalRep ir; - IndexRep *dupIndexRep = (IndexRep *)Tcl_Alloc(sizeof(IndexRep)); + IndexRep *dupIndexRep = (IndexRep *)ckalloc(sizeof(IndexRep)); memcpy(dupIndexRep, TclFetchInternalRep(srcPtr, &tclIndexType)->twoPtrValue.ptr1, sizeof(IndexRep)); @@ -446,7 +510,7 @@ static void FreeIndex( Tcl_Obj *objPtr) { - Tcl_Free(TclFetchInternalRep(objPtr, &tclIndexType)->twoPtrValue.ptr1); + ckfree(TclFetchInternalRep(objPtr, &tclIndexType)->twoPtrValue.ptr1); objPtr->typePtr = NULL; } @@ -508,7 +572,7 @@ PrefixMatchObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - int flags = 0, result; + int flags = 0, result, index; Tcl_Size errorLength, i; Tcl_Obj *errorPtr = NULL; const char *message = "option"; @@ -518,7 +582,7 @@ PrefixMatchObjCmd( }; enum matchOptionsEnum { PRFMATCH_ERROR, PRFMATCH_EXACT, PRFMATCH_MESSAGE - } index; + }; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "?options? table string"); @@ -530,7 +594,7 @@ PrefixMatchObjCmd( sizeof(char *), "option", 0, &index) != TCL_OK) { return TCL_ERROR; } - switch (index) { + switch ((enum matchOptionsEnum) index) { case PRFMATCH_EXACT: flags |= TCL_EXACT; break; @@ -819,6 +883,29 @@ Tcl_WrongNumArgs( Interp *iPtr = (Interp *)interp; const char *elementStr; + /* + * [incr Tcl] does something fairly horrific when generating error + * messages for its ensembles; it passes the whole set of ensemble + * arguments as a list in the first argument. This means that this code + * causes a problem in iTcl if it attempts to correctly quote all + * arguments, which would be the correct thing to do. We work around this + * nasty behaviour for now, and hope that we can remove it all in the + * future... + */ + +#ifndef AVOID_HACKS_FOR_ITCL + int isFirst = 1; /* Special flag used to inhibit the treating + * of the first word as a list element so the + * hacky way Itcl generates error messages for + * its ensembles will still work. [Bug + * 1066837] */ +# define MAY_QUOTE_WORD (!isFirst) +# define AFTER_FIRST_WORD (isFirst = 0) +#else /* !AVOID_HACKS_FOR_ITCL */ +# define MAY_QUOTE_WORD 1 +# define AFTER_FIRST_WORD (void) 0 +#endif /* AVOID_HACKS_FOR_ITCL */ + TclNewObj(objPtr); if (iPtr->flags & INTERP_ALTERNATE_WRONG_ARGS) { iPtr->flags &= ~INTERP_ALTERNATE_WRONG_ARGS; @@ -877,7 +964,7 @@ Tcl_WrongNumArgs( flags = 0; len = TclScanElement(elementStr, elemLen, &flags); - if (len != elemLen) { + if (MAY_QUOTE_WORD && len != elemLen) { char *quotedElementStr = (char *)TclStackAlloc(interp, len + 1); len = TclConvertElement(elementStr, elemLen, @@ -888,6 +975,8 @@ Tcl_WrongNumArgs( Tcl_AppendToObj(objPtr, elementStr, elemLen); } + AFTER_FIRST_WORD; + /* * Add a space if the word is not the last one (which has a * moderately complex condition here). @@ -926,7 +1015,7 @@ Tcl_WrongNumArgs( flags = 0; len = TclScanElement(elementStr, elemLen, &flags); - if (len != elemLen) { + if (MAY_QUOTE_WORD && len != elemLen) { char *quotedElementStr = (char *)TclStackAlloc(interp, len + 1); len = TclConvertElement(elementStr, elemLen, @@ -938,6 +1027,8 @@ Tcl_WrongNumArgs( } } + AFTER_FIRST_WORD; + /* * Append a space character (" ") if there is more text to follow * (either another element from objv, or the message string). @@ -960,6 +1051,8 @@ Tcl_WrongNumArgs( Tcl_AppendStringsToObj(objPtr, "\"", (char *)NULL); Tcl_SetErrorCode(interp, "TCL", "WRONGARGS", (char *)NULL); Tcl_SetObjResult(interp, objPtr); +#undef MAY_QUOTE_WORD +#undef AFTER_FIRST_WORD } /* @@ -1031,7 +1124,7 @@ Tcl_ParseArgsObjv( */ nrem = 1; - leftovers = (Tcl_Obj **)Tcl_Alloc((1 + *objcPtr) * sizeof(Tcl_Obj *)); + leftovers = (Tcl_Obj **)ckalloc((1 + *objcPtr) * sizeof(Tcl_Obj *)); leftovers[0] = objv[0]; } else { nrem = 0; @@ -1173,12 +1266,6 @@ Tcl_ParseArgsObjv( break; } case TCL_ARGV_GENFUNC: { - - if (objc > INT_MAX) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "too many (%" TCL_SIZE_MODIFIER "d) arguments for TCL_ARGV_GENFUNC", objc)); - goto error; - } Tcl_ArgvGenFuncProc *handlerProc = (Tcl_ArgvGenFuncProc *) infoPtr->srcPtr; @@ -1224,7 +1311,7 @@ Tcl_ParseArgsObjv( } leftovers[nrem] = NULL; *objcPtr = nrem++; - *remObjv = (Tcl_Obj **)Tcl_Realloc(leftovers, nrem * sizeof(Tcl_Obj *)); + *remObjv = (Tcl_Obj **)ckrealloc(leftovers, nrem * sizeof(Tcl_Obj *)); return TCL_OK; /* @@ -1237,7 +1324,7 @@ Tcl_ParseArgsObjv( "\"%s\" option requires an additional argument", str)); error: if (leftovers != NULL) { - Tcl_Free(leftovers); + ckfree(leftovers); } return TCL_ERROR; } diff --git a/generic/tclInt.decls b/generic/tclInt.decls index 83739c1..279f493 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -37,6 +37,11 @@ declare 6 { declare 7 { Tcl_Size TclCopyAndCollapse(Tcl_Size count, const char *src, char *dst) } +declare 8 {deprecated {}} { + int TclCopyChannelOld(Tcl_Interp *interp, Tcl_Channel inChan, + Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr) +} + # TclCreatePipeline unofficially exported for use by BLT. declare 9 { Tcl_Size TclCreatePipeline(Tcl_Interp *interp, Tcl_Size argc, const char **argv, @@ -85,14 +90,13 @@ declare 32 { int TclGetFrame(Tcl_Interp *interp, const char *str, CallFrame **framePtrPtr) } -# Removed in 9.0: -#declare 34 { -# int TclGetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr, -# int endValue, int *indexPtr) -#} -#declare 37 { -# int TclGetLoadedPackages(Tcl_Interp *interp, const char *targetName) -#} +declare 34 {deprecated {Use Tcl_GetIntForIndex}} { + int TclGetIntForIndex(Tcl_Interp *interp, Tcl_Obj *objPtr, + int endValue, int *indexPtr) +} +declare 37 {deprecated {}} { + int TclGetLoadedPackages(Tcl_Interp *interp, const char *targetName) +} declare 38 { int TclGetNamespaceForQualName(Tcl_Interp *interp, const char *qualName, Namespace *cxtNsPtr, int flags, Namespace **nsPtrPtr, @@ -111,36 +115,30 @@ declare 41 { declare 42 { const char *TclpGetUserHome(const char *name, Tcl_DString *bufferPtr) } -declare 43 { - Tcl_ObjCmdProc2 *TclGetObjInterpProc2(void) +declare 44 {deprecated {}} { + int TclGuessPackageName(const char *fileName, Tcl_DString *bufPtr) } -# Removed in 9.0: -#declare 44 { -# int TclGuessPackageName(const char *fileName, Tcl_DString *bufPtr) -#} declare 45 { int TclHideUnsafeCommands(Tcl_Interp *interp) } declare 46 { int TclInExit(void) } -# Removed in 9.0: -#declare 50 { -# void TclInitCompiledLocals(Tcl_Interp *interp, CallFrame *framePtr, -# Namespace *nsPtr) -#} +declare 50 {deprecated {}} { + void TclInitCompiledLocals(Tcl_Interp *interp, CallFrame *framePtr, + Namespace *nsPtr) +} declare 51 { int TclInterpInit(Tcl_Interp *interp) } -# Removed in 9.0 -#declare 53 { -# int TclInvokeObjectCommand(void *clientData, Tcl_Interp *interp, -# Tcl_Size argc, const char **argv) -#} -#declare 54 { -# int TclInvokeStringCommand(void *clientData, Tcl_Interp *interp, -# Tcl_Size objc, Tcl_Obj *const objv[]) -#} +declare 53 {deprecated {}} { + int TclInvokeObjectCommand(void *clientData, Tcl_Interp *interp, + Tcl_Size argc, const char **argv) +} +declare 54 {deprecated {}} { + int TclInvokeStringCommand(void *clientData, Tcl_Interp *interp, + Tcl_Size objc, Tcl_Obj *const objv[]) +} declare 55 { Proc *TclIsProc(Command *cmdPtr) } @@ -158,11 +156,10 @@ declare 61 { declare 62 { int TclObjCommandComplete(Tcl_Obj *cmdPtr) } -# Removed in 9.0: -#declare 63 { -# int TclObjInterpProc(void *clientData, Tcl_Interp *interp, -# Tcl_Size objc, Tcl_Obj *const objv[]) -#} +declare 63 {deprecated {}} { + int TclObjInterpProc(void *clientData, Tcl_Interp *interp, + Tcl_Size objc, Tcl_Obj *const objv[]) +} declare 64 { int TclObjInvoke(Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], int flags) @@ -174,23 +171,21 @@ declare 74 { void TclpFree(void *ptr) } declare 75 { - unsigned long long TclpGetClicks(void) + unsigned long TclpGetClicks(void) } declare 76 { - unsigned long long TclpGetSeconds(void) + unsigned long TclpGetSeconds(void) +} +declare 77 {deprecated {}} { + void TclpGetTime(Tcl_Time *time) } -# Removed in 9.0: -#declare 77 { -# void TclpGetTime(Tcl_Time *time) -#} declare 81 { void *TclpRealloc(void *ptr, TCL_HASH_TYPE size) } -# Removed in 9.0: -#declare 88 { -# char *TclPrecTraceProc(void *clientData, Tcl_Interp *interp, -# const char *name1, const char *name2, int flags) -#} +declare 88 {deprecated {}} { + char *TclPrecTraceProc(void *clientData, Tcl_Interp *interp, + const char *name1, const char *name2, int flags) +} declare 89 { int TclPreventAliasLoop(Tcl_Interp *interp, Tcl_Interp *cmdInterp, Tcl_Command cmd) @@ -216,10 +211,9 @@ declare 97 { declare 98 { int TclServiceIdle(void) } -# Removed in 9.0: -#declare 101 { -# const char *TclSetPreInitScript(const char *string) -#} +declare 101 {deprecated {Use Tcl_SetPreInitScript}} { + const char *TclSetPreInitScript(const char *string) +} declare 102 { void TclSetupEnv(Tcl_Interp *interp) } @@ -227,10 +221,9 @@ declare 103 { int TclSockGetPort(Tcl_Interp *interp, const char *str, const char *proto, int *portPtr) } -# Removed in 9.0: -#declare 104 { -# int TclSockMinimumBuffersOld(int sock, int size) -#} +declare 104 {deprecated {}} { + int TclSockMinimumBuffersOld(int sock, int size) +} declare 108 { void TclTeardownNamespace(Namespace *nsPtr) } @@ -249,30 +242,29 @@ declare 111 { Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc) } -# Removed in 9.0: -#declare 112 { -# int TclAppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr, -# Tcl_Obj *objPtr) -#} -#declare 113 { -# Tcl_Namespace *TclCreateNamespace(Tcl_Interp *interp, const char *name, -# void *clientData, Tcl_NamespaceDeleteProc *deleteProc) -#} -#declare 114 { -# void TclDeleteNamespace(Tcl_Namespace *nsPtr) -#} -#declare 115 { -# int TclExport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, -# const char *pattern, int resetListFirst) -#} -#declare 116 { -# Tcl_Command TclFindCommand(Tcl_Interp *interp, const char *name, -# Tcl_Namespace *contextNsPtr, int flags) -#} -#declare 117 { -# Tcl_Namespace *TclFindNamespace(Tcl_Interp *interp, const char *name, -# Tcl_Namespace *contextNsPtr, int flags) -#} +declare 112 {deprecated {Use Tcl_AppendExportList}} { + int TclAppendExportList(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + Tcl_Obj *objPtr) +} +declare 113 {deprecated {Use Tcl_CreateNamespace}} { + Tcl_Namespace *TclCreateNamespace(Tcl_Interp *interp, const char *name, + void *clientData, Tcl_NamespaceDeleteProc *deleteProc) +} +declare 114 {deprecated {Use Tcl_DeleteNamespace}} { + void TclDeleteNamespace(Tcl_Namespace *nsPtr) +} +declare 115 {deprecated {Use Tcl_Export}} { + int TclExport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + const char *pattern, int resetListFirst) +} +declare 116 {deprecated {Use Tcl_FindCommand}} { + Tcl_Command TclFindCommand(Tcl_Interp *interp, const char *name, + Tcl_Namespace *contextNsPtr, int flags) +} +declare 117 {deprecated {Use Tcl_FindNamespace}} { + Tcl_Namespace *TclFindNamespace(Tcl_Interp *interp, const char *name, + Tcl_Namespace *contextNsPtr, int flags) +} declare 118 { int Tcl_GetInterpResolvers(Tcl_Interp *interp, const char *name, Tcl_ResolverInfo *resInfo) @@ -285,10 +277,31 @@ declare 120 { Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags) } +declare 121 {deprecated {Use Tcl_ForgetImport}} { + int TclForgetImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + const char *pattern) +} +declare 122 {deprecated {Use Tcl_GetCommandFromObj}} { + Tcl_Command TclGetCommandFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr) +} +declare 123 {deprecated {Use Tcl_GetCommandFullName}} { + void TclGetCommandFullName(Tcl_Interp *interp, Tcl_Command command, + Tcl_Obj *objPtr) +} +declare 124 {deprecated {Use Tcl_GetCurrentNamespace}} { + Tcl_Namespace *TclGetCurrentNamespace_(Tcl_Interp *interp) +} +declare 125 {deprecated {Use Tcl_GetGlobalNamespace}} { + Tcl_Namespace *TclGetGlobalNamespace_(Tcl_Interp *interp) +} declare 126 { void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr) } +declare 127 {deprecated {Use }} { + int TclImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + const char *pattern, int allowOverwrite) +} declare 128 { void Tcl_PopCallFrame(Tcl_Interp *interp) } @@ -304,6 +317,12 @@ declare 131 { Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc) } +declare 132 {deprecated {}} { + int TclpHasSockets(Tcl_Interp *interp) +} +declare 133 {deprecated {}} { + struct tm *TclpGetDate(const time_t *time, int useGMT) +} declare 138 { const char *TclGetEnv(const char *name, Tcl_DString *valuePtr) } @@ -345,6 +364,12 @@ declare 151 { void TclRegExpRangeUniChar(Tcl_RegExp re, Tcl_Size index, Tcl_Size *startPtr, Tcl_Size *endPtr) } +declare 152 { + void TclSetLibraryPath(Tcl_Obj *pathPtr) +} +declare 153 { + Tcl_Obj *TclGetLibraryPath(void) +} declare 156 { void TclRegError(Tcl_Interp *interp, const char *msg, int status) @@ -352,6 +377,13 @@ declare 156 { declare 157 { Var *TclVarTraceExists(Tcl_Interp *interp, const char *varName) } +declare 158 {deprecated {use public Tcl_SetStartupScript()}} { + void TclSetStartupScriptFileName(const char *filename) +} +declare 159 {deprecated {use public Tcl_GetStartupScript()}} { + const char *TclGetStartupScriptFileName(void) +} + declare 161 { int TclChannelTransform(Tcl_Interp *interp, Tcl_Channel chan, Tcl_Obj *cmdObjPtr) @@ -388,9 +420,15 @@ declare 166 { Tcl_Size index, Tcl_Obj *valuePtr) } +declare 167 {deprecated {use public Tcl_SetStartupScript()}} { + void TclSetStartupScriptPath(Tcl_Obj *pathPtr) +} +declare 168 {deprecated {use public Tcl_GetStartupScript()}} { + Tcl_Obj *TclGetStartupScriptPath(void) +} # variant of Tcl_UtfNcmp that takes n as bytes, not chars declare 169 { - int TclpUtfNcmp2(const void *s1, const void *s2, size_t n) + int TclpUtfNcmp2(const char *s1, const char *s2, unsigned long n) } declare 170 { int TclCheckInterpTraces(Tcl_Interp *interp, const char *command, @@ -420,6 +458,21 @@ declare 177 { void TclVarErrMsg(Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason) } +declare 178 {deprecated {}} { + void TclSetStartupScript(Tcl_Obj *pathPtr, const char *encoding) +} +declare 179 {deprecated {}} { + Tcl_Obj *TclGetStartupScript(const char **encodingPtr) +} +declare 182 {deprecated {}} { + struct tm *TclpLocaltime(const time_t *clock) +} +declare 183 {deprecated {}} { + struct tm *TclpGmtime(const time_t *clock) +} + +# For the new "Thread Storage" subsystem. + declare 198 { int TclObjGetFrame(Tcl_Interp *interp, Tcl_Obj *objPtr, CallFrame **framePtrPtr) @@ -542,6 +595,9 @@ declare 234 { declare 235 { void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr) } +declare 236 {deprecated {use Tcl_BackgroundException}} { + void TclBackgroundException(Tcl_Interp *interp, int code) +} # TIP #285: Script cancellation support. declare 237 { @@ -653,64 +709,198 @@ declare 261 { interface tclIntPlat ################################ -# Platform specific functions +# Windows specific functions -declare 1 { - int TclpCloseFile(TclFile file) +declare 0 win { + void TclWinConvertError(DWORD errCode) } -declare 2 { - Tcl_Channel TclpCreateCommandChannel(TclFile readFile, - TclFile writeFile, TclFile errorFile, size_t numPids, Tcl_Pid *pidPtr) +declare 1 win { + void TclWinConvertWSAError(DWORD errCode) } -declare 3 { - int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe) +declare 2 win { + struct servent *TclWinGetServByName(const char *nm, + const char *proto) } -declare 4 { - void *TclWinGetTclInstance(void) +declare 3 win { + int TclWinGetSockOpt(SOCKET s, int level, int optname, + char *optval, int *optlen) } -declare 5 { +declare 4 win { + HINSTANCE TclWinGetTclInstance(void) +} +declare 5 win { int TclUnixWaitForFile(int fd, int mask, int timeout) } -declare 6 { - TclFile TclpMakeFile(Tcl_Channel channel, int direction) +declare 6 win { + unsigned short TclWinNToHS(unsigned short ns) } -declare 7 { - TclFile TclpOpenFile(const char *fname, int mode) +declare 7 win { + int TclWinSetSockOpt(SOCKET s, int level, int optname, + const char *optval, int optlen) } -declare 8 { +declare 8 win { Tcl_Size TclpGetPid(Tcl_Pid pid) } -declare 9 { - TclFile TclpCreateTempFile(const char *contents) +declare 9 win { + int TclWinGetPlatformId(void) } -declare 11 { +declare 10 win { + Tcl_DirEntry *TclpReaddir(TclDIR *dir) +} + +# Pipe channel functions + +declare 11 win { void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan) } -declare 15 { - int TclpCreateProcess(Tcl_Interp *interp, size_t argc, +declare 12 win { + int TclpCloseFile(TclFile file) +} +declare 13 win { + Tcl_Channel TclpCreateCommandChannel(TclFile readFile, + TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr) +} +declare 14 win { + int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe) +} +declare 15 win { + int TclpCreateProcess(Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr) } -declare 16 { +declare 16 win { int TclpIsAtty(int fd) } -declare 17 { +declare 17 win { int TclUnixCopyFile(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts) } -declare 20 { +declare 18 win { + TclFile TclpMakeFile(Tcl_Channel channel, int direction) +} +declare 19 win { + TclFile TclpOpenFile(const char *fname, int mode) +} +declare 20 win { void TclWinAddProcess(void *hProcess, Tcl_Size id) } -declare 24 { +declare 21 win { + char *TclpInetNtoa(struct in_addr addr) +} +declare 22 win { + TclFile TclpCreateTempFile(const char *contents) +} +declare 24 win { char *TclWinNoBackslash(char *path) } -declare 27 { +declare 26 win { + void TclWinSetInterfaces(int wide) +} +declare 27 win { void TclWinFlushDirtyChannels(void) } -declare 29 { +declare 28 win { + void TclWinResetInterfaces(void) +} + +################################ +# Unix specific functions + +# Pipe channel functions + +declare 0 unix { + void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan) +} +declare 1 unix { + int TclpCloseFile(TclFile file) +} +declare 2 unix { + Tcl_Channel TclpCreateCommandChannel(TclFile readFile, + TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr) +} +declare 3 unix { + int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe) +} +declare 4 unix { + int TclpCreateProcess(Tcl_Interp *interp, int argc, + const char **argv, TclFile inputFile, TclFile outputFile, + TclFile errorFile, Tcl_Pid *pidPtr) +} +declare 5 unix { + int TclUnixWaitForFile_(int fd, int mask, int timeout) +} +declare 6 unix { + TclFile TclpMakeFile(Tcl_Channel channel, int direction) +} +declare 7 unix { + TclFile TclpOpenFile(const char *fname, int mode) +} +declare 8 unix { + int TclUnixWaitForFile(int fd, int mask, int timeout) +} + +# Added in 8.1: + +declare 9 unix { + TclFile TclpCreateTempFile(const char *contents) +} + +# Added in 8.4: + +declare 10 unix { + Tcl_DirEntry *TclpReaddir(TclDIR *dir) +} +# Slots 11 and 12 are forwarders for functions that were promoted to +# generic Stubs +declare 11 unix { + struct tm *TclpLocaltime_unix(const time_t *clock) +} +declare 12 unix { + struct tm *TclpGmtime_unix(const time_t *clock) +} +declare 13 unix { + char *TclpInetNtoa(struct in_addr addr) +} + +# Added in 8.5: + +declare 14 unix { + int TclUnixCopyFile(const char *src, const char *dst, + const Tcl_StatBuf *statBufPtr, int dontCopyAtts) +} + +################################ +# Mac OS X specific functions + +declare 15 {unix macosx} { + int TclMacOSXGetFileAttribute(Tcl_Interp *interp, int objIndex, + Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr) +} +declare 16 {unix macosx} { + int TclMacOSXSetFileAttribute(Tcl_Interp *interp, int objIndex, + Tcl_Obj *fileName, Tcl_Obj *attributePtr) +} +declare 17 {unix macosx} { + int TclMacOSXCopyFileAttributes(const char *src, const char *dst, + const Tcl_StatBuf *statBufPtr) +} +declare 18 {unix macosx} { + int TclMacOSXMatchType(Tcl_Interp *interp, const char *pathName, + const char *fileName, Tcl_StatBuf *statBufPtr, + Tcl_GlobTypeData *types) +} +declare 19 {unix macosx} { + void TclMacOSXNotifierAddRunLoopMode(const void *runLoopMode) +} +declare 22 {unix macosx} { + TclFile TclpCreateTempFile_(const char *contents) +} + +declare 29 {win unix} { int TclWinCPUID(int index, int *regs) } -declare 30 { +# Added in 8.6; core of TclpOpenTemporaryFile +declare 30 {win unix} { int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj) } diff --git a/generic/tclInt.h b/generic/tclInt.h index 7d2e848..8a0970d 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -26,6 +26,20 @@ #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. @@ -65,7 +79,6 @@ #include <stdio.h> #include <ctype.h> -#include <stdarg.h> #include <stdlib.h> #include <stdint.h> #ifdef NO_STRING_H @@ -199,6 +212,9 @@ typedef struct Tcl_ResolverInfo { * - Bug #696893 - variable is either proc-local or in the current * namespace; never follow the second (global) resolution path * - Bug #631741 - do not use special namespace or interp resolvers + * + * It should also not collide with the (deprecated) TCL_PARSE_PART1 flag + * (Bug #835020) */ #define TCL_AVOID_RESOLVERS 0x40000 @@ -213,18 +229,15 @@ typedef struct Tcl_Ensemble Tcl_Ensemble; typedef struct NamespacePathEntry NamespacePathEntry; /* - * Special hashtable for variables: This is just a Tcl_HashTable with nsPtr - * and arrayPtr fields added at the end so that variables can find their - * namespace and possibly containing array without having to copy a pointer in - * their struct by accessing them via their hPtr->tablePtr. + * Special hashtable for variables: This is just a Tcl_HashTable with a nsPtr + * field added at the end, so that variables can find their namespace + * without having to copy a pointer in their struct by accessing them via + * their hPtr->tablePtr. */ typedef struct TclVarHashTable { Tcl_HashTable table; struct Namespace *nsPtr; -#if TCL_MAJOR_VERSION > 8 - struct Var *arrayPtr; -#endif /* TCL_MAJOR_VERSION > 8 */ } TclVarHashTable; /* @@ -274,11 +287,7 @@ typedef struct Namespace { * strings; values have type (Namespace *). If * NULL, there are no children. */ #endif -#if TCL_MAJOR_VERSION > 8 - size_t nsId; /* Unique id for the namespace. */ -#else - unsigned long nsId; -#endif + 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 @@ -623,7 +632,7 @@ typedef struct Var { TclVarHashTable *tablePtr;/* For array variables, this points to * information about the hash table used to * implement the associative array. Points to - * Tcl_Alloc-ed data. */ + * ckalloc-ed data. */ struct Var *linkPtr; /* If this is a global variable being referred * to in a procedure, or a variable created by * "upvar", this field points to the @@ -664,11 +673,6 @@ typedef struct VarInHash { * through "upvar" and "global" commands, or * through references to variables in enclosing * namespaces. - * VAR_CONSTANT - 1 means this is a constant "variable", and - * cannot be written to by ordinary commands. - * Structurally, it's the same as a scalar when - * being read, but writes are rejected. Constants - * are not supported inside arrays. * * Flags that indicate the type and status of storage; none is set for * compiled local variables (Var structs). @@ -733,7 +737,6 @@ typedef struct VarInHash { /* Type of value (0 is scalar) */ #define VAR_ARRAY 0x1 #define VAR_LINK 0x2 -#define VAR_CONSTANT 0x10000 /* Type of storage (0 is compiled local) */ #define VAR_IN_HASHTABLE 0x4 @@ -768,14 +771,13 @@ typedef struct VarInHash { * MODULE_SCOPE void TclSetVarScalar(Var *varPtr); * MODULE_SCOPE void TclSetVarArray(Var *varPtr); * MODULE_SCOPE void TclSetVarLink(Var *varPtr); - * MODULE_SCOPE void TclSetVarConstant(Var *varPtr); * MODULE_SCOPE void TclSetVarArrayElement(Var *varPtr); * MODULE_SCOPE void TclSetVarUndefined(Var *varPtr); * MODULE_SCOPE void TclClearVarUndefined(Var *varPtr); */ #define TclSetVarScalar(varPtr) \ - (varPtr)->flags &= ~(VAR_ARRAY|VAR_LINK|VAR_CONSTANT) + (varPtr)->flags &= ~(VAR_ARRAY|VAR_LINK) #define TclSetVarArray(varPtr) \ (varPtr)->flags = ((varPtr)->flags & ~VAR_LINK) | VAR_ARRAY @@ -783,14 +785,11 @@ typedef struct VarInHash { #define TclSetVarLink(varPtr) \ (varPtr)->flags = ((varPtr)->flags & ~VAR_ARRAY) | VAR_LINK -#define TclSetVarConstant(varPtr) \ - (varPtr)->flags = ((varPtr)->flags & ~(VAR_ARRAY|VAR_LINK)) | VAR_CONSTANT - #define TclSetVarArrayElement(varPtr) \ (varPtr)->flags = ((varPtr)->flags & ~VAR_ARRAY) | VAR_ARRAY_ELEMENT #define TclSetVarUndefined(varPtr) \ - (varPtr)->flags &= ~(VAR_ARRAY|VAR_LINK|VAR_CONSTANT);\ + (varPtr)->flags &= ~(VAR_ARRAY|VAR_LINK);\ (varPtr)->value.objPtr = NULL #define TclClearVarUndefined(varPtr) @@ -822,7 +821,6 @@ typedef struct VarInHash { * The ANSI C "prototypes" for these macros are: * * MODULE_SCOPE int TclIsVarScalar(Var *varPtr); - * MODULE_SCOPE int TclIsVarConstant(Var *varPtr); * MODULE_SCOPE int TclIsVarLink(Var *varPtr); * MODULE_SCOPE int TclIsVarArray(Var *varPtr); * MODULE_SCOPE int TclIsVarUndefined(Var *varPtr); @@ -832,14 +830,6 @@ typedef struct VarInHash { * MODULE_SCOPE int TclIsVarResolved(Var *varPtr); */ -#define TclVarFindHiddenArray(varPtr,arrayPtr) \ - do { \ - if ((arrayPtr == NULL) && TclIsVarInHash(varPtr) && \ - (TclVarParentArray(varPtr) != NULL)) { \ - arrayPtr = TclVarParentArray(varPtr); \ - } \ - } while(0) - #define TclIsVarScalar(varPtr) \ !((varPtr)->flags & (VAR_ARRAY|VAR_LINK)) @@ -849,10 +839,6 @@ typedef struct VarInHash { #define TclIsVarArray(varPtr) \ ((varPtr)->flags & VAR_ARRAY) -/* Implies scalar as well. */ -#define TclIsVarConstant(varPtr) \ - ((varPtr)->flags & VAR_CONSTANT) - #define TclIsVarUndefined(varPtr) \ ((varPtr)->value.objPtr == NULL) @@ -888,9 +874,6 @@ typedef struct VarInHash { ? ((TclVarHashTable *) ((((VarInHash *) (varPtr))->entry.tablePtr)))->nsPtr \ : NULL) -#define TclVarParentArray(varPtr) \ - ((TclVarHashTable *) ((VarInHash *) (varPtr))->entry.tablePtr)->arrayPtr - #define VarHashRefCount(varPtr) \ ((VarInHash *) (varPtr))->refCount @@ -902,23 +885,20 @@ typedef struct VarInHash { */ #define TclIsVarTricky(varPtr,trickyFlags) \ - ( ((varPtr)->flags & (VAR_ARRAY|VAR_LINK|trickyFlags)) \ - || (TclIsVarInHash(varPtr) \ - && (TclVarParentArray(varPtr) != NULL) \ - && (TclVarParentArray(varPtr)->flags & (trickyFlags)))) + ((varPtr)->flags & (VAR_ARRAY|VAR_LINK|trickyFlags)) #define TclIsVarDirectReadable(varPtr) \ ( (!TclIsVarTricky(varPtr,VAR_TRACED_READ)) \ && (varPtr)->value.objPtr) #define TclIsVarDirectWritable(varPtr) \ - (!TclIsVarTricky(varPtr,VAR_TRACED_WRITE|VAR_DEAD_HASH|VAR_CONSTANT)) + (!TclIsVarTricky(varPtr,VAR_TRACED_WRITE|VAR_DEAD_HASH)) #define TclIsVarDirectUnsettable(varPtr) \ - (!TclIsVarTricky(varPtr,VAR_TRACED_READ|VAR_TRACED_WRITE|VAR_TRACED_UNSET|VAR_DEAD_HASH|VAR_CONSTANT)) + (!TclIsVarTricky(varPtr,VAR_TRACED_READ|VAR_TRACED_WRITE|VAR_TRACED_UNSET|VAR_DEAD_HASH)) #define TclIsVarDirectModifyable(varPtr) \ - ( (!TclIsVarTricky(varPtr,VAR_TRACED_READ|VAR_TRACED_WRITE|VAR_CONSTANT)) \ + ( (!TclIsVarTricky(varPtr,VAR_TRACED_READ|VAR_TRACED_WRITE)) \ && (varPtr)->value.objPtr) #define TclIsVarDirectReadable2(varPtr, arrayPtr) \ @@ -977,9 +957,10 @@ typedef struct CompiledLocal { * Among others used to speed up var lookups. */ Tcl_Size frameIndex; /* Index in the array of compiler-assigned * variables in the procedure call frame. */ -#if TCL_MAJOR_VERSION < 9 - int flags; -#endif + int flags; /* Flag bits for the local variable. Same as + * the flags for the Var structure above, + * although only VAR_ARGUMENT, VAR_TEMPORARY, + * and VAR_RESOLVED make sense. */ Tcl_Obj *defValuePtr; /* Pointer to the default value of an * argument, if any. NULL if not an argument * or, if an argument, no default value. */ @@ -990,12 +971,6 @@ typedef struct CompiledLocal { * is marked by a unique tag during * compilation, and that same tag is used to * find the variable at runtime. */ -#if TCL_MAJOR_VERSION > 8 - int flags; /* Flag bits for the local variable. Same as - * the flags for the Var structure above, - * although only VAR_ARGUMENT, VAR_TEMPORARY, - * and VAR_RESOLVED make sense. */ -#endif char name[TCLFLEXARRAY]; /* Name of the local variable starts here. If * the name is NULL, this will just be '\0'. * The actual size of this field will be large @@ -1053,11 +1028,7 @@ typedef void (ProcErrorProc)(Tcl_Interp *interp, Tcl_Obj *procNameObj); typedef struct Trace { Tcl_Size level; /* Only trace commands at nesting level less * than or equal to this. */ -#if TCL_MAJOR_VERSION > 8 - Tcl_CmdObjTraceProc2 *proc; /* Procedure to call to trace command. */ -#else Tcl_CmdObjTraceProc *proc; /* Procedure to call to trace command. */ -#endif 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 @@ -1101,101 +1072,19 @@ typedef struct ActiveInterpTrace { #define TCL_TRACE_ENTER_EXEC 1 #define TCL_TRACE_LEAVE_EXEC 2 -#if TCL_MAJOR_VERSION > 8 -#define TclObjTypeHasProc(objPtr, proc) (((objPtr)->typePtr \ - && ((offsetof(Tcl_ObjType, proc) < offsetof(Tcl_ObjType, version)) \ - || (offsetof(Tcl_ObjType, proc) < (objPtr)->typePtr->version))) ? \ - ((objPtr)->typePtr)->proc : NULL) - -MODULE_SCOPE Tcl_Size TclLengthOne(Tcl_Obj *); - - -/* - * Abstract List - * - * This structure provides the functions used in List operations to emulate a - * List for AbstractList types. - */ - - -static inline Tcl_Size -TclObjTypeLength(Tcl_Obj *objPtr) -{ - Tcl_ObjTypeLengthProc *proc = TclObjTypeHasProc(objPtr, lengthProc); - return proc(objPtr); -} -static inline int -TclObjTypeIndex( - Tcl_Interp *interp, - Tcl_Obj *objPtr, - Tcl_Size index, - Tcl_Obj **elemObjPtr) -{ - Tcl_ObjTypeIndexProc *proc = TclObjTypeHasProc(objPtr, indexProc); - return proc(interp, objPtr, index, elemObjPtr); -} -static inline int -TclObjTypeSlice( - Tcl_Interp *interp, - Tcl_Obj *objPtr, - Tcl_Size fromIdx, - Tcl_Size toIdx, - Tcl_Obj **newObjPtr) -{ - Tcl_ObjTypeSliceProc *proc = TclObjTypeHasProc(objPtr, sliceProc); - return proc(interp, objPtr, fromIdx, toIdx, newObjPtr); -} -static inline int -TclObjTypeReverse( - Tcl_Interp *interp, - Tcl_Obj *objPtr, - Tcl_Obj **newObjPtr) -{ - Tcl_ObjTypeReverseProc *proc = TclObjTypeHasProc(objPtr, reverseProc); - return proc(interp, objPtr, newObjPtr); -} -static inline int -TclObjTypeGetElements( - Tcl_Interp *interp, - Tcl_Obj *objPtr, - Tcl_Size *objCPtr, - Tcl_Obj ***objVPtr) -{ - Tcl_ObjTypeGetElements *proc = TclObjTypeHasProc(objPtr, getElementsProc); - return proc(interp, objPtr, objCPtr, objVPtr); -} -static inline Tcl_Obj* -TclObjTypeSetElement( - Tcl_Interp *interp, - Tcl_Obj *objPtr, - Tcl_Size indexCount, - Tcl_Obj *const indexArray[], - Tcl_Obj *valueObj) -{ - Tcl_ObjTypeSetElement *proc = TclObjTypeHasProc(objPtr, setElementProc); - return proc(interp, objPtr, indexCount, indexArray, valueObj); -} -static inline int -TclObjTypeReplace( - Tcl_Interp *interp, - Tcl_Obj *objPtr, - Tcl_Size first, - Tcl_Size numToDelete, - Tcl_Size numToInsert, - Tcl_Obj *const insertObjs[]) -{ - Tcl_ObjTypeReplaceProc *proc = TclObjTypeHasProc(objPtr, replaceProc); - return proc(interp, objPtr, first, numToDelete, numToInsert, insertObjs); -} -static inline int -TclObjTypeInOperator(Tcl_Interp *interp, struct Tcl_Obj *valueObj, - struct Tcl_Obj *listObj, int *boolResult) -{ - Tcl_ObjTypeInOperatorProc *proc = TclObjTypeHasProc(listObj, inOperProc); - return proc(interp, valueObj, listObj, boolResult); -} -#endif /* TCL_MAJOR_VERSION > 8 */ - +MODULE_SCOPE Tcl_Obj *TclArithSeriesObjIndex(Tcl_Interp *, Tcl_Obj *, + Tcl_Size index); +MODULE_SCOPE Tcl_Size TclArithSeriesObjLength(Tcl_Obj *arithSeriesPtr); +MODULE_SCOPE Tcl_Obj * TclArithSeriesObjRange(Tcl_Interp *interp, + Tcl_Obj *arithSeriesPtr, Tcl_Size fromIdx, Tcl_Size toIdx); +MODULE_SCOPE Tcl_Obj * TclArithSeriesObjReverse(Tcl_Interp *interp, + Tcl_Obj *arithSeriesPtr); +MODULE_SCOPE int TclArithSeriesGetElements(Tcl_Interp *interp, + Tcl_Obj *objPtr, Tcl_Size *objcPtr, Tcl_Obj ***objvPtr); +MODULE_SCOPE int TclNewArithSeriesObj(Tcl_Interp *interp, + Tcl_Obj **arithSeriesObj, int useDoubles, + Tcl_Obj *startObj, Tcl_Obj *endObj, + Tcl_Obj *stepObj, Tcl_Obj *lenObj); /* * The structure below defines an entry in the assocData hash table which is @@ -1556,8 +1445,14 @@ struct CompileEnv; * reporting is deferred until the actual runtime, * because by then changes in the interp state may allow * the command to be successfully evaluated. + * TCL_OUT_LINE_COMPILE A source-compatible alias for TCL_ERROR, kept for the + * sake of old code only. */ +#ifndef TCL_NO_DEPRECATED +# define TCL_OUT_LINE_COMPILE TCL_ERROR +#endif + typedef int (CompileProc)(Tcl_Interp *interp, Tcl_Parse *parsePtr, struct Command *cmdPtr, struct CompileEnv *compEnvPtr); @@ -1858,6 +1753,9 @@ typedef struct Command { */ #define CMD_DYING 0x01 +#ifndef TCL_NO_DEPRECATED +# define CMD_IS_DELETED 0x01 /* Same as CMD_DYING */ +#endif #define CMD_TRACE_ACTIVE 0x02 #define CMD_HAS_EXEC_TRACES 0x04 #define CMD_COMPILES_EXPANDED 0x08 @@ -1941,31 +1839,41 @@ typedef struct AllocCache { typedef struct Interp { /* - * The first two fields were named "result" and "freeProc" in earlier - * versions of Tcl. They are no longer used within Tcl, and are no - * longer available to be accessed by extensions. However, they cannot - * be removed. Why? There is a deployed base of stub-enabled extensions - * that query the value of iPtr->stubTable. For them to continue to work, - * the location of the field "stubTable" within the Interp struct cannot - * change. The most robust way to assure that is to leave all fields up to - * that one undisturbed. + * Note: the first three fields must match exactly the fields in a + * Tcl_Interp struct (see tcl.h). If you change one, be sure to change the + * other. + * + * The interpreter's result is held in both the string and the + * objResultPtr fields. These fields hold, respectively, the result's + * string or object value. The interpreter's result is always in the + * result field if that is non-empty, otherwise it is in objResultPtr. + * The two fields are kept consistent unless some C code sets + * interp->result directly. Programs should not access result and + * objResultPtr directly; instead, they should always get and set the + * result using procedures such as Tcl_SetObjResult, Tcl_GetObjResult, and + * Tcl_GetStringResult. See the SetResult man page for details. */ - const char *legacyResult; - void (*legacyFreeProc) (void); + char *result; /* If the last command returned a string + * result, this points to it. Should not be + * accessed directly; see comment above. */ + Tcl_FreeProc *freeProc; /* Zero means a string result is statically + * allocated. TCL_DYNAMIC means string result + * was allocated with ckalloc and should be + * freed with ckfree. Other values give + * address of procedure to invoke to free the + * string result. Tcl_Eval must free it before + * executing next command. */ int errorLine; /* When TCL_ERROR is returned, this gives the * line number in the command where the error * occurred (1 means first line). */ const struct TclStubs *stubTable; - /* Pointer to the exported Tcl stub table. In - * ancient pre-8.1 versions of Tcl this was a - * pointer to the objResultPtr or a pointer to a - * buckets array in a hash table. Deployed stubs - * enabled extensions check for a NULL pointer value - * and for a TCL_STUBS_MAGIC value to verify they - * are not [load]ing into one of those pre-stubs - * interps. - */ + /* Pointer to the exported Tcl stub table. On + * previous versions of Tcl this is a pointer + * to the objResultPtr or a pointer to a + * buckets array in a hash table. We therefore + * have to do some careful checking before we + * can use this. */ TclHandle handle; /* Handle used to keep track of when this * interp is deleted. */ @@ -1978,9 +1886,6 @@ typedef struct Interp { void *interpInfo; /* Information used by tclInterp.c to keep * track of parent/child interps on a * per-interp basis. */ -#if TCL_MAJOR_VERSION > 8 - void (*optimizer)(void *envPtr); -#else union { void (*optimizer)(void *envPtr); Tcl_HashTable unused2; /* No longer used (was mathFuncTable). The @@ -1989,7 +1894,6 @@ typedef struct Interp { * contains one optimizer, which can be * selectively overridden by extensions. */ } extra; -#endif /* * Information related to procedures and variables. See tclProc.c and * tclVar.c for usage. @@ -2018,7 +1922,20 @@ typedef struct Interp { Namespace *lookupNsPtr; /* Namespace to use ONLY on the next * TCL_EVAL_INVOKE call to Tcl_EvalObjv. */ -#if TCL_MAJOR_VERSION < 9 + /* + * Information used by Tcl_AppendResult to keep track of partial results. + * See Tcl_AppendResult code for details. + */ + +#if !defined(TCL_NO_DEPRECATED) + char *appendResult; /* Storage space for results generated by + * Tcl_AppendResult. Ckalloc-ed. NULL means + * not yet allocated. */ + int appendAvl; /* Total amount of space available at + * partialResult. */ + int appendUsed; /* Number of non-null bytes currently stored + * at partialResult. */ +#else char *appendResultDontUse; int appendAvlDontUse; int appendUsedDontUse; @@ -2046,9 +1963,7 @@ typedef struct Interp { * Normally zero, but may be set before * calling Tcl_Eval. See below for valid * values. */ -#if TCL_MAJOR_VERSION < 9 int unused1; /* No longer used (was termOffset) */ -#endif LiteralTable literalTable; /* Contains LiteralEntry's describing all Tcl * objects holding literals of scripts * compiled by the interpreter. Indexed by the @@ -2086,7 +2001,10 @@ typedef struct Interp { * string. Returned by Tcl_ObjSetVar2 when * variable traces change a variable in a * gross way. */ -#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 Tcl_Obj *objResultPtr; /* If the last command returned an object @@ -2420,6 +2338,10 @@ typedef struct Interp { * script in progress has been canceled thereby allowing * the evaluation stack for the interp to be fully * unwound. + * + * WARNING: For the sake of some extensions that have made use of former + * internal values, do not re-use the flag values 2 (formerly ERR_IN_PROGRESS) + * or 8 (formerly ERROR_CODE_SET). */ #define DELETED 1 @@ -2706,7 +2628,7 @@ typedef struct ListRep { * converted to a list. */ #define TclListObjGetElements(interp_, listObj_, objcPtr_, objvPtr_) \ - ((TclHasInternalRep((listObj_), &tclListType)) \ + (((listObj_)->typePtr == &tclListType) \ ? ((ListObjGetElements((listObj_), *(objcPtr_), *(objvPtr_))), \ TCL_OK) \ : Tcl_ListObjGetElements( \ @@ -2718,12 +2640,12 @@ typedef struct ListRep { * Tcl_Obj cannot be converted to a list. */ #define TclListObjLength(interp_, listObj_, lenPtr_) \ - ((TclHasInternalRep((listObj_), &tclListType)) \ + (((listObj_)->typePtr == &tclListType) \ ? ((ListObjLength((listObj_), *(lenPtr_))), TCL_OK) \ : Tcl_ListObjLength((interp_), (listObj_), (lenPtr_))) #define TclListObjIsCanonical(listObj_) \ - ((TclHasInternalRep((listObj_), &tclListType)) ? ListObjIsCanonical((listObj_)) : 0) + (((listObj_)->typePtr == &tclListType) ? ListObjIsCanonical((listObj_)) : 0) /* * Modes for collecting (or not) in the implementations of TclNRForeachCmd, @@ -2741,29 +2663,21 @@ typedef struct ListRep { * WARNING: these macros eval their args more than once. */ -#if TCL_MAJOR_VERSION > 8 -#define TclGetBooleanFromObj(interp, objPtr, intPtr) \ - ((TclHasInternalRep((objPtr), &tclIntType) \ - || TclHasInternalRep((objPtr), &tclBooleanType)) \ - ? (*(intPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK) \ - : Tcl_GetBooleanFromObj((interp), (objPtr), (intPtr))) -#else #define TclGetBooleanFromObj(interp, objPtr, intPtr) \ - ((TclHasInternalRep((objPtr), &tclIntType)) \ + (((objPtr)->typePtr == &tclIntType) \ ? (*(intPtr) = ((objPtr)->internalRep.wideValue!=0), TCL_OK) \ - : (TclHasInternalRep((objPtr), &tclBooleanType)) \ + : ((objPtr)->typePtr == &tclBooleanType) \ ? (*(intPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \ : Tcl_GetBooleanFromObj((interp), (objPtr), (intPtr))) -#endif #ifdef TCL_WIDE_INT_IS_LONG #define TclGetLongFromObj(interp, objPtr, longPtr) \ - ((TclHasInternalRep((objPtr), &tclIntType)) \ + (((objPtr)->typePtr == &tclIntType) \ ? ((*(longPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \ : Tcl_GetLongFromObj((interp), (objPtr), (longPtr))) #else #define TclGetLongFromObj(interp, objPtr, longPtr) \ - ((TclHasInternalRep((objPtr), &tclIntType) \ + (((objPtr)->typePtr == &tclIntType \ && (objPtr)->internalRep.wideValue >= (Tcl_WideInt)(LONG_MIN) \ && (objPtr)->internalRep.wideValue <= (Tcl_WideInt)(LONG_MAX)) \ ? ((*(longPtr) = (long)(objPtr)->internalRep.wideValue), TCL_OK) \ @@ -2771,15 +2685,15 @@ typedef struct ListRep { #endif #define TclGetIntFromObj(interp, objPtr, intPtr) \ - ((TclHasInternalRep((objPtr), &tclIntType) \ + (((objPtr)->typePtr == &tclIntType \ && (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) \ - (((TclHasInternalRep((objPtr), &tclIntType)) && ((objPtr)->internalRep.wideValue >= 0) \ - && ((objPtr)->internalRep.wideValue <= endValue)) \ - ? ((*(idxPtr) = (objPtr)->internalRep.wideValue), TCL_OK) \ + ((((objPtr)->typePtr == &tclIntType) && ((objPtr)->internalRep.wideValue >= 0) \ + && ((Tcl_WideUInt)(objPtr)->internalRep.wideValue <= (Tcl_WideUInt)(endValue + 1))) \ + ? ((*(idxPtr) = (Tcl_Size)(objPtr)->internalRep.wideValue), TCL_OK) \ : Tcl_GetIntForIndex((interp), (objPtr), (endValue), (idxPtr))) /* @@ -2791,7 +2705,7 @@ typedef struct ListRep { */ #define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \ - ((TclHasInternalRep((objPtr), &tclIntType)) \ + (((objPtr)->typePtr == &tclIntType) \ ? (*(wideIntPtr) = \ ((objPtr)->internalRep.wideValue), TCL_OK) : \ Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr))) @@ -2866,6 +2780,18 @@ typedef struct TclFileAttrProcs { typedef struct TclFile_ *TclFile; +/* + * The "globParameters" argument of the function TclGlob is an or'ed + * combination of the following values: + */ + +#ifndef TCL_NO_DEPRECATED +# define TCL_GLOBMODE_NO_COMPLAIN 1 +# define TCL_GLOBMODE_JOIN 2 +# define TCL_GLOBMODE_DIR 4 +# define TCL_GLOBMODE_TAILS 8 +#endif + typedef enum Tcl_PathPart { TCL_PATH_DIRNAME, TCL_PATH_TAIL, @@ -2886,6 +2812,17 @@ typedef Tcl_Channel (TclOpenFileChannelProc_)(Tcl_Interp *interp, /* *---------------------------------------------------------------- + * Data structures related to procedures + *---------------------------------------------------------------- + */ + +#if !defined(TCL_NO_DEPRECATED) +typedef Tcl_CmdProc *TclCmdProcType; +typedef Tcl_ObjCmdProc *TclObjCmdProcType; +#endif + +/* + *---------------------------------------------------------------- * Data structures for process-global values. *---------------------------------------------------------------- */ @@ -2893,12 +2830,6 @@ typedef Tcl_Channel (TclOpenFileChannelProc_)(Tcl_Interp *interp, typedef void (TclInitProcessGlobalValueProc)(char **valuePtr, TCL_HASH_TYPE *lengthPtr, Tcl_Encoding *encodingPtr); -#ifdef _WIN32 -# define TCLFSENCODING tclUtf8Encoding /* On Windows, all Unicode (except surrogates) are valid */ -#else -# define TCLFSENCODING NULL /* On Non-Windows, use the system encoding for validation checks */ -#endif - /* * A ProcessGlobalValue struct exists for each internal value in Tcl that is * to be shared among several threads. Each thread sees a (Tcl_Obj) copy of @@ -2958,83 +2889,16 @@ typedef struct ProcessGlobalValue { */ #define ENCODING_PROFILE_MASK 0xFF000000 -#define ENCODING_PROFILE_GET(flags_) ((flags_) & ENCODING_PROFILE_MASK) -#define ENCODING_PROFILE_SET(flags_, profile_) \ - do { \ - (flags_) &= ~ENCODING_PROFILE_MASK; \ - (flags_) |= ((profile_) & ENCODING_PROFILE_MASK);\ +#define ENCODING_PROFILE_GET(flags_) (((flags_) & TCL_ENCODING_PROFILE_STRICT) ? \ + TCL_ENCODING_PROFILE_STRICT : (((flags_) & ENCODING_PROFILE_MASK) ? \ + ((flags_) & ENCODING_PROFILE_MASK) : TCL_ENCODING_PROFILE_TCL8)) +#define ENCODING_PROFILE_SET(flags_, profile_) \ + do { \ + (flags_) &= ~(ENCODING_PROFILE_MASK|TCL_ENCODING_PROFILE_STRICT); \ + (flags_) |= (profile_) & (ENCODING_PROFILE_MASK|TCL_ENCODING_PROFILE_STRICT); \ } while (0) /* - *---------------------------------------------------------------------- - * Common functions for calculating overallocation. Trivial but allows for - * experimenting with growth factors without having to change code in - * multiple places. See TclAttemptAllocElemsEx and similar for usage - * examples. Best to use those functions. Direct use of TclUpsizeAlloc / - * TclResizeAlloc is needed in special cases such as when total size of - * memory block is limited to less than TCL_SIZE_MAX. - * - *---------------------------------------------------------------------- - */ -static inline Tcl_Size -TclUpsizeAlloc(TCL_UNUSED(Tcl_Size) /* oldSize. For future experiments with - * some growth algorithms that use this - * information. */, - Tcl_Size needed, - Tcl_Size limit) -{ - /* assert (oldCapacity < needed <= limit) */ - if (needed < (limit - needed/2)) { - return needed + needed / 2; - } - else { - return limit; - } -} -static inline Tcl_Size TclUpsizeRetry(Tcl_Size needed, Tcl_Size lastAttempt) { - /* assert (needed < lastAttempt) */ - if (needed < lastAttempt - 1) { - /* (needed+lastAttempt)/2 but that formula may overflow Tcl_Size */ - return needed + (lastAttempt - needed) / 2; - } else { - return needed; - } -} -MODULE_SCOPE void *TclAllocElemsEx(Tcl_Size elemCount, Tcl_Size elemSize, - Tcl_Size leadSize, Tcl_Size *capacityPtr); -MODULE_SCOPE void *TclReallocElemsEx(void *oldPtr, Tcl_Size elemCount, - Tcl_Size elemSize, Tcl_Size leadSize, - Tcl_Size *capacityPtr); -MODULE_SCOPE void *TclAttemptReallocElemsEx(void *oldPtr, - Tcl_Size elemCount, Tcl_Size elemSize, - Tcl_Size leadSize, Tcl_Size *capacityPtr); -/* Alloc elemCount elements of size elemSize with leadSize header - * returning actual capacity (in elements) in *capacityPtr. */ -static inline void *TclAttemptAllocElemsEx(Tcl_Size elemCount, Tcl_Size elemSize, - Tcl_Size leadSize, Tcl_Size *capacityPtr) { - return TclAttemptReallocElemsEx( - NULL, elemCount, elemSize, leadSize, capacityPtr); -} -/* Alloc numByte bytes, returning actual capacity in *capacityPtr. */ -static inline void *TclAllocEx(Tcl_Size numBytes, Tcl_Size *capacityPtr) { - return TclAllocElemsEx(numBytes, 1, 0, capacityPtr); -} -/* Alloc numByte bytes, returning actual capacity in *capacityPtr. */ -static inline void * -TclAttemptAllocEx(Tcl_Size numBytes, Tcl_Size *capacityPtr) -{ - return TclAttemptAllocElemsEx(numBytes, 1, 0, capacityPtr); -} -/* Realloc numByte bytes, returning actual capacity in *capacityPtr. */ -static inline void *TclReallocEx(void *oldPtr, Tcl_Size numBytes, Tcl_Size *capacityPtr) { - return TclReallocElemsEx(oldPtr, numBytes, 1, 0, capacityPtr); -} -/* Realloc numByte bytes, returning actual capacity in *capacityPtr. */ -static inline void *TclAttemptReallocEx(void *oldPtr, Tcl_Size numBytes, Tcl_Size *capacityPtr) { - return TclAttemptReallocElemsEx(oldPtr, numBytes, 1, 0, capacityPtr); -} - -/* *---------------------------------------------------------------- * Variables shared among Tcl modules but not used by the outside world. *---------------------------------------------------------------- @@ -3074,14 +2938,17 @@ MODULE_SCOPE void *tclTimeClientData; MODULE_SCOPE const Tcl_ObjType tclBignumType; 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 tclIntType; MODULE_SCOPE const Tcl_ObjType tclIndexType; MODULE_SCOPE const Tcl_ObjType tclListType; +MODULE_SCOPE const Tcl_ObjType tclArithSeriesType; MODULE_SCOPE const Tcl_ObjType tclDictType; MODULE_SCOPE const Tcl_ObjType tclProcBodyType; MODULE_SCOPE const Tcl_ObjType tclStringType; +MODULE_SCOPE const Tcl_ObjType tclUniCharStringType; MODULE_SCOPE const Tcl_ObjType tclEnsembleCmdType; MODULE_SCOPE const Tcl_ObjType tclRegexpType; MODULE_SCOPE Tcl_ObjType tclCmdNameType; @@ -3221,7 +3088,6 @@ struct Tcl_LoadHandle_ { *---------------------------------------------------------------- */ -#if TCL_MAJOR_VERSION > 8 MODULE_SCOPE void TclAdvanceContinuations(Tcl_Size *line, Tcl_Size **next, int loc); MODULE_SCOPE void TclAdvanceLines(Tcl_Size *line, const char *start, @@ -3254,6 +3120,8 @@ MODULE_SCOPE void TclChannelRelease(Tcl_Channel chan); MODULE_SCOPE int TclChannelGetBlockingMode(Tcl_Channel chan); MODULE_SCOPE int TclCheckArrayTraces(Tcl_Interp *interp, Var *varPtr, Var *arrayPtr, Tcl_Obj *name, int index); +MODULE_SCOPE int TclCheckBadOctal(Tcl_Interp *interp, + const char *value); MODULE_SCOPE int TclCheckEmptyString(Tcl_Obj *objPtr); MODULE_SCOPE int TclChanCaughtErrorBypass(Tcl_Interp *interp, Tcl_Channel chan); @@ -3279,7 +3147,6 @@ MODULE_SCOPE Tcl_Command TclCreateEnsembleInNs(Tcl_Interp *interp, Tcl_Namespace *ensembleNamespacePtr, int flags); MODULE_SCOPE void TclDeleteNamespaceVars(Namespace *nsPtr); MODULE_SCOPE void TclDeleteNamespaceChildren(Namespace *nsPtr); -MODULE_SCOPE Tcl_Size TclDictGetSize(Tcl_Obj *dictPtr); MODULE_SCOPE int TclFindDictElement(Tcl_Interp *interp, const char *dict, Tcl_Size dictLength, const char **elementPtr, const char **nextPtr, @@ -3359,7 +3226,7 @@ MODULE_SCOPE Tcl_Obj * TclGetProcessGlobalValue(ProcessGlobalValue *pgvPtr); MODULE_SCOPE Tcl_Obj * TclGetSourceFromFrame(CmdFrame *cfPtr, int objc, Tcl_Obj *const objv[]); MODULE_SCOPE char * TclGetStringStorage(Tcl_Obj *objPtr, - Tcl_Size *sizePtr); + TCL_HASH_TYPE *sizePtr); MODULE_SCOPE int TclGetLoadedLibraries(Tcl_Interp *interp, const char *targetName, const char *packageName); @@ -3375,8 +3242,6 @@ MODULE_SCOPE Tcl_Obj * TclInfoFrame(Tcl_Interp *interp, CmdFrame *framePtr); MODULE_SCOPE Tcl_ObjCmdProc TclInfoGlobalsCmd; MODULE_SCOPE Tcl_ObjCmdProc TclInfoLocalsCmd; MODULE_SCOPE Tcl_ObjCmdProc TclInfoVarsCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclInfoConstsCmd; -MODULE_SCOPE Tcl_ObjCmdProc TclInfoConstantCmd; MODULE_SCOPE void TclInitAlloc(void); MODULE_SCOPE void TclInitDbCkalloc(void); MODULE_SCOPE void TclInitDoubleConversion(void); @@ -3402,7 +3267,6 @@ MODULE_SCOPE Tcl_Obj * TclLindexList(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *argPtr); MODULE_SCOPE Tcl_Obj * TclLindexFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size indexCount, Tcl_Obj *const indexArray[]); -MODULE_SCOPE Tcl_Obj * TclListObjGetElement(Tcl_Obj *listObj, Tcl_Size index); /* TIP #280 */ MODULE_SCOPE void TclListLines(Tcl_Obj *listObj, Tcl_Size line, Tcl_Size n, Tcl_Size *lines, Tcl_Obj *const *elems); @@ -3419,6 +3283,7 @@ MODULE_SCOPE Tcl_Obj * TclLsetFlat(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Obj *valuePtr); MODULE_SCOPE Tcl_Command TclMakeEnsemble(Tcl_Interp *interp, const char *name, const EnsembleImplMap map[]); +MODULE_SCOPE int TclMakeSafe(Tcl_Interp *interp); MODULE_SCOPE Tcl_Size TclMaxListLength(const char *bytes, Tcl_Size numBytes, const char **endPtr); MODULE_SCOPE int TclMergeReturnOptions(Tcl_Interp *interp, int objc, @@ -3446,14 +3311,10 @@ MODULE_SCOPE void TclParseInit(Tcl_Interp *interp, const char *string, MODULE_SCOPE Tcl_Size TclParseAllWhiteSpace(const char *src, Tcl_Size numBytes); MODULE_SCOPE int TclProcessReturn(Tcl_Interp *interp, int code, int level, Tcl_Obj *returnOpts); -MODULE_SCOPE void TclUndoRefCount(Tcl_Obj *objPtr); MODULE_SCOPE int TclpObjLstat(Tcl_Obj *pathPtr, Tcl_StatBuf *buf); MODULE_SCOPE Tcl_Obj * TclpTempFileName(void); MODULE_SCOPE Tcl_Obj * TclpTempFileNameForLibrary(Tcl_Interp *interp, Tcl_Obj* pathPtr); -MODULE_SCOPE int TclNewArithSeriesObj(Tcl_Interp *interp, Tcl_Obj **arithSeriesPtr, - int useDoubles, Tcl_Obj *startObj, Tcl_Obj *endObj, - Tcl_Obj *stepObj, Tcl_Obj *lenObj); MODULE_SCOPE Tcl_Obj * TclNewFSPathObj(Tcl_Obj *dirPtr, const char *addStrRep, Tcl_Size len); MODULE_SCOPE void TclpAlertNotifier(void *clientData); @@ -3475,6 +3336,7 @@ MODULE_SCOPE void TclInitSockets(void); #else #define TclInitSockets() /* do nothing */ #endif +struct addrinfo; /* forward declaration, needed for TclCreateSocketAddress */ MODULE_SCOPE int TclCreateSocketAddress(Tcl_Interp *interp, struct addrinfo **addrlist, const char *host, int port, int willBind, @@ -3530,7 +3392,7 @@ MODULE_SCOPE void TclRemoveScriptLimitCallbacks(Tcl_Interp *interp); MODULE_SCOPE int TclReToGlob(Tcl_Interp *interp, const char *reStr, Tcl_Size reStrLen, Tcl_DString *dsPtr, int *flagsPtr, int *quantifiersFoundPtr); -MODULE_SCOPE Tcl_Size TclScanElement(const char *string, Tcl_Size length, +MODULE_SCOPE TCL_HASH_TYPE TclScanElement(const char *string, Tcl_Size length, char *flagPtr); MODULE_SCOPE void TclSetBgErrorHandler(Tcl_Interp *interp, Tcl_Obj *cmdPrefix); @@ -3574,9 +3436,6 @@ MODULE_SCOPE Tcl_Size TclTrimLeft(const char *bytes, Tcl_Size numBytes, MODULE_SCOPE Tcl_Size TclTrimRight(const char *bytes, Tcl_Size numBytes, const char *trim, Tcl_Size numTrim); MODULE_SCOPE const char*TclGetCommandTypeName(Tcl_Command command); -MODULE_SCOPE int TclObjInterpProc(void *clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); MODULE_SCOPE void TclRegisterCommandTypeName( Tcl_ObjCmdProc *implementationProc, const char *nameStr); @@ -3626,6 +3485,18 @@ MODULE_SCOPE int TclZipfs_Init(Tcl_Interp *interp); MODULE_SCOPE int TclIsZipfsPath(const char *path); MODULE_SCOPE void TclZipfsFinalize(void); +MODULE_SCOPE int *TclGetUnicodeFromObj(Tcl_Obj *, int *); +MODULE_SCOPE Tcl_Obj *TclNewUnicodeObj(const int *, int); +MODULE_SCOPE void TclAppendUnicodeToObj(Tcl_Obj *, const int *, int); +MODULE_SCOPE int TclUniCharNcasecmp(const int *, const int *, size_t); +MODULE_SCOPE int TclUniCharNcasememcmp(const void *, const void *, size_t); +MODULE_SCOPE int TclUniCharCaseMatch(const int *, const int *, int); +MODULE_SCOPE int TclUniCharNcmp(const int *, const int *, size_t); +MODULE_SCOPE int TclUniCharNmemcmp(const void *, const void *, size_t); +MODULE_SCOPE int TclUtfNcasememcmp(const void *s1, const void *s2, size_t n); +MODULE_SCOPE int TclUtfNmemcmp(const void *s1, const void *s2, size_t n); + + /* * Many parsing tasks need a common definition of whitespace. * Use this routine and macro to achieve that and place @@ -3648,6 +3519,9 @@ MODULE_SCOPE Tcl_ObjCmdProc Tcl_ApplyObjCmd; MODULE_SCOPE Tcl_Command TclInitArrayCmd(Tcl_Interp *interp); MODULE_SCOPE Tcl_Command TclInitBinaryCmd(Tcl_Interp *interp); MODULE_SCOPE Tcl_ObjCmdProc Tcl_BreakObjCmd; +#if !defined(TCL_NO_DEPRECATED) +MODULE_SCOPE Tcl_ObjCmdProc Tcl_CaseObjCmd; +#endif MODULE_SCOPE Tcl_ObjCmdProc Tcl_CatchObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_CdObjCmd; MODULE_SCOPE Tcl_Command TclInitChanCmd(Tcl_Interp *interp); @@ -3659,7 +3533,6 @@ MODULE_SCOPE void TclClockInit(Tcl_Interp *interp); MODULE_SCOPE Tcl_ObjCmdProc TclClockOldscanObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_CloseObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_ConcatObjCmd; -MODULE_SCOPE Tcl_ObjCmdProc Tcl_ConstObjCmd; MODULE_SCOPE Tcl_ObjCmdProc Tcl_ContinueObjCmd; MODULE_SCOPE Tcl_TimerToken TclCreateAbsoluteTimerHandler( Tcl_Time *timePtr, Tcl_TimerProc *proc, @@ -3773,7 +3646,6 @@ MODULE_SCOPE CompileProc TclCompileCatchCmd; MODULE_SCOPE CompileProc TclCompileClockClicksCmd; MODULE_SCOPE CompileProc TclCompileClockReadingCmd; MODULE_SCOPE CompileProc TclCompileConcatCmd; -MODULE_SCOPE CompileProc TclCompileConstCmd; MODULE_SCOPE CompileProc TclCompileContinueCmd; MODULE_SCOPE CompileProc TclCompileDictAppendCmd; MODULE_SCOPE CompileProc TclCompileDictCreateCmd; @@ -4000,19 +3872,6 @@ MODULE_SCOPE TCL_HASH_TYPE TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr); MODULE_SCOPE int TclFullFinalizationRequested(void); /* - * TIP #542 - */ - -MODULE_SCOPE size_t TclUniCharLen(const Tcl_UniChar *uniStr); -MODULE_SCOPE int TclUniCharNcmp(const Tcl_UniChar *ucs, - const Tcl_UniChar *uct, size_t numChars); -MODULE_SCOPE int TclUniCharNcasecmp(const Tcl_UniChar *ucs, - const Tcl_UniChar *uct, size_t numChars); -MODULE_SCOPE int TclUniCharCaseMatch(const Tcl_UniChar *uniStr, - const Tcl_UniChar *uniPattern, int nocase); - - -/* * Just for the purposes of command-type registration. */ @@ -4048,7 +3907,6 @@ MODULE_SCOPE void TclProcessCreated(Tcl_Pid pid); MODULE_SCOPE TclProcessWaitStatus TclProcessWait(Tcl_Pid pid, int options, int *codePtr, Tcl_Obj **msgObjPtr, Tcl_Obj **errorObjPtr); -MODULE_SCOPE int TclClose(Tcl_Interp *, Tcl_Channel chan); /* * TIP #508: [array default] @@ -4066,13 +3924,6 @@ MODULE_SCOPE int TclIndexEncode(Tcl_Interp *interp, Tcl_Obj *objPtr, int before, int after, int *indexPtr); MODULE_SCOPE Tcl_Size TclIndexDecode(int encoded, Tcl_Size endValue); -/* - * Error message utility functions - */ -MODULE_SCOPE int TclCommandWordLimitError(Tcl_Interp *interp, Tcl_Size count); - -#endif /* TCL_MAJOR_VERSION > 8 */ - /* Constants used in index value encoding routines. */ #define TCL_INDEX_END ((Tcl_Size)-2) #define TCL_INDEX_START ((Tcl_Size)0) @@ -4183,7 +4034,7 @@ TclScaleTime( TCL_DTRACE_OBJ_FREE(objPtr); \ if ((objPtr)->bytes \ && ((objPtr)->bytes != &tclEmptyString)) { \ - Tcl_Free((objPtr)->bytes); \ + ckfree((objPtr)->bytes); \ } \ (objPtr)->length = TCL_INDEX_NONE; \ TclFreeObjStorage(objPtr); \ @@ -4207,10 +4058,10 @@ TclScaleTime( */ # define TclAllocObjStorageEx(interp, objPtr) \ - (objPtr) = (Tcl_Obj *)Tcl_Alloc(sizeof(Tcl_Obj)) + (objPtr) = (Tcl_Obj *)ckalloc(sizeof(Tcl_Obj)) # define TclFreeObjStorageEx(interp, objPtr) \ - Tcl_Free(objPtr) + ckfree(objPtr) #undef USE_THREAD_ALLOC #undef USE_TCLALLOC @@ -4359,7 +4210,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, if ((len) == 0) { \ TclInitEmptyStringRep(objPtr); \ } else { \ - (objPtr)->bytes = (char *)Tcl_Alloc((len) + 1U); \ + (objPtr)->bytes = (char *)ckalloc((len) + 1U); \ memcpy((objPtr)->bytes, (bytePtr) ? (bytePtr) : &tclEmptyString, (len)); \ (objPtr)->bytes[len] = '\0'; \ (objPtr)->length = (len); \ @@ -4369,7 +4220,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, ((((len) == 0) ? ( \ TclInitEmptyStringRep(objPtr) \ ) : ( \ - (objPtr)->bytes = (char *)Tcl_AttemptAlloc((len) + 1U), \ + (objPtr)->bytes = (char *)attemptckalloc((len) + 1U), \ (objPtr)->length = ((objPtr)->bytes) ? \ (memcpy((objPtr)->bytes, (bytePtr) ? (bytePtr) : &tclEmptyString, (len)), \ (objPtr)->bytes[len] = '\0', (len)) : (-1) \ @@ -4413,6 +4264,10 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, (objPtr)->typePtr = NULL; \ } +#if !defined(TCL_NO_DEPRECATED) +# define TclFreeIntRep(objPtr) TclFreeInternalRep(objPtr) +#endif + /* *---------------------------------------------------------------- * Macro used by the Tcl core to clean out an object's string representation. @@ -4427,7 +4282,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, const char *file, Tcl_Obj *_isobjPtr = (Tcl_Obj *)(objPtr); \ if (_isobjPtr->bytes != NULL) { \ if (_isobjPtr->bytes != &tclEmptyString) { \ - Tcl_Free((char *)_isobjPtr->bytes); \ + ckfree((char *)_isobjPtr->bytes); \ } \ _isobjPtr->bytes = NULL; \ } \ @@ -4515,10 +4370,14 @@ MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[]; #define TCL_MIN_TOKEN_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Token) #endif -/* TODO - code below does not check for integer overflow */ +#define TCL_MAX_TOKENS (int)(UINT_MAX / sizeof(Tcl_Token)) #define TclGrowTokenArray(tokenPtr, used, available, append, staticPtr) \ do { \ Tcl_Size _needed = (used) + (append); \ + if (_needed > TCL_MAX_TOKENS) { \ + Tcl_Panic("max # of tokens for a Tcl parse (%d) exceeded", \ + TCL_MAX_TOKENS); \ + } \ if (_needed > (available)) { \ Tcl_Size allocated = 2 * _needed; \ Tcl_Token *oldPtr = (tokenPtr); \ @@ -4526,11 +4385,17 @@ MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[]; if (oldPtr == (staticPtr)) { \ oldPtr = NULL; \ } \ - newPtr = (Tcl_Token *)Tcl_AttemptRealloc((char *) oldPtr, \ + if (allocated > TCL_MAX_TOKENS) { \ + allocated = TCL_MAX_TOKENS; \ + } \ + newPtr = (Tcl_Token *) attemptckrealloc((char *) oldPtr, \ allocated * sizeof(Tcl_Token)); \ if (newPtr == NULL) { \ allocated = _needed + (append) + TCL_MIN_TOKEN_GROWTH; \ - newPtr = (Tcl_Token *)Tcl_Realloc((char *) oldPtr, \ + if (allocated > TCL_MAX_TOKENS) { \ + allocated = TCL_MAX_TOKENS; \ + } \ + newPtr = (Tcl_Token *) ckrealloc((char *) oldPtr, \ allocated * sizeof(Tcl_Token)); \ } \ (available) = allocated; \ @@ -4584,7 +4449,7 @@ MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[]; while (_i > 0 && (*_str < 0xC0)) { _i--; _str++; } \ _count = (numBytes) - _i; \ if (_i) { \ - _count += Tcl_NumUtfChars((bytes) + _count, _i); \ + _count += TclNumUtfChars((bytes) + _count, _i); \ } \ (numChars) = _count; \ } while (0); @@ -4606,7 +4471,7 @@ MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[]; MODULE_SCOPE int TclIsPureByteArray(Tcl_Obj *objPtr); #define TclIsPureDict(objPtr) \ - (((objPtr)->bytes==NULL) && TclHasInternalRep((objPtr), &tclDictType)) + (((objPtr)->bytes==NULL) && ((objPtr)->typePtr==&tclDictType)) #define TclHasInternalRep(objPtr, type) \ ((objPtr)->typePtr == (type)) #define TclFetchInternalRep(objPtr, type) \ @@ -4655,7 +4520,6 @@ MODULE_SCOPE Tcl_LibraryInitProc TclObjTest_Init; MODULE_SCOPE Tcl_LibraryInitProc TclThread_Init; MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_Init; MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit; -MODULE_SCOPE Tcl_LibraryInitProc Tcl_ABSListTest_Init; /* @@ -4821,6 +4685,33 @@ MODULE_SCOPE Tcl_LibraryInitProc Tcl_ABSListTest_Init; /* *---------------------------------------------------------------- + * Macros used by the Tcl core to test for some special double values. + * (deprecated) The ANSI C "prototypes" for these macros are: + * + * MODULE_SCOPE int TclIsInfinite(double d); + * MODULE_SCOPE int TclIsNaN(double d); + */ + +#if !defined(TCL_NO_DEPRECATED) && !defined(BUILD_tcl) +# define TclIsInfinite(d) isinf(d) +# define TclIsNaN(d) isnan(d) +#endif + +/* + * Macro to use to find the offset of a field in astructure. + * Computes number of bytes from beginning of structure to a given field. + */ + +#if !defined(TCL_NO_DEPRECATED) && !defined(BUILD_tcl) +# 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 + +/* + *---------------------------------------------------------------- * Inline version of Tcl_GetCurrentNamespace and Tcl_GetGlobalNamespace. */ @@ -4839,7 +4730,7 @@ MODULE_SCOPE Tcl_LibraryInitProc Tcl_ABSListTest_Init; #define TclCleanupCommandMacro(cmdPtr) \ do { \ if ((cmdPtr)->refCount-- <= 1) { \ - Tcl_Free(cmdPtr); \ + ckfree(cmdPtr); \ } \ } while (0) @@ -4852,7 +4743,7 @@ MODULE_SCOPE Tcl_LibraryInitProc Tcl_ABSListTest_Init; (cmdPtr)->refCount++; \ if ((location) != NULL \ && (location--) <= 1) { \ - Tcl_Free(((location))); \ + ckfree(((location))); \ } \ (location) = (cmdPtr); \ } while (0) @@ -5015,8 +4906,8 @@ typedef struct NRE_callback { #define TCLNR_FREE(interp, ptr) TclSmallFreeEx((interp), (ptr)) #else #define TCLNR_ALLOC(interp, ptr) \ - ((ptr) = Tcl_Alloc(sizeof(NRE_callback))) -#define TCLNR_FREE(interp, ptr) Tcl_Free(ptr) + ((ptr) = (void *)ckalloc(sizeof(NRE_callback))) +#define TCLNR_FREE(interp, ptr) ckfree(ptr) #endif #if NRE_ENABLE_ASSERTS diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h index 85c8986..b6caa06 100644 --- a/generic/tclIntDecls.h +++ b/generic/tclIntDecls.h @@ -27,6 +27,23 @@ # endif #endif +#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 * script. Any modifications to the function declarations below should be made @@ -58,7 +75,11 @@ EXTERN void TclCleanupCommand(Command *cmdPtr); /* 7 */ EXTERN Tcl_Size TclCopyAndCollapse(Tcl_Size count, const char *src, char *dst); -/* Slot 8 is reserved */ +/* 8 */ +TCL_DEPRECATED("") +int TclCopyChannelOld(Tcl_Interp *interp, + Tcl_Channel inChan, Tcl_Channel outChan, + int toRead, Tcl_Obj *cmdPtr); /* 9 */ EXTERN Tcl_Size TclCreatePipeline(Tcl_Interp *interp, Tcl_Size argc, const char **argv, Tcl_Pid **pidArrayPtr, @@ -109,10 +130,16 @@ EXTERN const char * TclGetExtension(const char *name); EXTERN int TclGetFrame(Tcl_Interp *interp, const char *str, CallFrame **framePtrPtr); /* Slot 33 is reserved */ -/* Slot 34 is reserved */ +/* 34 */ +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 */ -/* Slot 37 is reserved */ +/* 37 */ +TCL_DEPRECATED("") +int TclGetLoadedPackages(Tcl_Interp *interp, + const char *targetName); /* 38 */ EXTERN int TclGetNamespaceForQualName(Tcl_Interp *interp, const char *qualName, Namespace *cxtNsPtr, @@ -130,9 +157,11 @@ EXTERN Tcl_Command TclGetOriginalCommand(Tcl_Command command); /* 42 */ EXTERN const char * TclpGetUserHome(const char *name, Tcl_DString *bufferPtr); -/* 43 */ -EXTERN Tcl_ObjCmdProc2 * TclGetObjInterpProc2(void); -/* Slot 44 is reserved */ +/* Slot 43 is reserved */ +/* 44 */ +TCL_DEPRECATED("") +int TclGuessPackageName(const char *fileName, + Tcl_DString *bufPtr); /* 45 */ EXTERN int TclHideUnsafeCommands(Tcl_Interp *interp); /* 46 */ @@ -140,12 +169,23 @@ EXTERN int TclInExit(void); /* Slot 47 is reserved */ /* Slot 48 is reserved */ /* Slot 49 is reserved */ -/* Slot 50 is reserved */ +/* 50 */ +TCL_DEPRECATED("") +void TclInitCompiledLocals(Tcl_Interp *interp, + CallFrame *framePtr, Namespace *nsPtr); /* 51 */ EXTERN int TclInterpInit(Tcl_Interp *interp); /* Slot 52 is reserved */ -/* Slot 53 is reserved */ -/* Slot 54 is reserved */ +/* 53 */ +TCL_DEPRECATED("") +int TclInvokeObjectCommand(void *clientData, + Tcl_Interp *interp, Tcl_Size argc, + const char **argv); +/* 54 */ +TCL_DEPRECATED("") +int TclInvokeStringCommand(void *clientData, + Tcl_Interp *interp, Tcl_Size objc, + Tcl_Obj *const objv[]); /* 55 */ EXTERN Proc * TclIsProc(Command *cmdPtr); /* Slot 56 is reserved */ @@ -162,7 +202,11 @@ EXTERN int TclNeedSpace(const char *start, const char *end); EXTERN Tcl_Obj * TclNewProcBodyObj(Proc *procPtr); /* 62 */ EXTERN int TclObjCommandComplete(Tcl_Obj *cmdPtr); -/* Slot 63 is reserved */ +/* 63 */ +TCL_DEPRECATED("") +int TclObjInterpProc(void *clientData, + Tcl_Interp *interp, Tcl_Size objc, + Tcl_Obj *const objv[]); /* 64 */ EXTERN int TclObjInvoke(Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], int flags); @@ -179,10 +223,12 @@ EXTERN void * TclpAlloc(TCL_HASH_TYPE size); /* 74 */ EXTERN void TclpFree(void *ptr); /* 75 */ -EXTERN unsigned long long TclpGetClicks(void); +EXTERN unsigned long TclpGetClicks(void); /* 76 */ -EXTERN unsigned long long TclpGetSeconds(void); -/* Slot 77 is reserved */ +EXTERN unsigned long TclpGetSeconds(void); +/* 77 */ +TCL_DEPRECATED("") +void TclpGetTime(Tcl_Time *time); /* Slot 78 is reserved */ /* Slot 79 is reserved */ /* Slot 80 is reserved */ @@ -194,7 +240,11 @@ EXTERN void * TclpRealloc(void *ptr, TCL_HASH_TYPE size); /* Slot 85 is reserved */ /* Slot 86 is reserved */ /* Slot 87 is reserved */ -/* Slot 88 is reserved */ +/* 88 */ +TCL_DEPRECATED("") +char * TclPrecTraceProc(void *clientData, + Tcl_Interp *interp, const char *name1, + const char *name2, int flags); /* 89 */ EXTERN int TclPreventAliasLoop(Tcl_Interp *interp, Tcl_Interp *cmdInterp, Tcl_Command cmd); @@ -220,13 +270,17 @@ EXTERN void TclResetShadowedCmdRefs(Tcl_Interp *interp, EXTERN int TclServiceIdle(void); /* Slot 99 is reserved */ /* Slot 100 is reserved */ -/* Slot 101 is reserved */ +/* 101 */ +TCL_DEPRECATED("Use Tcl_SetPreInitScript") +const char * TclSetPreInitScript(const char *string); /* 102 */ EXTERN void TclSetupEnv(Tcl_Interp *interp); /* 103 */ EXTERN int TclSockGetPort(Tcl_Interp *interp, const char *str, const char *proto, int *portPtr); -/* Slot 104 is reserved */ +/* 104 */ +TCL_DEPRECATED("") +int TclSockMinimumBuffersOld(int sock, int size); /* Slot 105 is reserved */ /* Slot 106 is reserved */ /* Slot 107 is reserved */ @@ -242,12 +296,31 @@ EXTERN void Tcl_AddInterpResolvers(Tcl_Interp *interp, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); -/* Slot 112 is reserved */ -/* Slot 113 is reserved */ -/* Slot 114 is reserved */ -/* Slot 115 is reserved */ -/* Slot 116 is reserved */ -/* Slot 117 is reserved */ +/* 112 */ +TCL_DEPRECATED("Use Tcl_AppendExportList") +int TclAppendExportList(Tcl_Interp *interp, + Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); +/* 113 */ +TCL_DEPRECATED("Use Tcl_CreateNamespace") +Tcl_Namespace * TclCreateNamespace(Tcl_Interp *interp, + const char *name, void *clientData, + Tcl_NamespaceDeleteProc *deleteProc); +/* 114 */ +TCL_DEPRECATED("Use Tcl_DeleteNamespace") +void TclDeleteNamespace(Tcl_Namespace *nsPtr); +/* 115 */ +TCL_DEPRECATED("Use Tcl_Export") +int TclExport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + const char *pattern, int resetListFirst); +/* 116 */ +TCL_DEPRECATED("Use Tcl_FindCommand") +Tcl_Command TclFindCommand(Tcl_Interp *interp, const char *name, + Tcl_Namespace *contextNsPtr, int flags); +/* 117 */ +TCL_DEPRECATED("Use Tcl_FindNamespace") +Tcl_Namespace * TclFindNamespace(Tcl_Interp *interp, + const char *name, + Tcl_Namespace *contextNsPtr, int flags); /* 118 */ EXTERN int Tcl_GetInterpResolvers(Tcl_Interp *interp, const char *name, Tcl_ResolverInfo *resInfo); @@ -259,15 +332,31 @@ EXTERN int Tcl_GetNamespaceResolvers( EXTERN Tcl_Var Tcl_FindNamespaceVar(Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); -/* Slot 121 is reserved */ -/* Slot 122 is reserved */ -/* Slot 123 is reserved */ -/* Slot 124 is reserved */ -/* Slot 125 is reserved */ +/* 121 */ +TCL_DEPRECATED("Use Tcl_ForgetImport") +int TclForgetImport(Tcl_Interp *interp, + Tcl_Namespace *nsPtr, const char *pattern); +/* 122 */ +TCL_DEPRECATED("Use Tcl_GetCommandFromObj") +Tcl_Command TclGetCommandFromObj(Tcl_Interp *interp, + Tcl_Obj *objPtr); +/* 123 */ +TCL_DEPRECATED("Use Tcl_GetCommandFullName") +void TclGetCommandFullName(Tcl_Interp *interp, + Tcl_Command command, Tcl_Obj *objPtr); +/* 124 */ +TCL_DEPRECATED("Use Tcl_GetCurrentNamespace") +Tcl_Namespace * TclGetCurrentNamespace_(Tcl_Interp *interp); +/* 125 */ +TCL_DEPRECATED("Use Tcl_GetGlobalNamespace") +Tcl_Namespace * TclGetGlobalNamespace_(Tcl_Interp *interp); /* 126 */ EXTERN void Tcl_GetVariableFullName(Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr); -/* Slot 127 is reserved */ +/* 127 */ +TCL_DEPRECATED("Use ") +int TclImport(Tcl_Interp *interp, Tcl_Namespace *nsPtr, + const char *pattern, int allowOverwrite); /* 128 */ EXTERN void Tcl_PopCallFrame(Tcl_Interp *interp); /* 129 */ @@ -283,8 +372,12 @@ EXTERN void Tcl_SetNamespaceResolvers( Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); -/* Slot 132 is reserved */ -/* Slot 133 is reserved */ +/* 132 */ +TCL_DEPRECATED("") +int TclpHasSockets(Tcl_Interp *interp); +/* 133 */ +TCL_DEPRECATED("") +struct tm * TclpGetDate(const time_t *time, int useGMT); /* Slot 134 is reserved */ /* Slot 135 is reserved */ /* Slot 136 is reserved */ @@ -320,8 +413,10 @@ EXTERN int TclRegAbout(Tcl_Interp *interp, Tcl_RegExp re); /* 151 */ EXTERN void TclRegExpRangeUniChar(Tcl_RegExp re, Tcl_Size index, Tcl_Size *startPtr, Tcl_Size *endPtr); -/* Slot 152 is reserved */ -/* Slot 153 is reserved */ +/* 152 */ +EXTERN void TclSetLibraryPath(Tcl_Obj *pathPtr); +/* 153 */ +EXTERN Tcl_Obj * TclGetLibraryPath(void); /* Slot 154 is reserved */ /* Slot 155 is reserved */ /* 156 */ @@ -330,8 +425,12 @@ EXTERN void TclRegError(Tcl_Interp *interp, const char *msg, /* 157 */ EXTERN Var * TclVarTraceExists(Tcl_Interp *interp, const char *varName); -/* Slot 158 is reserved */ -/* Slot 159 is reserved */ +/* 158 */ +TCL_DEPRECATED("use public Tcl_SetStartupScript()") +void TclSetStartupScriptFileName(const char *filename); +/* 159 */ +TCL_DEPRECATED("use public Tcl_GetStartupScript()") +const char * TclGetStartupScriptFileName(void); /* Slot 160 is reserved */ /* 161 */ EXTERN int TclChannelTransform(Tcl_Interp *interp, @@ -349,11 +448,15 @@ EXTERN void TclpSetInitialEncodings(void); EXTERN int TclListObjSetElement(Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size index, Tcl_Obj *valuePtr); -/* Slot 167 is reserved */ -/* Slot 168 is reserved */ +/* 167 */ +TCL_DEPRECATED("use public Tcl_SetStartupScript()") +void TclSetStartupScriptPath(Tcl_Obj *pathPtr); +/* 168 */ +TCL_DEPRECATED("use public Tcl_GetStartupScript()") +Tcl_Obj * TclGetStartupScriptPath(void); /* 169 */ -EXTERN int TclpUtfNcmp2(const void *s1, const void *s2, - size_t n); +EXTERN int TclpUtfNcmp2(const char *s1, const char *s2, + unsigned long n); /* 170 */ EXTERN int TclCheckInterpTraces(Tcl_Interp *interp, const char *command, Tcl_Size numChars, @@ -382,12 +485,21 @@ EXTERN void TclCleanupVar(Var *varPtr, Var *arrayPtr); EXTERN void TclVarErrMsg(Tcl_Interp *interp, const char *part1, const char *part2, const char *operation, const char *reason); -/* Slot 178 is reserved */ -/* Slot 179 is reserved */ +/* 178 */ +TCL_DEPRECATED("") +void TclSetStartupScript(Tcl_Obj *pathPtr, + const char *encoding); +/* 179 */ +TCL_DEPRECATED("") +Tcl_Obj * TclGetStartupScript(const char **encodingPtr); /* Slot 180 is reserved */ /* Slot 181 is reserved */ -/* Slot 182 is reserved */ -/* Slot 183 is reserved */ +/* 182 */ +TCL_DEPRECATED("") +struct tm * TclpLocaltime(const time_t *clock); +/* 183 */ +TCL_DEPRECATED("") +struct tm * TclpGmtime(const time_t *clock); /* Slot 184 is reserved */ /* Slot 185 is reserved */ /* Slot 186 is reserved */ @@ -497,7 +609,9 @@ EXTERN Var * TclVarHashCreateVar(TclVarHashTable *tablePtr, /* 235 */ EXTERN void TclInitVarHashTable(TclVarHashTable *tablePtr, Namespace *nsPtr); -/* Slot 236 is reserved */ +/* 236 */ +TCL_DEPRECATED("use Tcl_BackgroundException") +void TclBackgroundException(Tcl_Interp *interp, int code); /* 237 */ EXTERN int TclResetCancellation(Tcl_Interp *interp, int force); /* 238 */ @@ -588,7 +702,7 @@ typedef struct TclIntStubs { int (*tclCleanupChildren) (Tcl_Interp *interp, Tcl_Size numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan); /* 5 */ void (*tclCleanupCommand) (Command *cmdPtr); /* 6 */ Tcl_Size (*tclCopyAndCollapse) (Tcl_Size count, const char *src, char *dst); /* 7 */ - void (*reserved8)(void); + TCL_DEPRECATED_API("") int (*tclCopyChannelOld) (Tcl_Interp *interp, Tcl_Channel inChan, Tcl_Channel outChan, int toRead, Tcl_Obj *cmdPtr); /* 8 */ Tcl_Size (*tclCreatePipeline) (Tcl_Interp *interp, Tcl_Size 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 */ @@ -614,27 +728,27 @@ typedef struct TclIntStubs { const char * (*tclGetExtension) (const char *name); /* 31 */ int (*tclGetFrame) (Tcl_Interp *interp, const char *str, CallFrame **framePtrPtr); /* 32 */ void (*reserved33)(void); - void (*reserved34)(void); + 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); - void (*reserved37)(void); + TCL_DEPRECATED_API("") int (*tclGetLoadedPackages) (Tcl_Interp *interp, const char *targetName); /* 37 */ int (*tclGetNamespaceForQualName) (Tcl_Interp *interp, const char *qualName, Namespace *cxtNsPtr, int flags, Namespace **nsPtrPtr, Namespace **altNsPtrPtr, Namespace **actualCxtPtrPtr, const char **simpleNamePtr); /* 38 */ Tcl_ObjCmdProc * (*tclGetObjInterpProc) (void); /* 39 */ int (*tclGetOpenMode) (Tcl_Interp *interp, const char *str, int *modeFlagsPtr); /* 40 */ Tcl_Command (*tclGetOriginalCommand) (Tcl_Command command); /* 41 */ const char * (*tclpGetUserHome) (const char *name, Tcl_DString *bufferPtr); /* 42 */ - Tcl_ObjCmdProc2 * (*tclGetObjInterpProc2) (void); /* 43 */ - void (*reserved44)(void); + void (*reserved43)(void); + TCL_DEPRECATED_API("") int (*tclGuessPackageName) (const char *fileName, Tcl_DString *bufPtr); /* 44 */ int (*tclHideUnsafeCommands) (Tcl_Interp *interp); /* 45 */ int (*tclInExit) (void); /* 46 */ void (*reserved47)(void); void (*reserved48)(void); void (*reserved49)(void); - void (*reserved50)(void); + TCL_DEPRECATED_API("") void (*tclInitCompiledLocals) (Tcl_Interp *interp, CallFrame *framePtr, Namespace *nsPtr); /* 50 */ int (*tclInterpInit) (Tcl_Interp *interp); /* 51 */ void (*reserved52)(void); - void (*reserved53)(void); - void (*reserved54)(void); + TCL_DEPRECATED_API("") int (*tclInvokeObjectCommand) (void *clientData, Tcl_Interp *interp, Tcl_Size argc, const char **argv); /* 53 */ + TCL_DEPRECATED_API("") int (*tclInvokeStringCommand) (void *clientData, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[]); /* 54 */ Proc * (*tclIsProc) (Command *cmdPtr); /* 55 */ void (*reserved56)(void); void (*reserved57)(void); @@ -643,7 +757,7 @@ typedef struct TclIntStubs { int (*tclNeedSpace) (const char *start, const char *end); /* 60 */ Tcl_Obj * (*tclNewProcBodyObj) (Proc *procPtr); /* 61 */ int (*tclObjCommandComplete) (Tcl_Obj *cmdPtr); /* 62 */ - void (*reserved63)(void); + TCL_DEPRECATED_API("") int (*tclObjInterpProc) (void *clientData, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[]); /* 63 */ int (*tclObjInvoke) (Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[], int flags); /* 64 */ void (*reserved65)(void); void (*reserved66)(void); @@ -655,9 +769,9 @@ typedef struct TclIntStubs { void (*reserved72)(void); void (*reserved73)(void); void (*tclpFree) (void *ptr); /* 74 */ - unsigned long long (*tclpGetClicks) (void); /* 75 */ - unsigned long long (*tclpGetSeconds) (void); /* 76 */ - void (*reserved77)(void); + unsigned long (*tclpGetClicks) (void); /* 75 */ + unsigned long (*tclpGetSeconds) (void); /* 76 */ + TCL_DEPRECATED_API("") void (*tclpGetTime) (Tcl_Time *time); /* 77 */ void (*reserved78)(void); void (*reserved79)(void); void (*reserved80)(void); @@ -668,7 +782,7 @@ typedef struct TclIntStubs { void (*reserved85)(void); void (*reserved86)(void); void (*reserved87)(void); - void (*reserved88)(void); + TCL_DEPRECATED_API("") char * (*tclPrecTraceProc) (void *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 */ @@ -681,10 +795,10 @@ typedef struct TclIntStubs { int (*tclServiceIdle) (void); /* 98 */ void (*reserved99)(void); void (*reserved100)(void); - void (*reserved101)(void); + TCL_DEPRECATED_API("Use Tcl_SetPreInitScript") const 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 */ - void (*reserved104)(void); + TCL_DEPRECATED_API("") int (*tclSockMinimumBuffersOld) (int sock, int size); /* 104 */ void (*reserved105)(void); void (*reserved106)(void); void (*reserved107)(void); @@ -692,28 +806,28 @@ typedef struct TclIntStubs { int (*tclUpdateReturnInfo) (Interp *iPtr); /* 109 */ int (*tclSockMinimumBuffers) (void *sock, Tcl_Size size); /* 110 */ void (*tcl_AddInterpResolvers) (Tcl_Interp *interp, const char *name, Tcl_ResolveCmdProc *cmdProc, Tcl_ResolveVarProc *varProc, Tcl_ResolveCompiledVarProc *compiledVarProc); /* 111 */ - void (*reserved112)(void); - void (*reserved113)(void); - void (*reserved114)(void); - void (*reserved115)(void); - void (*reserved116)(void); - void (*reserved117)(void); + TCL_DEPRECATED_API("Use Tcl_AppendExportList") int (*tclAppendExportList) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, Tcl_Obj *objPtr); /* 112 */ + TCL_DEPRECATED_API("Use Tcl_CreateNamespace") Tcl_Namespace * (*tclCreateNamespace) (Tcl_Interp *interp, const char *name, void *clientData, Tcl_NamespaceDeleteProc *deleteProc); /* 113 */ + TCL_DEPRECATED_API("Use Tcl_DeleteNamespace") void (*tclDeleteNamespace) (Tcl_Namespace *nsPtr); /* 114 */ + TCL_DEPRECATED_API("Use Tcl_Export") int (*tclExport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern, int resetListFirst); /* 115 */ + TCL_DEPRECATED_API("Use Tcl_FindCommand") Tcl_Command (*tclFindCommand) (Tcl_Interp *interp, const char *name, Tcl_Namespace *contextNsPtr, int flags); /* 116 */ + TCL_DEPRECATED_API("Use Tcl_FindNamespace") 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 */ - void (*reserved121)(void); - void (*reserved122)(void); - void (*reserved123)(void); - void (*reserved124)(void); - void (*reserved125)(void); + TCL_DEPRECATED_API("Use Tcl_ForgetImport") int (*tclForgetImport) (Tcl_Interp *interp, Tcl_Namespace *nsPtr, const char *pattern); /* 121 */ + TCL_DEPRECATED_API("Use Tcl_GetCommandFromObj") Tcl_Command (*tclGetCommandFromObj) (Tcl_Interp *interp, Tcl_Obj *objPtr); /* 122 */ + TCL_DEPRECATED_API("Use Tcl_GetCommandFullName") void (*tclGetCommandFullName) (Tcl_Interp *interp, Tcl_Command command, Tcl_Obj *objPtr); /* 123 */ + TCL_DEPRECATED_API("Use Tcl_GetCurrentNamespace") Tcl_Namespace * (*tclGetCurrentNamespace_) (Tcl_Interp *interp); /* 124 */ + TCL_DEPRECATED_API("Use Tcl_GetGlobalNamespace") Tcl_Namespace * (*tclGetGlobalNamespace_) (Tcl_Interp *interp); /* 125 */ void (*tcl_GetVariableFullName) (Tcl_Interp *interp, Tcl_Var variable, Tcl_Obj *objPtr); /* 126 */ - void (*reserved127)(void); + TCL_DEPRECATED_API("Use ") 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 */ - void (*reserved132)(void); - void (*reserved133)(void); + TCL_DEPRECATED_API("") int (*tclpHasSockets) (Tcl_Interp *interp); /* 132 */ + TCL_DEPRECATED_API("") struct tm * (*tclpGetDate) (const time_t *time, int useGMT); /* 133 */ void (*reserved134)(void); void (*reserved135)(void); void (*reserved136)(void); @@ -732,14 +846,14 @@ typedef struct TclIntStubs { void (*tclHandleRelease) (TclHandle handle); /* 149 */ int (*tclRegAbout) (Tcl_Interp *interp, Tcl_RegExp re); /* 150 */ void (*tclRegExpRangeUniChar) (Tcl_RegExp re, Tcl_Size index, Tcl_Size *startPtr, Tcl_Size *endPtr); /* 151 */ - void (*reserved152)(void); - void (*reserved153)(void); + void (*tclSetLibraryPath) (Tcl_Obj *pathPtr); /* 152 */ + Tcl_Obj * (*tclGetLibraryPath) (void); /* 153 */ void (*reserved154)(void); void (*reserved155)(void); void (*tclRegError) (Tcl_Interp *interp, const char *msg, int status); /* 156 */ Var * (*tclVarTraceExists) (Tcl_Interp *interp, const char *varName); /* 157 */ - void (*reserved158)(void); - void (*reserved159)(void); + 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) (void *clientData, int flags); /* 162 */ @@ -747,9 +861,9 @@ typedef struct TclIntStubs { void (*tclExpandCodeArray) (void *envPtr); /* 164 */ void (*tclpSetInitialEncodings) (void); /* 165 */ int (*tclListObjSetElement) (Tcl_Interp *interp, Tcl_Obj *listPtr, Tcl_Size index, Tcl_Obj *valuePtr); /* 166 */ - void (*reserved167)(void); - void (*reserved168)(void); - int (*tclpUtfNcmp2) (const void *s1, const void *s2, size_t n); /* 169 */ + 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, Tcl_Size numChars, Command *cmdPtr, int result, int traceFlags, Tcl_Size objc, Tcl_Obj *const objv[]); /* 170 */ int (*tclCheckExecutionTraces) (Tcl_Interp *interp, const char *command, Tcl_Size numChars, Command *cmdPtr, int result, int traceFlags, Tcl_Size objc, Tcl_Obj *const objv[]); /* 171 */ int (*tclInThreadExit) (void); /* 172 */ @@ -758,12 +872,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 (*reserved178)(void); - void (*reserved179)(void); + TCL_DEPRECATED_API("") void (*tclSetStartupScript) (Tcl_Obj *pathPtr, const char *encoding); /* 178 */ + TCL_DEPRECATED_API("") Tcl_Obj * (*tclGetStartupScript) (const char **encodingPtr); /* 179 */ void (*reserved180)(void); void (*reserved181)(void); - void (*reserved182)(void); - void (*reserved183)(void); + 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); @@ -816,7 +930,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 (*reserved236)(void); + TCL_DEPRECATED_API("use Tcl_BackgroundException") void (*tclBackgroundException) (Tcl_Interp *interp, int code); /* 236 */ int (*tclResetCancellation) (Tcl_Interp *interp, int force); /* 237 */ int (*tclNRInterpProc) (void *clientData, Tcl_Interp *interp, Tcl_Size objc, Tcl_Obj *const objv[]); /* 238 */ int (*tclNRInterpProcCore) (Tcl_Interp *interp, Tcl_Obj *procNameObj, Tcl_Size skip, ProcErrorProc *errorProc); /* 239 */ @@ -868,7 +982,8 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclCleanupCommand) /* 6 */ #define TclCopyAndCollapse \ (tclIntStubsPtr->tclCopyAndCollapse) /* 7 */ -/* Slot 8 is reserved */ +#define TclCopyChannelOld \ + (tclIntStubsPtr->tclCopyChannelOld) /* 8 */ #define TclCreatePipeline \ (tclIntStubsPtr->tclCreatePipeline) /* 9 */ #define TclCreateProc \ @@ -907,10 +1022,12 @@ extern const TclIntStubs *tclIntStubsPtr; #define TclGetFrame \ (tclIntStubsPtr->tclGetFrame) /* 32 */ /* Slot 33 is reserved */ -/* Slot 34 is reserved */ +#define TclGetIntForIndex \ + (tclIntStubsPtr->tclGetIntForIndex) /* 34 */ /* Slot 35 is reserved */ /* Slot 36 is reserved */ -/* Slot 37 is reserved */ +#define TclGetLoadedPackages \ + (tclIntStubsPtr->tclGetLoadedPackages) /* 37 */ #define TclGetNamespaceForQualName \ (tclIntStubsPtr->tclGetNamespaceForQualName) /* 38 */ #define TclGetObjInterpProc \ @@ -921,9 +1038,9 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclGetOriginalCommand) /* 41 */ #define TclpGetUserHome \ (tclIntStubsPtr->tclpGetUserHome) /* 42 */ -#define TclGetObjInterpProc2 \ - (tclIntStubsPtr->tclGetObjInterpProc2) /* 43 */ -/* Slot 44 is reserved */ +/* Slot 43 is reserved */ +#define TclGuessPackageName \ + (tclIntStubsPtr->tclGuessPackageName) /* 44 */ #define TclHideUnsafeCommands \ (tclIntStubsPtr->tclHideUnsafeCommands) /* 45 */ #define TclInExit \ @@ -931,12 +1048,15 @@ extern const TclIntStubs *tclIntStubsPtr; /* Slot 47 is reserved */ /* Slot 48 is reserved */ /* Slot 49 is reserved */ -/* Slot 50 is reserved */ +#define TclInitCompiledLocals \ + (tclIntStubsPtr->tclInitCompiledLocals) /* 50 */ #define TclInterpInit \ (tclIntStubsPtr->tclInterpInit) /* 51 */ /* Slot 52 is reserved */ -/* Slot 53 is reserved */ -/* Slot 54 is reserved */ +#define TclInvokeObjectCommand \ + (tclIntStubsPtr->tclInvokeObjectCommand) /* 53 */ +#define TclInvokeStringCommand \ + (tclIntStubsPtr->tclInvokeStringCommand) /* 54 */ #define TclIsProc \ (tclIntStubsPtr->tclIsProc) /* 55 */ /* Slot 56 is reserved */ @@ -950,7 +1070,8 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclNewProcBodyObj) /* 61 */ #define TclObjCommandComplete \ (tclIntStubsPtr->tclObjCommandComplete) /* 62 */ -/* Slot 63 is reserved */ +#define TclObjInterpProc \ + (tclIntStubsPtr->tclObjInterpProc) /* 63 */ #define TclObjInvoke \ (tclIntStubsPtr->tclObjInvoke) /* 64 */ /* Slot 65 is reserved */ @@ -969,7 +1090,8 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclpGetClicks) /* 75 */ #define TclpGetSeconds \ (tclIntStubsPtr->tclpGetSeconds) /* 76 */ -/* Slot 77 is reserved */ +#define TclpGetTime \ + (tclIntStubsPtr->tclpGetTime) /* 77 */ /* Slot 78 is reserved */ /* Slot 79 is reserved */ /* Slot 80 is reserved */ @@ -981,7 +1103,8 @@ extern const TclIntStubs *tclIntStubsPtr; /* Slot 85 is reserved */ /* Slot 86 is reserved */ /* Slot 87 is reserved */ -/* Slot 88 is reserved */ +#define TclPrecTraceProc \ + (tclIntStubsPtr->tclPrecTraceProc) /* 88 */ #define TclPreventAliasLoop \ (tclIntStubsPtr->tclPreventAliasLoop) /* 89 */ /* Slot 90 is reserved */ @@ -1001,12 +1124,14 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclServiceIdle) /* 98 */ /* Slot 99 is reserved */ /* Slot 100 is reserved */ -/* Slot 101 is reserved */ +#define TclSetPreInitScript \ + (tclIntStubsPtr->tclSetPreInitScript) /* 101 */ #define TclSetupEnv \ (tclIntStubsPtr->tclSetupEnv) /* 102 */ #define TclSockGetPort \ (tclIntStubsPtr->tclSockGetPort) /* 103 */ -/* Slot 104 is reserved */ +#define TclSockMinimumBuffersOld \ + (tclIntStubsPtr->tclSockMinimumBuffersOld) /* 104 */ /* Slot 105 is reserved */ /* Slot 106 is reserved */ /* Slot 107 is reserved */ @@ -1018,26 +1143,38 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclSockMinimumBuffers) /* 110 */ #define Tcl_AddInterpResolvers \ (tclIntStubsPtr->tcl_AddInterpResolvers) /* 111 */ -/* Slot 112 is reserved */ -/* Slot 113 is reserved */ -/* Slot 114 is reserved */ -/* Slot 115 is reserved */ -/* Slot 116 is reserved */ -/* Slot 117 is reserved */ +#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 */ -/* Slot 121 is reserved */ -/* Slot 122 is reserved */ -/* Slot 123 is reserved */ -/* Slot 124 is reserved */ -/* Slot 125 is reserved */ +#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 */ -/* Slot 127 is reserved */ +#define TclImport \ + (tclIntStubsPtr->tclImport) /* 127 */ #define Tcl_PopCallFrame \ (tclIntStubsPtr->tcl_PopCallFrame) /* 128 */ #define Tcl_PushCallFrame \ @@ -1046,8 +1183,10 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tcl_RemoveInterpResolvers) /* 130 */ #define Tcl_SetNamespaceResolvers \ (tclIntStubsPtr->tcl_SetNamespaceResolvers) /* 131 */ -/* Slot 132 is reserved */ -/* Slot 133 is reserved */ +#define TclpHasSockets \ + (tclIntStubsPtr->tclpHasSockets) /* 132 */ +#define TclpGetDate \ + (tclIntStubsPtr->tclpGetDate) /* 133 */ /* Slot 134 is reserved */ /* Slot 135 is reserved */ /* Slot 136 is reserved */ @@ -1078,16 +1217,20 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclRegAbout) /* 150 */ #define TclRegExpRangeUniChar \ (tclIntStubsPtr->tclRegExpRangeUniChar) /* 151 */ -/* Slot 152 is reserved */ -/* Slot 153 is reserved */ +#define TclSetLibraryPath \ + (tclIntStubsPtr->tclSetLibraryPath) /* 152 */ +#define TclGetLibraryPath \ + (tclIntStubsPtr->tclGetLibraryPath) /* 153 */ /* Slot 154 is reserved */ /* Slot 155 is reserved */ #define TclRegError \ (tclIntStubsPtr->tclRegError) /* 156 */ #define TclVarTraceExists \ (tclIntStubsPtr->tclVarTraceExists) /* 157 */ -/* Slot 158 is reserved */ -/* Slot 159 is reserved */ +#define TclSetStartupScriptFileName \ + (tclIntStubsPtr->tclSetStartupScriptFileName) /* 158 */ +#define TclGetStartupScriptFileName \ + (tclIntStubsPtr->tclGetStartupScriptFileName) /* 159 */ /* Slot 160 is reserved */ #define TclChannelTransform \ (tclIntStubsPtr->tclChannelTransform) /* 161 */ @@ -1101,8 +1244,10 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclpSetInitialEncodings) /* 165 */ #define TclListObjSetElement \ (tclIntStubsPtr->tclListObjSetElement) /* 166 */ -/* Slot 167 is reserved */ -/* Slot 168 is reserved */ +#define TclSetStartupScriptPath \ + (tclIntStubsPtr->tclSetStartupScriptPath) /* 167 */ +#define TclGetStartupScriptPath \ + (tclIntStubsPtr->tclGetStartupScriptPath) /* 168 */ #define TclpUtfNcmp2 \ (tclIntStubsPtr->tclpUtfNcmp2) /* 169 */ #define TclCheckInterpTraces \ @@ -1120,12 +1265,16 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclCleanupVar) /* 176 */ #define TclVarErrMsg \ (tclIntStubsPtr->tclVarErrMsg) /* 177 */ -/* Slot 178 is reserved */ -/* Slot 179 is reserved */ +#define TclSetStartupScript \ + (tclIntStubsPtr->tclSetStartupScript) /* 178 */ +#define TclGetStartupScript \ + (tclIntStubsPtr->tclGetStartupScript) /* 179 */ /* Slot 180 is reserved */ /* Slot 181 is reserved */ -/* Slot 182 is reserved */ -/* Slot 183 is reserved */ +#define TclpLocaltime \ + (tclIntStubsPtr->tclpLocaltime) /* 182 */ +#define TclpGmtime \ + (tclIntStubsPtr->tclpGmtime) /* 183 */ /* Slot 184 is reserved */ /* Slot 185 is reserved */ /* Slot 186 is reserved */ @@ -1210,7 +1359,8 @@ extern const TclIntStubs *tclIntStubsPtr; (tclIntStubsPtr->tclVarHashCreateVar) /* 234 */ #define TclInitVarHashTable \ (tclIntStubsPtr->tclInitVarHashTable) /* 235 */ -/* Slot 236 is reserved */ +#define TclBackgroundException \ + (tclIntStubsPtr->tclBackgroundException) /* 236 */ #define TclResetCancellation \ (tclIntStubsPtr->tclResetCancellation) /* 237 */ #define TclNRInterpProc \ @@ -1263,28 +1413,46 @@ extern const TclIntStubs *tclIntStubsPtr; /* !END!: Do not edit above this line. */ -#if defined(USE_TCL_STUBS) -#undef Tcl_StaticLibrary -#define Tcl_StaticLibrary \ - (tclIntStubsPtr->tclStaticLibrary) -#endif /* defined(USE_TCL_STUBS) */ +#undef TCL_STORAGE_CLASS +#define TCL_STORAGE_CLASS DLLIMPORT -#if (TCL_MAJOR_VERSION < 9) && defined(USE_TCL_STUBS) -#undef TclpGetClicks -#define TclpGetClicks() \ - ((unsigned long)tclIntStubsPtr->tclpGetClicks()) -#undef TclpGetSeconds -#define TclpGetSeconds() \ - ((unsigned long)tclIntStubsPtr->tclpGetSeconds()) -#undef TclGetObjInterpProc2 -#define TclGetObjInterpProc2 TclGetObjInterpProc +#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_StaticLibrary +# define Tcl_StaticLibrary (tclIntStubsPtr->tclStaticLibrary) #endif #undef TclUnusedStubEntry +#undef TclGuessPackageName +#undef TclSetPreInitScript +#undef TclObjInterpProc #define TclObjInterpProc TclGetObjInterpProc() -#define TclObjInterpProc2 TclGetObjInterpProc2() +#define TclObjInterpProc2 TclObjInterpProc -#undef TCL_STORAGE_CLASS -#define TCL_STORAGE_CLASS DLLIMPORT +#ifndef TCL_NO_DEPRECATED +# define TclSetPreInitScript Tcl_SetPreInitScript +# define TclGuessPackageName(fileName, pkgName) ((void)fileName,(void)pkgName,0) +#endif #endif /* _TCLINTDECLS */ diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h index aab3737..1a43e15 100644 --- a/generic/tclIntPlatDecls.h +++ b/generic/tclIntPlatDecls.h @@ -30,7 +30,7 @@ * in the generic/tclInt.decls script. */ -#if TCL_MAJOR_VERSION < 9 +/* !BEGIN!: Do not edit below this line. */ #ifdef __cplusplus extern "C" { @@ -57,7 +57,8 @@ EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); -/* Slot 5 is reserved */ +/* 5 */ +EXTERN int TclUnixWaitForFile_(int fd, int mask, int timeout); /* 6 */ EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); /* 7 */ @@ -68,9 +69,12 @@ EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); EXTERN TclFile TclpCreateTempFile(const char *contents); /* 10 */ EXTERN Tcl_DirEntry * TclpReaddir(TclDIR *dir); -/* Slot 11 is reserved */ -/* Slot 12 is reserved */ -/* Slot 13 is reserved */ +/* 11 */ +EXTERN struct tm * TclpLocaltime_unix(const time_t *clock); +/* 12 */ +EXTERN struct tm * TclpGmtime_unix(const time_t *clock); +/* 13 */ +EXTERN char * TclpInetNtoa(struct in_addr addr); /* 14 */ EXTERN int TclUnixCopyFile(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, @@ -97,7 +101,8 @@ EXTERN void TclMacOSXNotifierAddRunLoopMode( const void *runLoopMode); /* Slot 20 is reserved */ /* Slot 21 is reserved */ -/* Slot 22 is reserved */ +/* 22 */ +EXTERN TclFile TclpCreateTempFile_(const char *contents); /* Slot 23 is reserved */ /* Slot 24 is reserved */ /* Slot 25 is reserved */ @@ -112,20 +117,31 @@ EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, Tcl_Obj *resultingNameObj); #endif /* UNIX */ #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ -/* Slot 0 is reserved */ -/* Slot 1 is reserved */ -/* Slot 2 is reserved */ -/* Slot 3 is reserved */ +/* 0 */ +EXTERN void TclWinConvertError(DWORD errCode); +/* 1 */ +EXTERN void TclWinConvertWSAError(DWORD errCode); +/* 2 */ +EXTERN struct servent * TclWinGetServByName(const char *nm, + const char *proto); +/* 3 */ +EXTERN int TclWinGetSockOpt(SOCKET s, int level, int optname, + char *optval, int *optlen); /* 4 */ -EXTERN void * TclWinGetTclInstance(void); +EXTERN HINSTANCE TclWinGetTclInstance(void); /* 5 */ EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); -/* Slot 6 is reserved */ -/* Slot 7 is reserved */ +/* 6 */ +EXTERN unsigned short TclWinNToHS(unsigned short ns); +/* 7 */ +EXTERN int TclWinSetSockOpt(SOCKET s, int level, int optname, + const char *optval, int optlen); /* 8 */ EXTERN Tcl_Size TclpGetPid(Tcl_Pid pid); -/* Slot 9 is reserved */ -/* Slot 10 is reserved */ +/* 9 */ +EXTERN int TclWinGetPlatformId(void); +/* 10 */ +EXTERN Tcl_DirEntry * TclpReaddir(TclDIR *dir); /* 11 */ EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, Tcl_Channel chan); @@ -154,17 +170,20 @@ EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); EXTERN TclFile TclpOpenFile(const char *fname, int mode); /* 20 */ EXTERN void TclWinAddProcess(void *hProcess, Tcl_Size id); -/* Slot 21 is reserved */ +/* 21 */ +EXTERN char * TclpInetNtoa(struct in_addr addr); /* 22 */ EXTERN TclFile TclpCreateTempFile(const char *contents); /* Slot 23 is reserved */ /* 24 */ EXTERN char * TclWinNoBackslash(char *path); /* Slot 25 is reserved */ -/* Slot 26 is reserved */ +/* 26 */ +EXTERN void TclWinSetInterfaces(int wide); /* 27 */ EXTERN void TclWinFlushDirtyChannels(void); -/* Slot 28 is reserved */ +/* 28 */ +EXTERN void TclWinResetInterfaces(void); /* 29 */ EXTERN int TclWinCPUID(int index, int *regs); /* 30 */ @@ -189,7 +208,8 @@ EXTERN int TclpCreateProcess(Tcl_Interp *interp, int argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); -/* Slot 5 is reserved */ +/* 5 */ +EXTERN int TclUnixWaitForFile_(int fd, int mask, int timeout); /* 6 */ EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); /* 7 */ @@ -200,7 +220,12 @@ EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); EXTERN TclFile TclpCreateTempFile(const char *contents); /* 10 */ EXTERN Tcl_DirEntry * TclpReaddir(TclDIR *dir); -/* Slot 13 is reserved */ +/* 11 */ +EXTERN struct tm * TclpLocaltime_unix(const time_t *clock); +/* 12 */ +EXTERN struct tm * TclpGmtime_unix(const time_t *clock); +/* 13 */ +EXTERN char * TclpInetNtoa(struct in_addr addr); /* 14 */ EXTERN int TclUnixCopyFile(const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, @@ -227,7 +252,8 @@ EXTERN void TclMacOSXNotifierAddRunLoopMode( const void *runLoopMode); /* Slot 20 is reserved */ /* Slot 21 is reserved */ -/* Slot 22 is reserved */ +/* 22 */ +EXTERN TclFile TclpCreateTempFile_(const char *contents); /* Slot 23 is reserved */ /* Slot 24 is reserved */ /* Slot 25 is reserved */ @@ -258,9 +284,9 @@ typedef struct TclIntPlatStubs { int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */ TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */ Tcl_DirEntry * (*tclpReaddir) (TclDIR *dir); /* 10 */ - void (*reserved11)(void); - void (*reserved12)(void); - void (*reserved13)(void); + struct tm * (*tclpLocaltime_unix) (const time_t *clock); /* 11 */ + struct tm * (*tclpGmtime_unix) (const time_t *clock); /* 12 */ + char * (*tclpInetNtoa) (struct in_addr addr); /* 13 */ int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 14 */ int (*tclMacOSXGetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); /* 15 */ int (*tclMacOSXSetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); /* 16 */ @@ -280,17 +306,17 @@ typedef struct TclIntPlatStubs { int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ #endif /* UNIX */ #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ - void (*reserved0)(void); - void (*reserved1)(void); - void (*reserved2)(void); - void (*reserved3)(void); - void * (*tclWinGetTclInstance) (void); /* 4 */ + void (*tclWinConvertError) (DWORD errCode); /* 0 */ + void (*tclWinConvertWSAError) (DWORD errCode); /* 1 */ + struct servent * (*tclWinGetServByName) (const char *nm, const char *proto); /* 2 */ + int (*tclWinGetSockOpt) (SOCKET s, int level, int optname, char *optval, int *optlen); /* 3 */ + HINSTANCE (*tclWinGetTclInstance) (void); /* 4 */ int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 5 */ - void (*reserved6)(void); - void (*reserved7)(void); + unsigned short (*tclWinNToHS) (unsigned short ns); /* 6 */ + int (*tclWinSetSockOpt) (SOCKET s, int level, int optname, const char *optval, int optlen); /* 7 */ Tcl_Size (*tclpGetPid) (Tcl_Pid pid); /* 8 */ - void (*reserved9)(void); - void *(*tclpReaddir) (void *dir); /* 10 */ + int (*tclWinGetPlatformId) (void); /* 9 */ + Tcl_DirEntry * (*tclpReaddir) (TclDIR *dir); /* 10 */ void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 11 */ int (*tclpCloseFile) (TclFile file); /* 12 */ Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 13 */ @@ -301,14 +327,14 @@ typedef struct TclIntPlatStubs { TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 18 */ TclFile (*tclpOpenFile) (const char *fname, int mode); /* 19 */ void (*tclWinAddProcess) (void *hProcess, Tcl_Size id); /* 20 */ - void (*reserved21)(void); + char * (*tclpInetNtoa) (struct in_addr addr); /* 21 */ TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */ void (*reserved23)(void); char * (*tclWinNoBackslash) (char *path); /* 24 */ void (*reserved25)(void); - void (*reserved26)(void); + void (*tclWinSetInterfaces) (int wide); /* 26 */ void (*tclWinFlushDirtyChannels) (void); /* 27 */ - void (*reserved28)(void); + void (*tclWinResetInterfaces) (void); /* 28 */ int (*tclWinCPUID) (int index, int *regs); /* 29 */ int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ #endif /* WIN */ @@ -324,9 +350,9 @@ typedef struct TclIntPlatStubs { int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 8 */ TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */ Tcl_DirEntry * (*tclpReaddir) (TclDIR *dir); /* 10 */ - void (*reserved11)(void); - void (*reserved12)(void); - void (*reserved13)(void); + struct tm * (*tclpLocaltime_unix) (const time_t *clock); /* 11 */ + struct tm * (*tclpGmtime_unix) (const time_t *clock); /* 12 */ + char * (*tclpInetNtoa) (struct in_addr addr); /* 13 */ int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 14 */ int (*tclMacOSXGetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj **attributePtrPtr); /* 15 */ int (*tclMacOSXSetFileAttribute) (Tcl_Interp *interp, int objIndex, Tcl_Obj *fileName, Tcl_Obj *attributePtr); /* 16 */ @@ -370,7 +396,8 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ #define TclpCreateProcess \ (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */ -/* Slot 5 is reserved */ +#define TclUnixWaitForFile_ \ + (tclIntPlatStubsPtr->tclUnixWaitForFile_) /* 5 */ #define TclpMakeFile \ (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */ #define TclpOpenFile \ @@ -381,9 +408,12 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */ #define TclpReaddir \ (tclIntPlatStubsPtr->tclpReaddir) /* 10 */ -/* Slot 11 is reserved */ -/* Slot 12 is reserved */ -/* Slot 13 is reserved */ +#define TclpLocaltime_unix \ + (tclIntPlatStubsPtr->tclpLocaltime_unix) /* 11 */ +#define TclpGmtime_unix \ + (tclIntPlatStubsPtr->tclpGmtime_unix) /* 12 */ +#define TclpInetNtoa \ + (tclIntPlatStubsPtr->tclpInetNtoa) /* 13 */ #define TclUnixCopyFile \ (tclIntPlatStubsPtr->tclUnixCopyFile) /* 14 */ #define TclMacOSXGetFileAttribute \ @@ -398,7 +428,8 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */ /* Slot 20 is reserved */ /* Slot 21 is reserved */ -/* Slot 22 is reserved */ +#define TclpCreateTempFile_ \ + (tclIntPlatStubsPtr->tclpCreateTempFile_) /* 22 */ /* Slot 23 is reserved */ /* Slot 24 is reserved */ /* Slot 25 is reserved */ @@ -411,20 +442,28 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ #endif /* UNIX */ #if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ -/* Slot 0 is reserved */ -/* Slot 1 is reserved */ -/* Slot 2 is reserved */ -/* Slot 3 is reserved */ +#define TclWinConvertError \ + (tclIntPlatStubsPtr->tclWinConvertError) /* 0 */ +#define TclWinConvertWSAError \ + (tclIntPlatStubsPtr->tclWinConvertWSAError) /* 1 */ +#define TclWinGetServByName \ + (tclIntPlatStubsPtr->tclWinGetServByName) /* 2 */ +#define TclWinGetSockOpt \ + (tclIntPlatStubsPtr->tclWinGetSockOpt) /* 3 */ #define TclWinGetTclInstance \ (tclIntPlatStubsPtr->tclWinGetTclInstance) /* 4 */ #define TclUnixWaitForFile \ (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 5 */ -/* Slot 6 is reserved */ -/* Slot 7 is reserved */ +#define TclWinNToHS \ + (tclIntPlatStubsPtr->tclWinNToHS) /* 6 */ +#define TclWinSetSockOpt \ + (tclIntPlatStubsPtr->tclWinSetSockOpt) /* 7 */ #define TclpGetPid \ (tclIntPlatStubsPtr->tclpGetPid) /* 8 */ -/* Slot 9 is reserved */ -/* Slot 10 is reserved */ +#define TclWinGetPlatformId \ + (tclIntPlatStubsPtr->tclWinGetPlatformId) /* 9 */ +#define TclpReaddir \ + (tclIntPlatStubsPtr->tclpReaddir) /* 10 */ #define TclGetAndDetachPids \ (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 11 */ #define TclpCloseFile \ @@ -445,17 +484,20 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; (tclIntPlatStubsPtr->tclpOpenFile) /* 19 */ #define TclWinAddProcess \ (tclIntPlatStubsPtr->tclWinAddProcess) /* 20 */ -/* Slot 21 is reserved */ +#define TclpInetNtoa \ + (tclIntPlatStubsPtr->tclpInetNtoa) /* 21 */ #define TclpCreateTempFile \ (tclIntPlatStubsPtr->tclpCreateTempFile) /* 22 */ /* Slot 23 is reserved */ #define TclWinNoBackslash \ (tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */ /* Slot 25 is reserved */ -/* Slot 26 is reserved */ +#define TclWinSetInterfaces \ + (tclIntPlatStubsPtr->tclWinSetInterfaces) /* 26 */ #define TclWinFlushDirtyChannels \ (tclIntPlatStubsPtr->tclWinFlushDirtyChannels) /* 27 */ -/* Slot 28 is reserved */ +#define TclWinResetInterfaces \ + (tclIntPlatStubsPtr->tclWinResetInterfaces) /* 28 */ #define TclWinCPUID \ (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ #define TclUnixOpenTemporaryFile \ @@ -472,7 +514,8 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ #define TclpCreateProcess \ (tclIntPlatStubsPtr->tclpCreateProcess) /* 4 */ -/* Slot 5 is reserved */ +#define TclUnixWaitForFile_ \ + (tclIntPlatStubsPtr->tclUnixWaitForFile_) /* 5 */ #define TclpMakeFile \ (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */ #define TclpOpenFile \ @@ -483,9 +526,12 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */ #define TclpReaddir \ (tclIntPlatStubsPtr->tclpReaddir) /* 10 */ -/* Slot 11 is reserved */ -/* Slot 12 is reserved */ -/* Slot 13 is reserved */ +#define TclpLocaltime_unix \ + (tclIntPlatStubsPtr->tclpLocaltime_unix) /* 11 */ +#define TclpGmtime_unix \ + (tclIntPlatStubsPtr->tclpGmtime_unix) /* 12 */ +#define TclpInetNtoa \ + (tclIntPlatStubsPtr->tclpInetNtoa) /* 13 */ #define TclUnixCopyFile \ (tclIntPlatStubsPtr->tclUnixCopyFile) /* 14 */ #define TclMacOSXGetFileAttribute \ @@ -500,7 +546,8 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; (tclIntPlatStubsPtr->tclMacOSXNotifierAddRunLoopMode) /* 19 */ /* Slot 20 is reserved */ /* Slot 21 is reserved */ -/* Slot 22 is reserved */ +#define TclpCreateTempFile_ \ + (tclIntPlatStubsPtr->tclpCreateTempFile_) /* 22 */ /* Slot 23 is reserved */ /* Slot 24 is reserved */ /* Slot 25 is reserved */ @@ -515,202 +562,25 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr; #endif /* defined(USE_TCL_STUBS) */ -#else /* TCL_MAJOR_VERSION > 8 */ -/* !BEGIN!: Do not edit below this line. */ - -#ifdef __cplusplus -extern "C" { -#endif - -/* - * Exported function declarations: - */ - -/* Slot 0 is reserved */ -/* 1 */ -EXTERN int TclpCloseFile(TclFile file); -/* 2 */ -EXTERN Tcl_Channel TclpCreateCommandChannel(TclFile readFile, - TclFile writeFile, TclFile errorFile, - size_t numPids, Tcl_Pid *pidPtr); -/* 3 */ -EXTERN int TclpCreatePipe(TclFile *readPipe, TclFile *writePipe); -/* 4 */ -EXTERN void * TclWinGetTclInstance(void); -/* 5 */ -EXTERN int TclUnixWaitForFile(int fd, int mask, int timeout); -/* 6 */ -EXTERN TclFile TclpMakeFile(Tcl_Channel channel, int direction); -/* 7 */ -EXTERN TclFile TclpOpenFile(const char *fname, int mode); -/* 8 */ -EXTERN Tcl_Size TclpGetPid(Tcl_Pid pid); -/* 9 */ -EXTERN TclFile TclpCreateTempFile(const char *contents); -/* Slot 10 is reserved */ -/* 11 */ -EXTERN void TclGetAndDetachPids(Tcl_Interp *interp, - Tcl_Channel chan); -/* Slot 12 is reserved */ -/* Slot 13 is reserved */ -/* Slot 14 is reserved */ -/* 15 */ -EXTERN int TclpCreateProcess(Tcl_Interp *interp, size_t argc, - const char **argv, TclFile inputFile, - TclFile outputFile, TclFile errorFile, - Tcl_Pid *pidPtr); -/* 16 */ -EXTERN int TclpIsAtty(int fd); -/* 17 */ -EXTERN int TclUnixCopyFile(const char *src, const char *dst, - const Tcl_StatBuf *statBufPtr, - int dontCopyAtts); -/* Slot 18 is reserved */ -/* Slot 19 is reserved */ -/* 20 */ -EXTERN void TclWinAddProcess(void *hProcess, Tcl_Size id); -/* Slot 21 is reserved */ -/* Slot 22 is reserved */ -/* Slot 23 is reserved */ -/* 24 */ -EXTERN char * TclWinNoBackslash(char *path); -/* Slot 25 is reserved */ -/* Slot 26 is reserved */ -/* 27 */ -EXTERN void TclWinFlushDirtyChannels(void); -/* Slot 28 is reserved */ -/* 29 */ -EXTERN int TclWinCPUID(int index, int *regs); -/* 30 */ -EXTERN int TclUnixOpenTemporaryFile(Tcl_Obj *dirObj, - Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, - Tcl_Obj *resultingNameObj); - -typedef struct TclIntPlatStubs { - int magic; - void *hooks; - - void (*reserved0)(void); - int (*tclpCloseFile) (TclFile file); /* 1 */ - Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, size_t numPids, Tcl_Pid *pidPtr); /* 2 */ - int (*tclpCreatePipe) (TclFile *readPipe, TclFile *writePipe); /* 3 */ - void * (*tclWinGetTclInstance) (void); /* 4 */ - int (*tclUnixWaitForFile) (int fd, int mask, int timeout); /* 5 */ - TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 6 */ - TclFile (*tclpOpenFile) (const char *fname, int mode); /* 7 */ - Tcl_Size (*tclpGetPid) (Tcl_Pid pid); /* 8 */ - TclFile (*tclpCreateTempFile) (const char *contents); /* 9 */ - void (*reserved10)(void); - void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 11 */ - void (*reserved12)(void); - void (*reserved13)(void); - void (*reserved14)(void); - int (*tclpCreateProcess) (Tcl_Interp *interp, size_t argc, const char **argv, TclFile inputFile, TclFile outputFile, TclFile errorFile, Tcl_Pid *pidPtr); /* 15 */ - int (*tclpIsAtty) (int fd); /* 16 */ - int (*tclUnixCopyFile) (const char *src, const char *dst, const Tcl_StatBuf *statBufPtr, int dontCopyAtts); /* 17 */ - void (*reserved18)(void); - void (*reserved19)(void); - void (*tclWinAddProcess) (void *hProcess, Tcl_Size id); /* 20 */ - void (*reserved21)(void); - void (*reserved22)(void); - void (*reserved23)(void); - char * (*tclWinNoBackslash) (char *path); /* 24 */ - void (*reserved25)(void); - void (*reserved26)(void); - void (*tclWinFlushDirtyChannels) (void); /* 27 */ - void (*reserved28)(void); - int (*tclWinCPUID) (int index, int *regs); /* 29 */ - int (*tclUnixOpenTemporaryFile) (Tcl_Obj *dirObj, Tcl_Obj *basenameObj, Tcl_Obj *extensionObj, Tcl_Obj *resultingNameObj); /* 30 */ -} TclIntPlatStubs; - -extern const TclIntPlatStubs *tclIntPlatStubsPtr; - -#ifdef __cplusplus -} -#endif - -#if defined(USE_TCL_STUBS) - -/* - * Inline function declarations: - */ - -/* Slot 0 is reserved */ -#define TclpCloseFile \ - (tclIntPlatStubsPtr->tclpCloseFile) /* 1 */ -#define TclpCreateCommandChannel \ - (tclIntPlatStubsPtr->tclpCreateCommandChannel) /* 2 */ -#define TclpCreatePipe \ - (tclIntPlatStubsPtr->tclpCreatePipe) /* 3 */ -#define TclWinGetTclInstance \ - (tclIntPlatStubsPtr->tclWinGetTclInstance) /* 4 */ -#define TclUnixWaitForFile \ - (tclIntPlatStubsPtr->tclUnixWaitForFile) /* 5 */ -#define TclpMakeFile \ - (tclIntPlatStubsPtr->tclpMakeFile) /* 6 */ -#define TclpOpenFile \ - (tclIntPlatStubsPtr->tclpOpenFile) /* 7 */ -#define TclpGetPid \ - (tclIntPlatStubsPtr->tclpGetPid) /* 8 */ -#define TclpCreateTempFile \ - (tclIntPlatStubsPtr->tclpCreateTempFile) /* 9 */ -/* Slot 10 is reserved */ -#define TclGetAndDetachPids \ - (tclIntPlatStubsPtr->tclGetAndDetachPids) /* 11 */ -/* Slot 12 is reserved */ -/* Slot 13 is reserved */ -/* Slot 14 is reserved */ -#define TclpCreateProcess \ - (tclIntPlatStubsPtr->tclpCreateProcess) /* 15 */ -#define TclpIsAtty \ - (tclIntPlatStubsPtr->tclpIsAtty) /* 16 */ -#define TclUnixCopyFile \ - (tclIntPlatStubsPtr->tclUnixCopyFile) /* 17 */ -/* Slot 18 is reserved */ -/* Slot 19 is reserved */ -#define TclWinAddProcess \ - (tclIntPlatStubsPtr->tclWinAddProcess) /* 20 */ -/* Slot 21 is reserved */ -/* Slot 22 is reserved */ -/* Slot 23 is reserved */ -#define TclWinNoBackslash \ - (tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */ -/* Slot 25 is reserved */ -/* Slot 26 is reserved */ -#define TclWinFlushDirtyChannels \ - (tclIntPlatStubsPtr->tclWinFlushDirtyChannels) /* 27 */ -/* Slot 28 is reserved */ -#define TclWinCPUID \ - (tclIntPlatStubsPtr->tclWinCPUID) /* 29 */ -#define TclUnixOpenTemporaryFile \ - (tclIntPlatStubsPtr->tclUnixOpenTemporaryFile) /* 30 */ - -#endif /* defined(USE_TCL_STUBS) */ - /* !END!: Do not edit above this line. */ -#endif /* TCL_MAJOR_VERSION */ #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT +#undef TclpLocaltime_unix +#undef TclpGmtime_unix +#undef TclWinConvertWSAError +#define TclWinConvertWSAError TclWinConvertError +#if !defined(TCL_USE_STUBS) && !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 +# undef TclWinConvertError +# define TclWinConvertError Tcl_WinConvertError +#endif -#ifdef MAC_OSX_TCL /* not accessible on Win32/UNIX */ -MODULE_SCOPE int TclMacOSXGetFileAttribute(Tcl_Interp *interp, - int objIndex, Tcl_Obj *fileName, - Tcl_Obj **attributePtrPtr); -/* 16 */ -MODULE_SCOPE int TclMacOSXSetFileAttribute(Tcl_Interp *interp, - int objIndex, Tcl_Obj *fileName, - Tcl_Obj *attributePtr); -/* 17 */ -MODULE_SCOPE int TclMacOSXCopyFileAttributes(const char *src, - const char *dst, - const Tcl_StatBuf *statBufPtr); -/* 18 */ -MODULE_SCOPE int TclMacOSXMatchType(Tcl_Interp *interp, - const char *pathName, const char *fileName, - Tcl_StatBuf *statBufPtr, - Tcl_GlobTypeData *types); -#else +#undef TclpInetNtoa +#define TclpInetNtoa inet_ntoa + +#undef TclpCreateTempFile_ +#undef TclUnixWaitForFile_ +#ifndef MAC_OSX_TCL /* not accessible on Win32/UNIX */ #undef TclMacOSXGetFileAttribute /* 15 */ #undef TclMacOSXSetFileAttribute /* 16 */ #undef TclMacOSXCopyFileAttributes /* 17 */ @@ -719,11 +589,15 @@ MODULE_SCOPE int TclMacOSXMatchType(Tcl_Interp *interp, #endif #if defined(_WIN32) -# if !defined(TCL_NO_DEPRECATED) -# define TclWinConvertError Tcl_WinConvertError -# define TclWinConvertWSAError Tcl_WinConvertError +# undef TclWinNToHS +# undef TclWinGetServByName +# undef TclWinGetSockOpt +# undef TclWinSetSockOpt +# undef TclWinGetPlatformId +# undef TclWinResetInterfaces +# undef TclWinSetInterfaces +# if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 # define TclWinNToHS ntohs -# define TclpInetNtoa inet_ntoa # define TclWinGetServByName getservbyname # define TclWinGetSockOpt getsockopt # define TclWinSetSockOpt setsockopt @@ -733,7 +607,7 @@ MODULE_SCOPE int TclMacOSXMatchType(Tcl_Interp *interp, # endif /* TCL_NO_DEPRECATED */ #else # undef TclpGetPid -# define TclpGetPid(pid) ((Tcl_Size)(pid)) +# define TclpGetPid(pid) ((Tcl_Size)(size_t)(pid)) #endif #endif /* _TCLINTPLATDECLS */ diff --git a/generic/tclInterp.c b/generic/tclInterp.c index b2d883b..a98216c 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -268,7 +268,6 @@ static void SetScriptLimitCallback(Tcl_Interp *interp, int type, static void CallScriptLimitCallback(void *clientData, Tcl_Interp *interp); static void DeleteScriptLimitCallback(void *clientData); -static void MakeSafe(Tcl_Interp *interp); static void RunLimitHandlers(LimitHandler *handlerPtr, Tcl_Interp *interp); static void TimeLimitCallback(void *clientData); @@ -483,7 +482,7 @@ TclInterpInit( Parent *parentPtr; Child *childPtr; - interpInfoPtr = (InterpInfo *)Tcl_Alloc(sizeof(InterpInfo)); + interpInfoPtr = (InterpInfo *)ckalloc(sizeof(InterpInfo)); ((Interp *) interp)->interpInfo = interpInfoPtr; parentPtr = &interpInfoPtr->parent; @@ -580,7 +579,7 @@ InterpInfoDeleteProc( } Tcl_DeleteHashTable(&childPtr->aliasTable); - Tcl_Free(interpInfoPtr); + ckfree(interpInfoPtr); } /* @@ -618,17 +617,15 @@ NRInterpCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Interp *childInterp; + int index; static const char *const options[] = { "alias", "aliases", "bgerror", "cancel", "children", "create", "debug", "delete", "eval", "exists", "expose", "hide", "hidden", "issafe", "invokehidden", "limit", "marktrusted", "recursionlimit", - "share", -#ifndef TCL_NO_DEPRECATED - "slaves", -#endif - "target", "transfer", NULL + "share", "slaves", "target", "transfer", + NULL }; static const char *const optionsNoSlaves[] = { "alias", "aliases", "bgerror", "cancel", @@ -636,20 +633,16 @@ NRInterpCmd( "eval", "exists", "expose", "hide", "hidden", "issafe", "invokehidden", "limit", "marktrusted", "recursionlimit", - "share", "target", "transfer", - NULL + "share", "target", "transfer", NULL }; enum interpOptionEnum { OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_CANCEL, OPT_CHILDREN, OPT_CREATE, OPT_DEBUG, OPT_DELETE, OPT_EVAL, OPT_EXISTS, OPT_EXPOSE, OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHID, - OPT_LIMIT, OPT_MARKTRUSTED, OPT_RECLIMIT, OPT_SHARE, -#ifndef TCL_NO_DEPRECATED - OPT_SLAVES, -#endif - OPT_TARGET, OPT_TRANSFER - } index; + OPT_LIMIT, OPT_MARKTRUSTED,OPT_RECLIMIT, + OPT_SHARE, OPT_SLAVES, OPT_TARGET, OPT_TRANSFER + }; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "cmd ?arg ...?"); @@ -662,7 +655,7 @@ NRInterpCmd( "option", 0, &index); return TCL_ERROR; } - switch (index) { + switch ((enum interpOptionEnum)index) { case OPT_ALIAS: { Tcl_Interp *parentInterp; @@ -718,7 +711,7 @@ NRInterpCmd( }; enum optionCancelEnum { OPT_UNWIND, OPT_LAST - } idx; + }; flags = 0; @@ -727,11 +720,11 @@ NRInterpCmd( break; } if (Tcl_GetIndexFromObj(interp, objv[i], cancelOptions, "option", - 0, &idx) != TCL_OK) { + 0, &index) != TCL_OK) { return TCL_ERROR; } - switch (idx) { + switch ((enum optionCancelEnum) index) { case OPT_UNWIND: /* * The evaluation stack in the target interp is to be unwound. @@ -792,7 +785,7 @@ NRInterpCmd( }; enum option { OPT_SAFE, OPT_LAST - } idx; + }; safe = Tcl_IsSafe(interp); @@ -805,10 +798,10 @@ NRInterpCmd( for (i = 2; i < objc; i++) { if ((last == 0) && (TclGetString(objv[i])[0] == '-')) { if (Tcl_GetIndexFromObj(interp, objv[i], createOptions, - "option", 0, &idx) != TCL_OK) { + "option", 0, &index) != TCL_OK) { return TCL_ERROR; } - if (idx == OPT_SAFE) { + if (index == OPT_SAFE) { safe = 1; continue; } @@ -951,7 +944,7 @@ NRInterpCmd( }; enum hiddenOption { OPT_GLOBAL, OPT_NAMESPACE, OPT_LAST - } idx; + }; namespaceName = NULL; for (i = 3; i < objc; i++) { @@ -959,12 +952,12 @@ NRInterpCmd( break; } if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions, "option", - 0, &idx) != TCL_OK) { + 0, &index) != TCL_OK) { return TCL_ERROR; } - if (idx == OPT_GLOBAL) { + if (index == OPT_GLOBAL) { namespaceName = "::"; - } else if (idx == OPT_NAMESPACE) { + } else if (index == OPT_NAMESPACE) { if (++i == objc) { /* There must be more arguments. */ break; } else { @@ -993,7 +986,8 @@ NRInterpCmd( }; enum LimitTypes { LIMIT_TYPE_COMMANDS, LIMIT_TYPE_TIME - } limitType; + }; + int limitType; if (objc < 4) { Tcl_WrongNumArgs(interp, 2, objv, @@ -1008,7 +1002,7 @@ NRInterpCmd( &limitType) != TCL_OK) { return TCL_ERROR; } - switch (limitType) { + switch ((enum LimitTypes) limitType) { case LIMIT_TYPE_COMMANDS: return ChildCommandLimitCmd(interp, childInterp, 4, objc,objv); case LIMIT_TYPE_TIME: @@ -1036,10 +1030,8 @@ NRInterpCmd( return TCL_ERROR; } return ChildRecursionLimit(interp, childInterp, objc - 3, objv + 3); -#ifndef TCL_NO_DEPRECATED - case OPT_SLAVES: -#endif - case OPT_CHILDREN: { + case OPT_CHILDREN: + case OPT_SLAVES: { InterpInfo *iiPtr; Tcl_Obj *resultPtr; Tcl_HashEntry *hPtr; @@ -1278,6 +1270,69 @@ Tcl_CreateAliasObj( /* *---------------------------------------------------------------------- * + * Tcl_GetAlias -- + * + * Gets information about an alias. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ +#ifndef TCL_NO_DEPRECATED +int +Tcl_GetAlias( + Tcl_Interp *interp, /* Interp to start search from. */ + const char *aliasName, /* Name of alias to find. */ + Tcl_Interp **targetInterpPtr, + /* (Return) target interpreter. */ + const char **targetCmdPtr, /* (Return) name of target command. */ + int *argcPtr, /* (Return) count of addnl args. */ + const char ***argvPtr) /* (Return) additional arguments. */ +{ + InterpInfo *iiPtr = (InterpInfo *) ((Interp *) interp)->interpInfo; + Tcl_HashEntry *hPtr; + Alias *aliasPtr; + int i, objc; + Tcl_Obj **objv; + + hPtr = Tcl_FindHashEntry(&iiPtr->child.aliasTable, aliasName); + if (hPtr == NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "alias \"%s\" not found", aliasName)); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ALIAS", aliasName, (char *)NULL); + return TCL_ERROR; + } + aliasPtr = (Alias *)Tcl_GetHashValue(hPtr); + objc = aliasPtr->objc; + objv = &aliasPtr->objPtr; + + if (targetInterpPtr != NULL) { + *targetInterpPtr = aliasPtr->targetInterp; + } + if (targetCmdPtr != NULL) { + *targetCmdPtr = TclGetString(objv[0]); + } + if (argcPtr != NULL) { + *argcPtr = objc - 1; + } + if (argvPtr != NULL) { + *argvPtr = (const char **) + ckalloc(sizeof(const char *) * (objc - 1)); + for (i = 1; i < objc; i++) { + (*argvPtr)[i - 1] = TclGetString(objv[i]); + } + } + return TCL_OK; +} +#endif /* TCL_NO_DEPRECATED */ + +/* + *---------------------------------------------------------------------- + * * Tcl_GetAliasObj -- * * Object version: Gets information about an alias. @@ -1474,7 +1529,7 @@ AliasCreate( int isNew; Tcl_Size i; - aliasPtr = (Alias *)Tcl_Alloc(sizeof(Alias) + objc * sizeof(Tcl_Obj *)); + aliasPtr = (Alias *)ckalloc(sizeof(Alias) + objc * sizeof(Tcl_Obj *)); aliasPtr->token = namePtr; Tcl_IncrRefCount(aliasPtr->token); aliasPtr->targetInterp = parentInterp; @@ -1525,7 +1580,7 @@ AliasCreate( cmdPtr->deleteData = NULL; Tcl_DeleteCommandFromToken(childInterp, aliasPtr->childCmd); - Tcl_Free(aliasPtr); + ckfree(aliasPtr); /* * The result was already set by TclPreventAliasLoop. @@ -1582,7 +1637,7 @@ AliasCreate( * interp alias {} foo {} zop # Now recreate "foo"... */ - targetPtr = (Target *)Tcl_Alloc(sizeof(Target)); + targetPtr = (Target *)ckalloc(sizeof(Target)); targetPtr->childCmd = aliasPtr->childCmd; targetPtr->childInterp = childInterp; @@ -2024,8 +2079,8 @@ AliasObjCmdDeleteProc( targetPtr->nextPtr->prevPtr = targetPtr->prevPtr; } - Tcl_Free(targetPtr); - Tcl_Free(aliasPtr); + ckfree(targetPtr); + ckfree(aliasPtr); } /* @@ -2225,7 +2280,7 @@ Tcl_GetInterpPath( InterpInfo *iiPtr; if (targetInterp == interp) { - Tcl_SetObjResult(interp, Tcl_NewObj()); + Tcl_ResetResult(interp); return TCL_OK; } if (targetInterp == NULL) { @@ -2425,7 +2480,9 @@ ChildCreate( ((Interp *) parentInterp)->maxNestingDepth; if (safe) { - MakeSafe(childInterp); + if (TclMakeSafe(childInterp) == TCL_ERROR) { + goto error; + } } else { if (Tcl_Init(childInterp) == TCL_ERROR) { goto error; @@ -2510,6 +2567,7 @@ NRChildCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { Tcl_Interp *childInterp = (Tcl_Interp *)clientData; + int index; static const char *const options[] = { "alias", "aliases", "bgerror", "debug", "eval", "expose", "hide", "hidden", @@ -2521,7 +2579,7 @@ NRChildCmd( OPT_EVAL, OPT_EXPOSE, OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE, OPT_INVOKEHIDDEN, OPT_LIMIT, OPT_MARKTRUSTED, OPT_RECLIMIT - } index; + }; if (childInterp == NULL) { Tcl_Panic("TclChildObjCmd: interpreter has been deleted"); @@ -2536,7 +2594,7 @@ NRChildCmd( return TCL_ERROR; } - switch (index) { + switch ((enum childCmdOptionsEnum) index) { case OPT_ALIAS: if (objc > 2) { if (objc == 3) { @@ -2614,7 +2672,7 @@ NRChildCmd( }; enum hiddenOption { OPT_GLOBAL, OPT_NAMESPACE, OPT_LAST - } idx; + }; namespaceName = NULL; for (i = 2; i < objc; i++) { @@ -2622,12 +2680,12 @@ NRChildCmd( break; } if (Tcl_GetIndexFromObj(interp, objv[i], hiddenOptions, "option", - 0, &idx) != TCL_OK) { + 0, &index) != TCL_OK) { return TCL_ERROR; } - if (idx == OPT_GLOBAL) { + if (index == OPT_GLOBAL) { namespaceName = "::"; - } else if (idx == OPT_NAMESPACE) { + } else if (index == OPT_NAMESPACE) { if (++i == objc) { /* There must be more arguments. */ break; } else { @@ -2652,7 +2710,8 @@ NRChildCmd( }; enum LimitTypes { LIMIT_TYPE_COMMANDS, LIMIT_TYPE_TIME - } limitType; + }; + int limitType; if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "limitType ?-option value ...?"); @@ -2662,7 +2721,7 @@ NRChildCmd( &limitType) != TCL_OK) { return TCL_ERROR; } - switch (limitType) { + switch ((enum LimitTypes) limitType) { case LIMIT_TYPE_COMMANDS: return ChildCommandLimitCmd(interp, childInterp, 3, objc,objv); case LIMIT_TYPE_TIME: @@ -2938,7 +2997,7 @@ ChildRecursionLimit( Tcl_Obj *const objv[]) /* Argument strings. */ { Interp *iPtr; - Tcl_WideInt limit; + int limit; if (objc) { if (Tcl_IsSafe(interp)) { @@ -2948,7 +3007,7 @@ ChildRecursionLimit( (char *)NULL); return TCL_ERROR; } - if (TclGetWideIntFromObj(interp, objv[0], &limit) == TCL_ERROR) { + if (TclGetIntFromObj(interp, objv[0], &limit) == TCL_ERROR) { return TCL_ERROR; } if (limit <= 0) { @@ -3206,7 +3265,7 @@ Tcl_IsSafe( /* *---------------------------------------------------------------------- * - * MakeSafe -- + * TclMakeSafe -- * * Makes its argument interpreter contain only functionality that is * defined to be part of Safe Tcl. Unsafe commands are hidden, the env @@ -3222,8 +3281,8 @@ Tcl_IsSafe( *---------------------------------------------------------------------- */ -void -MakeSafe( +int +TclMakeSafe( Tcl_Interp *interp) /* Interpreter to be made safe. */ { Tcl_Channel chan; /* Channel to remove from safe interpreter. */ @@ -3297,6 +3356,8 @@ MakeSafe( if (chan != NULL) { Tcl_UnregisterChannel(interp, chan); } + + return TCL_OK; } /* @@ -3522,7 +3583,7 @@ RunLimitHandlers( if (handlerPtr->deleteProc != NULL) { handlerPtr->deleteProc(handlerPtr->clientData); } - Tcl_Free(handlerPtr); + ckfree(handlerPtr); } } } @@ -3543,6 +3604,14 @@ RunLimitHandlers( *---------------------------------------------------------------------- */ +/* Bug 52dbc4b3f8: wrap Tcl_Free since it is not a Tcl_LimitHandlerDeleteProc. */ +static void +WrapFree( + void *ptr) +{ + ckfree(ptr); +} + void Tcl_LimitAddHandler( Tcl_Interp *interp, @@ -3558,15 +3627,15 @@ Tcl_LimitAddHandler( * Convert everything into a real deletion callback. */ - if (deleteProc == TCL_DYNAMIC) { - deleteProc = TclpFree; + if (deleteProc == (Tcl_LimitHandlerDeleteProc *)TCL_DYNAMIC) { + deleteProc = WrapFree; } /* * Allocate a handler record. */ - handlerPtr = (LimitHandler *)Tcl_Alloc(sizeof(LimitHandler)); + handlerPtr = (LimitHandler *)ckalloc(sizeof(LimitHandler)); handlerPtr->flags = 0; handlerPtr->handlerProc = handlerProc; handlerPtr->clientData = clientData; @@ -3685,7 +3754,7 @@ Tcl_LimitRemoveHandler( if (handlerPtr->deleteProc != NULL) { handlerPtr->deleteProc(handlerPtr->clientData); } - Tcl_Free(handlerPtr); + ckfree(handlerPtr); } return; } @@ -3745,7 +3814,7 @@ TclLimitRemoveAllHandlers( if (handlerPtr->deleteProc != NULL) { handlerPtr->deleteProc(handlerPtr->clientData); } - Tcl_Free(handlerPtr); + ckfree(handlerPtr); } } @@ -3778,7 +3847,7 @@ TclLimitRemoveAllHandlers( if (handlerPtr->deleteProc != NULL) { handlerPtr->deleteProc(handlerPtr->clientData); } - Tcl_Free(handlerPtr); + ckfree(handlerPtr); } } @@ -4173,7 +4242,7 @@ DeleteScriptLimitCallback( if (limitCBPtr->entryPtr != NULL) { Tcl_DeleteHashEntry(limitCBPtr->entryPtr); } - Tcl_Free(limitCBPtr); + ckfree(limitCBPtr); } /* @@ -4273,7 +4342,7 @@ SetScriptLimitCallback( limitCBPtr); } - limitCBPtr = (ScriptLimitCallback *)Tcl_Alloc(sizeof(ScriptLimitCallback)); + limitCBPtr = (ScriptLimitCallback *)ckalloc(sizeof(ScriptLimitCallback)); limitCBPtr->interp = interp; limitCBPtr->scriptObj = scriptObj; limitCBPtr->entryPtr = hashPtr; @@ -4433,8 +4502,9 @@ ChildCommandLimitCmd( }; enum Options { OPT_CMD, OPT_GRAN, OPT_VAL - } index; + }; Interp *iPtr = (Interp *) interp; + int index; ScriptLimitCallbackKey key; ScriptLimitCallback *limitCBPtr; Tcl_HashEntry *hPtr; @@ -4497,7 +4567,7 @@ ChildCommandLimitCmd( 0, &index) != TCL_OK) { return TCL_ERROR; } - switch (index) { + switch ((enum Options) index) { case OPT_CMD: key.interp = childInterp; key.type = TCL_LIMIT_COMMANDS; @@ -4534,7 +4604,7 @@ ChildCommandLimitCmd( &index) != TCL_OK) { return TCL_ERROR; } - switch (index) { + switch ((enum Options) index) { case OPT_CMD: scriptObj = objv[i+1]; (void) TclGetStringFromObj(scriptObj, &scriptLen); @@ -4620,8 +4690,9 @@ ChildTimeLimitCmd( }; enum Options { OPT_CMD, OPT_GRAN, OPT_MILLI, OPT_SEC - } index; + }; Interp *iPtr = (Interp *) interp; + int index; ScriptLimitCallbackKey key; ScriptLimitCallback *limitCBPtr; Tcl_HashEntry *hPtr; @@ -4690,7 +4761,7 @@ ChildTimeLimitCmd( 0, &index) != TCL_OK) { return TCL_ERROR; } - switch (index) { + switch ((enum Options) index) { case OPT_CMD: key.interp = childInterp; key.type = TCL_LIMIT_TIME; @@ -4742,7 +4813,7 @@ ChildTimeLimitCmd( &index) != TCL_OK) { return TCL_ERROR; } - switch (index) { + switch ((enum Options) index) { case OPT_CMD: scriptObj = objv[i+1]; (void) TclGetStringFromObj(objv[i+1], &scriptLen); @@ -4769,14 +4840,14 @@ ChildTimeLimitCmd( if (TclGetWideIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) { return TCL_ERROR; } - if (tmp < 0) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "milliseconds must be non-negative", -1)); + if (tmp < 0 || tmp > LONG_MAX) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "milliseconds must be between 0 and %ld", LONG_MAX)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADVALUE", (char *)NULL); return TCL_ERROR; } - limitMoment.usec = tmp*1000; + limitMoment.usec = ((long)tmp)*1000; break; case OPT_SEC: secObj = objv[i+1]; @@ -4787,14 +4858,14 @@ ChildTimeLimitCmd( if (TclGetWideIntFromObj(interp, objv[i+1], &tmp) != TCL_OK) { return TCL_ERROR; } - if (tmp < 0) { - Tcl_SetObjResult(interp, Tcl_NewStringObj( - "seconds must be non-negative", -1)); + if (tmp < 0 || tmp > LONG_MAX) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "seconds must be between 0 and %ld", LONG_MAX)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADVALUE", (char *)NULL); return TCL_ERROR; } - limitMoment.sec = (long long)tmp; + limitMoment.sec = (long)tmp; break; } } diff --git a/generic/tclLink.c b/generic/tclLink.c index 3bd855b..8bc738f 100644 --- a/generic/tclLink.c +++ b/generic/tclLink.c @@ -25,7 +25,7 @@ * variable. */ -typedef struct { +typedef struct Link { Tcl_Interp *interp; /* Interpreter containing Tcl variable. */ Namespace *nsPtr; /* Namespace containing Tcl variable */ Tcl_Obj *varName; /* Name of variable (must be global). This is @@ -33,10 +33,10 @@ typedef struct { * actual variable may be aliased at that time * via upvar. */ void *addr; /* Location of C variable. */ - Tcl_Size bytes; /* Size of C variable array. This is 0 when + int bytes; /* Size of C variable array. This is 0 when * single variables, and >0 used for array * variables. */ - Tcl_Size numElems; /* Number of elements in C variable array. + int numElems; /* Number of elements in C variable array. * Zero for single variables. */ int type; /* Type of link (TCL_LINK_INT, etc.). */ union { @@ -114,8 +114,7 @@ static Tcl_ObjType invalidRealType = { NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ NULL, /* updateStringProc */ - NULL, /* setFromAnyProc */ - TCL_OBJTYPE_V0 + NULL /* setFromAnyProc */ }; /* @@ -172,13 +171,21 @@ Tcl_LinkVar( return TCL_ERROR; } - linkPtr = (Link *)Tcl_Alloc(sizeof(Link)); + linkPtr = (Link *)ckalloc(sizeof(Link)); linkPtr->interp = interp; linkPtr->nsPtr = NULL; linkPtr->varName = Tcl_NewStringObj(varName, -1); 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 { @@ -238,7 +245,7 @@ Tcl_LinkArray( * interpreter result. */ int type, /* Type of C variable: TCL_LINK_INT, etc. Also * may have TCL_LINK_READ_ONLY OR'ed in. */ - Tcl_Size size) /* Size of C variable array, >1 if array */ + int size) /* Size of C variable array, >1 if array */ { Tcl_Obj *objPtr; Link *linkPtr; @@ -252,8 +259,16 @@ Tcl_LinkArray( return TCL_ERROR; } - linkPtr = (Link *)Tcl_Alloc(sizeof(Link)); + linkPtr = (Link *)ckalloc(sizeof(Link)); 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 linkPtr->numElems = size; if (type & TCL_LINK_READ_ONLY) { linkPtr->flags = LINK_READ_ONLY; @@ -290,6 +305,14 @@ Tcl_LinkArray( 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; @@ -304,7 +327,7 @@ Tcl_LinkArray( */ if (addr == NULL) { - linkPtr->lastValue.aryPtr = Tcl_Alloc(linkPtr->bytes); + linkPtr->lastValue.aryPtr = ckalloc(linkPtr->bytes); linkPtr->flags |= LINK_ALLOC_LAST; addr = (char *) &linkPtr->lastValue.cPtr; } @@ -325,7 +348,7 @@ Tcl_LinkArray( */ if (addr == NULL) { - linkPtr->addr = Tcl_Alloc(linkPtr->bytes); + linkPtr->addr = ckalloc(linkPtr->bytes); linkPtr->flags |= LINK_ALLOC_ADDR; } else { linkPtr->addr = addr; @@ -336,7 +359,7 @@ Tcl_LinkArray( */ if (size > 1) { - linkPtr->lastValue.aryPtr = Tcl_Alloc(linkPtr->bytes); + linkPtr->lastValue.aryPtr = ckalloc(linkPtr->bytes); linkPtr->flags |= LINK_ALLOC_LAST; } @@ -487,7 +510,7 @@ GetWide( Tcl_Obj *objPtr, Tcl_WideInt *widePtr) { - if (TclGetWideIntFromObj(NULL, objPtr, widePtr) != TCL_OK) { + if (Tcl_GetWideIntFromObj(NULL, objPtr, widePtr) != TCL_OK) { int intValue; if (GetInvalidIntFromObj(objPtr, &intValue) != TCL_OK) { @@ -568,7 +591,7 @@ SetInvalidRealFromAny( { const char *str; const char *endPtr; - Tcl_Size length; + int length; str = TclGetStringFromObj(objPtr, &length); if ((length == 1) && (str[0] == '.')) { @@ -614,7 +637,7 @@ GetInvalidIntFromObj( Tcl_Obj *objPtr, int *intPtr) { - Tcl_Size length; + int length; const char *str = TclGetStringFromObj(objPtr, &length); if ((length == 0) || ((length == 2) && (str[0] == '0') @@ -691,7 +714,7 @@ LinkTraceProc( { Link *linkPtr = (Link *)clientData; int changed; - Tcl_Size valueLength = 0; + int valueLength; const char *value; char **pp; Tcl_Obj *valueObj; @@ -699,8 +722,9 @@ LinkTraceProc( Tcl_WideInt valueWide; Tcl_WideUInt valueUWide; double valueDouble; - Tcl_Size objc, i; + int objc; Tcl_Obj **objv; + int i; /* * If the variable is being unset, then just re-create it (with a trace) @@ -775,6 +799,14 @@ LinkTraceProc( case TCL_LINK_UINT: changed = (LinkedVar(unsigned int) != linkPtr->lastValue.ui); break; +#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) + case TCL_LINK_LONG: + changed = (LinkedVar(long) != linkPtr->lastValue.l); + break; + case TCL_LINK_ULONG: + changed = (LinkedVar(unsigned long) != linkPtr->lastValue.ul); + break; +#endif case TCL_LINK_FLOAT: changed = !EqualDouble(LinkedVar(float), linkPtr->lastValue.f); break; @@ -825,9 +857,10 @@ LinkTraceProc( switch (linkPtr->type) { case TCL_LINK_STRING: value = TclGetStringFromObj(valueObj, &valueLength); + valueLength++; /* include end of string char */ pp = (char **) linkPtr->addr; - *pp = (char *)Tcl_Realloc(*pp, ++valueLength); + *pp = (char *)ckrealloc(*pp, valueLength); memcpy(*pp, value, valueLength); return NULL; @@ -847,10 +880,8 @@ LinkTraceProc( return NULL; case TCL_LINK_BINARY: - value = (char *) Tcl_GetBytesFromObj(NULL, valueObj, &valueLength); - if (value == NULL) { - return (char *) "invalid binary value"; - } else if (valueLength != linkPtr->bytes) { + value = (char *) Tcl_GetByteArrayFromObj(valueObj, &valueLength); + if (valueLength != linkPtr->bytes) { return (char *) "wrong size of binary value"; } if (linkPtr->flags & LINK_ALLOC_LAST) { @@ -885,7 +916,7 @@ LinkTraceProc( switch (linkPtr->type) { case TCL_LINK_INT: if (linkPtr->flags & LINK_ALLOC_LAST) { - for (i = 0; i < objc; i++) { + for (i=0; i < objc; i++) { int *varPtr = &linkPtr->lastValue.iPtr[i]; if (GetInt(objv[i], varPtr)) { @@ -1089,6 +1120,55 @@ LinkTraceProc( (unsigned int) valueWide; } break; + +#if !defined(TCL_WIDE_INT_IS_LONG) && !defined(_WIN32) && !defined(__CYGWIN__) + case TCL_LINK_LONG: + 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; + } + break; + + case TCL_LINK_ULONG: + if (linkPtr->flags & LINK_ALLOC_LAST) { + for (i=0; i < objc; i++) { + if (GetUWide(objv[i], &valueUWide) + || (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) + || (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; + } + break; +#endif + case TCL_LINK_WIDE_UINT: if (linkPtr->flags & LINK_ALLOC_LAST) { for (i=0; i < objc; i++) { @@ -1168,18 +1248,18 @@ ObjValue( { char *p; Tcl_Obj *resultObj, **objv; - Tcl_Size i; + int i; switch (linkPtr->type) { case TCL_LINK_INT: if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objv = (Tcl_Obj **)Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { TclNewIntObj(objv[i], linkPtr->lastValue.iPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - Tcl_Free(objv); + ckfree(objv); return resultObj; } linkPtr->lastValue.i = LinkedVar(int); @@ -1187,12 +1267,12 @@ ObjValue( case TCL_LINK_WIDE_INT: if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objv = (Tcl_Obj **)Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { TclNewIntObj(objv[i], linkPtr->lastValue.wPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - Tcl_Free(objv); + ckfree(objv); return resultObj; } linkPtr->lastValue.w = LinkedVar(Tcl_WideInt); @@ -1200,12 +1280,12 @@ ObjValue( case TCL_LINK_DOUBLE: if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objv = (Tcl_Obj **)Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { TclNewDoubleObj(objv[i], linkPtr->lastValue.dPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - Tcl_Free(objv); + ckfree(objv); return resultObj; } linkPtr->lastValue.d = LinkedVar(double); @@ -1213,12 +1293,12 @@ ObjValue( case TCL_LINK_BOOLEAN: if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objv = (Tcl_Obj **)Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + objv = (Tcl_Obj **)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); - Tcl_Free(objv); + ckfree(objv); return resultObj; } linkPtr->lastValue.i = LinkedVar(int); @@ -1226,12 +1306,12 @@ ObjValue( case TCL_LINK_CHAR: if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objv = (Tcl_Obj **)Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { TclNewIntObj(objv[i], linkPtr->lastValue.cPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - Tcl_Free(objv); + ckfree(objv); return resultObj; } linkPtr->lastValue.c = LinkedVar(char); @@ -1239,12 +1319,12 @@ ObjValue( case TCL_LINK_UCHAR: if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objv = (Tcl_Obj **)Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { TclNewIntObj(objv[i], linkPtr->lastValue.ucPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - Tcl_Free(objv); + ckfree(objv); return resultObj; } linkPtr->lastValue.uc = LinkedVar(unsigned char); @@ -1252,12 +1332,12 @@ ObjValue( case TCL_LINK_SHORT: if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objv = (Tcl_Obj **)Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { TclNewIntObj(objv[i], linkPtr->lastValue.sPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - Tcl_Free(objv); + ckfree(objv); return resultObj; } linkPtr->lastValue.s = LinkedVar(short); @@ -1265,12 +1345,12 @@ ObjValue( case TCL_LINK_USHORT: if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objv = (Tcl_Obj **)Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { TclNewIntObj(objv[i], linkPtr->lastValue.usPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - Tcl_Free(objv); + ckfree(objv); return resultObj; } linkPtr->lastValue.us = LinkedVar(unsigned short); @@ -1278,25 +1358,53 @@ ObjValue( case TCL_LINK_UINT: if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objv = (Tcl_Obj **)Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { TclNewIntObj(objv[i], linkPtr->lastValue.uiPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - Tcl_Free(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 = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { + TclNewIntObj(objv[i], 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 = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + for (i=0; i < linkPtr->numElems; i++) { + TclNewIntObj(objv[i], 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 = (Tcl_Obj **)Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { TclNewDoubleObj(objv[i], linkPtr->lastValue.fPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - Tcl_Free(objv); + ckfree(objv); return resultObj; } linkPtr->lastValue.f = LinkedVar(float); @@ -1304,12 +1412,12 @@ ObjValue( case TCL_LINK_WIDE_UINT: { if (linkPtr->flags & LINK_ALLOC_LAST) { memcpy(linkPtr->lastValue.aryPtr, linkPtr->addr, linkPtr->bytes); - objv = (Tcl_Obj **)Tcl_Alloc(linkPtr->numElems * sizeof(Tcl_Obj *)); + objv = (Tcl_Obj **)ckalloc(linkPtr->numElems * sizeof(Tcl_Obj *)); for (i=0; i < linkPtr->numElems; i++) { TclNewUIntObj(objv[i], linkPtr->lastValue.uwPtr[i]); } resultObj = Tcl_NewListObj(linkPtr->numElems, objv); - Tcl_Free(objv); + ckfree(objv); return resultObj; } linkPtr->lastValue.uw = LinkedVar(Tcl_WideUInt); @@ -1380,12 +1488,12 @@ LinkFree( TclNsDecrRefCount(linkPtr->nsPtr); } if (linkPtr->flags & LINK_ALLOC_ADDR) { - Tcl_Free(linkPtr->addr); + ckfree(linkPtr->addr); } if (linkPtr->flags & LINK_ALLOC_LAST) { - Tcl_Free(linkPtr->lastValue.aryPtr); + ckfree(linkPtr->lastValue.aryPtr); } - Tcl_Free(linkPtr); + ckfree((char *) linkPtr); } /* diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 2d925e7..1060333 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -68,7 +68,8 @@ /* Checks for when caller should have already converted to internal list type */ #define LIST_ASSERT_TYPE(listObj_) \ - LIST_ASSERT(TclHasInternalRep((listObj_), &tclListType)) + LIST_ASSERT(TclHasInternalRep(listObj_, &tclListType)); + /* * If ENABLE_LIST_INVARIANTS is enabled (-DENABLE_LIST_INVARIANTS from the @@ -141,7 +142,6 @@ static void DupListInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static void FreeListInternalRep(Tcl_Obj *listPtr); static int SetListFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void UpdateStringOfList(Tcl_Obj *listPtr); -static Tcl_Size ListLength(Tcl_Obj *listPtr); /* * The structure below defines the list Tcl object type by means of functions @@ -155,17 +155,15 @@ const Tcl_ObjType tclListType = { FreeListInternalRep, /* freeIntRepProc */ DupListInternalRep, /* dupIntRepProc */ UpdateStringOfList, /* updateStringProc */ - SetListFromAny, /* setFromAnyProc */ - TCL_OBJTYPE_V1(ListLength) + SetListFromAny /* setFromAnyProc */ }; /* Macros to manipulate the List internal rep */ -#define ListRepIncrRefs(repPtr_) \ - do { \ - (repPtr_)->storePtr->refCount++; \ - if ((repPtr_)->spanPtr) { \ - (repPtr_)->spanPtr->refCount++; \ - } \ +#define ListRepIncrRefs(repPtr_) \ + do { \ + (repPtr_)->storePtr->refCount++; \ + if ((repPtr_)->spanPtr) \ + (repPtr_)->spanPtr->refCount++; \ } while (0) /* Returns number of free unused slots at the back of the ListRep's ListStore */ @@ -242,7 +240,7 @@ ListSpanNew( Tcl_Size firstSlot, /* Starting slot index of the span */ Tcl_Size numSlots) /* Number of slots covered by the span */ { - ListSpan *spanPtr = (ListSpan *) Tcl_Alloc(sizeof(*spanPtr)); + ListSpan *spanPtr = (ListSpan *) ckalloc(sizeof(*spanPtr)); spanPtr->refCount = 0; spanPtr->spanStart = firstSlot; spanPtr->spanLength = numSlots; @@ -269,7 +267,7 @@ static inline void ListSpanDecrRefs(ListSpan *spanPtr) { if (spanPtr->refCount <= 1) { - Tcl_Free(spanPtr); + ckfree(spanPtr); } else { spanPtr->refCount -= 1; } @@ -302,12 +300,12 @@ ListSpanMerited( Tcl_Size allocatedStorageLength) /* Length of the currently allocation */ { /* - * Possible optimizations for future consideration - * - heuristic LIST_SPAN_THRESHOLD - * - currently, information about the sharing (ref count) of existing - * storage is not passed. Perhaps it should be. For example if the - * existing storage has a "large" ref count, then it might make sense - * to do even a small span. + TODO + - heuristics thresholds need to be determined + - currently, information about the sharing (ref count) of existing + storage is not passed. Perhaps it should be. For example if the + existing storage has a "large" ref count, then it might make sense + to do even a small span. */ if (length < LIST_SPAN_THRESHOLD) { @@ -326,6 +324,30 @@ ListSpanMerited( /* *------------------------------------------------------------------------ * + * ListStoreUpSize -- + * + * For reasons of efficiency, extra space is allocated for a ListStore + * compared to what was requested. This function calculates how many + * slots should actually be allocated for a given request size. + * + * Results: + * Number of slots to allocate. + * + * Side effects: + * None. + * + *------------------------------------------------------------------------ + */ +static inline Tcl_Size +ListStoreUpSize(Tcl_Size numSlotsRequested) { + /* TODO -how much extra? May be double only for smaller requests? */ + return numSlotsRequested < (LIST_MAX / 2) ? 2 * numSlotsRequested + : LIST_MAX; +} + +/* + *------------------------------------------------------------------------ + * * ListRepFreeUnreferenced -- * * Inline wrapper for ListRepUnsharedFreeUnreferenced that does quick checks @@ -467,7 +489,9 @@ MemoryAllocationError( size_t size) /* Size of attempted allocation that failed */ { if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( + Tcl_SetObjResult( + interp, + Tcl_ObjPrintf( "list construction failed: unable to alloc %" TCL_Z_MODIFIER "u bytes", size)); @@ -744,15 +768,16 @@ ListStoreNew( return NULL; } - storePtr = NULL; if (flags & LISTREP_SPACE_FLAGS) { - /* Caller requests extra space front, back or both */ - storePtr = (ListStore *)TclAttemptAllocElemsEx( - objc, sizeof(Tcl_Obj *), offsetof(ListStore, slots), &capacity); + capacity = ListStoreUpSize(objc); } else { - /* Exact allocation */ capacity = objc; - storePtr = (ListStore *)Tcl_AttemptAlloc(LIST_SIZE(capacity)); + } + + storePtr = (ListStore *)attemptckalloc(LIST_SIZE(capacity)); + if (storePtr == NULL && capacity != objc) { + capacity = objc; /* Try allocating exact size */ + storePtr = (ListStore *)attemptckalloc(LIST_SIZE(capacity)); } if (storePtr == NULL) { if (flags & LISTREP_PANIC_ON_FAIL) { @@ -816,23 +841,25 @@ ListStoreNew( * *------------------------------------------------------------------------ */ -static ListStore * -ListStoreReallocate( - ListStore *storePtr, - Tcl_Size needed) +ListStore * +ListStoreReallocate (ListStore *storePtr, Tcl_Size needed) { Tcl_Size capacity; - - if (needed > LIST_MAX) { - return NULL; + ListStore *newStorePtr; + + capacity = ListStoreUpSize(needed); + newStorePtr = + (ListStore *)attemptckrealloc(storePtr, LIST_SIZE(capacity)); + if (newStorePtr == NULL) { + capacity = needed; + newStorePtr = (ListStore *)attemptckrealloc(storePtr, + LIST_SIZE(capacity)); + if (newStorePtr == NULL) + return NULL; } - storePtr = (ListStore *) TclAttemptReallocElemsEx(storePtr, - needed, sizeof(Tcl_Obj *), offsetof(ListStore, slots), &capacity); /* Only the capacity has changed, fix it in the header */ - if (storePtr) { - storePtr->numAllocated = capacity; - } - return storePtr; + newStorePtr->numAllocated = capacity; + return newStorePtr; } /* @@ -871,7 +898,8 @@ ListRepInit( Tcl_Size objc, Tcl_Obj *const objv[], int flags, - ListRep *repPtr) + ListRep *repPtr + ) { ListStore *storePtr; @@ -961,10 +989,7 @@ ListRepInitAttempt( *------------------------------------------------------------------------ */ static void -ListRepClone( - ListRep *fromRepPtr, - ListRep *toRepPtr, - int flags) +ListRepClone(ListRep *fromRepPtr, ListRep *toRepPtr, int flags) { Tcl_Obj **fromObjs; Tcl_Size numFrom; @@ -993,9 +1018,7 @@ ListRepClone( * *------------------------------------------------------------------------ */ -static void -ListRepUnsharedFreeUnreferenced( - const ListRep *repPtr) +static void ListRepUnsharedFreeUnreferenced(const ListRep *repPtr) { Tcl_Size count; ListStore *storePtr; @@ -1191,7 +1214,8 @@ TclNewListObj2( Tcl_Size objc1, /* Count of objects referenced by objv1. */ Tcl_Obj *const objv1[], /* First array of pointers to Tcl objects. */ Tcl_Size objc2, /* Count of objects referenced by objv2. */ - Tcl_Obj *const objv2[]) /* Second array of pointers to Tcl objects. */ + Tcl_Obj *const objv2[] /* Second array of pointers to Tcl objects. */ +) { Tcl_Obj *listObj; ListStore *storePtr; @@ -1250,7 +1274,7 @@ TclListObjGetRep( Tcl_Interp *interp, /* Used to report errors if not NULL. */ Tcl_Obj *listObj, /* List object for which an element array is * to be returned. */ - ListRep *repPtr) /* Location to store descriptor */ + ListRep *repPtr) /* Location to store descriptor */ { if (!TclHasInternalRep(listObj, &tclListType)) { int result; @@ -1347,9 +1371,6 @@ TclListObjCopy( Tcl_Obj *copyObj; if (!TclHasInternalRep(listObj, &tclListType)) { - if (TclObjTypeHasProc(listObj, lengthProc)) { - return Tcl_DuplicateObj(listObj); - } if (SetListFromAny(interp, listObj) != TCL_OK) { return NULL; } @@ -1390,13 +1411,13 @@ TclListObjCopy( */ static void ListRepRange( - ListRep *srcRepPtr, /* Contains source of the range */ - Tcl_Size rangeStart, /* Index of first element to include */ - Tcl_Size rangeEnd, /* Index of last element to include */ - int preserveSrcRep, /* If true, srcRepPtr contents must not be - * modified (generally because a shared Tcl_Obj - * references it) */ - ListRep *rangeRepPtr) /* Output. Must NOT be == srcRepPtr */ + ListRep *srcRepPtr, /* Contains source of the range */ + Tcl_Size rangeStart, /* Index of first element to include */ + Tcl_Size rangeEnd, /* Index of last element to include */ + int preserveSrcRep, /* If true, srcRepPtr contents must not be + modified (generally because a shared Tcl_Obj + references it) */ + ListRep *rangeRepPtr) /* Output. Must NOT be == srcRepPtr */ { Tcl_Obj **srcElems; Tcl_Size numSrcElems = ListRepLength(srcRepPtr); @@ -1448,12 +1469,13 @@ ListRepRange( /* T:listrep-1.10.1,2.8.1 */ *rangeRepPtr = *srcRepPtr; /* Not ref counts not incremented */ } else if (rangeStart == 0 && (!preserveSrcRep) - && (!ListRepIsShared(srcRepPtr) && srcRepPtr->spanPtr == NULL)) { + && (!ListRepIsShared(srcRepPtr) && srcRepPtr->spanPtr == NULL)) { /* Option 1 - Special case unshared, exclude end elements, no span */ LIST_ASSERT(srcRepPtr->storePtr->firstUsed == 0); /* If no span */ ListRepElements(srcRepPtr, numSrcElems, srcElems); numAfterRangeEnd = numSrcElems - (rangeEnd + 1); /* Assert: Because numSrcElems > rangeEnd earlier */ + LIST_ASSERT(numAfterRangeEnd >= 0); if (numAfterRangeEnd != 0) { /* T:listrep-1.{8,9} */ ObjArrayDecrRefs(srcElems, rangeEnd + 1, numAfterRangeEnd); @@ -1463,12 +1485,13 @@ ListRepRange( srcRepPtr->storePtr->flags = 0; rangeRepPtr->storePtr = srcRepPtr->storePtr; /* Note no incr ref */ rangeRepPtr->spanPtr = NULL; - } else if (ListSpanMerited(rangeLen, srcRepPtr->storePtr->numUsed, - srcRepPtr->storePtr->numAllocated)) { + } else if (ListSpanMerited(rangeLen, + srcRepPtr->storePtr->numUsed, + srcRepPtr->storePtr->numAllocated)) { /* Option 2 - because span would be most efficient */ Tcl_Size spanStart = ListRepStart(srcRepPtr) + rangeStart; if (!preserveSrcRep && srcRepPtr->spanPtr - && srcRepPtr->spanPtr->refCount <= 1) { + && srcRepPtr->spanPtr->refCount <= 1) { /* If span is not shared reuse it */ /* T:listrep-2.7.3,3.{16,18} */ srcRepPtr->spanPtr->spanStart = spanStart; @@ -1495,8 +1518,10 @@ ListRepRange( /* T:listrep-2.{4,6} */ ListRepElements(srcRepPtr, numSrcElems, srcElems); /* TODO - allocate extra space? */ - ListRepInit(rangeLen, &srcElems[rangeStart], LISTREP_PANIC_ON_FAIL, - rangeRepPtr); + ListRepInit(rangeLen, + &srcElems[rangeStart], + LISTREP_PANIC_ON_FAIL, + rangeRepPtr); } else { /* * Option 4 - modify in place. Note that because of the invariant @@ -1523,6 +1548,7 @@ ListRepRange( /* Ditto for trailing */ numAfterRangeEnd = numSrcElems - (rangeEnd + 1); /* Assert: Because numSrcElems > rangeEnd earlier */ + LIST_ASSERT(numAfterRangeEnd >= 0); if (numAfterRangeEnd != 0) { /* T:listrep-3.17 */ ObjArrayDecrRefs(srcElems, rangeEnd + 1, numAfterRangeEnd); @@ -1583,9 +1609,8 @@ TclListObjRange( ListRep resultRep; int isShared; - if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) { + if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) return NULL; - } isShared = Tcl_IsShared(listObj); @@ -1602,29 +1627,6 @@ TclListObjRange( /* *---------------------------------------------------------------------- * - * TclListObjGetElement -- - * - * Returns a single element from the array of the elements in a list - * object, without doing doing any bounds checking. Caller must ensure - * that ObjPtr of of type 'tclListType' and that index is valid for the - * list. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclListObjGetElement( - Tcl_Obj *objPtr, /* List object for which an element array is - * to be returned. */ - Tcl_Size index -) -{ - return ListObjStorePtr(objPtr)->slots[ListObjStart(objPtr) + index]; -} - -/* - *---------------------------------------------------------------------- - * * Tcl_ListObjGetElements -- * * This function returns an (objc,objv) array of the elements in a list @@ -1665,12 +1667,12 @@ Tcl_ListObjGetElements( { ListRep listRep; - if (TclObjTypeHasProc(objPtr, getElementsProc)) { - return TclObjTypeGetElements(interp, objPtr, objcPtr, objvPtr); - } - if (TclListObjGetRep(interp, objPtr, &listRep) != TCL_OK) { - return TCL_ERROR; + if (TclHasInternalRep(objPtr,&tclArithSeriesType)) { + return TclArithSeriesGetElements(interp, objPtr, objcPtr, objvPtr); } + + if (TclListObjGetRep(interp, objPtr, &listRep) != TCL_OK) + return TCL_ERROR; ListRepElements(&listRep, *objcPtr, *objvPtr); return TCL_OK; } @@ -1744,11 +1746,10 @@ Tcl_ListObjAppendList( * *------------------------------------------------------------------------ */ - int - TclListObjAppendElements ( + int TclListObjAppendElements ( Tcl_Interp *interp, /* Used to report errors if not NULL. */ Tcl_Obj *toObj, /* List object to append */ - Tcl_Size elemCount, /* Number of elements in elemObjs[] */ + Tcl_Size elemCount, /* Number of elements in elemObjs[] */ Tcl_Obj * const elemObjv[]) /* Objects to append to toObj's list. */ { ListRep listRep; @@ -1760,15 +1761,11 @@ Tcl_ListObjAppendList( Tcl_Panic("%s called with shared object", "TclListObjAppendElements"); } - if (TclListObjGetRep(interp, toObj, &listRep) != TCL_OK) { - /* Cannot be converted to a list */ - return TCL_ERROR; - } + if (TclListObjGetRep(interp, toObj, &listRep) != TCL_OK) + return TCL_ERROR; /* Cannot be converted to a list */ - if (elemCount <= 0) { - /* Nothing to do. Note AFTER check for list above */ - return TCL_OK; - } + if (elemCount <= 0) + return TCL_OK; /* Nothing to do. Note AFTER check for list above */ ListRepElements(&listRep, toLen, toObjv); if (elemCount > LIST_MAX || toLen > (LIST_MAX - elemCount)) { @@ -1793,8 +1790,8 @@ Tcl_ListObjAppendList( if (finalLen > listRep.storePtr->numAllocated) { /* T:listrep-1.{2,11},3.6 */ - ListStore *newStorePtr = ListStoreReallocate( - listRep.storePtr, finalLen); + ListStore *newStorePtr; + newStorePtr = ListStoreReallocate(listRep.storePtr, finalLen); if (newStorePtr == NULL) { return MemoryAllocationError(interp, LIST_SIZE(finalLen)); } @@ -1824,10 +1821,10 @@ Tcl_ListObjAppendList( ListRepUnsharedShiftDown(&listRep, shiftCount); } } /* else T:listrep-3.{4,6} */ - ObjArrayCopy( - &listRep.storePtr->slots[ - ListRepStart(&listRep) + ListRepLength(&listRep)], - elemCount, elemObjv); + ObjArrayCopy(&listRep.storePtr->slots[ListRepStart(&listRep) + + ListRepLength(&listRep)], + elemCount, + elemObjv); listRep.storePtr->numUsed = finalLen; if (listRep.spanPtr) { /* T:listrep-3.{4,5,6} */ @@ -1849,9 +1846,12 @@ Tcl_ListObjAppendList( * not leave space in the front either, assuming all appends and no * prepends. */ - if (ListRepInit(finalLen, NULL, - listRep.spanPtr ? LISTREP_SPACE_FAVOR_BACK : LISTREP_SPACE_ONLY_BACK, - &listRep) != TCL_OK) { + if (ListRepInit(finalLen, + NULL, + listRep.spanPtr ? LISTREP_SPACE_FAVOR_BACK + : LISTREP_SPACE_ONLY_BACK, + &listRep) + != TCL_OK) { return MemoryAllocationError(interp, finalLen); } LIST_ASSERT(listRep.storePtr->numAllocated >= finalLen); @@ -1945,10 +1945,10 @@ Tcl_ListObjAppendElement( */ int Tcl_ListObjIndex( - Tcl_Interp *interp, /* Used to report errors if not NULL. */ - Tcl_Obj *listObj, /* List object to index into. */ - Tcl_Size index, /* Index of element to return. */ - Tcl_Obj **objPtrPtr) /* The resulting Tcl_Obj* is stored here. */ + Tcl_Interp *interp, /* Used to report errors if not NULL. */ + Tcl_Obj *listObj, /* List object to index into. */ + Tcl_Size index, /* Index of element to return. */ + Tcl_Obj **objPtrPtr) /* The resulting Tcl_Obj* is stored here. */ { Tcl_Obj **elemObjs; Tcl_Size numElems; @@ -1959,12 +1959,8 @@ Tcl_ListObjIndex( return TCL_OK; } - int hasAbstractList = TclObjTypeHasProc(listObj,indexProc) != 0; - if (hasAbstractList) { - return TclObjTypeIndex(interp, listObj, index, objPtrPtr); - } - - if (TclListObjGetElements(interp, listObj, &numElems, &elemObjs) != TCL_OK) { + if (TclListObjGetElements(interp, listObj, &numElems, &elemObjs) + != TCL_OK) { return TCL_ERROR; } if ((index < 0) || (index >= numElems)) { @@ -2013,8 +2009,8 @@ Tcl_ListObjLength( return TCL_OK; } - if (TclObjTypeHasProc(listObj, lengthProc)) { - *lenPtr = TclObjTypeLength(listObj); + if (TclHasInternalRep(listObj,&tclArithSeriesType)) { + *lenPtr = TclArithSeriesObjLength(listObj); return TCL_OK; } @@ -2025,16 +2021,6 @@ Tcl_ListObjLength( *lenPtr = ListRepLength(&listRep); return TCL_OK; } - -static Tcl_Size -ListLength( - Tcl_Obj *listPtr) -{ - ListRep listRep; - ListObjGetRep(listPtr, &listRep); - - return ListRepLength(&listRep); -} /* *---------------------------------------------------------------------- @@ -2097,15 +2083,8 @@ Tcl_ListObjReplace( Tcl_Panic("%s called with shared object", "Tcl_ListObjReplace"); } - if (TclObjTypeHasProc(listObj, replaceProc)) { - return TclObjTypeReplace(interp, listObj, first, - numToDelete, numToInsert, insertObjs); - } - - if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) { - /* Cannot be converted to a list */ - return TCL_ERROR; - } + if (TclListObjGetRep(interp, listObj, &listRep) != TCL_OK) + return TCL_ERROR; /* Cannot be converted to a list */ /* Make limits sane */ origListLen = ListRepLength(&listRep); @@ -2207,14 +2186,16 @@ Tcl_ListObjReplace( * NOTE THIS IS TRUE EVEN IF THE ListStore IS SHARED as it will not * affect the other Tcl_Obj's referencing this ListStore. */ - if (first == 0 && /* (i) */ - ListRepStart(&listRep) == listRep.storePtr->firstUsed && /* (ii) */ - numToInsert <= listRep.storePtr->firstUsed) { /* (iii) */ + if (first == 0 && /* (i) */ + ListRepStart(&listRep) == listRep.storePtr->firstUsed && /* (ii) */ + numToInsert <= listRep.storePtr->firstUsed /* (iii) */ + ) { Tcl_Size newLen; LIST_ASSERT(numToInsert); /* Else would have returned above */ listRep.storePtr->firstUsed -= numToInsert; ObjArrayCopy(&listRep.storePtr->slots[listRep.storePtr->firstUsed], - numToInsert, insertObjs); + numToInsert, + insertObjs); listRep.storePtr->numUsed += numToInsert; newLen = listRep.spanPtr->spanLength + numToInsert; if (listRep.spanPtr && listRep.spanPtr->refCount <= 1) { @@ -2259,7 +2240,7 @@ Tcl_ListObjReplace( ListStoreReallocate(listRep.storePtr, origListLen + lenChange); if (newStorePtr == NULL) { return MemoryAllocationError(interp, - LIST_SIZE(origListLen + lenChange)); + LIST_SIZE(origListLen + lenChange)); } listRep.storePtr = newStorePtr; numFreeSlots = @@ -2279,15 +2260,17 @@ Tcl_ListObjReplace( * (c) The new unshared size is much "smaller" (TODO) than the allocated space * TODO - for unshared case ONLY, consider a "move" based implementation */ - if (ListRepIsShared(&listRep) || /* 3a */ - numFreeSlots < lenChange || /* 3b */ - (origListLen + lenChange) < - (listRep.storePtr->numAllocated / 4)) { /* 3c */ + if (ListRepIsShared(&listRep) || /* 3a */ + numFreeSlots < lenChange || /* 3b */ + (origListLen + lenChange) < (listRep.storePtr->numAllocated / 4) /* 3c */ + ) { ListRep newRep; Tcl_Obj **toObjs; listObjs = &listRep.storePtr->slots[ListRepStart(&listRep)]; - ListRepInit(origListLen + lenChange, NULL, - LISTREP_PANIC_ON_FAIL | favor, &newRep); + ListRepInit(origListLen + lenChange, + NULL, + LISTREP_PANIC_ON_FAIL | favor, + &newRep); toObjs = ListRepSlotPtr(&newRep, 0); if (leadSegmentLen > 0) { /* T:listrep-2.{2,3,13:18},4.{6,9,13:18} */ @@ -2295,13 +2278,15 @@ Tcl_ListObjReplace( } if (numToInsert > 0) { /* T:listrep-2.{1,2,3,10:18},4.{1,2,4,6,10:18} */ - ObjArrayCopy(&toObjs[leadSegmentLen], numToInsert, - insertObjs); + ObjArrayCopy(&toObjs[leadSegmentLen], + numToInsert, + insertObjs); } if (tailSegmentLen > 0) { /* T:listrep-2.{1,2,3,10:15},4.{1,2,4,6,9:12,16:18} */ ObjArrayCopy(&toObjs[leadSegmentLen + numToInsert], - tailSegmentLen, &listObjs[leadSegmentLen+numToDelete]); + tailSegmentLen, + &listObjs[leadSegmentLen+numToDelete]); } newRep.storePtr->numUsed = origListLen + lenChange; if (newRep.spanPtr) { @@ -2397,7 +2382,7 @@ Tcl_ListObjReplace( LIST_ASSERT((leadSpace + tailSpace) >= lenChange); if (leadSpace >= lenChange - && (leadSegmentLen < tailSegmentLen || tailSpace < lenChange)) { + && (leadSegmentLen < tailSegmentLen || tailSpace < lenChange)) { /* Move only lead to the front to make more room */ /* T:listrep-3.25,36,38, */ leadShift = -lenChange; @@ -2526,7 +2511,7 @@ Tcl_ListObjReplace( } else { /* T:listrep-1.{1,3,6.1,13,14,16,18,21} */ listRep.spanPtr = ListSpanNew(listRep.storePtr->firstUsed, - listRep.storePtr->numUsed); + listRep.storePtr->numUsed); } } @@ -2565,7 +2550,7 @@ TclLindexList( Tcl_Obj *listObj, /* List being unpacked. */ Tcl_Obj *argObj) /* Index or index list. */ { - Tcl_Size index; /* Index into the list. */ + Tcl_Size index; /* Index into the list. */ Tcl_Obj *indexListCopy; Tcl_Obj **indexObjs; Tcl_Size numIndexObjs; @@ -2577,8 +2562,8 @@ TclLindexList( * see TIP#22 and TIP#33 for the details. */ if (!TclHasInternalRep(argObj, &tclListType) - && TclGetIntForIndexM(NULL, argObj, TCL_SIZE_MAX - 1, - &index) == TCL_OK) { + && TclGetIntForIndexM(NULL, argObj, TCL_SIZE_MAX - 1, &index) + == TCL_OK) { /* * argPtr designates a single index. */ @@ -2648,25 +2633,22 @@ TclLindexFlat( int status; Tcl_Size i; - /* Handle AbstractList as special case */ - if (TclObjTypeHasProc(listObj,indexProc)) { - Tcl_Size listLen = TclObjTypeLength(listObj); + /* Handle ArithSeries as special case */ + if (TclHasInternalRep(listObj,&tclArithSeriesType)) { + Tcl_Size listLen = TclArithSeriesObjLength(listObj); Tcl_Size index; Tcl_Obj *elemObj = listObj; /* for lindex without indices return list */ for (i=0 ; i<indexCount && listObj ; i++) { if (TclGetIntForIndexM(interp, indexArray[i], /*endValue*/ listLen-1, - &index) == TCL_OK) { - // TODO: ??? + &index) == TCL_OK) { } if (i==0) { - if (TclObjTypeIndex(interp, listObj, index, &elemObj) != TCL_OK) { - return NULL; - } + elemObj = TclArithSeriesObjIndex(NULL, listObj, index); } else if (index > 0) { - // TODO: support nested lists - Tcl_Obj *e2Obj = TclLindexFlat(interp, elemObj, 1, &indexArray[i]); + /* ArithSeries cannot be a list of lists */ Tcl_DecrRefCount(elemObj); - elemObj = e2Obj; + TclNewObj(elemObj); + break; } } Tcl_IncrRefCount(elemObj); @@ -2694,8 +2676,9 @@ TclLindexFlat( */ while (++i < indexCount) { - if (TclGetIntForIndexM(interp, indexArray[i], - TCL_SIZE_MAX - 1, &index) != TCL_OK) { + if (TclGetIntForIndexM( + interp, indexArray[i], TCL_SIZE_MAX - 1, &index) + != TCL_OK) { Tcl_DecrRefCount(listObj); return NULL; } @@ -2784,18 +2767,10 @@ TclLsetList( if (!TclHasInternalRep(indexArgObj, &tclListType) && TclGetIntForIndexM(NULL, indexArgObj, TCL_SIZE_MAX - 1, &index) == TCL_OK) { - if (TclObjTypeHasProc(listObj, setElementProc)) { - indices = &indexArgObj; - retValueObj = TclObjTypeSetElement( - interp, listObj, 1, indices, valueObj); - if (retValueObj) { - Tcl_IncrRefCount(retValueObj); - } - } else { - /* indexArgPtr designates a single index. */ - /* T:listrep-1.{2.1,12.1,15.1,19.1},2.{2.3,9.3,10.1,13.1,16.1}, 3.{4,5,6}.3 */ - retValueObj = TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj); - } + + /* indexArgPtr designates a single index. */ + /* T:listrep-1.{2.1,12.1,15.1,19.1},2.{2.3,9.3,10.1,13.1,16.1}, 3.{4,5,6}.3 */ + retValueObj = TclLsetFlat(interp, listObj, 1, &indexArgObj, valueObj); } else { @@ -2828,7 +2803,6 @@ TclLsetList( } } } - assert (retValueObj==NULL || retValueObj->typePtr || retValueObj->bytes); return retValueObj; } @@ -2872,7 +2846,7 @@ Tcl_Obj * TclLsetFlat( Tcl_Interp *interp, /* Tcl interpreter. */ Tcl_Obj *listObj, /* Pointer to the list being modified. */ - Tcl_Size indexCount, /* Number of index args. */ + Tcl_Size indexCount, /* Number of index args. */ Tcl_Obj *const indexArray[], /* Index args. */ Tcl_Obj *valueObj) /* Value arg to 'lset' or NULL to 'lpop'. */ @@ -2919,10 +2893,10 @@ TclLsetFlat( result = TCL_OK; /* Allocate if static array for pending invalidations is too small */ - if (indexCount > (int) (sizeof(pendingInvalidates) / - sizeof(pendingInvalidates[0]))) { + if (indexCount + > (int) (sizeof(pendingInvalidates) / sizeof(pendingInvalidates[0]))) { pendingInvalidatesPtr = - (Tcl_Obj **) Tcl_Alloc(indexCount * sizeof(*pendingInvalidatesPtr)); + (Tcl_Obj **) ckalloc(indexCount * sizeof(*pendingInvalidatesPtr)); } /* @@ -2938,8 +2912,8 @@ TclLsetFlat( * Check for the possible error conditions... */ - if (TclListObjGetElements(interp, subListObj, - &elemCount, &elemPtrs) != TCL_OK) { + if (TclListObjGetElements(interp, subListObj, &elemCount, &elemPtrs) + != TCL_OK) { /* ...the sublist we're indexing into isn't a list at all. */ result = TCL_ERROR; break; @@ -2950,8 +2924,8 @@ TclLsetFlat( * post-increments, avoid '*indexArray++' here. */ - if (TclGetIntForIndexM(interp, *indexArray, elemCount - 1, - &index) != TCL_OK) { + if (TclGetIntForIndexM(interp, *indexArray, elemCount - 1, &index) + != TCL_OK) { /* ...the index we're trying to use isn't an index at all. */ result = TCL_ERROR; indexArray++; /* Why bother with this increment? TBD */ @@ -2968,14 +2942,18 @@ TclLsetFlat( index = 0; } if (index < 0 || index > elemCount - || (valueObj == NULL && index >= elemCount)) { + || (valueObj == NULL && index >= elemCount)) { /* ...the index points outside the sublist. */ if (interp != NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "index \"%s\" out of range", - Tcl_GetString(indexArray[-1]))); + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("index \"%s\" out of range", + Tcl_GetString(indexArray[-1]))); Tcl_SetErrorCode(interp, - "TCL", "VALUE", "INDEX" "OUTOFRANGE", (void *)NULL); + "TCL", + "VALUE", + "INDEX" + "OUTOFRANGE", + (void *)NULL); } result = TCL_ERROR; break; @@ -3070,9 +3048,8 @@ TclLsetFlat( } } - if (pendingInvalidatesPtr != pendingInvalidates) { - Tcl_Free(pendingInvalidatesPtr); - } + if (pendingInvalidatesPtr != pendingInvalidates) + ckfree(pendingInvalidatesPtr); if (result != TCL_OK) { /* @@ -3231,7 +3208,7 @@ FreeListInternalRep( ObjArrayDecrRefs( listRep.storePtr->slots, listRep.storePtr->firstUsed, listRep.storePtr->numUsed); - Tcl_Free(listRep.storePtr); + ckfree(listRep.storePtr); } if (listRep.spanPtr) { ListSpanDecrRefs(listRep.spanPtr); @@ -3315,8 +3292,9 @@ SetListFromAny( Tcl_DictObjSize(NULL, objPtr, &size); /* TODO - leave space in front and/or back? */ - if (ListRepInitAttempt(interp, size > 0 ? 2 * size : 1, NULL, - &listRep) != TCL_OK) { + if (ListRepInitAttempt( + interp, size > 0 ? 2 * size : 1, NULL, &listRep) + != TCL_OK) { return TCL_ERROR; } @@ -3337,32 +3315,35 @@ SetListFromAny( Tcl_IncrRefCount(valuePtr); Tcl_DictObjNext(&search, &keyPtr, &valuePtr, &done); } - } else if (TclObjTypeHasProc(objPtr,indexProc)) { - Tcl_Size elemCount, i; - - elemCount = TclObjTypeLength(objPtr); + } else if (TclHasInternalRep(objPtr,&tclArithSeriesType)) { + /* + * Convertion from Arithmetic Series is a special case + * because it can be done an order of magnitude faster + * and may occur frequently. + */ + Tcl_Size j, size = TclArithSeriesObjLength(objPtr); - if (ListRepInitAttempt(interp, elemCount, NULL, &listRep) != TCL_OK) { + /* TODO - leave space in front and/or back? */ + if (ListRepInitAttempt( + interp, size > 0 ? size : 1, NULL, &listRep) + != TCL_OK) { return TCL_ERROR; } LIST_ASSERT(listRep.spanPtr == NULL); /* Guard against future changes */ LIST_ASSERT(listRep.storePtr->firstUsed == 0); + LIST_ASSERT((listRep.storePtr->flags & LISTSTORE_CANONICAL) == 0); + listRep.storePtr->numUsed = size; elemPtrs = listRep.storePtr->slots; - - /* Each iteration, store a list element */ - for (i = 0; i < elemCount; i++) { - if (TclObjTypeIndex(interp, objPtr, i, elemPtrs) != TCL_OK) { + for (j = 0; j < size; j++) { + elemPtrs[j] = TclArithSeriesObjIndex(interp, objPtr, j); + if (elemPtrs[j] == NULL) { return TCL_ERROR; } - Tcl_IncrRefCount(*elemPtrs++);/* Since list now holds ref to it. */ + Tcl_IncrRefCount(elemPtrs[j]); } - LIST_ASSERT((Tcl_Size)(elemPtrs - listRep.storePtr->slots) == elemCount); - - listRep.storePtr->numUsed = elemCount; - } else { Tcl_Size estCount, length; const char *limit, *nextElem = TclGetStringFromObj(objPtr, &length); @@ -3376,7 +3357,8 @@ SetListFromAny( estCount += (estCount == 0); /* Smallest list struct holds 1 * element. */ /* TODO - allocate additional space? */ - if (ListRepInitAttempt(interp, estCount, NULL, &listRep) != TCL_OK) { + if (ListRepInitAttempt(interp, estCount, NULL, &listRep) + != TCL_OK) { return TCL_ERROR; } @@ -3395,11 +3377,11 @@ SetListFromAny( if (TCL_OK != TclFindElement(interp, nextElem, limit - nextElem, &elemStart, &nextElem, &elemSize, &literal)) { - fail: +fail: while (--elemPtrs >= listRep.storePtr->slots) { Tcl_DecrRefCount(*elemPtrs); } - Tcl_Free(listRep.storePtr); + ckfree(listRep.storePtr); return TCL_ERROR; } if (elemStart == limit) { @@ -3473,7 +3455,7 @@ UpdateStringOfList( # define LOCAL_SIZE 64 char localFlags[LOCAL_SIZE], *flagPtr = NULL; Tcl_Size numElems, i, length; - size_t bytesNeeded = 0; + TCL_HASH_TYPE bytesNeeded = 0; const char *elem, *start; char *dst; Tcl_Obj **elemPtrs; @@ -3520,16 +3502,19 @@ UpdateStringOfList( flagPtr = localFlags; } else { /* We know numElems <= LIST_MAX, so this is safe. */ - flagPtr = (char *)Tcl_Alloc(numElems); + flagPtr = (char *)ckalloc(numElems); } for (i = 0; i < numElems; i++) { flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0); elem = TclGetStringFromObj(elemPtrs[i], &length); bytesNeeded += TclScanElement(elem, length, flagPtr+i); - if (bytesNeeded > SIZE_MAX - numElems) { - Tcl_Panic("max size for a Tcl value (%" TCL_Z_MODIFIER "u bytes) exceeded", SIZE_MAX); + if (bytesNeeded > INT_MAX) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } } + if (bytesNeeded + numElems > INT_MAX + 1U) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } bytesNeeded += numElems - 1; /* @@ -3549,7 +3534,7 @@ UpdateStringOfList( (void) Tcl_InitStringRep(listObj, NULL, dst - 1 - start); if (flagPtr != localFlags) { - Tcl_Free(flagPtr); + ckfree(flagPtr); } } @@ -3571,10 +3556,7 @@ UpdateStringOfList( *------------------------------------------------------------------------ */ Tcl_Obj * -TclListTestObj( - size_t length, - size_t leadingSpace, - size_t endSpace) +TclListTestObj(size_t length, size_t leadingSpace, size_t endSpace) { ListRep listRep; size_t capacity; diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c index f4d92cd..3966901 100644 --- a/generic/tclLiteral.c +++ b/generic/tclLiteral.c @@ -28,10 +28,10 @@ * Function prototypes for static functions in this file: */ -static size_t AddLocalLiteralEntry(CompileEnv *envPtr, +static int AddLocalLiteralEntry(CompileEnv *envPtr, Tcl_Obj *objPtr, int localHash); static void ExpandLocalLiteralArray(CompileEnv *envPtr); -static size_t HashString(const char *string, size_t length); +static unsigned HashString(const char *string, int length); #ifdef TCL_COMPILE_DEBUG static LiteralEntry * LookupLiteralEntry(Tcl_Interp *interp, Tcl_Obj *objPtr); @@ -133,7 +133,7 @@ TclDeleteLiteralTable( objPtr = entryPtr->objPtr; TclDecrRefCount(objPtr); nextPtr = entryPtr->nextPtr; - Tcl_Free(entryPtr); + ckfree(entryPtr); entryPtr = nextPtr; } } @@ -143,7 +143,7 @@ TclDeleteLiteralTable( */ if (tablePtr->buckets != tablePtr->staticBuckets) { - Tcl_Free(tablePtr->buckets); + ckfree(tablePtr->buckets); } } @@ -178,9 +178,9 @@ TclCreateLiteral( Interp *iPtr, const char *bytes, /* The start of the string. Note that this is * not a NUL-terminated string. */ - Tcl_Size length, /* Number of bytes in the string. */ - size_t hash, /* The string's hash. If the value is - * TCL_INDEX_NONE, it will be computed here. */ + int length, /* Number of bytes in the string. */ + unsigned hash, /* The string's hash. If -1, it will be + * computed here. */ int *newPtr, Namespace *nsPtr, int flags, @@ -188,14 +188,14 @@ TclCreateLiteral( { LiteralTable *globalTablePtr = &iPtr->literalTable; LiteralEntry *globalPtr; - size_t globalHash; + unsigned int globalHash; Tcl_Obj *objPtr; /* * Is it in the interpreter's global literal table? */ - if (hash == (size_t) TCL_INDEX_NONE) { + if (hash == (unsigned) -1) { hash = HashString(bytes, length); } globalHash = (hash & globalTablePtr->mask); @@ -210,7 +210,7 @@ TclCreateLiteral( * https://stackoverflow.com/q/54337750/301832 */ - Tcl_Size objLength; + int objLength; const char *objBytes = TclGetStringFromObj(objPtr, &objLength); if ((objLength == length) && ((length == 0) @@ -227,7 +227,7 @@ TclCreateLiteral( *globalPtrPtr = globalPtr; } if (flags & LITERAL_ON_HEAP) { - Tcl_Free((void *)bytes); + ckfree(bytes); } if (globalPtr->refCount != TCL_INDEX_NONE) { globalPtr->refCount++; @@ -238,7 +238,7 @@ TclCreateLiteral( } if (!newPtr) { if ((flags & LITERAL_ON_HEAP)) { - Tcl_Free((void *)bytes); + ckfree(bytes); } return NULL; } @@ -274,11 +274,11 @@ TclCreateLiteral( #ifdef TCL_COMPILE_DEBUG if (LookupLiteralEntry((Tcl_Interp *) iPtr, objPtr) != NULL) { Tcl_Panic("%s: literal \"%.*s\" found globally but shouldn't be", - "TclRegisterLiteral", (length>60? 60 : (int)length), bytes); + "TclRegisterLiteral", (length>60? 60 : length), bytes); } #endif - globalPtr = (LiteralEntry *)Tcl_Alloc(sizeof(LiteralEntry)); + globalPtr = (LiteralEntry *)ckalloc(sizeof(LiteralEntry)); globalPtr->objPtr = objPtr; Tcl_IncrRefCount(objPtr); globalPtr->refCount = 1; @@ -314,7 +314,7 @@ TclCreateLiteral( } if (!found) { Tcl_Panic("%s: literal \"%.*s\" wasn't global", - "TclRegisterLiteral", (length>60? 60 : (int)length), bytes); + "TclRegisterLiteral", (length>60? 60 : length), bytes); } } #endif /*TCL_COMPILE_DEBUG*/ @@ -351,10 +351,10 @@ Tcl_Obj * TclFetchLiteral( CompileEnv *envPtr, /* Points to the CompileEnv from which to * fetch the registered literal value. */ - Tcl_Size index) /* Index of the desired literal, as returned + unsigned int index) /* Index of the desired literal, as returned * by prior call to TclRegisterLiteral() */ { - if (index >= envPtr->literalArrayNext) { + if (index >= (unsigned int) envPtr->literalArrayNext) { return NULL; } return envPtr->literalArrayPtr[index].objPtr; @@ -387,14 +387,14 @@ TclFetchLiteral( *---------------------------------------------------------------------- */ -int /* Do NOT change this type. Should not be wider than TclEmitPush operand*/ +int TclRegisterLiteral( void *ePtr, /* Points to the CompileEnv in whose object * array an object is found or created. */ const char *bytes, /* Points to string for which to find or * create an object in CompileEnv's object * array. */ - Tcl_Size length, /* Number of bytes in the string. If -1, the + int length, /* Number of bytes in the string. If < 0, the * string consists of all bytes up to the * first null character. */ int flags) /* If LITERAL_ON_HEAP then the caller already @@ -408,8 +408,9 @@ TclRegisterLiteral( LiteralTable *localTablePtr = &envPtr->localLitTable; LiteralEntry *globalPtr, *localPtr; Tcl_Obj *objPtr; - size_t hash, localHash, objIndex; - int isNew; + unsigned hash; + unsigned int localHash; + int objIndex, isNew; Namespace *nsPtr; if (length < 0) { @@ -430,16 +431,13 @@ TclRegisterLiteral( || ((objPtr->bytes[0] == bytes[0]) && (memcmp(objPtr->bytes, bytes, length) == 0)))) { if ((flags & LITERAL_ON_HEAP)) { - Tcl_Free((void *)bytes); + ckfree(bytes); } objIndex = (localPtr - envPtr->literalArrayPtr); #ifdef TCL_COMPILE_DEBUG TclVerifyLocalLiteralTable(envPtr); #endif /*TCL_COMPILE_DEBUG*/ - if (objIndex > INT_MAX) { - Tcl_Panic("Literal table index too large. Cannot be handled by TclEmitPush"); - } return objIndex; } } @@ -471,17 +469,13 @@ TclRegisterLiteral( objIndex = AddLocalLiteralEntry(envPtr, objPtr, localHash); #ifdef TCL_COMPILE_DEBUG - if (globalPtr != NULL && (globalPtr->refCount + 1 < 2)) { - Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %" TCL_Z_MODIFIER "u", - "TclRegisterLiteral", (length>60? 60 : (int)length), bytes, + 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); } TclVerifyLocalLiteralTable(envPtr); #endif /*TCL_COMPILE_DEBUG*/ - if (objIndex > INT_MAX) { - Tcl_Panic( - "Literal table index too large. Cannot be handled by TclEmitPush"); - } return objIndex; } @@ -515,7 +509,7 @@ LookupLiteralEntry( LiteralTable *globalTablePtr = &iPtr->literalTable; LiteralEntry *entryPtr; const char *bytes; - size_t globalHash, length; + int length, globalHash; bytes = TclGetStringFromObj(objPtr, &length); globalHash = (HashString(bytes, length) & globalTablePtr->mask); @@ -560,8 +554,8 @@ TclHideLiteral( { LiteralEntry **nextPtrPtr, *entryPtr, *lPtr; LiteralTable *localTablePtr = &envPtr->localLitTable; - size_t localHash; - Tcl_Size length; + unsigned int localHash; + int length; const char *bytes; Tcl_Obj *newObjPtr; @@ -625,17 +619,13 @@ TclAddLiteralObj( * NULL. */ { LiteralEntry *lPtr; - size_t objIndex; + int objIndex; if (envPtr->literalArrayNext >= envPtr->literalArrayEnd) { ExpandLocalLiteralArray(envPtr); } objIndex = envPtr->literalArrayNext; envPtr->literalArrayNext++; - if (objIndex > INT_MAX) { - Tcl_Panic( - "Literal table index too large. Cannot be handled by TclEmitPush"); - } lPtr = &envPtr->literalArrayPtr[objIndex]; lPtr->objPtr = objPtr; @@ -668,7 +658,7 @@ TclAddLiteralObj( *---------------------------------------------------------------------- */ -static size_t +static int AddLocalLiteralEntry( CompileEnv *envPtr,/* Points to CompileEnv in whose literal array * the object is to be inserted. */ @@ -677,7 +667,7 @@ AddLocalLiteralEntry( { LiteralTable *localTablePtr = &envPtr->localLitTable; LiteralEntry *localPtr; - size_t objIndex; + int objIndex; objIndex = TclAddLiteralObj(envPtr, objPtr, &localPtr); @@ -702,8 +692,8 @@ AddLocalLiteralEntry( TclVerifyLocalLiteralTable(envPtr); { char *bytes; - int found; - size_t length, i; + int length, found; + size_t i; found = 0; for (i=0 ; i<localTablePtr->numBuckets ; i++) { @@ -718,7 +708,7 @@ AddLocalLiteralEntry( if (!found) { bytes = TclGetStringFromObj(objPtr, &length); Tcl_Panic("%s: literal \"%.*s\" wasn't found locally", - "AddLocalLiteralEntry", (length>60? 60 : (int)length), bytes); + "AddLocalLiteralEntry", (length>60? 60 : length), bytes); } } #endif /*TCL_COMPILE_DEBUG*/ @@ -770,14 +760,14 @@ ExpandLocalLiteralArray( } if (envPtr->mallocedLiteralArray) { - newArrayPtr = (LiteralEntry *)Tcl_Realloc(currArrayPtr, newSize); + newArrayPtr = (LiteralEntry *)ckrealloc(currArrayPtr, newSize); } else { /* - * envPtr->literalArrayPtr isn't a Tcl_Alloc'd pointer, so we must - * code a Tcl_Realloc equivalent for ourselves. + * envPtr->literalArrayPtr isn't a ckalloc'd pointer, so we must + * code a ckrealloc equivalent for ourselves. */ - newArrayPtr = (LiteralEntry *)Tcl_Alloc(newSize); + newArrayPtr = (LiteralEntry *)ckalloc(newSize); memcpy(newArrayPtr, currArrayPtr, currBytes); envPtr->mallocedLiteralArray = 1; } @@ -838,8 +828,8 @@ TclReleaseLiteral( LiteralTable *globalTablePtr; LiteralEntry *entryPtr, *prevPtr; const char *bytes; - size_t index; - Tcl_Size length; + int length; + unsigned int index; if (iPtr == NULL) { goto done; @@ -847,7 +837,7 @@ TclReleaseLiteral( globalTablePtr = &iPtr->literalTable; bytes = TclGetStringFromObj(objPtr, &length); - index = HashString(bytes, length) & globalTablePtr->mask; + index = (HashString(bytes, length) & globalTablePtr->mask); /* * Check to see if the object is in the global literal table and remove @@ -870,7 +860,7 @@ TclReleaseLiteral( } else { prevPtr->nextPtr = entryPtr->nextPtr; } - Tcl_Free(entryPtr); + ckfree(entryPtr); globalTablePtr->numEntries--; TclDecrRefCount(objPtr); @@ -908,12 +898,12 @@ TclReleaseLiteral( *---------------------------------------------------------------------- */ -static size_t +static unsigned HashString( const char *string, /* String for which to compute hash value. */ - size_t length) /* Number of bytes in the string. */ + int length) /* Number of bytes in the string. */ { - size_t result = 0; + unsigned int result = 0; /* * I tried a zillion different hash functions and asked many other people @@ -982,8 +972,8 @@ RebuildLiteralTable( LiteralEntry *entryPtr; LiteralEntry **bucketPtr; const char *bytes; - size_t oldSize, count, index; - Tcl_Size length; + unsigned int oldSize, index; + int count, length; oldSize = tablePtr->numBuckets; oldBuckets = tablePtr->buckets; @@ -1004,7 +994,7 @@ RebuildLiteralTable( } tablePtr->numBuckets *= 4; - tablePtr->buckets = (LiteralEntry **)Tcl_Alloc( + tablePtr->buckets = (LiteralEntry **)ckalloc( tablePtr->numBuckets * sizeof(LiteralEntry*)); for (count=tablePtr->numBuckets, newChainPtr=tablePtr->buckets; count>0 ; count--, newChainPtr++) { @@ -1034,7 +1024,7 @@ RebuildLiteralTable( */ if (oldBuckets != tablePtr->staticBuckets) { - Tcl_Free(oldBuckets); + ckfree(oldBuckets); } } @@ -1071,7 +1061,7 @@ TclInvalidateCmdLiteral( { Interp *iPtr = (Interp *) interp; Tcl_Obj *literalObjPtr = TclCreateLiteral(iPtr, name, - strlen(name), TCL_INDEX_NONE, NULL, nsPtr, 0, NULL); + strlen(name), -1, NULL, nsPtr, 0, NULL); if (literalObjPtr != NULL) { if (TclHasInternalRep(literalObjPtr, &tclCmdNameType)) { @@ -1107,7 +1097,9 @@ TclLiteralStats( LiteralTable *tablePtr) /* Table for which to produce stats. */ { #define NUM_COUNTERS 10 - size_t count[NUM_COUNTERS], overflow, i, j; + size_t count[NUM_COUNTERS]; + int overflow; + size_t i, j; double average, tmp; LiteralEntry *entryPtr; char *result, *p; @@ -1141,8 +1133,8 @@ TclLiteralStats( * Print out the histogram and a few other pieces of information. */ - result = (char *)Tcl_Alloc(NUM_COUNTERS*60 + 300); - snprintf(result, 60, "%" TCL_Z_MODIFIER "u entries in table, %" TCL_Z_MODIFIER "u buckets\n", + result = (char *)ckalloc(NUM_COUNTERS*60 + 300); + snprintf(result, 60, "%d entries in table, %d buckets\n", tablePtr->numEntries, tablePtr->numBuckets); p = result + strlen(result); for (i=0 ; i<NUM_COUNTERS ; i++) { @@ -1150,7 +1142,7 @@ TclLiteralStats( i, count[i]); p += strlen(p); } - snprintf(p, 60, "number of buckets with %d or more entries: %" TCL_Z_MODIFIER "u\n", + snprintf(p, 60, "number of buckets with %d or more entries: %d\n", NUM_COUNTERS, overflow); p += strlen(p); snprintf(p, 60, "average search distance for entry: %.1f", average); @@ -1183,17 +1175,19 @@ TclVerifyLocalLiteralTable( LiteralTable *localTablePtr = &envPtr->localLitTable; LiteralEntry *localPtr; char *bytes; - size_t i, length, count = 0; + 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 != TCL_INDEX_NONE) { bytes = TclGetStringFromObj(localPtr->objPtr, &length); - Tcl_Panic("%s: local literal \"%.*s\" had bad refCount %" TCL_Z_MODIFIER "u", + Tcl_Panic("%s: local literal \"%.*s\" had bad refCount %u", "TclVerifyLocalLiteralTable", - (length>60? 60 : (int) length), bytes, localPtr->refCount); + (length>60? 60 : length), bytes, localPtr->refCount); } if (localPtr->objPtr->bytes == NULL) { Tcl_Panic("%s: literal has NULL string rep", @@ -1202,7 +1196,7 @@ TclVerifyLocalLiteralTable( } } if (count != localTablePtr->numEntries) { - Tcl_Panic("%s: local literal table had %" TCL_Z_MODIFIER "u entries, should be %" TCL_Z_MODIFIER "u", + Tcl_Panic("%s: local literal table had %" TCL_Z_MODIFIER "u entries, should be %u", "TclVerifyLocalLiteralTable", count, localTablePtr->numEntries); } @@ -1232,17 +1226,19 @@ TclVerifyGlobalLiteralTable( LiteralTable *globalTablePtr = &iPtr->literalTable; LiteralEntry *globalPtr; char *bytes; - size_t i, length, count = 0; + 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 < 2) { bytes = TclGetStringFromObj(globalPtr->objPtr, &length); - Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %" TCL_Z_MODIFIER "u", + Tcl_Panic("%s: global literal \"%.*s\" had bad refCount %d", "TclVerifyGlobalLiteralTable", - (length>60? 60 : (int)length), bytes, globalPtr->refCount); + (length>60? 60 : length), bytes, globalPtr->refCount); } if (globalPtr->objPtr->bytes == NULL) { Tcl_Panic("%s: literal has NULL string rep", @@ -1251,7 +1247,7 @@ TclVerifyGlobalLiteralTable( } } if (count != globalTablePtr->numEntries) { - Tcl_Panic("%s: global literal table had %" TCL_Z_MODIFIER "u entries, should be %" TCL_Z_MODIFIER "u", + 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 d7c13d1..b14a4a8 100644 --- a/generic/tclLoad.c +++ b/generic/tclLoad.c @@ -17,14 +17,18 @@ * The following structure describes a library that has been loaded either * dynamically (with the "load" command) or statically (as indicated by a call * to Tcl_StaticLibrary). All such libraries are linked together into a - * single list for the process. + * single list for the process. Library are never unloaded, until the + * application exits, when TclFinalizeLoad is called, and these structures are + * freed. */ typedef struct LoadedLibrary { char *fileName; /* Name of the file from which the library was * loaded. An empty string means the library * is loaded statically. Malloc-ed. */ - char *prefix; /* Prefix for the library. + char *prefix; /* Prefix for the library, + * properly capitalized (first letter UC, + * others LC), as in "Net". * Malloc-ed. */ Tcl_LoadHandle loadHandle; /* Token for the loaded file which should be * passed to (*unLoadProcPtr)() when the file @@ -90,19 +94,19 @@ typedef struct InterpLibrary { * Prototypes for functions that are private to this file: */ -static void LoadCleanupProc(void *clientData, +static void LoadCleanupProc(ClientData clientData, Tcl_Interp *interp); -static int IsStatic(LoadedLibrary *libraryPtr); +static int IsStatic (LoadedLibrary *libraryPtr); static int UnloadLibrary(Tcl_Interp *interp, Tcl_Interp *target, LoadedLibrary *library, int keepLibrary, const char *fullFileName, int interpExiting); static int -IsStatic( - LoadedLibrary *libraryPtr) -{ - return (libraryPtr->fileName[0] == '\0'); +IsStatic (LoadedLibrary *libraryPtr) { + int res; + res = (libraryPtr->fileName[0] == '\0'); + return res; } /* @@ -140,15 +144,15 @@ Tcl_LoadObjCmd( const char *p, *fullFileName, *prefix; Tcl_LoadHandle loadHandle; Tcl_UniChar ch = 0; - size_t len; - int flags = 0; + unsigned len; + int index, flags = 0; Tcl_Obj *const *savedobjv = objv; static const char *const options[] = { "-global", "-lazy", "--", NULL }; enum loadOptionsEnum { LOAD_GLOBAL, LOAD_LAZY, LOAD_LAST - } index; + }; while (objc > 2) { if (TclGetString(objv[1])[0] != '-') { @@ -159,9 +163,9 @@ Tcl_LoadObjCmd( return TCL_ERROR; } ++objv; --objc; - if (LOAD_GLOBAL == index) { + if (LOAD_GLOBAL == (enum loadOptionsEnum) index) { flags |= TCL_LOAD_GLOBAL; - } else if (LOAD_LAZY == index) { + } else if (LOAD_LAZY == (enum loadOptionsEnum) index) { flags |= TCL_LOAD_LAZY; } else { break; @@ -235,6 +239,8 @@ Tcl_LoadObjCmd( Tcl_DStringAppend(&pfx, prefix, -1); TclDStringClear(&tmp); Tcl_DStringAppend(&tmp, libraryPtr->prefix, -1); + Tcl_UtfToLower(Tcl_DStringValue(&pfx)); + Tcl_UtfToLower(Tcl_DStringValue(&tmp)); if (strcmp(Tcl_DStringValue(&tmp), Tcl_DStringValue(&pfx)) == 0) { namesMatch = 1; @@ -310,7 +316,7 @@ Tcl_LoadObjCmd( Tcl_DStringAppend(&pfx, prefix, -1); } else { Tcl_Obj *splitPtr, *pkgGuessPtr; - Tcl_Size pElements; + int pElements; const char *pkgGuess; /* @@ -320,7 +326,7 @@ Tcl_LoadObjCmd( /* * The platform-specific code couldn't figure out the prefix. * Make a guess by taking the last element of the file - * name, stripping off any leading "lib" and/or "tcl9", and + * name, stripping off any leading "lib" and/or "tcl", and * then using all of the alphabetic and underline characters * that follow that. */ @@ -343,13 +349,14 @@ Tcl_LoadObjCmd( || (pkgGuess[0] == 'T') #endif ) && (pkgGuess[1] == 'c') - && (pkgGuess[2] == 'l') && (pkgGuess[3] == '9')) { - pkgGuess += 4; + && (pkgGuess[2] == 'l')) { + pkgGuess += 3; } for (p = pkgGuess; *p != 0; p += offset) { offset = TclUtfToUniChar(p, &ch); - if (!Tcl_UniCharIsWordChar(UCHAR(ch)) - || Tcl_UniCharIsDigit(UCHAR(ch))) { + if ((ch > 0x100) + || !(isalpha(UCHAR(ch)) /* INTL: ISO only */ + || (UCHAR(ch) == '_'))) { break; } } @@ -365,17 +372,16 @@ Tcl_LoadObjCmd( } Tcl_DStringAppend(&pfx, pkgGuess, p - pkgGuess); Tcl_DecrRefCount(splitPtr); + } - /* - * Fix the capitalization in the prefix so that the first - * character is in caps (or title case) but the others are all - * lower-case. - */ - - Tcl_DStringSetLength(&pfx, - Tcl_UtfToTitle(Tcl_DStringValue(&pfx))); + /* + * Fix the capitalization in the prefix so that the first + * character is in caps (or title case) but the others are all + * lower-case. + */ - } + Tcl_DStringSetLength(&pfx, + Tcl_UtfToTitle(Tcl_DStringValue(&pfx))); /* * Compute the names of the two initialization functions, based on the @@ -411,12 +417,12 @@ Tcl_LoadObjCmd( * Create a new record to describe this library. */ - libraryPtr = (LoadedLibrary *)Tcl_Alloc(sizeof(LoadedLibrary)); + libraryPtr = (LoadedLibrary *)ckalloc(sizeof(LoadedLibrary)); len = strlen(fullFileName) + 1; - libraryPtr->fileName = (char *)Tcl_Alloc(len); + libraryPtr->fileName = (char *)ckalloc(len); memcpy(libraryPtr->fileName, fullFileName, len); len = Tcl_DStringLength(&pfx) + 1; - libraryPtr->prefix = (char *)Tcl_Alloc(len); + libraryPtr->prefix = (char *)ckalloc(len); memcpy(libraryPtr->prefix, Tcl_DStringValue(&pfx), len); libraryPtr->loadHandle = loadHandle; libraryPtr->initProc = initProc; @@ -480,17 +486,19 @@ Tcl_LoadObjCmd( */ if (code != TCL_OK) { +#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 Interp *iPtr = (Interp *) target; - if (iPtr->legacyResult && *(iPtr->legacyResult) && !iPtr->legacyFreeProc) { + 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->legacyResult, -1)); - iPtr->legacyResult = NULL; - iPtr->legacyFreeProc = (void (*) (void))-1; + 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; } @@ -516,7 +524,7 @@ Tcl_LoadObjCmd( */ ipFirstPtr = (InterpLibrary *)Tcl_GetAssocData(target, "tclLoad", NULL); - ipPtr = (InterpLibrary *)Tcl_Alloc(sizeof(InterpLibrary)); + ipPtr = (InterpLibrary *)ckalloc(sizeof(InterpLibrary)); ipPtr->libraryPtr = libraryPtr; ipPtr->nextPtr = ipFirstPtr; Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipPtr); @@ -559,7 +567,7 @@ Tcl_UnloadObjCmd( LoadedLibrary *libraryPtr; Tcl_DString pfx, tmp; InterpLibrary *ipFirstPtr, *ipPtr; - int i, code, complain = 1, keepLibrary = 0; + int i, index, code, complain = 1, keepLibrary = 0; const char *fullFileName = ""; const char *prefix; static const char *const options[] = { @@ -567,7 +575,7 @@ Tcl_UnloadObjCmd( }; enum unloadOptionsEnum { UNLOAD_NOCOMPLAIN, UNLOAD_KEEPLIB, UNLOAD_LAST - } index; + }; for (i = 1; i < objc; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, @@ -590,7 +598,7 @@ Tcl_UnloadObjCmd( break; } } - switch (index) { + switch ((enum unloadOptionsEnum)index) { case UNLOAD_NOCOMPLAIN: /* -nocomplain */ complain = 0; break; @@ -668,6 +676,8 @@ Tcl_UnloadObjCmd( Tcl_DStringAppend(&pfx, prefix, -1); TclDStringClear(&tmp); Tcl_DStringAppend(&tmp, libraryPtr->prefix, -1); + Tcl_UtfToLower(Tcl_DStringValue(&pfx)); + Tcl_UtfToLower(Tcl_DStringValue(&tmp)); if (strcmp(Tcl_DStringValue(&tmp), Tcl_DStringValue(&pfx)) == 0) { namesMatch = 1; @@ -882,7 +892,7 @@ UnloadLibrary( } } } - Tcl_Free(ipPtr); + ckfree(ipPtr); Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipFirstPtr); @@ -955,9 +965,9 @@ UnloadLibrary( } } - Tcl_Free(iterLibraryPtr->fileName); - Tcl_Free(iterLibraryPtr->prefix); - Tcl_Free(iterLibraryPtr); + ckfree(iterLibraryPtr->fileName); + ckfree(iterLibraryPtr->prefix); + ckfree(iterLibraryPtr); Tcl_MutexUnlock(&libraryMutex); } else { code = TCL_ERROR; @@ -1001,7 +1011,9 @@ Tcl_StaticLibrary( * already been loaded into the given * interpreter by calling the appropriate init * proc. */ - const char *prefix, /* Prefix. */ + const char *prefix, /* Prefix (must be properly + * capitalized: first letter upper case, + * others lower case). */ Tcl_LibraryInitProc *initProc, /* Function to call to incorporate this * library into a trusted interpreter. */ @@ -1036,10 +1048,10 @@ Tcl_StaticLibrary( */ if (libraryPtr == NULL) { - libraryPtr = (LoadedLibrary *)Tcl_Alloc(sizeof(LoadedLibrary)); - libraryPtr->fileName = (char *)Tcl_Alloc(1); + libraryPtr = (LoadedLibrary *)ckalloc(sizeof(LoadedLibrary)); + libraryPtr->fileName = (char *)ckalloc(1); libraryPtr->fileName[0] = 0; - libraryPtr->prefix = (char *)Tcl_Alloc(strlen(prefix) + 1); + libraryPtr->prefix = (char *)ckalloc(strlen(prefix) + 1); strcpy(libraryPtr->prefix, prefix); libraryPtr->loadHandle = NULL; libraryPtr->initProc = initProc; @@ -1071,7 +1083,7 @@ Tcl_StaticLibrary( * loaded. */ - ipPtr = (InterpLibrary *)Tcl_Alloc(sizeof(InterpLibrary)); + ipPtr = (InterpLibrary *)ckalloc(sizeof(InterpLibrary)); ipPtr->libraryPtr = libraryPtr; ipPtr->nextPtr = ipFirstPtr; Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc, ipPtr); @@ -1194,7 +1206,7 @@ TclGetLoadedLibraries( static void LoadCleanupProc( - TCL_UNUSED(void *), /* Pointer to first InterpLibrary structure + TCL_UNUSED(ClientData), /* Pointer to first InterpLibrary structure * for interp. */ Tcl_Interp *interp) { @@ -1257,9 +1269,9 @@ TclFinalizeLoad(void) } #endif - Tcl_Free(libraryPtr->fileName); - Tcl_Free(libraryPtr->prefix); - Tcl_Free(libraryPtr); + ckfree(libraryPtr->fileName); + ckfree(libraryPtr->prefix); + ckfree(libraryPtr); } } diff --git a/generic/tclMain.c b/generic/tclMain.c index a7cb7fb..e43958d 100644 --- a/generic/tclMain.c +++ b/generic/tclMain.c @@ -111,8 +111,8 @@ typedef struct { MODULE_SCOPE Tcl_MainLoopProc *TclGetMainLoop(void); static void Prompt(Tcl_Interp *interp, InteractiveState *isPtr); -static void StdinProc(void *clientData, int mask); -static void FreeMainInterp(void *clientData); +static void StdinProc(ClientData clientData, int mask); +static void FreeMainInterp(ClientData clientData); #if !defined(_WIN32) || defined(UNICODE) && !defined(TCL_ASCII_MAIN) static Tcl_ThreadDataKey dataKey; @@ -136,14 +136,14 @@ static Tcl_ThreadDataKey dataKey; void Tcl_SetStartupScript( Tcl_Obj *path, /* Filesystem path of startup script file */ - const char *encodingName) /* Encoding of the data in that file */ + const char *encoding) /* Encoding of the data in that file */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - Tcl_Obj *encodingObj = NULL; + Tcl_Obj *newEncoding = NULL; - if (encodingName != NULL) { - encodingObj = Tcl_NewStringObj(encodingName, -1); - Tcl_IncrRefCount(encodingObj); + if (encoding != NULL) { + newEncoding = Tcl_NewStringObj(encoding, -1); + Tcl_IncrRefCount(newEncoding); } if (path != NULL) { @@ -157,7 +157,7 @@ Tcl_SetStartupScript( if (tsdPtr->encoding != NULL) { Tcl_DecrRefCount(tsdPtr->encoding); } - tsdPtr->encoding = encodingObj; + tsdPtr->encoding = newEncoding; } /* @@ -239,7 +239,7 @@ Tcl_SourceRCFile( c = Tcl_OpenFileChannel(NULL, fullName, "r", 0); if (c != NULL) { - Tcl_CloseEx(NULL, c, 0); + Tcl_Close(NULL, c); if (Tcl_EvalFile(interp, fullName) != TCL_OK) { chan = Tcl_GetStdChannel(TCL_STDERR); if (chan) { @@ -276,7 +276,7 @@ Tcl_SourceRCFile( TCL_NORETURN void Tcl_MainEx( - Tcl_Size argc, /* Number of arguments. */ + int argc, /* Number of arguments. */ TCHAR **argv, /* Array of argument strings. */ Tcl_AppInitProc *appInitProc, /* Application-specific initialization @@ -284,7 +284,7 @@ Tcl_MainEx( * but before starting to execute commands. */ Tcl_Interp *interp) { - Tcl_Size i=0; /* argv[i] index */ + int i=0; /* argv[i] index */ Tcl_Obj *path, *resultPtr, *argvPtr, *appName; const char *encodingName = NULL; int code, exitCode = 0; @@ -453,7 +453,7 @@ Tcl_MainEx( while ((is.input != NULL) && !Tcl_InterpDeleted(interp)) { mainLoopProc = TclGetMainLoop(); if (mainLoopProc == NULL) { - Tcl_Size length; + int length; if (is.tty) { Prompt(interp, &is); @@ -739,11 +739,11 @@ TclFullFinalizationRequested(void) static void StdinProc( - void *clientData, /* The state of interactive cmd line */ + ClientData clientData, /* The state of interactive cmd line */ TCL_UNUSED(int) /*mask*/) { int code; - Tcl_Size length; + int length; InteractiveState *isPtr = (InteractiveState *)clientData; Tcl_Channel chan = isPtr->input; Tcl_Obj *commandPtr = isPtr->commandPtr; @@ -921,7 +921,7 @@ Prompt( static void FreeMainInterp( - void *clientData) + ClientData clientData) { Tcl_Interp *interp = (Tcl_Interp *)clientData; diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 2a30742..781e125 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -33,7 +33,7 @@ */ typedef struct { - size_t numNsCreated; /* Count of the number of namespaces created + 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 @@ -130,8 +130,7 @@ static const Tcl_ObjType nsNameType = { FreeNsNameInternalRep, /* freeIntRepProc */ DupNsNameInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ - SetNsNameFromAny, /* setFromAnyProc */ - TCL_OBJTYPE_V0 + SetNsNameFromAny /* setFromAnyProc */ }; #define NsNameSetInternalRep(objPtr, nnPtr) \ @@ -392,7 +391,7 @@ Tcl_PopCallFrame( if (framePtr->varTablePtr != NULL) { TclDeleteVars(iPtr, framePtr->varTablePtr); - Tcl_Free(framePtr->varTablePtr); + ckfree(framePtr->varTablePtr); framePtr->varTablePtr = NULL; } if (framePtr->numCompiledLocals > 0) { @@ -544,8 +543,10 @@ ErrorCodeRead( return NULL; } if (NULL == Tcl_ObjGetVar2(interp, iPtr->ecVar, NULL, TCL_GLOBAL_ONLY)) { + Tcl_Obj *objPtr; + TclNewObj(objPtr); Tcl_ObjSetVar2(interp, iPtr->ecVar, NULL, - Tcl_NewObj(), TCL_GLOBAL_ONLY); + objPtr, TCL_GLOBAL_ONLY); } return NULL; } @@ -618,8 +619,10 @@ ErrorInfoRead( return NULL; } if (NULL == Tcl_ObjGetVar2(interp, iPtr->eiVar, NULL, TCL_GLOBAL_ONLY)) { + Tcl_Obj *objPtr; + TclNewObj(objPtr); Tcl_ObjSetVar2(interp, iPtr->eiVar, NULL, - Tcl_NewObj(), TCL_GLOBAL_ONLY); + objPtr, TCL_GLOBAL_ONLY); } return NULL; } @@ -767,9 +770,9 @@ Tcl_CreateNamespace( */ doCreate: - nsPtr = (Namespace *)Tcl_Alloc(sizeof(Namespace)); + nsPtr = (Namespace *)ckalloc(sizeof(Namespace)); nameLen = strlen(simpleName) + 1; - nsPtr->name = (char *)Tcl_Alloc(nameLen); + nsPtr->name = (char *)ckalloc(nameLen); memcpy(nsPtr->name, simpleName, nameLen); nsPtr->fullName = NULL; /* Set below. */ nsPtr->clientData = clientData; @@ -857,7 +860,7 @@ Tcl_CreateNamespace( name = Tcl_DStringValue(namePtr); nameLen = Tcl_DStringLength(namePtr); - nsPtr->fullName = (char *)Tcl_Alloc(nameLen + 1); + nsPtr->fullName = (char *)ckalloc(nameLen + 1); memcpy(nsPtr->fullName, name, nameLen + 1); Tcl_DStringFree(&buffer1); @@ -1045,7 +1048,7 @@ Tcl_DeleteNamespace( #else if (nsPtr->childTablePtr != NULL) { Tcl_DeleteHashTable(nsPtr->childTablePtr); - Tcl_Free(nsPtr->childTablePtr); + ckfree(nsPtr->childTablePtr); } #endif Tcl_DeleteHashTable(&nsPtr->cmdTable); @@ -1271,9 +1274,9 @@ TclTeardownNamespace( if (nsPtr->exportArrayPtr != NULL) { for (i = 0; i < nsPtr->numExportPatterns; i++) { - Tcl_Free(nsPtr->exportArrayPtr[i]); + ckfree(nsPtr->exportArrayPtr[i]); } - Tcl_Free(nsPtr->exportArrayPtr); + ckfree(nsPtr->exportArrayPtr); nsPtr->exportArrayPtr = NULL; nsPtr->numExportPatterns = 0; nsPtr->maxExportPatterns = 0; @@ -1325,9 +1328,9 @@ NamespaceFree( * (for error messages), and the structure itself. */ - Tcl_Free(nsPtr->name); - Tcl_Free(nsPtr->fullName); - Tcl_Free(nsPtr); + ckfree(nsPtr->name); + ckfree(nsPtr->fullName); + ckfree(nsPtr); } /* @@ -1416,9 +1419,9 @@ Tcl_Export( if (resetListFirst) { if (nsPtr->exportArrayPtr != NULL) { for (i = 0; i < nsPtr->numExportPatterns; i++) { - Tcl_Free(nsPtr->exportArrayPtr[i]); + ckfree(nsPtr->exportArrayPtr[i]); } - Tcl_Free(nsPtr->exportArrayPtr); + ckfree(nsPtr->exportArrayPtr); nsPtr->exportArrayPtr = NULL; TclInvalidateNsCmdLookup(nsPtr); nsPtr->numExportPatterns = 0; @@ -1465,7 +1468,7 @@ Tcl_Export( if (neededElems > nsPtr->maxExportPatterns) { nsPtr->maxExportPatterns = nsPtr->maxExportPatterns ? 2 * nsPtr->maxExportPatterns : INIT_EXPORT_PATTERNS; - nsPtr->exportArrayPtr = (char **)Tcl_Realloc(nsPtr->exportArrayPtr, + nsPtr->exportArrayPtr = (char **)ckrealloc(nsPtr->exportArrayPtr, sizeof(char *) * nsPtr->maxExportPatterns); } @@ -1474,7 +1477,7 @@ Tcl_Export( */ len = strlen(pattern); - patternCpy = (char *)Tcl_Alloc(len + 1); + patternCpy = (char *)ckalloc(len + 1); memcpy(patternCpy, pattern, len + 1); nsPtr->exportArrayPtr[nsPtr->numExportPatterns] = patternCpy; @@ -1793,7 +1796,7 @@ DoImport( } } - dataPtr = (ImportedCmdData *)Tcl_Alloc(sizeof(ImportedCmdData)); + dataPtr = (ImportedCmdData *)ckalloc(sizeof(ImportedCmdData)); importedCmd = Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds), TclInvokeImportedCmd, InvokeImportedNRCmd, dataPtr, DeleteImportedCmd); @@ -1809,7 +1812,7 @@ DoImport( * and add it to the import ref list in the "real" command. */ - refPtr = (ImportRef *)Tcl_Alloc(sizeof(ImportRef)); + refPtr = (ImportRef *)ckalloc(sizeof(ImportRef)); refPtr->importedCmdPtr = (Command *) importedCmd; refPtr->nextPtr = cmdPtr->importRefPtr; cmdPtr->importRefPtr = refPtr; @@ -2106,9 +2109,9 @@ DeleteImportedCmd( } else { prevPtr->nextPtr = refPtr->nextPtr; } - Tcl_Free(refPtr); + ckfree(refPtr); TclCleanupCommandMacro(realCmdPtr); - Tcl_Free(dataPtr); + ckfree(dataPtr); return; } prevPtr = refPtr; @@ -2260,13 +2263,13 @@ TclGetNamespaceForQualName( start = qualName; /* Points to start of qualifying * namespace. */ - if ((qualName[0] == ':') && (qualName[1] == ':')) { - start = qualName + 2; /* Skip over the initial :: */ - while (start[0] == ':') { + if ((*qualName == ':') && (*(qualName+1) == ':')) { + start = qualName+2; /* Skip over the initial :: */ + while (*start == ':') { start++; /* Skip over a subsequent : */ } nsPtr = globalNsPtr; - if (start[0] == '\0') { /* qualName is just two or more + if (*start == '\0') { /* qualName is just two or more * ":"s. */ *nsPtrPtr = globalNsPtr; *altNsPtrPtr = NULL; @@ -2306,7 +2309,7 @@ TclGetNamespaceForQualName( len = 0; for (end = start; *end != '\0'; end++) { - if ((end[0] == ':') && (end[1] == ':')) { + if ((*end == ':') && (*(end+1) == ':')) { end += 2; /* Skip over the initial :: */ while (*end == ':') { end++; /* Skip over the subsequent : */ @@ -2316,7 +2319,7 @@ TclGetNamespaceForQualName( len++; } - if (end[0]=='\0' && !(end-start>=2 && end[-1]==':' && end[-2]==':')) { + if (*end=='\0' && !(end-start>=2 && *(end-1)==':' && *(end-2)==':')) { /* * qualName ended with a simple name at start. If TCL_FIND_ONLY_NS * was specified, look this up as a namespace. Otherwise, start is @@ -2436,7 +2439,7 @@ TclGetNamespaceForQualName( * variable name, trailing "::"s refer to the cmd or var named {}. */ - if ((flags & TCL_FIND_ONLY_NS) || (end>start && end[-1]!=':')) { + if ((flags & TCL_FIND_ONLY_NS) || (end>start && *(end-1)!=':')) { *simpleNamePtr = NULL; /* Found namespace name. */ } else { *simpleNamePtr = end; /* Found cmd/var: points to empty @@ -3058,7 +3061,7 @@ NamespaceChildrenCmd( if (objc == 3) { const char *name = TclGetString(objv[2]); - if ((name[0] == ':') && (name[1] == ':')) { + if ((*name == ':') && (*(name+1) == ':')) { pattern = name; } else { Tcl_DStringAppend(&buffer, nsPtr->fullName, -1); @@ -4140,7 +4143,7 @@ TclSetNsPath( { if (pathLength != 0) { NamespacePathEntry *tmpPathArray = - (NamespacePathEntry *)Tcl_Alloc(sizeof(NamespacePathEntry) * pathLength); + (NamespacePathEntry *)ckalloc(sizeof(NamespacePathEntry) * pathLength); Tcl_Size i; for (i=0 ; i<pathLength ; i++) { @@ -4208,7 +4211,7 @@ UnlinkNsPath( } } } - Tcl_Free(nsPtr->commandPathArray); + ckfree(nsPtr->commandPathArray); } /* @@ -4291,13 +4294,13 @@ NamespaceQualifiersCmd( */ name = TclGetString(objv[1]); - for (p = name; p[0] != '\0'; p++) { + for (p = name; *p != '\0'; p++) { /* empty body */ } while (--p >= name) { - if ((p[0] == ':') && (p > name) && (p[-1] == ':')) { + if ((*p == ':') && (p > name) && (*(p-1) == ':')) { p -= 2; /* Back up over the :: */ - while ((p >= name) && (p[0] == ':')) { + while ((p >= name) && (*p == ':')) { p--; /* Back up over the preceding : */ } break; @@ -4549,7 +4552,7 @@ NamespaceTailCmd( /* empty body */ } while (--p > name) { - if ((p[0] == ':') && (p[-1] == ':')) { + if ((*p == ':') && (*(p-1) == ':')) { p++; /* Just after the last "::" */ break; } @@ -4756,7 +4759,7 @@ FreeNsNameInternalRep( */ TclNsDecrRefCount(resNamePtr->nsPtr); - Tcl_Free(resNamePtr); + ckfree(resNamePtr); } } @@ -4843,7 +4846,7 @@ SetNsNameFromAny( */ nsPtr->refCount++; - resNamePtr = (ResolvedNsName *)Tcl_Alloc(sizeof(ResolvedNsName)); + resNamePtr = (ResolvedNsName *)ckalloc(sizeof(ResolvedNsName)); resNamePtr->nsPtr = nsPtr; if ((name[0] == ':') && (name[1] == ':')) { resNamePtr->refNsPtr = NULL; @@ -4903,7 +4906,7 @@ TclGetNamespaceChildTable( return &nPtr->childTable; #else if (nPtr->childTablePtr == NULL) { - nPtr->childTablePtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); + nPtr->childTablePtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(nPtr->childTablePtr, TCL_STRING_KEYS); } return nPtr->childTablePtr; @@ -4978,7 +4981,7 @@ TclLogCommandInfo( Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n %s\n\"%.*s%s\"", ((iPtr->errorInfo == NULL) ? "while executing" : "invoked from within"), - (overflow ? limit : (int)length), command, + (overflow ? limit : length), command, (overflow ? "..." : ""))); varPtr = TclObjLookupVarEx(interp, iPtr->eiVar, NULL, TCL_GLOBAL_ONLY, @@ -4991,7 +4994,7 @@ TclLogCommandInfo( return; } else { Tcl_HashEntry *hPtr - = Tcl_FindHashEntry(&iPtr->varTraces, varPtr); + = Tcl_FindHashEntry(&iPtr->varTraces, (char *)varPtr); VarTrace *tracePtr = (VarTrace *)Tcl_GetHashValue(hPtr); if (tracePtr->traceProc != EstablishErrorInfoTraces) { @@ -5062,7 +5065,7 @@ TclLogCommandInfo( Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->upLiteral); Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewWideIntObj( - (int)(iPtr->framePtr->level - iPtr->varFramePtr->level))); + iPtr->framePtr->level - iPtr->varFramePtr->level)); } else if (iPtr->framePtr != iPtr->rootFramePtr) { /* * normal case, [lappend errorstack CALL [info level 0]] diff --git a/generic/tclNotify.c b/generic/tclNotify.c index ec24a4b..c724157 100644 --- a/generic/tclNotify.c +++ b/generic/tclNotify.c @@ -35,7 +35,7 @@ static Tcl_NotifierProcs tclNotifierHooks = { typedef struct EventSource { Tcl_EventSetupProc *setupProc; Tcl_EventCheckProc *checkProc; - void *clientData; + ClientData clientData; struct EventSource *nextPtr; } EventSource; @@ -71,7 +71,7 @@ typedef struct ThreadSpecificData { /* Pointer to first event source in list of * event sources for this thread. */ Tcl_ThreadId threadId; /* Thread that owns this notifier instance. */ - void *clientData; /* Opaque handle for platform specific + ClientData clientData; /* Opaque handle for platform specific * notifier. */ int initialized; /* 1 if notifier has been initialized. */ struct ThreadSpecificData *nextPtr; @@ -182,7 +182,7 @@ TclFinalizeNotifier(void) for (evPtr = tsdPtr->firstEventPtr; evPtr != NULL; ) { hold = evPtr; evPtr = evPtr->nextPtr; - Tcl_Free(hold); + ckfree(hold); } tsdPtr->firstEventPtr = NULL; tsdPtr->lastEventPtr = NULL; @@ -288,7 +288,7 @@ Tcl_SetNotifier( * Tcl_QueueEvent to queue any events that are ready. * * Each of these functions is passed two arguments, e.g. - * (*checkProc)(void *clientData, int flags)); + * (*checkProc)(ClientData clientData, int flags)); * ClientData is the same as the clientData argument here, and flags is a * combination of things like TCL_FILE_EVENTS that indicates what events * are of interest: setupProc and checkProc use flags to figure out @@ -305,11 +305,11 @@ Tcl_CreateEventSource( Tcl_EventCheckProc *checkProc, /* Function to call after waiting to see what * happened. */ - void *clientData) /* One-word argument to pass to setupProc and + ClientData clientData) /* One-word argument to pass to setupProc and * checkProc. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); - EventSource *sourcePtr = (EventSource *)Tcl_Alloc(sizeof(EventSource)); + EventSource *sourcePtr = (EventSource *)ckalloc(sizeof(EventSource)); sourcePtr->setupProc = setupProc; sourcePtr->checkProc = checkProc; @@ -344,7 +344,7 @@ Tcl_DeleteEventSource( Tcl_EventCheckProc *checkProc, /* Function to call after waiting to see what * happened. */ - void *clientData) /* One-word argument to pass to setupProc and + ClientData clientData) /* One-word argument to pass to setupProc and * checkProc. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); @@ -363,7 +363,7 @@ Tcl_DeleteEventSource( } else { prevPtr->nextPtr = sourcePtr->nextPtr; } - Tcl_Free(sourcePtr); + ckfree(sourcePtr); return; } } @@ -388,7 +388,7 @@ void Tcl_QueueEvent( Tcl_Event *evPtr, /* Event to add to queue. The storage space * must have been allocated the caller with - * malloc (Tcl_Alloc), and it becomes the + * malloc (ckalloc), and it becomes the * property of the event queue. It will be * freed after the event has been handled. */ int position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK, @@ -420,7 +420,7 @@ Tcl_ThreadQueueEvent( Tcl_ThreadId threadId, /* Identifier for thread to use. */ Tcl_Event *evPtr, /* Event to add to queue. The storage space * must have been allocated the caller with - * malloc (Tcl_Alloc), and it becomes the + * malloc (ckalloc), and it becomes the * property of the event queue. It will be * freed after the event has been handled. */ int position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK, @@ -447,7 +447,7 @@ Tcl_ThreadQueueEvent( Tcl_AlertNotifier(tsdPtr->clientData); } } else { - Tcl_Free(evPtr); + ckfree(evPtr); } Tcl_MutexUnlock(&listLock); } @@ -480,7 +480,7 @@ QueueEvent( * which event queue to use. */ Tcl_Event *evPtr, /* Event to add to queue. The storage space * must have been allocated the caller with - * malloc (Tcl_Alloc), and it becomes the + * malloc (ckalloc), and it becomes the * property of the event queue. It will be * freed after the event has been handled. */ int position) /* One of TCL_QUEUE_TAIL, TCL_QUEUE_HEAD, TCL_QUEUE_MARK, @@ -556,7 +556,7 @@ QueueEvent( void Tcl_DeleteEvents( Tcl_EventDeleteProc *proc, /* The function to call. */ - void *clientData) /* The type-specific data. */ + ClientData clientData) /* The type-specific data. */ { Tcl_Event *evPtr; /* Pointer to the event being examined */ Tcl_Event *prevPtr; /* Pointer to evPtr's predecessor, or NULL if @@ -603,7 +603,7 @@ Tcl_DeleteEvents( hold = evPtr; evPtr = evPtr->nextPtr; - Tcl_Free(hold); + ckfree(hold); } else { /* * Event is to be retained. @@ -742,7 +742,7 @@ Tcl_ServiceEvent( } } if (evPtr) { - Tcl_Free(evPtr); + ckfree(evPtr); } Tcl_MutexUnlock(&(tsdPtr->queueMutex)); return 1; @@ -1189,7 +1189,7 @@ Tcl_ThreadAlert( *---------------------------------------------------------------------- */ -void * +ClientData Tcl_InitNotifier(void) { if (tclNotifierHooks.initNotifierProc) { @@ -1220,7 +1220,7 @@ Tcl_InitNotifier(void) void Tcl_FinalizeNotifier( - void *clientData) + ClientData clientData) { if (tclNotifierHooks.finalizeNotifierProc) { tclNotifierHooks.finalizeNotifierProc(clientData); @@ -1253,7 +1253,7 @@ Tcl_FinalizeNotifier( void Tcl_AlertNotifier( - void *clientData) /* Pointer to thread data. */ + ClientData clientData) /* Pointer to thread data. */ { if (tclNotifierHooks.alertNotifierProc) { tclNotifierHooks.alertNotifierProc(clientData); @@ -1380,7 +1380,7 @@ Tcl_CreateFileHandler( * called. */ Tcl_FileProc *proc, /* Function to call for each selected * event. */ - void *clientData) /* Arbitrary data to pass to proc. */ + ClientData clientData) /* Arbitrary data to pass to proc. */ { if (tclNotifierHooks.createFileHandlerProc) { tclNotifierHooks.createFileHandlerProc(fd, mask, proc, clientData); diff --git a/generic/tclOO.c b/generic/tclOO.c index 6074147..9df5338 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -81,8 +81,8 @@ static Tcl_InterpDeleteProc KillFoundation; static void MyDeleted(void *clientData); static void ObjectNamespaceDeleted(void *clientData); static Tcl_CommandTraceProc ObjectRenamedTrace; -static inline void RemoveClass(Class **list, size_t num, size_t idx); -static inline void RemoveObject(Object **list, size_t num, size_t idx); +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 PublicNRObjectCmd(void *clientData, @@ -201,8 +201,8 @@ MODULE_SCOPE const TclOOStubs tclOOStubs; static inline void RemoveClass( Class **list, - size_t num, - size_t idx) + int num, + int idx) { for (; idx + 1 < num; idx++) { list[idx] = list[idx + 1]; @@ -213,8 +213,8 @@ RemoveClass( static inline void RemoveObject( Object **list, - size_t num, - size_t idx) + int num, + int idx) { for (; idx + 1 < num; idx++) { list[idx] = list[idx + 1]; @@ -304,11 +304,11 @@ InitFoundation( static Tcl_ThreadDataKey tsdKey; ThreadLocalData *tsdPtr = (ThreadLocalData *)Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData)); - Foundation *fPtr = (Foundation *)Tcl_Alloc(sizeof(Foundation)); + Foundation *fPtr = (Foundation *)ckalloc(sizeof(Foundation)); Tcl_Obj *namePtr; Tcl_DString buffer; Command *cmdPtr; - size_t i; + int i; /* * Initialize the structure that holds the OO system core. This is @@ -328,7 +328,7 @@ InitFoundation( fPtr->helpersNs = Tcl_CreateNamespace(interp, "::oo::Helpers", fPtr, DeletedHelpersNamespace); Tcl_CreateNamespace(interp, "::oo::configuresupport", NULL, NULL); - fPtr->epoch = 1; + fPtr->epoch = 0; fPtr->tsdPtr = tsdPtr; TclNewLiteralStringObj(fPtr->unknownMethodNameObj, "unknown"); TclNewLiteralStringObj(fPtr->constructorName, "<constructor>"); @@ -392,9 +392,9 @@ InitFoundation( */ TclNewLiteralStringObj(namePtr, "new"); - TclNewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr, + Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr, namePtr /* keeps ref */, 0 /* private */, NULL, NULL); - fPtr->classCls->constructorPtr = (Method *) TclNewMethod(interp, + fPtr->classCls->constructorPtr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) fPtr->classCls, NULL, 0, &classConstructor, NULL); /* @@ -471,7 +471,7 @@ InitClassSystemRoots( */ fPtr->objectCls->superclasses.num = 0; - Tcl_Free(fPtr->objectCls->superclasses.list); + ckfree(fPtr->objectCls->superclasses.list); fPtr->objectCls->superclasses.list = NULL; /* @@ -589,7 +589,7 @@ KillFoundation( TclOODecrRefCount(fPtr->objectCls->thisPtr); TclOODecrRefCount(fPtr->classCls->thisPtr); - Tcl_Free(fPtr); + ckfree(fPtr); } /* @@ -627,9 +627,9 @@ AllocObject( Object *oPtr; Command *cmdPtr; CommandTrace *tracePtr; - size_t creationEpoch; + int creationEpoch; - oPtr = (Object *)Tcl_Alloc(sizeof(Object)); + oPtr = (Object *)ckalloc(sizeof(Object)); memset(oPtr, 0, sizeof(Object)); /* @@ -656,7 +656,7 @@ AllocObject( while (1) { char objName[10 + TCL_INTEGER_SPACE]; - snprintf(objName, sizeof(objName), "::oo::Obj%" TCL_Z_MODIFIER "u", ++fPtr->tsdPtr->nsCount); + snprintf(objName, sizeof(objName), "::oo::Obj%d", ++fPtr->tsdPtr->nsCount); oPtr->namespacePtr = Tcl_CreateNamespace(interp, objName, oPtr, NULL); if (oPtr->namespacePtr != NULL) { creationEpoch = fPtr->tsdPtr->nsCount; @@ -740,7 +740,7 @@ AllocObject( cmdPtr = (Command *) oPtr->command; cmdPtr->nreProc = PublicNRObjectCmd; - cmdPtr->tracePtr = tracePtr = (CommandTrace *)Tcl_Alloc(sizeof(CommandTrace)); + cmdPtr->tracePtr = tracePtr = (CommandTrace *)ckalloc(sizeof(CommandTrace)); tracePtr->traceProc = ObjectRenamedTrace; tracePtr->clientData = oPtr; tracePtr->flags = TCL_TRACE_RENAME|TCL_TRACE_DELETE; @@ -894,7 +894,7 @@ TclOODeleteDescendants( } } if (clsPtr->mixinSubs.size > 0) { - Tcl_Free(clsPtr->mixinSubs.list); + ckfree(clsPtr->mixinSubs.list); clsPtr->mixinSubs.size = 0; } @@ -914,7 +914,7 @@ TclOODeleteDescendants( } } if (clsPtr->subclasses.size > 0) { - Tcl_Free(clsPtr->subclasses.list); + ckfree(clsPtr->subclasses.list); clsPtr->subclasses.list = NULL; clsPtr->subclasses.size = 0; } @@ -939,7 +939,7 @@ TclOODeleteDescendants( } } if (clsPtr->instances.size > 0) { - Tcl_Free(clsPtr->instances.list); + ckfree(clsPtr->instances.list); clsPtr->instances.list = NULL; clsPtr->instances.size = 0; } @@ -1015,7 +1015,7 @@ TclOOReleaseClassContents( TclOODeleteChain(callPtr); } Tcl_DeleteHashTable(clsPtr->classChainCache); - Tcl_Free(clsPtr->classChainCache); + ckfree(clsPtr->classChainCache); clsPtr->classChainCache = NULL; } @@ -1033,13 +1033,13 @@ TclOOReleaseClassContents( FOREACH(propertyObj, clsPtr->properties.readable) { Tcl_DecrRefCount(propertyObj); } - Tcl_Free(clsPtr->properties.readable.list); + ckfree(clsPtr->properties.readable.list); } if (clsPtr->properties.writable.num) { FOREACH(propertyObj, clsPtr->properties.writable) { Tcl_DecrRefCount(propertyObj); } - Tcl_Free(clsPtr->properties.writable.list); + ckfree(clsPtr->properties.writable.list); } /* @@ -1052,7 +1052,7 @@ TclOOReleaseClassContents( FOREACH(filterObj, clsPtr->filters) { TclDecrRefCount(filterObj); } - Tcl_Free(clsPtr->filters.list); + ckfree(clsPtr->filters.list); clsPtr->filters.list = NULL; clsPtr->filters.num = 0; } @@ -1069,7 +1069,7 @@ TclOOReleaseClassContents( metadataTypePtr->deleteProc(value); } Tcl_DeleteHashTable(clsPtr->metadataPtr); - Tcl_Free(clsPtr->metadataPtr); + ckfree(clsPtr->metadataPtr); clsPtr->metadataPtr = NULL; } @@ -1078,7 +1078,7 @@ TclOOReleaseClassContents( TclOORemoveFromMixinSubs(clsPtr, tmpClsPtr); TclOODecrRefCount(tmpClsPtr->thisPtr); } - Tcl_Free(clsPtr->mixins.list); + ckfree(clsPtr->mixins.list); clsPtr->mixins.list = NULL; clsPtr->mixins.num = 0; } @@ -1088,7 +1088,7 @@ TclOOReleaseClassContents( TclOORemoveFromSubclasses(clsPtr, tmpClsPtr); TclOODecrRefCount(tmpClsPtr->thisPtr); } - Tcl_Free(clsPtr->superclasses.list); + ckfree(clsPtr->superclasses.list); clsPtr->superclasses.num = 0; clsPtr->superclasses.list = NULL; } @@ -1104,7 +1104,7 @@ TclOOReleaseClassContents( TclDecrRefCount(variableObj); } if (i) { - Tcl_Free(clsPtr->variables.list); + ckfree(clsPtr->variables.list); } FOREACH_STRUCT(privateVariable, clsPtr->privateVariables) { @@ -1112,7 +1112,7 @@ TclOOReleaseClassContents( TclDecrRefCount(privateVariable->fullNameObj); } if (i) { - Tcl_Free(clsPtr->privateVariables.list); + ckfree(clsPtr->privateVariables.list); } if (IsRootClass(oPtr) && !Destructing(fPtr->objectCls->thisPtr)) { @@ -1244,7 +1244,7 @@ ObjectNamespaceDeleted( TclOODecrRefCount(mixinPtr->thisPtr); } if (oPtr->mixins.list != NULL) { - Tcl_Free(oPtr->mixins.list); + ckfree(oPtr->mixins.list); } } @@ -1252,7 +1252,7 @@ ObjectNamespaceDeleted( TclDecrRefCount(filterObj); } if (i) { - Tcl_Free(oPtr->filters.list); + ckfree(oPtr->filters.list); } if (oPtr->methodsPtr) { @@ -1260,14 +1260,14 @@ ObjectNamespaceDeleted( TclOODelMethodRef(mPtr); } Tcl_DeleteHashTable(oPtr->methodsPtr); - Tcl_Free(oPtr->methodsPtr); + ckfree(oPtr->methodsPtr); } FOREACH(variableObj, oPtr->variables) { TclDecrRefCount(variableObj); } if (i) { - Tcl_Free(oPtr->variables.list); + ckfree(oPtr->variables.list); } FOREACH_STRUCT(privateVariable, oPtr->privateVariables) { @@ -1275,7 +1275,7 @@ ObjectNamespaceDeleted( TclDecrRefCount(privateVariable->fullNameObj); } if (i) { - Tcl_Free(oPtr->privateVariables.list); + ckfree(oPtr->privateVariables.list); } if (oPtr->chainCache) { @@ -1292,7 +1292,7 @@ ObjectNamespaceDeleted( metadataTypePtr->deleteProc(value); } Tcl_DeleteHashTable(oPtr->metadataPtr); - Tcl_Free(oPtr->metadataPtr); + ckfree(oPtr->metadataPtr); oPtr->metadataPtr = NULL; } @@ -1310,13 +1310,13 @@ ObjectNamespaceDeleted( FOREACH(propertyObj, oPtr->properties.readable) { Tcl_DecrRefCount(propertyObj); } - Tcl_Free(oPtr->properties.readable.list); + ckfree(oPtr->properties.readable.list); } if (oPtr->properties.writable.num) { FOREACH(propertyObj, oPtr->properties.writable) { Tcl_DecrRefCount(propertyObj); } - Tcl_Free(oPtr->properties.writable.list); + ckfree(oPtr->properties.writable.list); } /* @@ -1371,9 +1371,9 @@ TclOODecrRefCount( if (oPtr->refCount-- <= 1) { if (oPtr->classPtr != NULL) { - Tcl_Free(oPtr->classPtr); + ckfree(oPtr->classPtr); } - Tcl_Free(oPtr); + ckfree(oPtr); return 1; } return 0; @@ -1389,10 +1389,7 @@ TclOODecrRefCount( * * ---------------------------------------------------------------------- */ -int -TclOOObjectDestroyed( - Object *oPtr) -{ +int TclOOObjectDestroyed(Object *oPtr) { return (oPtr->namespacePtr == NULL); } @@ -1449,9 +1446,9 @@ TclOOAddToInstances( if (clsPtr->instances.num >= clsPtr->instances.size) { clsPtr->instances.size += ALLOC_CHUNK; if (clsPtr->instances.size == ALLOC_CHUNK) { - clsPtr->instances.list = (Object **)Tcl_Alloc(sizeof(Object *) * ALLOC_CHUNK); + clsPtr->instances.list = (Object **)ckalloc(sizeof(Object *) * ALLOC_CHUNK); } else { - clsPtr->instances.list = (Object **)Tcl_Realloc(clsPtr->instances.list, + clsPtr->instances.list = (Object **)ckrealloc(clsPtr->instances.list, sizeof(Object *) * clsPtr->instances.size); } } @@ -1489,7 +1486,7 @@ TclOORemoveFromMixins( } } if (oPtr->mixins.num == 0) { - Tcl_Free(oPtr->mixins.list); + ckfree(oPtr->mixins.list); oPtr->mixins.list = NULL; } return res; @@ -1550,9 +1547,9 @@ TclOOAddToSubclasses( if (superPtr->subclasses.num >= superPtr->subclasses.size) { superPtr->subclasses.size += ALLOC_CHUNK; if (superPtr->subclasses.size == ALLOC_CHUNK) { - superPtr->subclasses.list = (Class **)Tcl_Alloc(sizeof(Class *) * ALLOC_CHUNK); + superPtr->subclasses.list = (Class **)ckalloc(sizeof(Class *) * ALLOC_CHUNK); } else { - superPtr->subclasses.list = (Class **)Tcl_Realloc(superPtr->subclasses.list, + superPtr->subclasses.list = (Class **)ckrealloc(superPtr->subclasses.list, sizeof(Class *) * superPtr->subclasses.size); } } @@ -1616,9 +1613,9 @@ TclOOAddToMixinSubs( if (superPtr->mixinSubs.num >= superPtr->mixinSubs.size) { superPtr->mixinSubs.size += ALLOC_CHUNK; if (superPtr->mixinSubs.size == ALLOC_CHUNK) { - superPtr->mixinSubs.list = (Class **)Tcl_Alloc(sizeof(Class *) * ALLOC_CHUNK); + superPtr->mixinSubs.list = (Class **)ckalloc(sizeof(Class *) * ALLOC_CHUNK); } else { - superPtr->mixinSubs.list = (Class **)Tcl_Realloc(superPtr->mixinSubs.list, + superPtr->mixinSubs.list = (Class **)ckrealloc(superPtr->mixinSubs.list, sizeof(Class *) * superPtr->mixinSubs.size); } } @@ -1664,7 +1661,7 @@ TclOOAllocClass( * representation. */ { Foundation *fPtr = GetFoundation(interp); - Class *clsPtr = (Class *)Tcl_Alloc(sizeof(Class)); + Class *clsPtr = (Class *)ckalloc(sizeof(Class)); memset(clsPtr, 0, sizeof(Class)); clsPtr->thisPtr = useThisObj; @@ -1681,7 +1678,7 @@ TclOOAllocClass( */ clsPtr->superclasses.num = 1; - clsPtr->superclasses.list = (Class **)Tcl_Alloc(sizeof(Class *)); + clsPtr->superclasses.list = (Class **)ckalloc(sizeof(Class *)); clsPtr->superclasses.list[0] = fPtr->objectCls; AddRef(fPtr->objectCls->thisPtr); @@ -1738,7 +1735,7 @@ Tcl_NewObjectInstance( * used for object cloning only. */ - if (objc != TCL_INDEX_NONE) { + if (objc >= 0) { CallContext *contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL, NULL, NULL); @@ -1805,7 +1802,7 @@ TclNRNewObjectInstance( } /* - * Run constructors, except when objc == TCL_INDEX_NONE (a special flag case used for + * Run constructors, except when objc < 0 (a special flag case used for * object cloning only). If there aren't any constructors, we do nothing. */ @@ -2032,7 +2029,7 @@ Tcl_CopyObjectInstance( } TclOODecrRefCount(mixinPtr->thisPtr); } - Tcl_Free(o2Ptr->mixins.list); + ckfree(o2Ptr->mixins.list); } DUPLICATE(o2Ptr->mixins, oPtr->mixins, Class *); FOREACH(mixinPtr, o2Ptr->mixins) { @@ -2133,11 +2130,11 @@ Tcl_CopyObjectInstance( TclOODecrRefCount(superPtr->thisPtr); } if (cls2Ptr->superclasses.num) { - cls2Ptr->superclasses.list = (Class **)Tcl_Realloc(cls2Ptr->superclasses.list, + cls2Ptr->superclasses.list = (Class **)ckrealloc(cls2Ptr->superclasses.list, sizeof(Class *) * clsPtr->superclasses.num); } else { cls2Ptr->superclasses.list = - (Class **)Tcl_Alloc(sizeof(Class *) * clsPtr->superclasses.num); + (Class **)ckalloc(sizeof(Class *) * clsPtr->superclasses.num); } memcpy(cls2Ptr->superclasses.list, clsPtr->superclasses.list, sizeof(Class *) * clsPtr->superclasses.num); @@ -2188,7 +2185,7 @@ Tcl_CopyObjectInstance( TclOORemoveFromMixinSubs(cls2Ptr, mixinPtr); TclOODecrRefCount(mixinPtr->thisPtr); } - Tcl_Free(clsPtr->mixins.list); + ckfree(clsPtr->mixins.list); } DUPLICATE(cls2Ptr->mixins, clsPtr->mixins, Class *); FOREACH(mixinPtr, cls2Ptr->mixins) { @@ -2302,7 +2299,7 @@ CloneObjectMethod( Tcl_Obj *namePtr) { if (mPtr->typePtr == NULL) { - TclNewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr, + Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr, mPtr->flags & PUBLIC_METHOD, NULL, NULL); } else if (mPtr->typePtr->cloneProc) { void *newClientData; @@ -2311,10 +2308,10 @@ CloneObjectMethod( &newClientData) != TCL_OK) { return TCL_ERROR; } - TclNewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr, + Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, newClientData); } else { - TclNewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr, + Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, mPtr->clientData); } return TCL_OK; @@ -2331,7 +2328,7 @@ CloneClassMethod( Method *m2Ptr; if (mPtr->typePtr == NULL) { - m2Ptr = (Method *) TclNewMethod(interp, (Tcl_Class) clsPtr, + m2Ptr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, namePtr, mPtr->flags & PUBLIC_METHOD, NULL, NULL); } else if (mPtr->typePtr->cloneProc) { void *newClientData; @@ -2340,11 +2337,11 @@ CloneClassMethod( &newClientData) != TCL_OK) { return TCL_ERROR; } - m2Ptr = (Method *) TclNewMethod(interp, (Tcl_Class) clsPtr, + m2Ptr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, newClientData); } else { - m2Ptr = (Method *) TclNewMethod(interp, (Tcl_Class) clsPtr, + m2Ptr = (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, namePtr, mPtr->flags & PUBLIC_METHOD, mPtr->typePtr, mPtr->clientData); } @@ -2401,7 +2398,7 @@ Tcl_ClassGetMetadata( * There is a metadata store, so look in it for the given type. */ - hPtr = Tcl_FindHashEntry(clsPtr->metadataPtr, typePtr); + hPtr = Tcl_FindHashEntry(clsPtr->metadataPtr, (char *) typePtr); /* * Return the metadata value if we found it, otherwise NULL. @@ -2431,7 +2428,7 @@ Tcl_ClassSetMetadata( if (metadata == NULL) { return; } - clsPtr->metadataPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); + clsPtr->metadataPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(clsPtr->metadataPtr, TCL_ONE_WORD_KEYS); } @@ -2440,7 +2437,7 @@ Tcl_ClassSetMetadata( */ if (metadata == NULL) { - hPtr = Tcl_FindHashEntry(clsPtr->metadataPtr, typePtr); + hPtr = Tcl_FindHashEntry(clsPtr->metadataPtr, (char *) typePtr); if (hPtr != NULL) { typePtr->deleteProc(Tcl_GetHashValue(hPtr)); Tcl_DeleteHashEntry(hPtr); @@ -2453,7 +2450,7 @@ Tcl_ClassSetMetadata( * some metadata attached of this type, we delete that first. */ - hPtr = Tcl_CreateHashEntry(clsPtr->metadataPtr, typePtr, &isNew); + hPtr = Tcl_CreateHashEntry(clsPtr->metadataPtr, (char *) typePtr, &isNew); if (!isNew) { typePtr->deleteProc(Tcl_GetHashValue(hPtr)); } @@ -2481,7 +2478,7 @@ Tcl_ObjectGetMetadata( * There is a metadata store, so look in it for the given type. */ - hPtr = Tcl_FindHashEntry(oPtr->metadataPtr, typePtr); + hPtr = Tcl_FindHashEntry(oPtr->metadataPtr, (char *) typePtr); /* * Return the metadata value if we found it, otherwise NULL. @@ -2511,7 +2508,7 @@ Tcl_ObjectSetMetadata( if (metadata == NULL) { return; } - oPtr->metadataPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); + oPtr->metadataPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(oPtr->metadataPtr, TCL_ONE_WORD_KEYS); } @@ -2520,7 +2517,7 @@ Tcl_ObjectSetMetadata( */ if (metadata == NULL) { - hPtr = Tcl_FindHashEntry(oPtr->metadataPtr, typePtr); + hPtr = Tcl_FindHashEntry(oPtr->metadataPtr, (char *) typePtr); if (hPtr != NULL) { typePtr->deleteProc(Tcl_GetHashValue(hPtr)); Tcl_DeleteHashEntry(hPtr); @@ -2533,7 +2530,7 @@ Tcl_ObjectSetMetadata( * some metadata attached of this type, we delete that first. */ - hPtr = Tcl_CreateHashEntry(oPtr->metadataPtr, typePtr, &isNew); + hPtr = Tcl_CreateHashEntry(oPtr->metadataPtr, (char *) typePtr, &isNew); if (!isNew) { typePtr->deleteProc(Tcl_GetHashValue(hPtr)); } @@ -2855,8 +2852,8 @@ Tcl_ObjectContextInvokeNext( Tcl_Size skip) { CallContext *contextPtr = (CallContext *) context; - size_t savedIndex = contextPtr->index; - size_t savedSkip = contextPtr->skip; + int savedIndex = contextPtr->index; + int savedSkip = contextPtr->skip; int result; if (contextPtr->index + 1 >= contextPtr->callPtr->numChain) { diff --git a/generic/tclOO.decls b/generic/tclOO.decls index 2df34d0..913d76c 100644 --- a/generic/tclOO.decls +++ b/generic/tclOO.decls @@ -135,19 +135,8 @@ declare 30 { declare 31 { Tcl_Obj *Tcl_GetObjectClassName(Tcl_Interp *interp, Tcl_Object object) } -declare 32 { - int Tcl_MethodIsType2(Tcl_Method method, const Tcl_MethodType2 *typePtr, - void **clientDataPtr) -} -declare 33 { - Tcl_Method Tcl_NewInstanceMethod2(Tcl_Interp *interp, Tcl_Object object, - Tcl_Obj *nameObj, int flags, const Tcl_MethodType2 *typePtr, - void *clientData) -} declare 34 { - Tcl_Method Tcl_NewMethod2(Tcl_Interp *interp, Tcl_Class cls, - Tcl_Obj *nameObj, int flags, const Tcl_MethodType2 *typePtr, - void *clientData) + void TclOOUnusedStubEntry(void) } ###################################################################### diff --git a/generic/tclOO.h b/generic/tclOO.h index 7cda876..19d93f9 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -62,12 +62,7 @@ typedef struct Tcl_ObjectContext_ *Tcl_ObjectContext; typedef int (Tcl_MethodCallProc)(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext objectContext, int objc, Tcl_Obj *const *objv); -#if TCL_MAJOR_VERSION > 8 -typedef int (Tcl_MethodCallProc2)(void *clientData, Tcl_Interp *interp, - Tcl_ObjectContext objectContext, Tcl_Size objc, Tcl_Obj *const *objv); -#else #define Tcl_MethodCallProc2 Tcl_MethodCallProc -#endif typedef void (Tcl_MethodDeleteProc)(void *clientData); typedef int (Tcl_CloneProc)(Tcl_Interp *interp, void *oldClientData, void **newClientData); @@ -98,26 +93,7 @@ typedef struct { * be copied directly. */ } Tcl_MethodType; -#if TCL_MAJOR_VERSION > 8 -typedef struct { - int version; /* Structure version field. Always to be equal - * to TCL_OO_METHOD_VERSION_2 in - * declarations. */ - const char *name; /* Name of this type of method, mostly for - * debugging purposes. */ - Tcl_MethodCallProc2 *callProc; - /* How to invoke this method. */ - Tcl_MethodDeleteProc *deleteProc; - /* How to delete this method's type-specific - * data, or NULL if the type-specific data - * does not need deleting. */ - Tcl_CloneProc *cloneProc; /* How to copy this method's type-specific - * data, or NULL if the type-specific data can - * be copied directly. */ -} Tcl_MethodType2; -#else #define Tcl_MethodType2 Tcl_MethodType -#endif /* * The correct value for the version field of the Tcl_MethodType structure. diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 11af6a2..7bffcb1 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -15,7 +15,6 @@ #endif #include "tclInt.h" #include "tclOOInt.h" -#include "tclTomMath.h" static inline Tcl_Object *AddConstructionFinalizer(Tcl_Interp *interp); static Tcl_NRPostProc AfterNRDestructor; @@ -52,7 +51,7 @@ AddConstructionFinalizer( static int FinalizeConstruction( - void *data[], + ClientData data[], Tcl_Interp *interp, int result) { @@ -77,7 +76,7 @@ FinalizeConstruction( int TclOO_Class_Constructor( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, @@ -86,12 +85,11 @@ TclOO_Class_Constructor( Object *oPtr = (Object *) Tcl_ObjectContextObject(context); Tcl_Obj **invoke, *nameObj; - size_t skip = Tcl_ObjectContextSkippedArgs(context); - if ((size_t)objc > skip + 1) { - Tcl_WrongNumArgs(interp, skip, objv, + if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) { + Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "?definitionScript?"); return TCL_ERROR; - } else if ((size_t)objc == skip) { + } else if (objc == Tcl_ObjectContextSkippedArgs(context)) { return TCL_OK; } @@ -110,7 +108,7 @@ TclOO_Class_Constructor( * Delegate to [oo::define] to do the work. */ - invoke = (Tcl_Obj **)Tcl_Alloc(3 * sizeof(Tcl_Obj *)); + invoke = (Tcl_Obj **)ckalloc(3 * sizeof(Tcl_Obj *)); invoke[0] = oPtr->fPtr->defineName; invoke[1] = TclOOObjectName(interp, oPtr); invoke[2] = objv[objc-1]; @@ -136,7 +134,7 @@ TclOO_Class_Constructor( static int DecrRefsPostClassConstructor( - void *data[], + ClientData data[], Tcl_Interp *interp, int result) { @@ -156,7 +154,7 @@ DecrRefsPostClassConstructor( code = Tcl_EvalObjv(interp, 2, invoke, 0); TclDecrRefCount(invoke[0]); TclDecrRefCount(invoke[1]); - Tcl_Free(invoke); + ckfree(invoke); if (code != TCL_OK) { Tcl_DiscardInterpState(saved); return code; @@ -176,7 +174,7 @@ DecrRefsPostClassConstructor( int TclOO_Class_Create( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, /* Interpreter in which to create the object; * also used for error reporting. */ Tcl_ObjectContext context, /* The object/call context. */ @@ -185,7 +183,7 @@ TclOO_Class_Create( { Object *oPtr = (Object *) Tcl_ObjectContextObject(context); const char *objName; - Tcl_Size len; + int len; /* * Sanity check; should not be possible to invoke this method on a @@ -205,12 +203,12 @@ TclOO_Class_Create( * Check we have the right number of (sensible) arguments. */ - if (objc < 1 + Tcl_ObjectContextSkippedArgs(context)) { + if (objc - Tcl_ObjectContextSkippedArgs(context) < 1) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "objectName ?arg ...?"); return TCL_ERROR; } - objName = Tcl_GetStringFromObj( + objName = TclGetStringFromObj( objv[Tcl_ObjectContextSkippedArgs(context)], &len); if (len == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -241,7 +239,7 @@ TclOO_Class_Create( int TclOO_Class_CreateNs( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, /* Interpreter in which to create the object; * also used for error reporting. */ Tcl_ObjectContext context, /* The object/call context. */ @@ -250,7 +248,7 @@ TclOO_Class_CreateNs( { Object *oPtr = (Object *) Tcl_ObjectContextObject(context); const char *objName, *nsName; - Tcl_Size len; + int len; /* * Sanity check; should not be possible to invoke this method on a @@ -270,12 +268,12 @@ TclOO_Class_CreateNs( * Check we have the right number of (sensible) arguments. */ - if (objc + 1 < Tcl_ObjectContextSkippedArgs(context) + 3) { + if (objc - Tcl_ObjectContextSkippedArgs(context) < 2) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "objectName namespaceName ?arg ...?"); return TCL_ERROR; } - objName = Tcl_GetStringFromObj( + objName = TclGetStringFromObj( objv[Tcl_ObjectContextSkippedArgs(context)], &len); if (len == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -283,7 +281,7 @@ TclOO_Class_CreateNs( Tcl_SetErrorCode(interp, "TCL", "OO", "EMPTY_NAME", (char *)NULL); return TCL_ERROR; } - nsName = Tcl_GetStringFromObj( + nsName = TclGetStringFromObj( objv[Tcl_ObjectContextSkippedArgs(context)+1], &len); if (len == 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -314,7 +312,7 @@ TclOO_Class_CreateNs( int TclOO_Class_New( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, /* Interpreter in which to create the object; * also used for error reporting. */ Tcl_ObjectContext context, /* The object/call context. */ @@ -358,7 +356,7 @@ TclOO_Class_New( int TclOO_Object_Destroy( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, /* Interpreter in which to create the object; * also used for error reporting. */ Tcl_ObjectContext context, /* The object/call context. */ @@ -368,7 +366,7 @@ TclOO_Object_Destroy( Object *oPtr = (Object *) Tcl_ObjectContextObject(context); CallContext *contextPtr; - if (objc != (int)Tcl_ObjectContextSkippedArgs(context)) { + if (objc != Tcl_ObjectContextSkippedArgs(context)) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, NULL); return TCL_ERROR; @@ -394,7 +392,7 @@ TclOO_Object_Destroy( static int AfterNRDestructor( - void *data[], + ClientData data[], Tcl_Interp *interp, int result) { @@ -419,7 +417,7 @@ AfterNRDestructor( int TclOO_Object_Eval( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, /* Interpreter in which to create the object; * also used for error reporting. */ Tcl_ObjectContext context, /* The object/call context. */ @@ -428,12 +426,12 @@ TclOO_Object_Eval( { CallContext *contextPtr = (CallContext *) context; Tcl_Object object = Tcl_ObjectContextObject(context); - size_t skip = Tcl_ObjectContextSkippedArgs(context); + const int skip = Tcl_ObjectContextSkippedArgs(context); CallFrame *framePtr, **framePtrPtr = &framePtr; Tcl_Obj *scriptPtr; CmdFrame *invoker; - if ((size_t)objc < skip + 1) { + if (objc-1 < skip) { Tcl_WrongNumArgs(interp, skip, objv, "arg ?arg ...?"); return TCL_ERROR; } @@ -461,7 +459,7 @@ TclOO_Object_Eval( * object when it decrements its refcount after eval'ing it. */ - if ((size_t)objc != skip+1) { + if (objc != skip+1) { scriptPtr = Tcl_ConcatObj(objc-skip, objv+skip); invoker = NULL; } else { @@ -480,7 +478,7 @@ TclOO_Object_Eval( static int FinalizeEval( - void *data[], + ClientData data[], Tcl_Interp *interp, int result) { @@ -520,7 +518,7 @@ FinalizeEval( int TclOO_Object_Unknown( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, /* Interpreter in which to create the object; * also used for error reporting. */ Tcl_ObjectContext context, /* The object/call context. */ @@ -532,8 +530,7 @@ TclOO_Object_Unknown( Class *callerCls = NULL; Object *oPtr = contextPtr->oPtr; const char **methodNames; - int numMethodNames, i; - size_t skip = Tcl_ObjectContextSkippedArgs(context); + int numMethodNames, i, skip = Tcl_ObjectContextSkippedArgs(context); CallFrame *framePtr = ((Interp *) interp)->varFramePtr; Tcl_Obj *errorMsg; @@ -543,7 +540,7 @@ TclOO_Object_Unknown( * name without an error). */ - if ((size_t)objc < skip+1) { + if (objc < skip+1) { Tcl_WrongNumArgs(interp, skip, objv, "method ?arg ...?"); return TCL_ERROR; } @@ -608,7 +605,7 @@ TclOO_Object_Unknown( Tcl_AppendToObj(errorMsg, " or ", -1); } Tcl_AppendToObj(errorMsg, methodNames[i], -1); - Tcl_Free((void *)methodNames); + ckfree(methodNames); Tcl_SetObjResult(interp, errorMsg); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD", TclGetString(objv[skip]), (char *)NULL); @@ -627,7 +624,7 @@ TclOO_Object_Unknown( int TclOO_Object_LinkVar( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, /* Interpreter in which to create the object; * also used for error reporting. */ Tcl_ObjectContext context, /* The object/call context. */ @@ -637,9 +634,9 @@ TclOO_Object_LinkVar( Interp *iPtr = (Interp *) interp; Tcl_Object object = Tcl_ObjectContextObject(context); Namespace *savedNsPtr; - Tcl_Size i; + int i; - if (objc < Tcl_ObjectContextSkippedArgs(context)) { + if (objc-Tcl_ObjectContextSkippedArgs(context) < 0) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "?varName ...?"); return TCL_ERROR; @@ -655,7 +652,7 @@ TclOO_Object_LinkVar( return TCL_OK; } - for (i = Tcl_ObjectContextSkippedArgs(context) ; i < objc ; i++) { + for (i=Tcl_ObjectContextSkippedArgs(context) ; i<objc ; i++) { Var *varPtr, *aryPtr; const char *varName = TclGetString(objv[i]); @@ -729,7 +726,7 @@ TclOO_Object_LinkVar( int TclOO_Object_VarName( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, /* Interpreter in which to create the object; * also used for error reporting. */ Tcl_ObjectContext context, /* The object/call context. */ @@ -741,13 +738,13 @@ TclOO_Object_VarName( CallFrame *framePtr = ((Interp *) interp)->varFramePtr; const char *arg; - if ((int)Tcl_ObjectContextSkippedArgs(context)+1 != objc) { + if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, "varName"); return TCL_ERROR; } argPtr = objv[objc-1]; - arg = TclGetString(argPtr); + arg = Tcl_GetString(argPtr); /* * Convert the variable name to fully-qualified form if it wasn't already. @@ -780,12 +777,12 @@ TclOO_Object_VarName( Method *mPtr = callerContext->callPtr->chain[ callerContext->index].mPtr; PrivateVariableMapping *pvPtr; - Tcl_Size i; + int i; if (mPtr->declaringObjectPtr == oPtr) { FOREACH_STRUCT(pvPtr, oPtr->privateVariables) { - if (!strcmp(TclGetString(pvPtr->variableObj), - TclGetString(argPtr))) { + if (!strcmp(Tcl_GetString(pvPtr->variableObj), + Tcl_GetString(argPtr))) { argPtr = pvPtr->fullNameObj; break; } @@ -806,8 +803,8 @@ TclOO_Object_VarName( } if (isInstance) { FOREACH_STRUCT(pvPtr, clsPtr->privateVariables) { - if (!strcmp(TclGetString(pvPtr->variableObj), - TclGetString(argPtr))) { + if (!strcmp(Tcl_GetString(pvPtr->variableObj), + Tcl_GetString(argPtr))) { argPtr = pvPtr->fullNameObj; break; } @@ -867,7 +864,7 @@ TclOO_Object_VarName( int TclOONextObjCmd( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -903,7 +900,7 @@ TclOONextObjCmd( int TclOONextToObjCmd( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -912,7 +909,7 @@ TclOONextToObjCmd( CallFrame *framePtr = iPtr->varFramePtr; Class *classPtr; CallContext *contextPtr; - Tcl_Size i; + int i; Tcl_Object object; const char *methodType; @@ -988,7 +985,7 @@ TclOONextToObjCmd( methodType = "method"; } - for (i=contextPtr->index ; i != TCL_INDEX_NONE ; i--) { + for (i=contextPtr->index ; i>=0 ; i--) { struct MInvoke *miPtr = contextPtr->callPtr->chain + i; if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) { @@ -1009,7 +1006,7 @@ TclOONextToObjCmd( static int NextRestoreFrame( - void *data[], + ClientData data[], Tcl_Interp *interp, int result) { @@ -1018,7 +1015,7 @@ NextRestoreFrame( iPtr->varFramePtr = (CallFrame *)data[0]; if (contextPtr != NULL) { - contextPtr->index = PTR2UINT(data[2]); + contextPtr->index = PTR2INT(data[2]); } return result; } @@ -1036,7 +1033,7 @@ NextRestoreFrame( int TclOOSelfObjCmd( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -1048,11 +1045,12 @@ TclOOSelfObjCmd( enum SelfCmds { SELF_CALL, SELF_CALLER, SELF_CLASS, SELF_FILTER, SELF_METHOD, SELF_NS, SELF_NEXT, SELF_OBJECT, SELF_TARGET - } index; + }; Interp *iPtr = (Interp *) interp; CallFrame *framePtr = iPtr->varFramePtr; CallContext *contextPtr; Tcl_Obj *result[3]; + int index; #define CurrentlyInvoked(contextPtr) \ ((contextPtr)->callPtr->chain[(contextPtr)->index]) @@ -1086,13 +1084,13 @@ TclOOSelfObjCmd( return TCL_ERROR; } - switch (index) { + switch ((enum SelfCmds) index) { case SELF_OBJECT: Tcl_SetObjResult(interp, TclOOObjectName(interp, contextPtr->oPtr)); return TCL_OK; case SELF_NS: Tcl_SetObjResult(interp, Tcl_NewStringObj( - contextPtr->oPtr->namespacePtr->fullName, -1)); + contextPtr->oPtr->namespacePtr->fullName,-1)); return TCL_OK; case SELF_CLASS: { Class *clsPtr = CurrentlyInvoked(contextPtr).mPtr->declaringClassPtr; @@ -1220,7 +1218,7 @@ TclOOSelfObjCmd( } else { Method *mPtr; Object *declarerPtr; - Tcl_Size i; + int i; for (i=contextPtr->index ; i<contextPtr->callPtr->numChain ; i++){ if (!contextPtr->callPtr->chain[i].isFilter) { @@ -1272,7 +1270,7 @@ TclOOSelfObjCmd( int TclOOCopyObjectCmd( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -1281,7 +1279,7 @@ TclOOCopyObjectCmd( if (objc < 2 || objc > 4) { Tcl_WrongNumArgs(interp, 1, objv, - "sourceName ?targetName? ?targetNamespace?"); + "sourceName ?targetName? ?targetNamespace?"); return TCL_ERROR; } diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index 7695483..85ca995 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -25,7 +25,7 @@ struct ChainBuilder { CallChain *callChainPtr; /* The call chain being built. */ - size_t filterLength; /* Number of entries in the call chain that + int filterLength; /* Number of entries in the call chain that * are due to processing filters and not the * main call chain. */ Object *oPtr; /* The object that we are building the chain @@ -139,7 +139,7 @@ static inline int IsStillValid(CallChain *callPtr, Object *oPtr, int flags, int reuseMask); static Tcl_NRPostProc ResetFilterFlags; static Tcl_NRPostProc SetFilterFlags; -static size_t SortMethodNames(Tcl_HashTable *namesPtr, int flags, +static int SortMethodNames(Tcl_HashTable *namesPtr, int flags, const char ***stringsPtr); static inline void StashCallChain(Tcl_Obj *objPtr, CallChain *callPtr); @@ -152,8 +152,7 @@ static const Tcl_ObjType methodNameType = { FreeMethodNameRep, DupMethodNameRep, NULL, - NULL, - TCL_OBJTYPE_V0 + NULL }; @@ -208,7 +207,7 @@ TclOODeleteChainCache( } } Tcl_DeleteHashTable(tablePtr); - Tcl_Free(tablePtr); + ckfree(tablePtr); } /* @@ -229,9 +228,9 @@ TclOODeleteChain( return; } if (callPtr->chain != callPtr->staticChain) { - Tcl_Free(callPtr->chain); + ckfree(callPtr->chain); } - Tcl_Free(callPtr); + ckfree(callPtr); } /* @@ -329,7 +328,7 @@ TclOOInvokeContext( */ if (contextPtr->index == 0) { - Tcl_Size i; + int i; for (i = 0 ; i < contextPtr->callPtr->numChain ; i++) { AddRef(contextPtr->callPtr->chain[i].mPtr); @@ -372,11 +371,7 @@ TclOOInvokeContext( * Run the method implementation. */ - if (mPtr->typePtr->version < TCL_OO_METHOD_VERSION_2) { - return (mPtr->typePtr->callProc)(mPtr->clientData, interp, - (Tcl_ObjectContext) contextPtr, objc, objv); - } - return ((Tcl_MethodCallProc2 *)(void *)(mPtr->typePtr->callProc))(mPtr->clientData, interp, + return (mPtr->typePtr->callProc)(mPtr->clientData, interp, (Tcl_ObjectContext) contextPtr, objc, objv); } @@ -411,7 +406,7 @@ FinalizeMethodRefs( int result) { CallContext *contextPtr = (CallContext *)data[0]; - Tcl_Size i; + int i; for (i = 0 ; i < contextPtr->callPtr->numChain ; i++) { TclOODelMethodRef(contextPtr->callPtr->chain[i].mPtr); @@ -452,7 +447,7 @@ TclOOGetSortedMethodList( * at. Is set-like in nature and keyed by * pointer to class. */ FOREACH_HASH_DECLS; - Tcl_Size i, numStrings; + int i, numStrings; Class *mixinPtr; Tcl_Obj *namePtr; Method *mPtr; @@ -528,7 +523,7 @@ TclOOGetSortedMethodList( return numStrings; } -size_t +int TclOOGetSortedClassMethodList( Class *clsPtr, /* The class to get the method names for. */ int flags, /* Whether we just want the public method @@ -542,7 +537,7 @@ TclOOGetSortedClassMethodList( /* Used to track what classes have been looked * at. Is set-like in nature and keyed by * pointer to class. */ - size_t numStrings; + int numStrings; Tcl_InitObjHashTable(&names); Tcl_InitHashTable(&examinedClasses, TCL_ONE_WORD_KEYS); @@ -587,7 +582,7 @@ TclOOGetSortedClassMethodList( * ---------------------------------------------------------------------- */ -static size_t +static int SortMethodNames( Tcl_HashTable *namesPtr, /* The table of names; unsorted, but contains * whether the names are wanted and under what @@ -596,13 +591,13 @@ SortMethodNames( * 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. Tcl_Alloced() */ + * that we produce. ckalloced() */ { const char **strings; FOREACH_HASH_DECLS; Tcl_Obj *namePtr; void *isWanted; - size_t i = 0; + int i = 0; /* * See how many (visible) method names there are. If none, we do not (and @@ -620,7 +615,7 @@ SortMethodNames( * sorted when it is long enough to matter. */ - strings = (const char **)Tcl_Alloc(sizeof(char *) * namesPtr->numEntries); + strings = (const char **)ckalloc(sizeof(char *) * namesPtr->numEntries); FOREACH_HASH(namePtr, isWanted, namesPtr) { if (!WANT_PUBLIC(flags) || (PTR2INT(isWanted) & IN_LIST)) { if (PTR2INT(isWanted) & NO_IMPLEMENTATION) { @@ -642,7 +637,7 @@ SortMethodNames( } *stringsPtr = strings; } else { - Tcl_Free((void *)strings); + ckfree(strings); *stringsPtr = NULL; } return i; @@ -693,14 +688,14 @@ AddClassMethodNames( * pointers to the classes, and the values are * immaterial. */ { - Tcl_Size i; + int i; /* * If we've already started looking at this class, stop working on it now * to prevent repeated work. */ - if (Tcl_FindHashEntry(examinedClassesPtr, clsPtr)) { + if (Tcl_FindHashEntry(examinedClassesPtr, (char *) clsPtr)) { return; } @@ -717,7 +712,7 @@ AddClassMethodNames( Method *mPtr; int isNew; - (void) Tcl_CreateHashEntry(examinedClassesPtr, clsPtr, + (void) Tcl_CreateHashEntry(examinedClassesPtr, (char *) clsPtr, &isNew); if (!isNew) { break; @@ -776,7 +771,7 @@ AddPrivateMethodNames( if (IS_PRIVATE(mPtr)) { int isNew; - hPtr = Tcl_CreateHashEntry(namesPtr, namePtr, &isNew); + hPtr = Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew); Tcl_SetHashValue(hPtr, INT2PTR(IN_LIST)); } } @@ -792,7 +787,7 @@ AddStandardMethodName( if (!IS_PRIVATE(mPtr)) { int isNew; Tcl_HashEntry *hPtr = - Tcl_CreateHashEntry(namesPtr, namePtr, &isNew); + Tcl_CreateHashEntry(namesPtr, (char *) namePtr, &isNew); if (isNew) { int isWanted = (!WANT_PUBLIC(flags) || IS_PUBLIC(mPtr)) @@ -840,7 +835,7 @@ AddInstancePrivateToCallContext( int donePrivate = 0; if (oPtr->methodsPtr) { - hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, methodName); + hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodName); if (hPtr != NULL) { mPtr = (Method *)Tcl_GetHashValue(hPtr); if (IS_PRIVATE(mPtr)) { @@ -884,13 +879,12 @@ AddSimpleChainToCallContext( * NULL, either the filter was declared by the * object or this isn't a filter. */ { - Tcl_Size i; - int foundPrivate = 0, blockedUnexported = 0; + int i, foundPrivate = 0, blockedUnexported = 0; Tcl_HashEntry *hPtr; Method *mPtr; if (!(flags & (KNOWN_STATE | SPECIAL)) && oPtr->methodsPtr) { - hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, methodNameObj); + hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) methodNameObj); if (hPtr != NULL) { mPtr = (Method *)Tcl_GetHashValue(hPtr); @@ -921,7 +915,7 @@ AddSimpleChainToCallContext( flags | TRAVERSED_MIXIN, filterDecl); } if (oPtr->methodsPtr && !blockedUnexported) { - hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, methodNameObj); + hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char*) methodNameObj); if (hPtr != NULL) { mPtr = (Method *)Tcl_GetHashValue(hPtr); if (!IS_PRIVATE(mPtr)) { @@ -977,7 +971,7 @@ AddMethodToCallChain( * not passed a mixin. */ { CallChain *callPtr = cbPtr->callChainPtr; - Tcl_Size i; + int i; /* * Return if this is just an entry used to record whether this is a public @@ -1045,11 +1039,11 @@ AddMethodToCallChain( if (callPtr->numChain == CALL_CHAIN_STATIC_SIZE) { callPtr->chain = - (struct MInvoke *)Tcl_Alloc(sizeof(struct MInvoke) * (callPtr->numChain + 1)); + (struct MInvoke *)ckalloc(sizeof(struct MInvoke) * (callPtr->numChain + 1)); memcpy(callPtr->chain, callPtr->staticChain, sizeof(struct MInvoke) * callPtr->numChain); } else if (callPtr->numChain > CALL_CHAIN_STATIC_SIZE) { - callPtr->chain = (struct MInvoke *)Tcl_Realloc(callPtr->chain, + callPtr->chain = (struct MInvoke *)ckrealloc(callPtr->chain, sizeof(struct MInvoke) * (callPtr->numChain + 1)); } callPtr->chain[i].mPtr = mPtr; @@ -1157,7 +1151,7 @@ TclOOGetCallContext( CallContext *contextPtr; CallChain *callPtr; struct ChainBuilder cb; - Tcl_Size i, count; + int i, count; int doFilters, donePrivate = 0; Tcl_HashEntry *hPtr; Tcl_HashTable doneFilters; @@ -1213,14 +1207,14 @@ TclOOGetCallContext( if (oPtr->flags & USE_CLASS_CACHE) { if (oPtr->selfCls->classChainCache != NULL) { hPtr = Tcl_FindHashEntry(oPtr->selfCls->classChainCache, - methodNameObj); + (char *) methodNameObj); } else { hPtr = NULL; } } else { if (oPtr->chainCache != NULL) { hPtr = Tcl_FindHashEntry(oPtr->chainCache, - methodNameObj); + (char *) methodNameObj); } else { hPtr = NULL; } @@ -1239,7 +1233,7 @@ TclOOGetCallContext( doFilters = 1; } - callPtr = (CallChain *)Tcl_Alloc(sizeof(CallChain)); + callPtr = (CallChain *)ckalloc(sizeof(CallChain)); InitCallChain(callPtr, oPtr, flags); cb.callChainPtr = callPtr; @@ -1257,7 +1251,7 @@ TclOOGetCallContext( AddSimpleChainToCallContext(oPtr, NULL, oPtr->fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL); callPtr->flags |= OO_UNKNOWN_METHOD; - callPtr->epoch = 0; + callPtr->epoch = -1; if (callPtr->numChain == 0) { TclOODeleteChain(callPtr); return NULL; @@ -1334,31 +1328,30 @@ TclOOGetCallContext( AddSimpleChainToCallContext(oPtr, NULL, oPtr->fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL); callPtr->flags |= OO_UNKNOWN_METHOD; - callPtr->epoch = 0; + callPtr->epoch = -1; if (count == callPtr->numChain) { TclOODeleteChain(callPtr); return NULL; } } else if (doFilters && !donePrivate) { if (hPtr == NULL) { - int isNew; if (oPtr->flags & USE_CLASS_CACHE) { if (oPtr->selfCls->classChainCache == NULL) { oPtr->selfCls->classChainCache = - (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); + (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); Tcl_InitObjHashTable(oPtr->selfCls->classChainCache); } hPtr = Tcl_CreateHashEntry(oPtr->selfCls->classChainCache, - methodNameObj, &isNew); + (char *) methodNameObj, &i); } else { if (oPtr->chainCache == NULL) { - oPtr->chainCache = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); + oPtr->chainCache = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); Tcl_InitObjHashTable(oPtr->chainCache); } hPtr = Tcl_CreateHashEntry(oPtr->chainCache, - methodNameObj, &isNew); + (char *) methodNameObj, &i); } } callPtr->refCount++; @@ -1418,7 +1411,7 @@ TclOOGetStereotypeCallChain( { CallChain *callPtr; struct ChainBuilder cb; - Tcl_Size count; + int i, count; Foundation *fPtr = clsPtr->thisPtr->fPtr; Tcl_HashEntry *hPtr; Tcl_HashTable doneFilters; @@ -1444,7 +1437,7 @@ TclOOGetStereotypeCallChain( if (clsPtr->classChainCache != NULL) { hPtr = Tcl_FindHashEntry(clsPtr->classChainCache, - methodNameObj); + (char *) methodNameObj); if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) { const int reuseMask = (WANT_PUBLIC(flags) ? ~0 : ~PUBLIC_METHOD); @@ -1460,7 +1453,7 @@ TclOOGetStereotypeCallChain( hPtr = NULL; } - callPtr = (CallChain *)Tcl_Alloc(sizeof(CallChain)); + callPtr = (CallChain *)ckalloc(sizeof(CallChain)); memset(callPtr, 0, sizeof(CallChain)); callPtr->flags = flags & (PUBLIC_METHOD|PRIVATE_METHOD|FILTER_HANDLING); callPtr->epoch = fPtr->epoch; @@ -1507,20 +1500,19 @@ TclOOGetStereotypeCallChain( AddSimpleChainToCallContext(&obj, NULL, fPtr->unknownMethodNameObj, &cb, NULL, 0, NULL); callPtr->flags |= OO_UNKNOWN_METHOD; - callPtr->epoch = 0; + callPtr->epoch = -1; if (count == callPtr->numChain) { TclOODeleteChain(callPtr); return NULL; } } else { if (hPtr == NULL) { - int isNew; if (clsPtr->classChainCache == NULL) { - clsPtr->classChainCache = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); + clsPtr->classChainCache = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); Tcl_InitObjHashTable(clsPtr->classChainCache); } hPtr = Tcl_CreateHashEntry(clsPtr->classChainCache, - methodNameObj, &isNew); + (char *) methodNameObj, &i); } callPtr->refCount++; Tcl_SetHashValue(hPtr, callPtr); @@ -1553,7 +1545,7 @@ AddClassFiltersToCallContext( int flags) /* Whether we've gone along a mixin link * yet. */ { - Tcl_Size i; + int i; int clearedFlags = flags & ~(TRAVERSED_MIXIN|OBJECT_MIXIN|BUILDING_MIXINS); Class *superPtr, *mixinPtr; @@ -1584,7 +1576,8 @@ AddClassFiltersToCallContext( FOREACH(filterObj, clsPtr->filters) { int isNew; - (void) Tcl_CreateHashEntry(doneFilters, filterObj, &isNew); + (void) Tcl_CreateHashEntry(doneFilters, (char *) filterObj, + &isNew); if (isNew) { AddSimpleChainToCallContext(oPtr, NULL, filterObj, cbPtr, doneFilters, clearedFlags|BUILDING_MIXINS, clsPtr); @@ -1642,7 +1635,7 @@ AddPrivatesFromClassChainToCallContext( * NULL, either the filter was declared by the * object or this isn't a filter. */ { - Tcl_Size i; + int i; Class *superPtr; /* @@ -1720,8 +1713,7 @@ AddSimpleClassChainToCallContext( * NULL, either the filter was declared by the * object or this isn't a filter. */ { - Tcl_Size i; - int privateDanger = 0; + int i, privateDanger = 0; Class *superPtr; /* @@ -1747,7 +1739,7 @@ AddSimpleClassChainToCallContext( filterDecl, flags); } else { Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&classPtr->classMethods, - methodNameObj); + (char *) methodNameObj); if (classPtr->flags & HAS_PRIVATE_METHODS) { privateDanger |= 1; @@ -1806,7 +1798,7 @@ TclOORenderCallChain( Tcl_Obj *filterLiteral, *methodLiteral, *objectLiteral, *privateLiteral; Tcl_Obj *resultObj, *descObjs[4], **objv; Foundation *fPtr = TclOOGetFoundation(interp); - Tcl_Size i; + int i; /* * Allocate the literals (potentially) used in our description. @@ -1936,7 +1928,7 @@ TclOOGetDefineContextNamespace( Tcl_ResetResult(interp); } if (define.list != staticSpace) { - Tcl_Free(define.list); + ckfree(define.list); } return nsPtr; } @@ -1962,7 +1954,7 @@ AddSimpleDefineNamespaces( * building. */ { Class *mixinPtr; - Tcl_Size i; + int i; FOREACH(mixinPtr, oPtr->mixins) { AddSimpleClassDefineNamespaces(mixinPtr, definePtr, @@ -1991,7 +1983,7 @@ AddSimpleClassDefineNamespaces( int flags) /* What sort of define chain are we * building. */ { - Tcl_Size i; + int i; Class *superPtr; /* @@ -2101,11 +2093,11 @@ AddDefinitionNamespaceToChain( DefineEntry *staticList = definePtr->list; definePtr->list = - (DefineEntry *)Tcl_Alloc(sizeof(DefineEntry) * definePtr->size); + (DefineEntry *)ckalloc(sizeof(DefineEntry) * definePtr->size); memcpy(definePtr->list, staticList, sizeof(DefineEntry) * definePtr->num); } else { - definePtr->list = (DefineEntry *)Tcl_Realloc(definePtr->list, + definePtr->list = (DefineEntry *)ckrealloc(definePtr->list, sizeof(DefineEntry) * definePtr->size); } } diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h index 68c5b2b..6126fe2 100644 --- a/generic/tclOODecls.h +++ b/generic/tclOODecls.h @@ -123,20 +123,10 @@ TCLAPI Tcl_Class Tcl_GetClassOfObject(Tcl_Object object); /* 31 */ TCLAPI Tcl_Obj * Tcl_GetObjectClassName(Tcl_Interp *interp, Tcl_Object object); -/* 32 */ -TCLAPI int Tcl_MethodIsType2(Tcl_Method method, - const Tcl_MethodType2 *typePtr, - void **clientDataPtr); -/* 33 */ -TCLAPI Tcl_Method Tcl_NewInstanceMethod2(Tcl_Interp *interp, - Tcl_Object object, Tcl_Obj *nameObj, - int flags, const Tcl_MethodType2 *typePtr, - void *clientData); +/* Slot 32 is reserved */ +/* Slot 33 is reserved */ /* 34 */ -TCLAPI Tcl_Method Tcl_NewMethod2(Tcl_Interp *interp, Tcl_Class cls, - Tcl_Obj *nameObj, int flags, - const Tcl_MethodType2 *typePtr, - void *clientData); +TCLAPI void TclOOUnusedStubEntry(void); typedef struct { const struct TclOOIntStubs *tclOOIntStubs; @@ -178,9 +168,9 @@ typedef struct TclOOStubs { int (*tcl_MethodIsPrivate) (Tcl_Method method); /* 29 */ Tcl_Class (*tcl_GetClassOfObject) (Tcl_Object object); /* 30 */ Tcl_Obj * (*tcl_GetObjectClassName) (Tcl_Interp *interp, Tcl_Object object); /* 31 */ - int (*tcl_MethodIsType2) (Tcl_Method method, const Tcl_MethodType2 *typePtr, void **clientDataPtr); /* 32 */ - Tcl_Method (*tcl_NewInstanceMethod2) (Tcl_Interp *interp, Tcl_Object object, Tcl_Obj *nameObj, int flags, const Tcl_MethodType2 *typePtr, void *clientData); /* 33 */ - Tcl_Method (*tcl_NewMethod2) (Tcl_Interp *interp, Tcl_Class cls, Tcl_Obj *nameObj, int flags, const Tcl_MethodType2 *typePtr, void *clientData); /* 34 */ + void (*reserved32)(void); + void (*reserved33)(void); + void (*tclOOUnusedStubEntry) (void); /* 34 */ } TclOOStubs; extern const TclOOStubs *tclOOStubsPtr; @@ -259,25 +249,19 @@ extern const TclOOStubs *tclOOStubsPtr; (tclOOStubsPtr->tcl_GetClassOfObject) /* 30 */ #define Tcl_GetObjectClassName \ (tclOOStubsPtr->tcl_GetObjectClassName) /* 31 */ -#define Tcl_MethodIsType2 \ - (tclOOStubsPtr->tcl_MethodIsType2) /* 32 */ -#define Tcl_NewInstanceMethod2 \ - (tclOOStubsPtr->tcl_NewInstanceMethod2) /* 33 */ -#define Tcl_NewMethod2 \ - (tclOOStubsPtr->tcl_NewMethod2) /* 34 */ +/* Slot 32 is reserved */ +/* Slot 33 is reserved */ +#define TclOOUnusedStubEntry \ + (tclOOStubsPtr->tclOOUnusedStubEntry) /* 34 */ #endif /* defined(USE_TCLOO_STUBS) */ /* !END!: Do not edit above this line. */ -#if TCL_MAJOR_VERSION < 9 - /* TIP #630 for 8.7 */ -# undef Tcl_MethodIsType2 -# define Tcl_MethodIsType2 Tcl_MethodIsType -# undef Tcl_NewInstanceMethod2 -# define Tcl_NewInstanceMethod2 Tcl_NewInstanceMethod -# undef Tcl_NewMethod2 -# define Tcl_NewMethod2 Tcl_NewMethod -#endif +#undef TclOOUnusedStubEntry +#define Tcl_MethodIsType2 Tcl_MethodIsType +#define Tcl_NewInstanceMethod2 Tcl_NewInstanceMethod +#define Tcl_NewMethod2 Tcl_NewMethod + #endif /* _TCLOODECLS */ diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 7bee39b..e244683 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -79,55 +79,18 @@ static inline void RecomputeClassCacheFlag(Object *oPtr); static int RenameDeleteMethod(Tcl_Interp *interp, Object *oPtr, int useClass, Tcl_Obj *const fromPtr, Tcl_Obj *const toPtr); -static int ClassFilterGet(void *clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -static int ClassFilterSet(void *clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -static int ClassMixinGet(void *clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -static int ClassMixinSet(void *clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -static int ClassSuperGet(void *clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -static int ClassSuperSet(void *clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -static int ClassVarsGet(void *clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -static int ClassVarsSet(void *clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); +static Tcl_MethodCallProc ClassFilterGet, ClassFilterSet; +static Tcl_MethodCallProc ClassMixinGet, ClassMixinSet; static Tcl_MethodCallProc ClassRPropsGet, ClassRPropsSet; +static Tcl_MethodCallProc ClassSuperGet, ClassSuperSet; +static Tcl_MethodCallProc ClassVarsGet, ClassVarsSet; static Tcl_MethodCallProc ClassWPropsGet, ClassWPropsSet; -static int ObjFilterGet(void *clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -static int ObjFilterSet(void *clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -static int ObjMixinGet(void *clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -static int ObjMixinSet(void *clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -static int ObjVarsGet(void *clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); -static int ObjVarsSet(void *clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); +static Tcl_MethodCallProc ObjFilterGet, ObjFilterSet; +static Tcl_MethodCallProc ObjMixinGet, ObjMixinSet; static Tcl_MethodCallProc ObjRPropsGet, ObjRPropsSet; +static Tcl_MethodCallProc ObjVarsGet, ObjVarsSet; static Tcl_MethodCallProc ObjWPropsGet, ObjWPropsSet; -static int ResolveClass(void *clientData, - Tcl_Interp *interp, Tcl_ObjectContext context, - int objc, Tcl_Obj *const *objv); +static Tcl_MethodCallProc ResolveClass; /* * Now define the slots used in declarations. @@ -302,10 +265,10 @@ RecomputeClassCacheFlag( void TclOOObjectSetFilters( Object *oPtr, - Tcl_Size numFilters, + int numFilters, Tcl_Obj *const *filters) { - Tcl_Size i; + int i; if (oPtr->filters.num) { Tcl_Obj *filterObj; @@ -320,7 +283,7 @@ TclOOObjectSetFilters( * No list of filters was supplied, so we're deleting filters. */ - Tcl_Free(oPtr->filters.list); + ckfree(oPtr->filters.list); oPtr->filters.list = NULL; oPtr->filters.num = 0; RecomputeClassCacheFlag(oPtr); @@ -333,9 +296,9 @@ TclOOObjectSetFilters( int size = sizeof(Tcl_Obj *) * numFilters; /* should be size_t */ if (oPtr->filters.num == 0) { - filtersList = (Tcl_Obj **)Tcl_Alloc(size); + filtersList = (Tcl_Obj **)ckalloc(size); } else { - filtersList = (Tcl_Obj **)Tcl_Realloc(oPtr->filters.list, size); + filtersList = (Tcl_Obj **)ckrealloc(oPtr->filters.list, size); } for (i = 0 ; i < numFilters ; i++) { filtersList[i] = filters[i]; @@ -362,10 +325,10 @@ void TclOOClassSetFilters( Tcl_Interp *interp, Class *classPtr, - Tcl_Size numFilters, + int numFilters, Tcl_Obj *const *filters) { - Tcl_Size i; + int i; if (classPtr->filters.num) { Tcl_Obj *filterObj; @@ -380,7 +343,7 @@ TclOOClassSetFilters( * No list of filters was supplied, so we're deleting filters. */ - Tcl_Free(classPtr->filters.list); + ckfree(classPtr->filters.list); classPtr->filters.list = NULL; classPtr->filters.num = 0; } else { @@ -392,9 +355,9 @@ TclOOClassSetFilters( int size = sizeof(Tcl_Obj *) * numFilters; /* should be size_t */ if (classPtr->filters.num == 0) { - filtersList = (Tcl_Obj **)Tcl_Alloc(size); + filtersList = (Tcl_Obj **)ckalloc(size); } else { - filtersList = (Tcl_Obj **)Tcl_Realloc(classPtr->filters.list, size); + filtersList = (Tcl_Obj **)ckrealloc(classPtr->filters.list, size); } for (i = 0 ; i < numFilters ; i++) { filtersList[i] = filters[i]; @@ -424,11 +387,11 @@ TclOOClassSetFilters( void TclOOObjectSetMixins( Object *oPtr, - Tcl_Size numMixins, + int numMixins, Class *const *mixins) { Class *mixinPtr; - Tcl_Size i; + int i; if (numMixins == 0) { if (oPtr->mixins.num != 0) { @@ -436,7 +399,7 @@ TclOOObjectSetMixins( TclOORemoveFromInstances(oPtr, mixinPtr); TclOODecrRefCount(mixinPtr->thisPtr); } - Tcl_Free(oPtr->mixins.list); + ckfree(oPtr->mixins.list); oPtr->mixins.num = 0; } RecomputeClassCacheFlag(oPtr); @@ -448,10 +411,10 @@ TclOOObjectSetMixins( } TclOODecrRefCount(mixinPtr->thisPtr); } - oPtr->mixins.list = (Class **)Tcl_Realloc(oPtr->mixins.list, + oPtr->mixins.list = (Class **)ckrealloc(oPtr->mixins.list, sizeof(Class *) * numMixins); } else { - oPtr->mixins.list = (Class **)Tcl_Alloc(sizeof(Class *) * numMixins); + oPtr->mixins.list = (Class **)ckalloc(sizeof(Class *) * numMixins); oPtr->flags &= ~USE_CLASS_CACHE; } oPtr->mixins.num = numMixins; @@ -485,11 +448,11 @@ void TclOOClassSetMixins( Tcl_Interp *interp, Class *classPtr, - Tcl_Size numMixins, + int numMixins, Class *const *mixins) { Class *mixinPtr; - Tcl_Size i; + int i; if (numMixins == 0) { if (classPtr->mixins.num != 0) { @@ -497,7 +460,7 @@ TclOOClassSetMixins( TclOORemoveFromMixinSubs(classPtr, mixinPtr); TclOODecrRefCount(mixinPtr->thisPtr); } - Tcl_Free(classPtr->mixins.list); + ckfree(classPtr->mixins.list); classPtr->mixins.num = 0; } } else { @@ -506,10 +469,10 @@ TclOOClassSetMixins( TclOORemoveFromMixinSubs(classPtr, mixinPtr); TclOODecrRefCount(mixinPtr->thisPtr); } - classPtr->mixins.list = (Class **)Tcl_Realloc(classPtr->mixins.list, + classPtr->mixins.list = (Class **)ckrealloc(classPtr->mixins.list, sizeof(Class *) * numMixins); } else { - classPtr->mixins.list = (Class **)Tcl_Alloc(sizeof(Class *) * numMixins); + classPtr->mixins.list = (Class **)ckalloc(sizeof(Class *) * numMixins); } classPtr->mixins.num = numMixins; memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins); @@ -539,12 +502,11 @@ TclOOClassSetMixins( static inline void InstallStandardVariableMapping( VariableNameList *vnlPtr, - Tcl_Size varc, + int varc, Tcl_Obj *const *varv) { Tcl_Obj *variableObj; - Tcl_Size i, n; - int created; + int i, n, created; Tcl_HashTable uniqueTable; for (i=0 ; i<varc ; i++) { @@ -555,11 +517,11 @@ InstallStandardVariableMapping( } if (i != varc) { if (varc == 0) { - Tcl_Free(vnlPtr->list); + ckfree(vnlPtr->list); } else if (i) { - vnlPtr->list = (Tcl_Obj **)Tcl_Realloc(vnlPtr->list, sizeof(Tcl_Obj *) * varc); + vnlPtr->list = (Tcl_Obj **)ckrealloc(vnlPtr->list, sizeof(Tcl_Obj *) * varc); } else { - vnlPtr->list = (Tcl_Obj **)Tcl_Alloc(sizeof(Tcl_Obj *) * varc); + vnlPtr->list = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * varc); } } vnlPtr->num = 0; @@ -580,7 +542,7 @@ InstallStandardVariableMapping( */ if (n != varc) { - vnlPtr->list = (Tcl_Obj **)Tcl_Realloc(vnlPtr->list, sizeof(Tcl_Obj *) * n); + vnlPtr->list = (Tcl_Obj **)ckrealloc(vnlPtr->list, sizeof(Tcl_Obj *) * n); } Tcl_DeleteHashTable(&uniqueTable); } @@ -589,13 +551,12 @@ InstallStandardVariableMapping( static inline void InstallPrivateVariableMapping( PrivateVariableList *pvlPtr, - Tcl_Size varc, + int varc, Tcl_Obj *const *varv, int creationEpoch) { PrivateVariableMapping *privatePtr; - Tcl_Size i, n; - int created; + int i, n, created; Tcl_HashTable uniqueTable; for (i=0 ; i<varc ; i++) { @@ -607,12 +568,12 @@ InstallPrivateVariableMapping( } if (i != varc) { if (varc == 0) { - Tcl_Free(pvlPtr->list); + ckfree(pvlPtr->list); } else if (i) { - pvlPtr->list = (PrivateVariableMapping *)Tcl_Realloc(pvlPtr->list, + pvlPtr->list = (PrivateVariableMapping *)ckrealloc(pvlPtr->list, sizeof(PrivateVariableMapping) * varc); } else { - pvlPtr->list = (PrivateVariableMapping *)Tcl_Alloc(sizeof(PrivateVariableMapping) * varc); + pvlPtr->list = (PrivateVariableMapping *)ckalloc(sizeof(PrivateVariableMapping) * varc); } } @@ -626,7 +587,7 @@ InstallPrivateVariableMapping( privatePtr->variableObj = varv[i]; privatePtr->fullNameObj = Tcl_ObjPrintf( PRIVATE_VARIABLE_PATTERN, - creationEpoch, TclGetString(varv[i])); + creationEpoch, Tcl_GetString(varv[i])); Tcl_IncrRefCount(privatePtr->fullNameObj); } else { Tcl_DecrRefCount(varv[i]); @@ -639,7 +600,7 @@ InstallPrivateVariableMapping( */ if (n != varc) { - pvlPtr->list = (PrivateVariableMapping *)Tcl_Realloc(pvlPtr->list, + pvlPtr->list = (PrivateVariableMapping *)ckrealloc(pvlPtr->list, sizeof(PrivateVariableMapping) * n); } Tcl_DeleteHashTable(&uniqueTable); @@ -677,12 +638,12 @@ RenameDeleteMethod( TclGetString(fromPtr), (char *)NULL); return TCL_ERROR; } - hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, fromPtr); + hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) fromPtr); if (hPtr == NULL) { goto noSuchMethod; } if (toPtr) { - newHPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, toPtr, + newHPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) toPtr, &isNew); if (hPtr == newHPtr) { renameToSelf: @@ -700,7 +661,8 @@ RenameDeleteMethod( } } } else { - hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods, fromPtr); + hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods, + (char *) fromPtr); if (hPtr == NULL) { goto noSuchMethod; } @@ -750,7 +712,7 @@ RenameDeleteMethod( int TclOOUnknownDefinition( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -758,7 +720,7 @@ TclOOUnknownDefinition( Namespace *nsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); Tcl_HashSearch search; Tcl_HashEntry *hPtr; - Tcl_Size soughtLen; + int soughtLen; const char *soughtStr, *matchedStr = NULL; if (objc < 2) { @@ -832,7 +794,7 @@ FindCommand( Tcl_Obj *stringObj, Tcl_Namespace *const namespacePtr) { - Tcl_Size length; + int length; const char *nameStr, *string = TclGetStringFromObj(stringObj, &length); Namespace *const nsPtr = (Namespace *) namespacePtr; FOREACH_HASH_DECLS; @@ -1051,7 +1013,7 @@ GenerateErrorInfo( * an object, class or class-as-object that * was being configured. */ { - Tcl_Size length; + int length; Tcl_Obj *realNameObj = Tcl_ObjectDeleted((Tcl_Object) oPtr) ? savedNameObj : TclOOObjectName(interp, oPtr); const char *objName = TclGetStringFromObj(realNameObj, &length); @@ -1060,7 +1022,7 @@ GenerateErrorInfo( Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (in definition script for %s \"%.*s%s\" line %d)", - typeOfSubject, (overflow ? limit : (int)length), objName, + typeOfSubject, (overflow ? limit : length), objName, (overflow ? "..." : ""), Tcl_GetErrorLine(interp))); } @@ -1087,8 +1049,7 @@ MagicDefinitionInvoke( { Tcl_Obj *objPtr, *obj2Ptr, **objs; Tcl_Command cmd; - int isRoot, result, offset = cmdIndex + 1; - Tcl_Size dummy; + int isRoot, dummy, result, offset = cmdIndex + 1; /* * More than one argument: fire them through the ensemble processing @@ -1148,7 +1109,7 @@ MagicDefinitionInvoke( int TclOODefineObjCmd( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -1224,7 +1185,7 @@ TclOODefineObjCmd( int TclOOObjDefObjCmd( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -1293,7 +1254,7 @@ TclOOObjDefObjCmd( int TclOODefineSelfObjCmd( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -1364,7 +1325,7 @@ TclOODefineSelfObjCmd( int TclOODefineObjSelfObjCmd( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -1398,7 +1359,7 @@ TclOODefineObjSelfObjCmd( int TclOODefinePrivateObjCmd( - void *clientData, + ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -1471,7 +1432,7 @@ TclOODefinePrivateObjCmd( int TclOODefineClassObjCmd( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -1552,8 +1513,8 @@ TclOODefineClassObjCmd( TclOODeleteDescendants(interp, oPtr); oPtr->flags &= ~DONT_DELETE; TclOOReleaseClassContents(interp, oPtr); - Tcl_Free(oPtr->classPtr); - oPtr->classPtr = NULL; + ckfree(oPtr->classPtr); + oPtr->classPtr = NULL; } else if (!wasClass && willBeClass) { TclOOAllocClass(interp, oPtr); } @@ -1580,7 +1541,7 @@ TclOODefineClassObjCmd( int TclOODefineConstructorObjCmd( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -1588,7 +1549,7 @@ TclOODefineConstructorObjCmd( Object *oPtr; Class *clsPtr; Tcl_Method method; - Tcl_Size bodyLength; + int bodyLength; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "arguments body"); @@ -1606,7 +1567,7 @@ TclOODefineConstructorObjCmd( } clsPtr = oPtr->classPtr; - (void)TclGetStringFromObj(objv[2], &bodyLength); + TclGetStringFromObj(objv[2], &bodyLength); if (bodyLength > 0) { /* * Create the method structure. @@ -1649,7 +1610,7 @@ TclOODefineConstructorObjCmd( int TclOODefineDefnNsObjCmd( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -1694,7 +1655,7 @@ TclOODefineDefnNsObjCmd( &kind) != TCL_OK) { return TCL_ERROR; } - if (!TclGetString(objv[objc - 1])[0]) { + if (!Tcl_GetString(objv[objc - 1])[0]) { nsNamePtr = NULL; } else { nsPtr = GetNamespaceInOuterContext(interp, objv[objc - 1]); @@ -1734,7 +1695,7 @@ TclOODefineDefnNsObjCmd( int TclOODefineDeleteMethodObjCmd( - void *clientData, + ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -1791,7 +1752,7 @@ TclOODefineDeleteMethodObjCmd( int TclOODefineDestructorObjCmd( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -1799,7 +1760,7 @@ TclOODefineDestructorObjCmd( Object *oPtr; Class *clsPtr; Tcl_Method method; - Tcl_Size bodyLength; + int bodyLength; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "body"); @@ -1812,7 +1773,7 @@ TclOODefineDestructorObjCmd( } clsPtr = oPtr->classPtr; - (void)TclGetStringFromObj(objv[1], &bodyLength); + TclGetStringFromObj(objv[1], &bodyLength); if (bodyLength > 0) { /* * Create the method structure. @@ -1856,7 +1817,7 @@ TclOODefineDestructorObjCmd( int TclOODefineExportObjCmd( - void *clientData, + ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -1897,19 +1858,19 @@ TclOODefineExportObjCmd( if (isInstanceExport) { if (!oPtr->methodsPtr) { - oPtr->methodsPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); + oPtr->methodsPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); Tcl_InitObjHashTable(oPtr->methodsPtr); oPtr->flags &= ~USE_CLASS_CACHE; } - hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, objv[i], + hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) objv[i], &isNew); } else { - hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, objv[i], + hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char*) objv[i], &isNew); } if (isNew) { - mPtr = (Method *)Tcl_Alloc(sizeof(Method)); + mPtr = (Method *)ckalloc(sizeof(Method)); memset(mPtr, 0, sizeof(Method)); mPtr->refCount = 1; mPtr->namePtr = objv[i]; @@ -1952,7 +1913,7 @@ TclOODefineExportObjCmd( int TclOODefineForwardObjCmd( - void *clientData, + ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -2016,7 +1977,7 @@ TclOODefineForwardObjCmd( int TclOODefineMethodObjCmd( - void *clientData, + ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -2112,7 +2073,7 @@ TclOODefineMethodObjCmd( int TclOODefineRenameMethodObjCmd( - void *clientData, + ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -2169,7 +2130,7 @@ TclOODefineRenameMethodObjCmd( int TclOODefineUnexportObjCmd( - void *clientData, + ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) @@ -2210,19 +2171,19 @@ TclOODefineUnexportObjCmd( if (isInstanceUnexport) { if (!oPtr->methodsPtr) { - oPtr->methodsPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); + oPtr->methodsPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); Tcl_InitObjHashTable(oPtr->methodsPtr); oPtr->flags &= ~USE_CLASS_CACHE; } - hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, objv[i], + hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) objv[i], &isNew); } else { - hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, objv[i], + hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char*) objv[i], &isNew); } if (isNew) { - mPtr = (Method *)Tcl_Alloc(sizeof(Method)); + mPtr = (Method *)ckalloc(sizeof(Method)); memset(mPtr, 0, sizeof(Method)); mPtr->refCount = 1; mPtr->namePtr = objv[i]; @@ -2328,7 +2289,7 @@ TclOODefineSlots( Class *slotCls; slotCls = ((Object *) Tcl_NewObjectInstance(fPtr->interp, (Tcl_Class) - fPtr->classCls, "::oo::Slot", NULL, TCL_INDEX_NONE, NULL, 0))->classPtr; + fPtr->classCls, "::oo::Slot", NULL, -1, NULL, 0))->classPtr; if (slotCls == NULL) { return TCL_ERROR; } @@ -2337,17 +2298,17 @@ TclOODefineSlots( Tcl_IncrRefCount(resolveName); for (slotInfoPtr = slots ; slotInfoPtr->name ; slotInfoPtr++) { Tcl_Object slotObject = Tcl_NewObjectInstance(fPtr->interp, - (Tcl_Class) slotCls, slotInfoPtr->name, NULL, TCL_INDEX_NONE, NULL, 0); + (Tcl_Class) slotCls, slotInfoPtr->name, NULL, -1, NULL, 0); if (slotObject == NULL) { continue; } - TclNewInstanceMethod(fPtr->interp, slotObject, getName, 0, + Tcl_NewInstanceMethod(fPtr->interp, slotObject, getName, 0, &slotInfoPtr->getterType, NULL); - TclNewInstanceMethod(fPtr->interp, slotObject, setName, 0, + Tcl_NewInstanceMethod(fPtr->interp, slotObject, setName, 0, &slotInfoPtr->setterType, NULL); if (slotInfoPtr->resolverType.callProc) { - TclNewInstanceMethod(fPtr->interp, slotObject, resolveName, 0, + Tcl_NewInstanceMethod(fPtr->interp, slotObject, resolveName, 0, &slotInfoPtr->resolverType, NULL); } } @@ -2370,7 +2331,7 @@ TclOODefineSlots( static int ClassFilterGet( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, @@ -2378,7 +2339,7 @@ ClassFilterGet( { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); Tcl_Obj *resultObj, *filterObj; - Tcl_Size i; + int i; if (Tcl_ObjectContextSkippedArgs(context) != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, @@ -2404,14 +2365,14 @@ ClassFilterGet( static int ClassFilterSet( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Size filterc; + int filterc; Tcl_Obj **filterv; if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { @@ -2450,7 +2411,7 @@ ClassFilterSet( static int ClassMixinGet( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, @@ -2459,7 +2420,7 @@ ClassMixinGet( Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); Tcl_Obj *resultObj; Class *mixinPtr; - Tcl_Size i; + int i; if (Tcl_ObjectContextSkippedArgs(context) != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, @@ -2487,21 +2448,20 @@ ClassMixinGet( static int ClassMixinSet( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Size mixinc, i; + int mixinc, i, isNew; Tcl_Obj **mixinv; - Class **mixins; /* The references to the classes to actually + Class **mixins;; /* The references to the classes to actually * install. */ Tcl_HashTable uniqueCheck; /* Note that this hash table is just used as a * set of class references; it has no payload * values and keys are always pointers. */ - int isNew; if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, @@ -2571,7 +2531,7 @@ ClassMixinSet( static int ClassSuperGet( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, @@ -2580,7 +2540,7 @@ ClassSuperGet( Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); Tcl_Obj *resultObj; Class *superPtr; - Tcl_Size i; + int i; if (Tcl_ObjectContextSkippedArgs(context) != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, @@ -2607,15 +2567,14 @@ ClassSuperGet( static int ClassSuperSet( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Size superc, j; - Tcl_Size i; + int superc, i, j; Tcl_Obj **superv; Class **superclasses, *superPtr; @@ -2647,7 +2606,7 @@ ClassSuperSet( * Allocate some working space. */ - superclasses = (Class **) Tcl_Alloc(sizeof(Class *) * superc); + superclasses = (Class **) ckalloc(sizeof(Class *) * superc); /* * Parse the arguments to get the class to use as superclasses. @@ -2657,7 +2616,7 @@ ClassSuperSet( */ if (superc == 0) { - superclasses = (Class **)Tcl_Realloc(superclasses, sizeof(Class *)); + superclasses = (Class **)ckrealloc(superclasses, sizeof(Class *)); if (TclOOIsReachable(oPtr->fPtr->classCls, oPtr->classPtr)) { superclasses[0] = oPtr->fPtr->classCls; } else { @@ -2689,7 +2648,7 @@ ClassSuperSet( for (; i-- > 0 ;) { TclOODecrRefCount(superclasses[i]->thisPtr); } - Tcl_Free(superclasses); + ckfree(superclasses); return TCL_ERROR; } @@ -2714,7 +2673,7 @@ ClassSuperSet( TclOORemoveFromSubclasses(oPtr->classPtr, superPtr); TclOODecrRefCount(superPtr->thisPtr); } - Tcl_Free(oPtr->classPtr->superclasses.list); + ckfree(oPtr->classPtr->superclasses.list); } oPtr->classPtr->superclasses.list = superclasses; oPtr->classPtr->superclasses.num = superc; @@ -2739,7 +2698,7 @@ ClassSuperSet( static int ClassVarsGet( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, @@ -2747,7 +2706,7 @@ ClassVarsGet( { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); Tcl_Obj *resultObj; - Tcl_Size i; + int i; if (Tcl_ObjectContextSkippedArgs(context) != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, @@ -2783,16 +2742,16 @@ ClassVarsGet( static int ClassVarsSet( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Size i; - Tcl_Size varc; + int varc; Tcl_Obj **varv; + int i; if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, @@ -2854,7 +2813,7 @@ ClassVarsSet( static int ObjFilterGet( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, @@ -2862,7 +2821,7 @@ ObjFilterGet( { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); Tcl_Obj *resultObj, *filterObj; - Tcl_Size i; + int i; if (Tcl_ObjectContextSkippedArgs(context) != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, @@ -2882,14 +2841,14 @@ ObjFilterGet( static int ObjFilterSet( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Size filterc; + int filterc; Tcl_Obj **filterv; if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { @@ -2922,7 +2881,7 @@ ObjFilterSet( static int ObjMixinGet( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, @@ -2931,7 +2890,7 @@ ObjMixinGet( Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); Tcl_Obj *resultObj; Class *mixinPtr; - Tcl_Size i; + int i; if (Tcl_ObjectContextSkippedArgs(context) != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, @@ -2954,21 +2913,20 @@ ObjMixinGet( static int ObjMixinSet( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Size mixinc, i; + int mixinc, i, isNew; Tcl_Obj **mixinv; Class **mixins; /* The references to the classes to actually * install. */ Tcl_HashTable uniqueCheck; /* Note that this hash table is just used as a * set of class references; it has no payload * values and keys are always pointers. */ - int isNew; if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, @@ -3025,7 +2983,7 @@ ObjMixinSet( static int ObjVarsGet( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, @@ -3033,7 +2991,7 @@ ObjVarsGet( { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); Tcl_Obj *resultObj; - Tcl_Size i; + int i; if (Tcl_ObjectContextSkippedArgs(context) != objc) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, @@ -3063,14 +3021,14 @@ ObjVarsGet( static int ObjVarsSet( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv) { Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp); - Tcl_Size varc, i; + int varc, i; Tcl_Obj **varv; if (Tcl_ObjectContextSkippedArgs(context) + 1 != objc) { @@ -3128,7 +3086,7 @@ ObjVarsSet( static int ResolveClass( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, Tcl_ObjectContext context, int objc, @@ -3202,12 +3160,12 @@ InstallReadableProps( } if (i != objc) { if (objc == 0) { - Tcl_Free(props->readable.list); + ckfree(props->readable.list); } else if (i) { - props->readable.list = (Tcl_Obj **)Tcl_Realloc(props->readable.list, + props->readable.list = (Tcl_Obj **)ckrealloc(props->readable.list, sizeof(Tcl_Obj *) * objc); } else { - props->readable.list = (Tcl_Obj **)Tcl_Alloc(sizeof(Tcl_Obj *) * objc); + props->readable.list = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * objc); } } props->readable.num = 0; @@ -3228,7 +3186,7 @@ InstallReadableProps( */ if (n != objc) { - props->readable.list = (Tcl_Obj **)Tcl_Realloc(props->readable.list, + props->readable.list = (Tcl_Obj **)ckrealloc(props->readable.list, sizeof(Tcl_Obj *) * n); } Tcl_DeleteHashTable(&uniqueTable); @@ -3399,12 +3357,12 @@ InstallWritableProps( } if (i != objc) { if (objc == 0) { - Tcl_Free(props->writable.list); + ckfree(props->writable.list); } else if (i) { - props->writable.list = (Tcl_Obj **)Tcl_Realloc(props->writable.list, + props->writable.list = (Tcl_Obj **)ckrealloc(props->writable.list, sizeof(Tcl_Obj *) * objc); } else { - props->writable.list = (Tcl_Obj **)Tcl_Alloc(sizeof(Tcl_Obj *) * objc); + props->writable.list = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * objc); } } props->writable.num = 0; @@ -3425,7 +3383,7 @@ InstallWritableProps( */ if (n != objc) { - props->writable.list = (Tcl_Obj **)Tcl_Realloc(props->writable.list, + props->writable.list = (Tcl_Obj **)ckrealloc(props->writable.list, sizeof(Tcl_Obj *) * n); } Tcl_DeleteHashTable(&uniqueTable); diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c index 0b9099e..6e9c400 100644 --- a/generic/tclOOInfo.c +++ b/generic/tclOOInfo.c @@ -199,7 +199,7 @@ InfoObjectClassCmd( return TCL_OK; } else { Class *mixinPtr, *o2clsPtr; - Tcl_Size i; + int i; o2clsPtr = GetClassFromObj(interp, objv[2]); if (o2clsPtr == NULL) { @@ -257,7 +257,7 @@ InfoObjectDefnCmd( if (!oPtr->methodsPtr) { goto unknownMethod; } - hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, objv[2]); + hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]); if (hPtr == NULL) { unknownMethod: Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -312,7 +312,7 @@ InfoObjectFiltersCmd( int objc, Tcl_Obj *const objv[]) { - Tcl_Size i; + int i; Tcl_Obj *filterObj, *resultObj; Object *oPtr; @@ -368,7 +368,7 @@ InfoObjectForwardCmd( if (!oPtr->methodsPtr) { goto unknownMethod; } - hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, objv[2]); + hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]); if (hPtr == NULL) { unknownMethod: Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -413,10 +413,9 @@ InfoObjectIsACmd( }; enum IsACats { IsClass, IsMetaclass, IsMixin, IsObject, IsType - } idx; + }; Object *oPtr, *o2Ptr; - int result = 0; - Tcl_Size i; + int idx, i, result = 0; if (objc < 3) { Tcl_WrongNumArgs(interp, 1, objv, "category objName ?arg ...?"); @@ -432,7 +431,7 @@ InfoObjectIsACmd( * number of arguments. */ - switch (idx) { + switch ((enum IsACats) idx) { case IsObject: case IsClass: case IsMetaclass: @@ -460,7 +459,7 @@ InfoObjectIsACmd( goto failPrecondition; } - switch (idx) { + switch ((enum IsACats) idx) { case IsObject: result = 1; break; @@ -538,7 +537,7 @@ InfoObjectMethodsCmd( }; enum Options { OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE, OPT_SCOPE - } idx; + }; static const char *const scopes[] = { "private", "public", "unexported" }; @@ -556,14 +555,14 @@ InfoObjectMethodsCmd( return TCL_ERROR; } if (objc != 2) { - int i; + int i, idx; for (i=2 ; i<objc ; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &idx) != TCL_OK) { return TCL_ERROR; } - switch (idx) { + switch ((enum Options) idx) { case OPT_ALL: recurse = 1; break; @@ -618,7 +617,7 @@ InfoObjectMethodsCmd( Tcl_NewStringObj(names[i], -1)); } if (numNames > 0) { - Tcl_Free((void *)names); + ckfree(names); } } else if (oPtr->methodsPtr) { FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) { @@ -665,7 +664,7 @@ InfoObjectMethodTypeCmd( if (!oPtr->methodsPtr) { goto unknownMethod; } - hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, objv[2]); + hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) objv[2]); if (hPtr == NULL) { unknownMethod: Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -708,7 +707,7 @@ InfoObjectMixinsCmd( Class *mixinPtr; Object *oPtr; Tcl_Obj *resultObj; - Tcl_Size i; + int i; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "objName"); @@ -815,15 +814,14 @@ InfoObjectVariablesCmd( { Object *oPtr; Tcl_Obj *resultObj; - Tcl_Size i; - int isPrivate = 0; + int i, isPrivate = 0; if (objc != 2 && objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "objName ?-private?"); return TCL_ERROR; } if (objc == 3) { - if (strcmp("-private", TclGetString(objv[2])) != 0) { + if (strcmp("-private", Tcl_GetString(objv[2])) != 0) { return TCL_ERROR; } isPrivate = 1; @@ -1004,7 +1002,7 @@ InfoClassDefnCmd( if (clsPtr == NULL) { return TCL_ERROR; } - hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, objv[2]); + hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]); if (hPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown method \"%s\"", TclGetString(objv[2]))); @@ -1152,7 +1150,7 @@ InfoClassFiltersCmd( int objc, Tcl_Obj *const objv[]) { - Tcl_Size i; + int i; Tcl_Obj *filterObj, *resultObj; Class *clsPtr; @@ -1202,7 +1200,7 @@ InfoClassForwardCmd( if (clsPtr == NULL) { return TCL_ERROR; } - hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, objv[2]); + hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]); if (hPtr == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "unknown method \"%s\"", TclGetString(objv[2]))); @@ -1243,7 +1241,7 @@ InfoClassInstancesCmd( { Object *oPtr; Class *clsPtr; - Tcl_Size i; + int i; const char *pattern = NULL; Tcl_Obj *resultObj; @@ -1298,7 +1296,7 @@ InfoClassMethodsCmd( }; enum Options { OPT_ALL, OPT_LOCALPRIVATE, OPT_PRIVATE, OPT_SCOPE - } idx; + }; static const char *const scopes[] = { "private", "public", "unexported" }; @@ -1315,14 +1313,14 @@ InfoClassMethodsCmd( return TCL_ERROR; } if (objc != 2) { - int i; + int i, idx; for (i=2 ; i<objc ; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0, &idx) != TCL_OK) { return TCL_ERROR; } - switch (idx) { + switch ((enum Options) idx) { case OPT_ALL: recurse = 1; break; @@ -1366,14 +1364,14 @@ InfoClassMethodsCmd( TclNewObj(resultObj); if (recurse) { const char **names; - Tcl_Size i, numNames = TclOOGetSortedClassMethodList(clsPtr, flag, &names); + int i, numNames = TclOOGetSortedClassMethodList(clsPtr, flag, &names); for (i=0 ; i<numNames ; i++) { Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj(names[i], -1)); } if (numNames > 0) { - Tcl_Free((void *)names); + ckfree(names); } } else { FOREACH_HASH_DECLS; @@ -1418,7 +1416,7 @@ InfoClassMethodTypeCmd( return TCL_ERROR; } - hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, objv[2]); + hPtr = Tcl_FindHashEntry(&clsPtr->classMethods, (char *) objv[2]); if (hPtr == NULL) { unknownMethod: Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -1459,7 +1457,7 @@ InfoClassMixinsCmd( { Class *clsPtr, *mixinPtr; Tcl_Obj *resultObj; - Tcl_Size i; + int i; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "className"); @@ -1501,7 +1499,7 @@ InfoClassSubsCmd( { Class *clsPtr, *subclassPtr; Tcl_Obj *resultObj; - Tcl_Size i; + int i; const char *pattern = NULL; if (objc != 2 && objc != 3) { @@ -1556,7 +1554,7 @@ InfoClassSupersCmd( { Class *clsPtr, *superPtr; Tcl_Obj *resultObj; - Tcl_Size i; + int i; if (objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "className"); @@ -1595,15 +1593,14 @@ InfoClassVariablesCmd( { Class *clsPtr; Tcl_Obj *resultObj; - Tcl_Size i; - int isPrivate = 0; + int i, isPrivate = 0; if (objc != 2 && objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "className ?-private?"); return TCL_ERROR; } if (objc == 3) { - if (strcmp("-private", TclGetString(objv[2])) != 0) { + if (strcmp("-private", Tcl_GetString(objv[2])) != 0) { return TCL_ERROR; } isPrivate = 1; diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 031b910..82422b9 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -518,17 +518,6 @@ MODULE_SCOPE void TclOOAddToMixinSubs(Class *subPtr, Class *mixinPtr); MODULE_SCOPE void TclOOAddToSubclasses(Class *subPtr, Class *superPtr); MODULE_SCOPE Class * TclOOAllocClass(Tcl_Interp *interp, Object *useThisObj); -MODULE_SCOPE int TclMethodIsType(Tcl_Method method, - const Tcl_MethodType *typePtr, - void **clientDataPtr); -MODULE_SCOPE Tcl_Method TclNewInstanceMethod(Tcl_Interp *interp, - Tcl_Object object, Tcl_Obj *nameObj, - int flags, const Tcl_MethodType *typePtr, - void *clientData); -MODULE_SCOPE Tcl_Method TclNewMethod(Tcl_Interp *interp, Tcl_Class cls, - Tcl_Obj *nameObj, int flags, - const Tcl_MethodType *typePtr, - void *clientData); MODULE_SCOPE int TclNRNewObjectInstance(Tcl_Interp *interp, Tcl_Class cls, const char *nameStr, const char *nsNameStr, Tcl_Size objc, @@ -563,7 +552,7 @@ MODULE_SCOPE Foundation *TclOOGetFoundation(Tcl_Interp *interp); MODULE_SCOPE Tcl_Obj * TclOOGetFwdFromMethod(Method *mPtr); MODULE_SCOPE Proc * TclOOGetProcFromMethod(Method *mPtr); MODULE_SCOPE Tcl_Obj * TclOOGetMethodBody(Method *mPtr); -MODULE_SCOPE size_t TclOOGetSortedClassMethodList(Class *clsPtr, +MODULE_SCOPE int TclOOGetSortedClassMethodList(Class *clsPtr, int flags, const char ***stringsPtr); MODULE_SCOPE int TclOOGetSortedMethodList(Object *oPtr, Object *contextObj, Class *contextCls, int flags, @@ -608,7 +597,7 @@ MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr); /* * A convenience macro for iterating through the lists used in the internal * memory management of objects. - * REQUIRES DECLARATION: Tcl_Size i; + * REQUIRES DECLARATION: int i; */ #define FOREACH(var,ary) \ @@ -654,7 +643,7 @@ MODULE_SCOPE void TclOOSetupVariableResolver(Tcl_Namespace *nsPtr); do { \ size_t len = sizeof(type) * ((target).num=(source).num);\ if (len != 0) { \ - memcpy(((target).list=(type*)Tcl_Alloc(len)), (source).list, len); \ + memcpy(((target).list=(type*)ckalloc(len)), (source).list, len); \ } else { \ (target).list = NULL; \ } \ diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index be51f0b..9c503bf 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -126,7 +126,7 @@ static const Tcl_MethodType fwdMethodType = { */ Tcl_Method -TclNewInstanceMethod( +Tcl_NewInstanceMethod( TCL_UNUSED(Tcl_Interp *), Tcl_Object object, /* The object that has the method attached to * it. */ @@ -147,19 +147,19 @@ TclNewInstanceMethod( int isNew; if (nameObj == NULL) { - mPtr = (Method *)Tcl_Alloc(sizeof(Method)); + mPtr = (Method *)ckalloc(sizeof(Method)); mPtr->namePtr = NULL; mPtr->refCount = 1; goto populate; } if (!oPtr->methodsPtr) { - oPtr->methodsPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); + oPtr->methodsPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); Tcl_InitObjHashTable(oPtr->methodsPtr); oPtr->flags &= ~USE_CLASS_CACHE; } - hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, nameObj, &isNew); + hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) nameObj, &isNew); if (isNew) { - mPtr = (Method *)Tcl_Alloc(sizeof(Method)); + mPtr = (Method *)ckalloc(sizeof(Method)); mPtr->namePtr = nameObj; mPtr->refCount = 1; Tcl_IncrRefCount(nameObj); @@ -187,50 +187,6 @@ TclNewInstanceMethod( oPtr->epoch++; return (Tcl_Method) mPtr; } -Tcl_Method -Tcl_NewInstanceMethod( - TCL_UNUSED(Tcl_Interp *), - Tcl_Object object, /* The object that has the method attached to - * it. */ - Tcl_Obj *nameObj, /* The name of the method. May be NULL; if so, - * up to caller to manage storage (e.g., when - * it is a constructor or destructor). */ - int flags, /* Whether this is a public method. */ - const Tcl_MethodType *typePtr, - /* The type of method this is, which defines - * how to invoke, delete and clone the - * method. */ - void *clientData) /* Some data associated with the particular - * method to be created. */ -{ - if (typePtr->version > TCL_OO_METHOD_VERSION_1) { - Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_1", "Tcl_NewInstanceMethod"); - } - return TclNewInstanceMethod(NULL, object, nameObj, flags, - (const Tcl_MethodType *)typePtr, clientData); -} -Tcl_Method -Tcl_NewInstanceMethod2( - TCL_UNUSED(Tcl_Interp *), - Tcl_Object object, /* The object that has the method attached to - * it. */ - Tcl_Obj *nameObj, /* The name of the method. May be NULL; if so, - * up to caller to manage storage (e.g., when - * it is a constructor or destructor). */ - int flags, /* Whether this is a public method. */ - const Tcl_MethodType2 *typePtr, - /* The type of method this is, which defines - * how to invoke, delete and clone the - * method. */ - void *clientData) /* Some data associated with the particular - * method to be created. */ -{ - if (typePtr->version < TCL_OO_METHOD_VERSION_2) { - Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_2", "Tcl_NewInstanceMethod2"); - } - return TclNewInstanceMethod(NULL, object, nameObj, flags, - (const Tcl_MethodType *)typePtr, clientData); -} /* * ---------------------------------------------------------------------- @@ -243,7 +199,7 @@ Tcl_NewInstanceMethod2( */ Tcl_Method -TclNewMethod( +Tcl_NewMethod( TCL_UNUSED(Tcl_Interp *), Tcl_Class cls, /* The class to attach the method to. */ Tcl_Obj *nameObj, /* The name of the object. May be NULL (e.g., @@ -263,14 +219,14 @@ TclNewMethod( int isNew; if (nameObj == NULL) { - mPtr = (Method *)Tcl_Alloc(sizeof(Method)); + mPtr = (Method *)ckalloc(sizeof(Method)); mPtr->namePtr = NULL; mPtr->refCount = 1; goto populate; } - hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, nameObj,&isNew); + hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char *)nameObj,&isNew); if (isNew) { - mPtr = (Method *)Tcl_Alloc(sizeof(Method)); + mPtr = (Method *)ckalloc(sizeof(Method)); mPtr->refCount = 1; mPtr->namePtr = nameObj; Tcl_IncrRefCount(nameObj); @@ -299,48 +255,6 @@ TclNewMethod( return (Tcl_Method) mPtr; } - -Tcl_Method -Tcl_NewMethod( - TCL_UNUSED(Tcl_Interp *), - Tcl_Class cls, /* The class to attach the method to. */ - Tcl_Obj *nameObj, /* The name of the object. May be NULL (e.g., - * for constructors or destructors); if so, up - * to caller to manage storage. */ - int flags, /* Whether this is a public method. */ - const Tcl_MethodType *typePtr, - /* The type of method this is, which defines - * how to invoke, delete and clone the - * method. */ - void *clientData) /* Some data associated with the particular - * method to be created. */ -{ - if (typePtr->version > TCL_OO_METHOD_VERSION_1) { - Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_1", "Tcl_NewMethod"); - } - return TclNewMethod(NULL, cls, nameObj, flags, typePtr, clientData); -} - -Tcl_Method -Tcl_NewMethod2( - TCL_UNUSED(Tcl_Interp *), - Tcl_Class cls, /* The class to attach the method to. */ - Tcl_Obj *nameObj, /* The name of the object. May be NULL (e.g., - * for constructors or destructors); if so, up - * to caller to manage storage. */ - int flags, /* Whether this is a public method. */ - const Tcl_MethodType2 *typePtr, - /* The type of method this is, which defines - * how to invoke, delete and clone the - * method. */ - void *clientData) /* Some data associated with the particular - * method to be created. */ -{ - if (typePtr->version < TCL_OO_METHOD_VERSION_2) { - Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_2", "Tcl_NewMethod2"); - } - return TclNewMethod(NULL, cls, nameObj, flags, (const Tcl_MethodType *)typePtr, clientData); -} /* * ---------------------------------------------------------------------- @@ -364,7 +278,7 @@ TclOODelMethodRef( Tcl_DecrRefCount(mPtr->namePtr); } - Tcl_Free(mPtr); + ckfree(mPtr); } } @@ -390,7 +304,7 @@ TclOONewBasicMethod( Tcl_Obj *namePtr = Tcl_NewStringObj(dcm->name, -1); Tcl_IncrRefCount(namePtr); - TclNewMethod(interp, (Tcl_Class) clsPtr, namePtr, + Tcl_NewMethod(interp, (Tcl_Class) clsPtr, namePtr, (dcm->isPublic ? PUBLIC_METHOD : 0), &dcm->definition, NULL); Tcl_DecrRefCount(namePtr); } @@ -421,14 +335,14 @@ TclOONewProcInstanceMethod( * structure's contents. NULL if caller is not * interested. */ { - Tcl_Size argsLen; + int argsLen; ProcedureMethod *pmPtr; Tcl_Method method; if (TclListObjLength(interp, argsObj, &argsLen) != TCL_OK) { return NULL; } - pmPtr = (ProcedureMethod *)Tcl_Alloc(sizeof(ProcedureMethod)); + pmPtr = (ProcedureMethod *)ckalloc(sizeof(ProcedureMethod)); memset(pmPtr, 0, sizeof(ProcedureMethod)); pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION; pmPtr->flags = flags & USE_DECLARER_NS; @@ -437,7 +351,7 @@ TclOONewProcInstanceMethod( method = TclOOMakeProcInstanceMethod(interp, oPtr, flags, nameObj, argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr); if (method == NULL) { - Tcl_Free(pmPtr); + ckfree(pmPtr); } else if (pmPtrPtr != NULL) { *pmPtrPtr = pmPtr; } @@ -473,13 +387,13 @@ TclOONewProcMethod( * structure's contents. NULL if caller is not * interested. */ { - Tcl_Size argsLen; /* TCL_INDEX_NONE => delete argsObj before exit */ + int argsLen; /* -1 => delete argsObj before exit */ ProcedureMethod *pmPtr; const char *procName; Tcl_Method method; if (argsObj == NULL) { - argsLen = TCL_INDEX_NONE; + argsLen = -1; TclNewObj(argsObj); Tcl_IncrRefCount(argsObj); procName = "<destructor>"; @@ -489,7 +403,7 @@ TclOONewProcMethod( procName = (nameObj==NULL ? "<constructor>" : TclGetString(nameObj)); } - pmPtr = (ProcedureMethod *)Tcl_Alloc(sizeof(ProcedureMethod)); + pmPtr = (ProcedureMethod *)ckalloc(sizeof(ProcedureMethod)); memset(pmPtr, 0, sizeof(ProcedureMethod)); pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION; pmPtr->flags = flags & USE_DECLARER_NS; @@ -498,11 +412,11 @@ TclOONewProcMethod( method = TclOOMakeProcMethod(interp, clsPtr, flags, nameObj, procName, argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr); - if (argsLen == TCL_INDEX_NONE) { + if (argsLen == -1) { Tcl_DecrRefCount(argsObj); } if (method == NULL) { - Tcl_Free(pmPtr); + ckfree(pmPtr); } else if (pmPtrPtr != NULL) { *pmPtrPtr = pmPtr; } @@ -583,12 +497,12 @@ TclOOMakeProcInstanceMethod( if (context.line && (context.nline >= 4) && (context.line[3] >= 0)) { int isNew; - CmdFrame *cfPtr = (CmdFrame *)Tcl_Alloc(sizeof(CmdFrame)); + CmdFrame *cfPtr = (CmdFrame *)ckalloc(sizeof(CmdFrame)); Tcl_HashEntry *hPtr; cfPtr->level = -1; cfPtr->type = context.type; - cfPtr->line = (Tcl_Size *)Tcl_Alloc(sizeof(Tcl_Size)); + cfPtr->line = (int *)ckalloc(sizeof(int)); cfPtr->line[0] = context.line[3]; cfPtr->nline = 1; cfPtr->framePtr = NULL; @@ -601,7 +515,7 @@ TclOOMakeProcInstanceMethod( cfPtr->len = 0; hPtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr, - procPtr, &isNew); + (char *) procPtr, &isNew); Tcl_SetHashValue(hPtr, cfPtr); } @@ -615,7 +529,7 @@ TclOOMakeProcInstanceMethod( } } - return TclNewInstanceMethod(interp, (Tcl_Object) oPtr, nameObj, flags, + return Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, nameObj, flags, typePtr, clientData); } @@ -696,12 +610,12 @@ TclOOMakeProcMethod( if (context.line && (context.nline >= 4) && (context.line[3] >= 0)) { int isNew; - CmdFrame *cfPtr = (CmdFrame *)Tcl_Alloc(sizeof(CmdFrame)); + CmdFrame *cfPtr = (CmdFrame *)ckalloc(sizeof(CmdFrame)); Tcl_HashEntry *hPtr; cfPtr->level = -1; cfPtr->type = context.type; - cfPtr->line = (Tcl_Size *)Tcl_Alloc(sizeof(Tcl_Size)); + cfPtr->line = (int *)ckalloc(sizeof(int)); cfPtr->line[0] = context.line[3]; cfPtr->nline = 1; cfPtr->framePtr = NULL; @@ -714,7 +628,7 @@ TclOOMakeProcMethod( cfPtr->len = 0; hPtr = Tcl_CreateHashEntry(iPtr->linePBodyPtr, - procPtr, &isNew); + (char *) procPtr, &isNew); Tcl_SetHashValue(hPtr, cfPtr); } @@ -728,7 +642,7 @@ TclOOMakeProcMethod( } } - return TclNewMethod(interp, (Tcl_Class) clsPtr, nameObj, flags, typePtr, + return Tcl_NewMethod(interp, (Tcl_Class) clsPtr, nameObj, flags, typePtr, clientData); } @@ -761,8 +675,9 @@ InvokeProcedureMethod( * the next thing in the chain. */ - if (TclOOObjectDestroyed(((CallContext *)context)->oPtr) - || Tcl_InterpDeleted(interp)) { + if (TclOOObjectDestroyed(((CallContext *)context)->oPtr) || + Tcl_InterpDeleted(interp) + ) { return TclNRObjectContextInvokeNext(interp, context, objc, objv, Tcl_ObjectContextSkippedArgs(context)); } @@ -1072,8 +987,7 @@ ProcedureMethodCompiledVarConnect( Tcl_Obj *variableObj; PrivateVariableMapping *privateVar; Tcl_HashEntry *hPtr; - int isNew, cacheIt; - Tcl_Size i, varLen, len; + int i, isNew, cacheIt, varLen, len; const char *match, *varName; /* @@ -1102,12 +1016,12 @@ ProcedureMethodCompiledVarConnect( * either. */ - varName = Tcl_GetStringFromObj(infoPtr->variableObj, &varLen); + 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 = Tcl_GetStringFromObj(privateVar->variableObj, &len); + match = TclGetStringFromObj(privateVar->variableObj, &len); if ((len == varLen) && !memcmp(match, varName, len)) { variableObj = privateVar->fullNameObj; cacheIt = 0; @@ -1116,7 +1030,7 @@ ProcedureMethodCompiledVarConnect( } FOREACH(variableObj, contextPtr->callPtr->chain[contextPtr->index] .mPtr->declaringClassPtr->variables) { - match = Tcl_GetStringFromObj(variableObj, &len); + match = TclGetStringFromObj(variableObj, &len); if ((len == varLen) && !memcmp(match, varName, len)) { cacheIt = 0; goto gotMatch; @@ -1124,7 +1038,7 @@ ProcedureMethodCompiledVarConnect( } } else { FOREACH_STRUCT(privateVar, contextPtr->oPtr->privateVariables) { - match = Tcl_GetStringFromObj(privateVar->variableObj, &len); + match = TclGetStringFromObj(privateVar->variableObj, &len); if ((len == varLen) && !memcmp(match, varName, len)) { variableObj = privateVar->fullNameObj; cacheIt = 1; @@ -1132,7 +1046,7 @@ ProcedureMethodCompiledVarConnect( } } FOREACH(variableObj, contextPtr->oPtr->variables) { - match = Tcl_GetStringFromObj(variableObj, &len); + match = TclGetStringFromObj(variableObj, &len); if ((len == varLen) && !memcmp(match, varName, len)) { cacheIt = 1; goto gotMatch; @@ -1147,7 +1061,7 @@ ProcedureMethodCompiledVarConnect( gotMatch: hPtr = Tcl_CreateHashEntry(TclVarTable(contextPtr->oPtr->namespacePtr), - variableObj, &isNew); + (char *) variableObj, &isNew); if (isNew) { TclSetVarNamespaceVar((Var *) TclVarHashGetValue(hPtr)); } @@ -1180,14 +1094,14 @@ ProcedureMethodCompiledVarDelete( TclCleanupVar((Var *) infoPtr->cachedObjectVar, NULL); } Tcl_DecrRefCount(infoPtr->variableObj); - Tcl_Free(infoPtr); + ckfree(infoPtr); } static int ProcedureMethodCompiledVarResolver( TCL_UNUSED(Tcl_Interp *), const char *varName, - Tcl_Size length, + int length, TCL_UNUSED(Tcl_Namespace *), Tcl_ResolvedVarInfo **rPtrPtr) { @@ -1199,13 +1113,13 @@ ProcedureMethodCompiledVarResolver( * which look like array accesses. Both will lead us astray. */ - if (strstr(TclGetString(variableObj), "::") != NULL || - Tcl_StringMatch(TclGetString(variableObj), "*(*)")) { + if (strstr(Tcl_GetString(variableObj), "::") != NULL || + Tcl_StringMatch(Tcl_GetString(variableObj), "*(*)")) { Tcl_DecrRefCount(variableObj); return TCL_CONTINUE; } - infoPtr = (OOResVarInfo *)Tcl_Alloc(sizeof(OOResVarInfo)); + infoPtr = (OOResVarInfo *)ckalloc(sizeof(OOResVarInfo)); infoPtr->info.fetchProc = ProcedureMethodCompiledVarConnect; infoPtr->info.deleteProc = ProcedureMethodCompiledVarDelete; infoPtr->cachedObjectVar = NULL; @@ -1260,7 +1174,7 @@ RenderDeclarerName( #define LIMIT 60 #define ELLIPSIFY(str,len) \ - ((len) > LIMIT ? LIMIT : (int)(len)), (str), ((len) > LIMIT ? "..." : "") + ((len) > LIMIT ? LIMIT : (len)), (str), ((len) > LIMIT ? "..." : "") static void MethodErrorHandler( @@ -1268,11 +1182,11 @@ MethodErrorHandler( TCL_UNUSED(Tcl_Obj *) /*methodNameObj*/) /* We pull the method name out of context instead of from argument */ { - Tcl_Size nameLen, objectNameLen; + int nameLen, objectNameLen; CallContext *contextPtr = (CallContext *)((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) { @@ -1286,7 +1200,7 @@ MethodErrorHandler( kindName = "class"; } - objectName = Tcl_GetStringFromObj(TclOOObjectName(interp, declarerPtr), + objectName = TclGetStringFromObj(TclOOObjectName(interp, declarerPtr), &objectNameLen); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (%s \"%.*s%s\" method \"%.*s%s\" line %d)", @@ -1304,7 +1218,7 @@ ConstructorErrorHandler( Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr; Object *declarerPtr; const char *objectName, *kindName; - Tcl_Size objectNameLen; + int objectNameLen; if (mPtr->declaringObjectPtr != NULL) { declarerPtr = mPtr->declaringObjectPtr; @@ -1317,7 +1231,7 @@ ConstructorErrorHandler( kindName = "class"; } - objectName = Tcl_GetStringFromObj(TclOOObjectName(interp, declarerPtr), + objectName = TclGetStringFromObj(TclOOObjectName(interp, declarerPtr), &objectNameLen); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (%s \"%.*s%s\" constructor line %d)", kindName, @@ -1334,7 +1248,7 @@ DestructorErrorHandler( Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr; Object *declarerPtr; const char *objectName, *kindName; - Tcl_Size objectNameLen; + int objectNameLen; if (mPtr->declaringObjectPtr != NULL) { declarerPtr = mPtr->declaringObjectPtr; @@ -1347,7 +1261,7 @@ DestructorErrorHandler( kindName = "class"; } - objectName = Tcl_GetStringFromObj(TclOOObjectName(interp, declarerPtr), + objectName = TclGetStringFromObj(TclOOObjectName(interp, declarerPtr), &objectNameLen); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (%s \"%.*s%s\" destructor line %d)", kindName, @@ -1372,7 +1286,7 @@ DeleteProcedureMethodRecord( if (pmPtr->deleteClientdataProc) { pmPtr->deleteClientdataProc(pmPtr->clientData); } - Tcl_Free(pmPtr); + ckfree(pmPtr); } static void @@ -1423,7 +1337,7 @@ CloneProcedureMethod( */ bodyObj = Tcl_DuplicateObj(pmPtr->procPtr->bodyPtr); - TclGetString(bodyObj); + Tcl_GetString(bodyObj); Tcl_StoreInternalRep(pmPtr->procPtr->bodyPtr, &tclByteCodeType, NULL); /* @@ -1431,7 +1345,7 @@ CloneProcedureMethod( * record. */ - pm2Ptr = (ProcedureMethod *)Tcl_Alloc(sizeof(ProcedureMethod)); + pm2Ptr = (ProcedureMethod *)ckalloc(sizeof(ProcedureMethod)); memcpy(pm2Ptr, pmPtr, sizeof(ProcedureMethod)); pm2Ptr->refCount = 1; Tcl_IncrRefCount(argsObj); @@ -1440,7 +1354,7 @@ CloneProcedureMethod( &pm2Ptr->procPtr) != TCL_OK) { Tcl_DecrRefCount(argsObj); Tcl_DecrRefCount(bodyObj); - Tcl_Free(pm2Ptr); + ckfree(pm2Ptr); return TCL_ERROR; } Tcl_DecrRefCount(argsObj); @@ -1472,7 +1386,7 @@ TclOONewForwardInstanceMethod( Tcl_Obj *prefixObj) /* List of arguments that form the command * prefix to forward to. */ { - Tcl_Size prefixLen; + int prefixLen; ForwardMethod *fmPtr; if (TclListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) { @@ -1485,10 +1399,10 @@ TclOONewForwardInstanceMethod( return NULL; } - fmPtr = (ForwardMethod *)Tcl_Alloc(sizeof(ForwardMethod)); + fmPtr = (ForwardMethod *)ckalloc(sizeof(ForwardMethod)); fmPtr->prefixObj = prefixObj; Tcl_IncrRefCount(prefixObj); - return (Method *) TclNewInstanceMethod(interp, (Tcl_Object) oPtr, + return (Method *) Tcl_NewInstanceMethod(interp, (Tcl_Object) oPtr, nameObj, flags, &fwdMethodType, fmPtr); } @@ -1511,7 +1425,7 @@ TclOONewForwardMethod( Tcl_Obj *prefixObj) /* List of arguments that form the command * prefix to forward to. */ { - Tcl_Size prefixLen; + int prefixLen; ForwardMethod *fmPtr; if (TclListObjLength(interp, prefixObj, &prefixLen) != TCL_OK) { @@ -1524,10 +1438,10 @@ TclOONewForwardMethod( return NULL; } - fmPtr = (ForwardMethod *)Tcl_Alloc(sizeof(ForwardMethod)); + fmPtr = (ForwardMethod *)ckalloc(sizeof(ForwardMethod)); fmPtr->prefixObj = prefixObj; Tcl_IncrRefCount(prefixObj); - return (Method *) TclNewMethod(interp, (Tcl_Class) clsPtr, nameObj, + return (Method *) Tcl_NewMethod(interp, (Tcl_Class) clsPtr, nameObj, flags, &fwdMethodType, fmPtr); } @@ -1553,8 +1467,7 @@ InvokeForwardMethod( CallContext *contextPtr = (CallContext *) context; ForwardMethod *fmPtr = (ForwardMethod *)clientData; Tcl_Obj **argObjs, **prefixObjs; - Tcl_Size numPrefixes, skip = contextPtr->skip; - int len; + int numPrefixes, len, skip = contextPtr->skip; /* * Build the real list of arguments to use. Note that we know that the @@ -1606,7 +1519,7 @@ DeleteForwardMethod( ForwardMethod *fmPtr = (ForwardMethod *)clientData; Tcl_DecrRefCount(fmPtr->prefixObj); - Tcl_Free(fmPtr); + ckfree(fmPtr); } static int @@ -1616,7 +1529,7 @@ CloneForwardMethod( void **newClientData) { ForwardMethod *fmPtr = (ForwardMethod *)clientData; - ForwardMethod *fm2Ptr = (ForwardMethod *)Tcl_Alloc(sizeof(ForwardMethod)); + ForwardMethod *fm2Ptr = (ForwardMethod *)ckalloc(sizeof(ForwardMethod)); fm2Ptr->prefixObj = fmPtr->prefixObj; Tcl_IncrRefCount(fm2Ptr->prefixObj); @@ -1706,7 +1619,7 @@ InitEnsembleRewrite( int *lengthPtr) /* Where to write the resulting length of the * array of rewritten arguments. */ { - size_t len = rewriteLength + objc - toRewrite; + unsigned len = rewriteLength + objc - toRewrite; Tcl_Obj **argObjs = (Tcl_Obj **)TclStackAlloc(interp, sizeof(Tcl_Obj *) * len); memcpy(argObjs, rewriteObjs, rewriteLength * sizeof(Tcl_Obj *)); @@ -1759,23 +1672,6 @@ Tcl_MethodName( } int -TclMethodIsType( - Tcl_Method method, - const Tcl_MethodType *typePtr, - void **clientDataPtr) -{ - Method *mPtr = (Method *) method; - - if (mPtr->typePtr == typePtr) { - if (clientDataPtr != NULL) { - *clientDataPtr = mPtr->clientData; - } - return 1; - } - return 0; -} - -int Tcl_MethodIsType( Tcl_Method method, const Tcl_MethodType *typePtr, @@ -1783,9 +1679,6 @@ Tcl_MethodIsType( { Method *mPtr = (Method *) method; - if (typePtr->version > TCL_OO_METHOD_VERSION_1) { - Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_1", "Tcl_MethodIsType"); - } if (mPtr->typePtr == typePtr) { if (clientDataPtr != NULL) { *clientDataPtr = mPtr->clientData; @@ -1796,26 +1689,6 @@ Tcl_MethodIsType( } int -Tcl_MethodIsType2( - Tcl_Method method, - const Tcl_MethodType2 *typePtr, - void **clientDataPtr) -{ - Method *mPtr = (Method *) method; - - if (typePtr->version < TCL_OO_METHOD_VERSION_2) { - Tcl_Panic("%s: Wrong version in typePtr->version, should be TCL_OO_METHOD_VERSION_2", "Tcl_MethodIsType2"); - } - if (mPtr->typePtr == (const Tcl_MethodType *)typePtr) { - if (clientDataPtr != NULL) { - *clientDataPtr = mPtr->clientData; - } - return 1; - } - return 0; -} - -int Tcl_MethodIsPublic( Tcl_Method method) { diff --git a/generic/tclOOStubInit.c b/generic/tclOOStubInit.c index 7b653cb..1923037 100644 --- a/generic/tclOOStubInit.c +++ b/generic/tclOOStubInit.c @@ -14,6 +14,8 @@ MODULE_SCOPE const TclOOStubs tclOOStubs; #pragma GCC dependency "tclOO.decls" #endif +#define TclOOUnusedStubEntry 0 + /* !BEGIN!: Do not edit below this line. */ static const TclOOIntStubs tclOOIntStubs = { @@ -76,9 +78,9 @@ const TclOOStubs tclOOStubs = { Tcl_MethodIsPrivate, /* 29 */ Tcl_GetClassOfObject, /* 30 */ Tcl_GetObjectClassName, /* 31 */ - Tcl_MethodIsType2, /* 32 */ - Tcl_NewInstanceMethod2, /* 33 */ - Tcl_NewMethod2, /* 34 */ + 0, /* 32 */ + 0, /* 33 */ + TclOOUnusedStubEntry, /* 34 */ }; /* !END!: Do not edit above this line. */ diff --git a/generic/tclObj.c b/generic/tclObj.c index 30634a0..4d7800a 100644 --- a/generic/tclObj.c +++ b/generic/tclObj.c @@ -178,14 +178,14 @@ static Tcl_ThreadDataKey pendingObjDataKey; #define PACK_BIGNUM(bignum, objPtr) \ if ((bignum).used > 0x7FFF) { \ - mp_int *temp = (mp_int *)Tcl_Alloc(sizeof(mp_int)); \ + mp_int *temp = (mp_int *)ckalloc(sizeof(mp_int)); \ *temp = bignum; \ (objPtr)->internalRep.twoPtrValue.ptr1 = temp; \ (objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR(-1); \ } else if (((bignum).alloc <= 0x7FFF) || (mp_shrink(&(bignum))) == MP_OKAY) { \ - (objPtr)->internalRep.twoPtrValue.ptr1 = (bignum).dp; \ - (objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR( ((bignum).sign << 30) \ - | ((bignum).alloc << 15) | ((bignum).used)); \ + (objPtr)->internalRep.twoPtrValue.ptr1 = (void *)(bignum).dp; \ + (objPtr)->internalRep.twoPtrValue.ptr2 = INT2PTR(((bignum).sign << 30) \ + | ((bignum).alloc << 15) | ((bignum).used)); \ } /* @@ -197,6 +197,9 @@ 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); +#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); static void UpdateStringOfBignum(Tcl_Obj *objPtr); @@ -225,37 +228,55 @@ static int SetCmdNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); * implementations. */ -const Tcl_ObjType tclBooleanType= { +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 +static const Tcl_ObjType oldBooleanType = { "boolean", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ NULL, /* updateStringProc */ - TclSetBooleanFromAny, /* setFromAnyProc */ - TCL_OBJTYPE_V1(TclLengthOne) + TclSetBooleanFromAny /* setFromAnyProc */ }; -const Tcl_ObjType tclDoubleType= { +#endif +const Tcl_ObjType tclBooleanType = { + "booleanString", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + NULL, /* updateStringProc */ + TclSetBooleanFromAny /* setFromAnyProc */ +}; +const Tcl_ObjType tclDoubleType = { "double", /* name */ NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ UpdateStringOfDouble, /* updateStringProc */ - SetDoubleFromAny, /* setFromAnyProc */ - TCL_OBJTYPE_V1(TclLengthOne) + 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 */ - TCL_OBJTYPE_V1(TclLengthOne) + SetIntFromAny /* setFromAnyProc */ +}; +#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 */ + UpdateStringOfOldInt, /* updateStringProc */ + SetIntFromAny /* setFromAnyProc */ }; +#endif const Tcl_ObjType tclBignumType = { "bignum", /* name */ FreeBignum, /* freeIntRepProc */ DupBignum, /* dupIntRepProc */ UpdateStringOfBignum, /* updateStringProc */ - NULL, /* setFromAnyProc */ - TCL_OBJTYPE_V1(TclLengthOne) + NULL /* setFromAnyProc */ }; /* @@ -299,8 +320,7 @@ Tcl_ObjType tclCmdNameType = { FreeCmdNameInternalRep, /* freeIntRepProc */ DupCmdNameInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ - SetCmdNameFromAny, /* setFromAnyProc */ - TCL_OBJTYPE_V0 + SetCmdNameFromAny /* setFromAnyProc */ }; /* @@ -316,7 +336,7 @@ typedef struct ResolvedCmdName { * reference (not the namespace that contains * the referenced command). NULL if the name * is fully qualified.*/ - size_t refNsId; /* refNsPtr's unique namespace id. Used to + 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 @@ -338,18 +358,6 @@ typedef struct ResolvedCmdName { * structure can be freed when refCount * becomes zero. */ } ResolvedCmdName; - -#ifdef TCL_MEM_DEBUG -/* - * Filler matches the value used for filling freed memory in tclCkalloc. - * On 32-bit systems, the ref counts do not cross 0x7fffffff. On 64-bit - * implementations, ref counts will never reach this value (unless explicitly - * incremented without actual references!) - */ -#define FREEDREFCOUNTFILLER \ - (Tcl_Size)(sizeof(objPtr->refCount) == 4 ? 0xe8e8e8e8 : 0xe8e8e8e8e8e8e8e8) -#endif - /* *------------------------------------------------------------------------- @@ -377,8 +385,14 @@ TclInitObjSubsystem(void) Tcl_InitHashTable(&typeTable, TCL_STRING_KEYS); Tcl_MutexUnlock(&tableMutex); + Tcl_RegisterObjType(&tclByteArrayType); Tcl_RegisterObjType(&tclDoubleType); +#if !defined(TCL_NO_DEPRECATED) Tcl_RegisterObjType(&tclStringType); + /* Only registered for 8.7, not for 9.0 any more. + * See [https://core.tcl-lang.org/tk/tktview/6b49149b4e] */ + Tcl_RegisterObjType(&tclUniCharStringType); +#endif Tcl_RegisterObjType(&tclListType); Tcl_RegisterObjType(&tclDictType); Tcl_RegisterObjType(&tclByteCodeType); @@ -386,6 +400,15 @@ TclInitObjSubsystem(void) 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); +#endif + #ifdef TCL_COMPILE_STATS Tcl_MutexLock(&tclObjMutex); tclObjsAlloced = 0; @@ -433,12 +456,12 @@ TclFinalizeThreadObjects(void) ObjData *objData = (ObjData *)Tcl_GetHashValue(hPtr); if (objData != NULL) { - Tcl_Free(objData); + ckfree(objData); } } Tcl_DeleteHashTable(tablePtr); - Tcl_Free(tablePtr); + ckfree(tablePtr); tsdPtr->objThreadMap = NULL; } #endif @@ -514,7 +537,7 @@ TclGetContLineTable(void) ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (!tsdPtr->lineCLPtr) { - tsdPtr->lineCLPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); + tsdPtr->lineCLPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(tsdPtr->lineCLPtr, TCL_ONE_WORD_KEYS); Tcl_CreateThreadExitHandler(TclThreadFinalizeContLines,NULL); } @@ -549,7 +572,7 @@ TclContinuationsEnter( ThreadSpecificData *tsdPtr = TclGetContLineTable(); Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(tsdPtr->lineCLPtr, objPtr, &newEntry); - ContLineLoc *clLocPtr = (ContLineLoc *)Tcl_Alloc(offsetof(ContLineLoc, loc) + (num + 1U) *sizeof(Tcl_Size)); + ContLineLoc *clLocPtr = (ContLineLoc *)ckalloc(offsetof(ContLineLoc, loc) + (num + 1U) *sizeof(Tcl_Size)); if (!newEntry) { /* @@ -573,7 +596,7 @@ TclContinuationsEnter( * doing. */ - Tcl_Free(Tcl_GetHashValue(hPtr)); + ckfree(Tcl_GetHashValue(hPtr)); } clLocPtr->num = num; @@ -637,7 +660,7 @@ TclContinuationsEnterDerived( * better way which doesn't shimmer?) */ - (void)TclGetStringFromObj(objPtr, &length); + TclGetStringFromObj(objPtr, &length); end = start + length; /* First char after the word */ /* @@ -778,11 +801,11 @@ TclThreadFinalizeContLines( for (hPtr = Tcl_FirstHashEntry(tsdPtr->lineCLPtr, &hSearch); hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) { - Tcl_Free(Tcl_GetHashValue(hPtr)); + ckfree(Tcl_GetHashValue(hPtr)); Tcl_DeleteHashEntry(hPtr); } Tcl_DeleteHashTable(tsdPtr->lineCLPtr); - Tcl_Free(tsdPtr->lineCLPtr); + ckfree(tsdPtr->lineCLPtr); tsdPtr->lineCLPtr = NULL; } @@ -1058,7 +1081,7 @@ TclDbInitNewObj( ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); if (tsdPtr->objThreadMap == NULL) { - tsdPtr->objThreadMap = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); + tsdPtr->objThreadMap = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); Tcl_InitHashTable(tsdPtr->objThreadMap, TCL_ONE_WORD_KEYS); } tablePtr = tsdPtr->objThreadMap; @@ -1071,7 +1094,7 @@ TclDbInitNewObj( * Record the debugging information. */ - objData = (ObjData *)Tcl_Alloc(sizeof(ObjData)); + objData = (ObjData *)ckalloc(sizeof(ObjData)); objData->objPtr = objPtr; objData->file = file; objData->line = line; @@ -1196,7 +1219,7 @@ Tcl_DbNewObj( * TclAllocateFreeObjects -- * * Function to allocate a number of free Tcl_Objs. This is done using a - * single Tcl_Alloc to reduce the overhead for Tcl_Obj allocation. + * single ckalloc to reduce the overhead for Tcl_Obj allocation. * * Assumes mutex is held. * @@ -1225,12 +1248,12 @@ TclAllocateFreeObjects(void) * This has been noted by Purify to be a potential leak. The problem is * that Tcl, when not TCL_MEM_DEBUG compiled, keeps around all allocated * Tcl_Obj's, pointed to by tclFreeObjList, when freed instead of actually - * freeing the memory. TclFinalizeObjects() does not Tcl_Free() this memory, + * freeing the memory. TclFinalizeObjects() does not ckfree() this memory, * but leaves it to Tcl's memory subsystem finalization to release it. * Purify apparently can't figure that out, and fires a false alarm. */ - basePtr = (char *)Tcl_Alloc(bytesToAlloc); + basePtr = (char *)ckalloc(bytesToAlloc); prevPtr = NULL; objPtr = (Tcl_Obj *) basePtr; @@ -1296,7 +1319,7 @@ TclFreeObj( if (!tablePtr) { Tcl_Panic("TclFreeObj: object table not initialized"); } - hPtr = Tcl_FindHashEntry(tablePtr, objPtr); + hPtr = Tcl_FindHashEntry(tablePtr, (char *) objPtr); if (hPtr) { /* * As the Tcl_Obj is going to be deleted we remove the entry. @@ -1305,7 +1328,7 @@ TclFreeObj( ObjData *objData = (ObjData *)Tcl_GetHashValue(hPtr); if (objData != NULL) { - Tcl_Free(objData); + ckfree(objData); } Tcl_DeleteHashEntry(hPtr); @@ -1349,7 +1372,7 @@ TclFreeObj( } Tcl_MutexLock(&tclObjMutex); - Tcl_Free(objPtr); + ckfree(objPtr); Tcl_MutexUnlock(&tclObjMutex); TclIncrObjsFreed(); ObjDeletionLock(context); @@ -1361,7 +1384,7 @@ TclFreeObj( TclFreeInternalRep(objToFree); Tcl_MutexLock(&tclObjMutex); - Tcl_Free(objToFree); + ckfree(objToFree); Tcl_MutexUnlock(&tclObjMutex); TclIncrObjsFreed(); } @@ -1385,7 +1408,7 @@ TclFreeObj( if (tsdPtr->lineCLPtr) { hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr); if (hPtr) { - Tcl_Free(Tcl_GetHashValue(hPtr)); + ckfree(Tcl_GetHashValue(hPtr)); Tcl_DeleteHashEntry(hPtr); } } @@ -1476,7 +1499,7 @@ TclFreeObj( if (tsdPtr->lineCLPtr) { hPtr = Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr); if (hPtr) { - Tcl_Free(Tcl_GetHashValue(hPtr)); + ckfree(Tcl_GetHashValue(hPtr)); Tcl_DeleteHashEntry(hPtr); } } @@ -1543,7 +1566,7 @@ TclObjBeingDeleted( const Tcl_ObjType *typePtr = (objPtr)->typePtr; \ const char *bytes = (objPtr)->bytes; \ if (bytes) { \ - TclInitStringRep((dupPtr), bytes, (objPtr)->length); \ + (void)TclAttemptInitStringRep((dupPtr), bytes, (objPtr)->length); \ } else { \ (dupPtr)->bytes = NULL; \ } \ @@ -1626,7 +1649,7 @@ Tcl_GetString( objPtr->typePtr->name); } objPtr->typePtr->updateStringProc(objPtr); - if (objPtr->bytes == NULL || objPtr->length == TCL_INDEX_NONE + 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", @@ -1639,7 +1662,7 @@ Tcl_GetString( /* *---------------------------------------------------------------------- * - * Tcl_GetStringFromObj/TclGetStringFromObj -- + * Tcl_GetStringFromObj -- * * Returns the string representation's byte array pointer and length for * an object. @@ -1659,58 +1682,11 @@ Tcl_GetString( *---------------------------------------------------------------------- */ -#if !defined(TCL_NO_DEPRECATED) -#undef TclGetStringFromObj -char * -TclGetStringFromObj( - Tcl_Obj *objPtr, /* Object whose string rep byte pointer should - * be returned. */ - void *lengthPtr) /* If non-NULL, the location where the string - * rep's byte array length should * be stored. - * If NULL, no length is stored. */ -{ - 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 == TCL_INDEX_NONE - || objPtr->bytes[objPtr->length] != '\0') { - Tcl_Panic("UpdateStringProc for type '%s' " - "failed to create a valid string rep", - objPtr->typePtr->name); - } - } - if (lengthPtr != NULL) { - if (objPtr->length > INT_MAX) { - Tcl_Panic("Tcl_GetStringFromObj with 'int' lengthPtr" - " cannot handle such long strings. Please use 'Tcl_Size'"); - } - *(int *)lengthPtr = (int)objPtr->length; - } - return objPtr->bytes; -} -#endif /* !defined(TCL_NO_DEPRECATED) */ - -#undef Tcl_GetStringFromObj char * Tcl_GetStringFromObj( Tcl_Obj *objPtr, /* Object whose string rep byte pointer should * be returned. */ - Tcl_Size *lengthPtr) /* If non-NULL, the location where the string + int *lengthPtr) /* If non-NULL, the location where the string * rep's byte array length should * be stored. * If NULL, no length is stored. */ { @@ -1732,7 +1708,7 @@ Tcl_GetStringFromObj( objPtr->typePtr->name); } objPtr->typePtr->updateStringProc(objPtr); - if (objPtr->bytes == NULL + 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", @@ -1754,15 +1730,15 @@ Tcl_GetStringFromObj( * the tools needed to set an object's string representation. The * function is determined by the arguments. * - * (objPtr->bytes != NULL && bytes != NULL) || (numBytes == -1) + * (objPtr->bytes != NULL && bytes != NULL) || (numBytes < 0) * Invalid call -- panic! * - * objPtr->bytes == NULL && bytes == NULL && numBytes != -1 + * 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 != -1 + * 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 @@ -1771,7 +1747,7 @@ Tcl_GetStringFromObj( * Caller must guarantee there are numBytes chars at bytes to * be copied. * - * objPtr->bytes != NULL && bytes == NULL && numBytes != -1 + * 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 @@ -1793,19 +1769,23 @@ char * Tcl_InitStringRep( Tcl_Obj *objPtr, /* Object whose string rep is to be set */ const char *bytes, - size_t numBytes) + 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); + } + if (objPtr->bytes == NULL) { /* Start with no string rep */ if (numBytes == 0) { TclInitEmptyStringRep(objPtr); return objPtr->bytes; } else { - objPtr->bytes = (char *)Tcl_AttemptAlloc(numBytes + 1); + objPtr->bytes = (char *)attemptckalloc(numBytes + 1); if (objPtr->bytes) { - objPtr->length = numBytes; + objPtr->length = (int) numBytes; if (bytes) { memcpy(objPtr->bytes, bytes, numBytes); } @@ -1817,23 +1797,23 @@ Tcl_InitStringRep( if (numBytes == 0) { return objPtr->bytes; } else { - objPtr->bytes = (char *)Tcl_AttemptAlloc(numBytes + 1); + objPtr->bytes = (char *)attemptckalloc(numBytes + 1); if (objPtr->bytes) { - objPtr->length = numBytes; + objPtr->length = (int) numBytes; objPtr->bytes[objPtr->length] = '\0'; } } } else { /* Start with non-empty string rep (allocated) */ if (numBytes == 0) { - Tcl_Free(objPtr->bytes); + ckfree(objPtr->bytes); TclInitEmptyStringRep(objPtr); return objPtr->bytes; } else { - objPtr->bytes = (char *)Tcl_AttemptRealloc(objPtr->bytes, + objPtr->bytes = (char *)attemptckrealloc(objPtr->bytes, numBytes + 1); if (objPtr->bytes) { - objPtr->length = numBytes; + objPtr->length = (int) numBytes; objPtr->bytes[objPtr->length] = '\0'; } } @@ -1982,6 +1962,145 @@ Tcl_FreeInternalRep( /* *---------------------------------------------------------------------- * + * Tcl_NewBooleanObj -- + * + * This function is normally called when not debugging: i.e., when + * TCL_MEM_DEBUG is not defined. It creates a new Tcl_Obj and + * initializes it from the argument boolean value. A nonzero "intValue" + * is coerced to 1. + * + * When TCL_MEM_DEBUG is defined, this function just returns the result + * of calling the debugging version Tcl_DbNewLongObj. + * + * Results: + * The newly created object is returned. This object will have an invalid + * string representation. The returned object has ref count 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_NewBooleanObj +#ifdef TCL_MEM_DEBUG + +Tcl_Obj * +Tcl_NewBooleanObj( + int intValue) /* Boolean used to initialize new object. */ +{ + return Tcl_DbNewWideIntObj(intValue!=0, "unknown", 0); +} + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_NewBooleanObj( + int intValue) /* Boolean used to initialize new object. */ +{ + Tcl_Obj *objPtr; + + TclNewIntObj(objPtr, intValue!=0); + return objPtr; +} +#endif /* TCL_MEM_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_DbNewBooleanObj -- + * + * This function is normally called when debugging: i.e., when + * TCL_MEM_DEBUG is defined. It creates new boolean objects. It is the + * same as the Tcl_NewBooleanObj 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, this function just returns the + * result of calling Tcl_NewBooleanObj. + * + * Results: + * The newly created object is returned. This object will have an invalid + * string representation. The returned object has ref count 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#ifndef TCL_NO_DEPRECATED +#undef Tcl_DbNewBooleanObj +#ifdef TCL_MEM_DEBUG + +Tcl_Obj * +Tcl_DbNewBooleanObj( + int intValue, /* Boolean used to initialize new object. */ + const char *file, /* The name of the source file calling this + * function; used for debugging. */ + int line) /* Line number in the source file; used for + * debugging. */ +{ + Tcl_Obj *objPtr; + + TclDbNewObj(objPtr, file, line); + /* Optimized TclInvalidateStringRep() */ + objPtr->bytes = NULL; + + objPtr->internalRep.wideValue = (intValue != 0); + objPtr->typePtr = &tclIntType; + return objPtr; +} + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_DbNewBooleanObj( + int intValue, /* Boolean used to initialize new object. */ + TCL_UNUSED(const char *) /*file*/, + TCL_UNUSED(int) /*line*/) +{ + return Tcl_NewBooleanObj(intValue); +} +#endif /* TCL_MEM_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetBooleanObj -- + * + * Modify an object to be a boolean object and to have the specified + * boolean value. A nonzero "intValue" is coerced to 1. + * + * Results: + * None. + * + * Side effects: + * The object's old string rep, if any, is freed. Also, any old internal + * rep is freed. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_SetBooleanObj +void +Tcl_SetBooleanObj( + Tcl_Obj *objPtr, /* Object whose internal rep to init. */ + int intValue) /* Boolean used to set object's value. */ +{ + if (Tcl_IsShared(objPtr)) { + Tcl_Panic("%s called with shared object", "Tcl_SetBooleanObj"); + } + + TclSetIntObj(objPtr, intValue!=0); +} +#endif /* TCL_NO_DEPRECATED */ + +/* + *---------------------------------------------------------------------- + * * Tcl_GetBoolFromObj, Tcl_GetBooleanFromObj -- * * Attempt to return a boolean from the Tcl object "objPtr". This @@ -2021,10 +2140,14 @@ Tcl_GetBoolFromObj( return TCL_ERROR; } do { - if (TclHasInternalRep(objPtr, &tclIntType) || TclHasInternalRep(objPtr, &tclBooleanType)) { + if (TclHasInternalRep(objPtr, &tclIntType)) { result = (objPtr->internalRep.wideValue != 0); goto boolEnd; } + if (TclHasInternalRep(objPtr, &tclBooleanType)) { + result = objPtr->internalRep.longValue != 0; + goto boolEnd; + } if (TclHasInternalRep(objPtr, &tclDoubleType)) { /* * Caution: Don't be tempted to check directly for the "double" @@ -2093,7 +2216,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 or int. + * 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. * *---------------------------------------------------------------------- */ @@ -2133,7 +2261,7 @@ TclSetBooleanFromAny( badBoolean: if (interp != NULL) { Tcl_Size length; - const char *str = Tcl_GetStringFromObj(objPtr, &length); + const char *str = TclGetStringFromObj(objPtr, &length); Tcl_Obj *msg; TclNewLiteralStringObj(msg, "expected boolean value but got \""); @@ -2152,7 +2280,7 @@ ParseBoolean( int newBool; char lowerCase[6]; Tcl_Size i, length; - const char *str = Tcl_GetStringFromObj(objPtr, &length); + const char *str = TclGetStringFromObj(objPtr, &length); if ((length < 1) || (length > 5)) { /* @@ -2251,7 +2379,7 @@ ParseBoolean( goodBoolean: TclFreeInternalRep(objPtr); - objPtr->internalRep.wideValue = newBool; + objPtr->internalRep.longValue = newBool; objPtr->typePtr = &tclBooleanType; return TCL_OK; @@ -2486,7 +2614,8 @@ SetDoubleFromAny( * UpdateStringOfDouble -- * * Update the string representation for a double-precision floating point - * object. Note: This function does not free an + * object. This must obey the current tcl_precision value for + * double-to-string conversions. Note: This function does not free an * existing old string rep so storage will be lost if this has not * already been done. * @@ -2515,28 +2644,112 @@ UpdateStringOfDouble( /* *---------------------------------------------------------------------- * - * Tcl_GetIntFromObj -- + * Tcl_NewIntObj -- * - * Retrieve the integer value of 'objPtr'. + * If a client is compiled with TCL_MEM_DEBUG defined, calls to + * Tcl_NewIntObj to create a new integer object end up calling the + * debugging function Tcl_DbNewLongObj instead. * - * Value + * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined, + * calls to Tcl_NewIntObj result in a call to one of the two + * Tcl_NewIntObj implementations below. We provide two implementations so + * that the Tcl core can be compiled to do memory debugging of the core + * even if a client does not request it for itself. * - * TCL_OK + * 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. * - * Success. + * Results: + * The newly created object is returned. This object will have an invalid + * string representation. The returned object has ref count 0. * - * TCL_ERROR + * Side effects: + * None. * - * 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. + *---------------------------------------------------------------------- + */ + +#ifndef TCL_NO_DEPRECATED +#undef Tcl_NewIntObj +#ifdef TCL_MEM_DEBUG + +Tcl_Obj * +Tcl_NewIntObj( + int intValue) /* Int used to initialize the new object. */ +{ + return Tcl_DbNewWideIntObj(intValue, "unknown", 0); +} + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_NewIntObj( + int intValue) /* Int used to initialize the new object. */ +{ + Tcl_Obj *objPtr; + + TclNewIntObj(objPtr, intValue); + return objPtr; +} +#endif /* if TCL_MEM_DEBUG */ +#endif /* TCL_NO_DEPRECATED */ + +/* + *---------------------------------------------------------------------- * - * Effect + * Tcl_SetIntObj -- * - * 'objPtr' is converted to an integer if necessary if it is not one - * already. The conversion frees any previously-existing internal - * representation. + * Modify an object to be an integer and to have the specified integer + * value. + * + * Results: + * None. + * + * Side effects: + * The object's old string rep, if any, is freed. Also, any old internal + * rep is freed. + * + *---------------------------------------------------------------------- + */ +#ifndef TCL_NO_DEPRECATED +#undef Tcl_SetIntObj +void +Tcl_SetIntObj( + Tcl_Obj *objPtr, /* Object whose internal rep to init. */ + int intValue) /* Integer used to set object's value. */ +{ + if (Tcl_IsShared(objPtr)) { + Tcl_Panic("%s called with shared object", "Tcl_SetIntObj"); + } + + TclSetIntObj(objPtr, intValue); +} +#endif /* TCL_NO_DEPRECATED */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetIntFromObj -- + * + * 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. + * + * 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. + * + * 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. + * + * Side effects: + * If the object is not already an int, the conversion will free any old + * internal representation. * *---------------------------------------------------------------------- */ @@ -2592,7 +2805,7 @@ SetIntFromAny( Tcl_Obj *objPtr) /* Pointer to the object to convert */ { Tcl_WideInt w; - return TclGetWideIntFromObj(interp, objPtr, &w); + return Tcl_GetWideIntFromObj(interp, objPtr, &w); } /* @@ -2624,6 +2837,180 @@ UpdateStringOfInt( (void) Tcl_InitStringRep(objPtr, NULL, TclFormatInt(dst, objPtr->internalRep.wideValue)); } + +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 && !defined(TCL_WIDE_INT_IS_LONG) +static void +UpdateStringOfOldInt( + 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 + +/* + *---------------------------------------------------------------------- + * + * Tcl_NewLongObj -- + * + * If a client is compiled with TCL_MEM_DEBUG defined, calls to + * Tcl_NewLongObj to create a new long integer object end up calling the + * debugging function Tcl_DbNewLongObj instead. + * + * Otherwise, if the client is compiled without TCL_MEM_DEBUG defined, + * calls to Tcl_NewLongObj result in a call to one of the two + * Tcl_NewLongObj implementations below. We provide two implementations + * so that the Tcl core can be compiled to do memory debugging of the + * core even if a client does not request it for itself. + * + * 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. + * + * Results: + * The newly created object is returned. This object will have an invalid + * string representation. The returned object has ref count 0. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#ifndef TCL_NO_DEPRECATED +#undef Tcl_NewLongObj +#ifdef TCL_MEM_DEBUG + +Tcl_Obj * +Tcl_NewLongObj( + long longValue) /* Long integer used to initialize the + * new object. */ +{ + return Tcl_DbNewWideIntObj(longValue, "unknown", 0); +} + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_NewLongObj( + long longValue) /* Long integer used to initialize the + * new object. */ +{ + Tcl_Obj *objPtr; + + TclNewIntObj(objPtr, longValue); + return objPtr; +} +#endif /* if TCL_MEM_DEBUG */ +#endif /* TCL_NO_DEPRECATED */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_DbNewLongObj -- + * + * If a client is compiled with TCL_MEM_DEBUG defined, calls to + * Tcl_NewIntObj and Tcl_NewLongObj to create new integer or long integer + * objects end up calling the debugging function Tcl_DbNewLongObj + * instead. We provide two implementations of Tcl_DbNewLongObj so that + * whether the Tcl core is compiled to do memory debugging of the core is + * independent of whether a client requests debugging for itself. + * + * When the core is compiled with TCL_MEM_DEBUG defined, Tcl_DbNewLongObj + * 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 caller's file name and line number when + * reporting objects that haven't been freed. + * + * Otherwise, when the core is compiled without TCL_MEM_DEBUG defined, + * this function just returns the result of calling Tcl_NewLongObj. + * + * Results: + * The newly created long integer object is returned. This object will + * have an invalid string representation. The returned object has ref + * count 0. + * + * Side effects: + * Allocates memory. + * + *---------------------------------------------------------------------- + */ + +#ifndef TCL_NO_DEPRECATED +#undef Tcl_DbNewLongObj +#ifdef TCL_MEM_DEBUG + +Tcl_Obj * +Tcl_DbNewLongObj( + long longValue, /* Long integer used to initialize the new + * object. */ + const char *file, /* The name of the source file calling this + * function; used for debugging. */ + int line) /* Line number in the source file; used for + * debugging. */ +{ + Tcl_Obj *objPtr; + + TclDbNewObj(objPtr, file, line); + /* Optimized TclInvalidateStringRep */ + objPtr->bytes = NULL; + + objPtr->internalRep.wideValue = longValue; + objPtr->typePtr = &tclIntType; + return objPtr; +} + +#else /* if not TCL_MEM_DEBUG */ + +Tcl_Obj * +Tcl_DbNewLongObj( + long longValue, /* Long integer used to initialize the new + * object. */ + TCL_UNUSED(const char *) /*file*/, + TCL_UNUSED(int) /*line*/) +{ + return Tcl_NewWideIntObj(longValue); +} +#endif /* TCL_MEM_DEBUG */ +#endif /* TCL_NO_DEPRECATED */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetLongObj -- + * + * Modify an object to be an integer object and to have the specified + * long integer value. + * + * Results: + * None. + * + * Side effects: + * The object's old string rep, if any, is freed. Also, any old internal + * rep is freed. + * + *---------------------------------------------------------------------- + */ + +#ifndef TCL_NO_DEPRECATED +#undef Tcl_SetLongObj +void +Tcl_SetLongObj( + Tcl_Obj *objPtr, /* Object whose internal rep to init. */ + long longValue) /* Long integer used to initialize the + * object's value. */ +{ + if (Tcl_IsShared(objPtr)) { + Tcl_Panic("%s called with shared object", "Tcl_SetLongObj"); + } + + TclSetIntObj(objPtr, longValue); +} +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- @@ -3195,40 +3582,6 @@ TclGetWideBitsFromObj( /* *---------------------------------------------------------------------- * - * Tcl_GetSizeIntFromObj -- - * - * Attempt to return a Tcl_Size from the Tcl object "objPtr". - * - * Results: - * TCL_OK - the converted Tcl_Size value is stored in *sizePtr - * TCL_ERROR - the error message is stored in interp - * - * Side effects: - * The function may free up any existing internal representation. - * - *---------------------------------------------------------------------- - */ -int -Tcl_GetSizeIntFromObj( - Tcl_Interp *interp, /* Used for error reporting if not NULL. */ - Tcl_Obj *objPtr, /* The object from which to get a int. */ - Tcl_Size *sizePtr) /* Place to store resulting int. */ -{ - if (sizeof(Tcl_Size) == sizeof(int)) { - return TclGetIntFromObj(interp, objPtr, (int *)sizePtr); - } else { - Tcl_WideInt wide; - if (TclGetWideIntFromObj(interp, objPtr, &wide) != TCL_OK) { - return TCL_ERROR; - } - *sizePtr = (Tcl_Size)wide; - return TCL_OK; - } -} - -/* - *---------------------------------------------------------------------- - * * FreeBignum -- * * This function frees the internal rep of a bignum. @@ -3248,7 +3601,7 @@ FreeBignum( TclUnpackBignum(objPtr, toFree); mp_clear(&toFree); if (PTR2INT(objPtr->internalRep.twoPtrValue.ptr2) < 0) { - Tcl_Free(objPtr->internalRep.twoPtrValue.ptr1); + ckfree(objPtr->internalRep.twoPtrValue.ptr1); } objPtr->typePtr = NULL; } @@ -3730,15 +4083,7 @@ Tcl_GetNumber( numBytes = 0; } if (numBytes < 0) { - numBytes = strlen(bytes); - } - if (numBytes > INT_MAX) { - if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "max size for a Tcl value (%d bytes) exceeded", INT_MAX)); - Tcl_SetErrorCode(interp, "TCL", "MEMORY", (void *)NULL); - } - return TCL_ERROR; + numBytes = (int)strlen(bytes); } objPtr->bytes = (char *) bytes; @@ -3794,28 +4139,6 @@ Tcl_DecrRefCount( /* *---------------------------------------------------------------------- * - * TclUndoRefCount -- - * - * Decrement the refCount of objPtr without causing it to be freed if it - * drops from 1 to 0. This allows a function increment a refCount but - * then decrement it and still be able to pass return it to a caller, - * possibly with a refCount of 0. The caller must have previously - * incremented the refCount. - * - *---------------------------------------------------------------------- - */ -void -TclUndoRefCount( - Tcl_Obj *objPtr) /* The object we are releasing a reference to. */ -{ - if (objPtr->refCount > 0) { - --objPtr->refCount; - } -} - -/* - *---------------------------------------------------------------------- - * * Tcl_IsShared -- * * Tests if the object has a ref count greater than one. @@ -3865,7 +4188,7 @@ Tcl_DbIncrRefCount( int line) /* Line number in the source file; used for * debugging. */ { - if (objPtr->refCount == FREEDREFCOUNTFILLER) { + if (objPtr->refCount == 0x61616161) { fprintf(stderr, "file = %s, line = %d\n", file, line); fflush(stderr); Tcl_Panic("incrementing refCount of previously disposed object"); @@ -3938,7 +4261,7 @@ Tcl_DbDecrRefCount( int line) /* Line number in the source file; used for * debugging. */ { - if (objPtr->refCount == FREEDREFCOUNTFILLER) { + if (objPtr->refCount == 0x61616161) { fprintf(stderr, "file = %s, line = %d\n", file, line); fflush(stderr); Tcl_Panic("decrementing refCount of previously disposed object"); @@ -4020,7 +4343,7 @@ Tcl_DbIsShared( #endif { #ifdef TCL_MEM_DEBUG - if (objPtr->refCount == FREEDREFCOUNTFILLER) { + if (objPtr->refCount == 0x61616161) { fprintf(stderr, "file = %s, line = %d\n", file, line); fflush(stderr); Tcl_Panic("checking whether previously disposed object is shared"); @@ -4115,7 +4438,7 @@ AllocObjEntry( void *keyPtr) /* Key to store in the hash table entry. */ { Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr; - Tcl_HashEntry *hPtr = (Tcl_HashEntry *)Tcl_Alloc(sizeof(Tcl_HashEntry)); + Tcl_HashEntry *hPtr = (Tcl_HashEntry *)ckalloc(sizeof(Tcl_HashEntry)); hPtr->key.objPtr = objPtr; Tcl_IncrRefCount(objPtr); @@ -4155,9 +4478,7 @@ TclCompareObjKeys( * 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; */ /* @@ -4211,7 +4532,7 @@ TclFreeObjEntry( Tcl_Obj *objPtr = (Tcl_Obj *) hPtr->key.oneWordValue; Tcl_DecrRefCount(objPtr); - Tcl_Free(hPtr); + ckfree(hPtr); } /* @@ -4232,15 +4553,15 @@ TclFreeObjEntry( *---------------------------------------------------------------------- */ -size_t +TCL_HASH_TYPE TclHashObjKey( TCL_UNUSED(Tcl_HashTable *), void *keyPtr) /* Key from which to compute hash value. */ { Tcl_Obj *objPtr = (Tcl_Obj *)keyPtr; Tcl_Size length; - const char *string = Tcl_GetStringFromObj(objPtr, &length); - size_t result = 0; + const char *string = TclGetStringFromObj(objPtr, &length); + TCL_HASH_TYPE result = 0; /* * I tried a zillion different hash functions and asked many other people @@ -4346,7 +4667,7 @@ Tcl_GetCommandFromObj( TclGetCurrentNamespace(interp); if ((resPtr->refNsPtr == NULL) - || ((refNsPtr == resPtr->refNsPtr) + || ((refNsPtr == resPtr->refNsPtr) && (resPtr->refNsId == refNsPtr->nsId) && (resPtr->refNsCmdEpoch == refNsPtr->cmdRefEpoch))) { return (Tcl_Command) cmdPtr; @@ -4401,7 +4722,7 @@ SetCmdNameObj( if (resPtr) { fillPtr = resPtr; } else { - fillPtr = (ResolvedCmdName *)Tcl_Alloc(sizeof(ResolvedCmdName)); + fillPtr = (ResolvedCmdName *)ckalloc(sizeof(ResolvedCmdName)); fillPtr->refCount = 1; } @@ -4504,7 +4825,7 @@ FreeCmdNameInternalRep( Command *cmdPtr = resPtr->cmdPtr; TclCleanupCommandMacro(cmdPtr); - Tcl_Free(resPtr); + ckfree(resPtr); } objPtr->typePtr = NULL; } diff --git a/generic/tclOptimize.c b/generic/tclOptimize.c index cf5177a..de28b0c 100644 --- a/generic/tclOptimize.c +++ b/generic/tclOptimize.c @@ -28,7 +28,7 @@ static void TrimUnreachable(CompileEnv *envPtr); */ #define DefineTargetAddress(tablePtr, address) \ - ((void) Tcl_CreateHashEntry((tablePtr), (address), &isNew)) + ((void) Tcl_CreateHashEntry((tablePtr), (void *) (address), &isNew)) #define IsTargetAddress(tablePtr, address) \ (Tcl_FindHashEntry((tablePtr), (void *) (address)) != NULL) #define AddrLength(address) \ @@ -54,8 +54,7 @@ LocateTargetAddresses( Tcl_HashTable *tablePtr) { unsigned char *currentInstPtr, *targetInstPtr; - int isNew; - Tcl_Size i; + int isNew, i; Tcl_HashEntry *hPtr; Tcl_HashSearch hSearch; @@ -134,7 +133,7 @@ LocateTargetAddresses( } else { targetInstPtr = envPtr->codeStart + rangePtr->breakOffset; DefineTargetAddress(tablePtr, targetInstPtr); - if (rangePtr->continueOffset != TCL_INDEX_NONE) { + if (rangePtr->continueOffset >= 0) { targetInstPtr = envPtr->codeStart + rangePtr->continueOffset; DefineTargetAddress(tablePtr, targetInstPtr); } @@ -214,7 +213,7 @@ ConvertZeroEffectToNOP( size = AddrLength(currentInstPtr); while ((currentInstPtr + size < envPtr->codeNext) - && currentInstPtr[size] == INST_NOP) { + && *(currentInstPtr+size) == INST_NOP) { if (IsTargetAddress(&targets, currentInstPtr + size)) { break; } @@ -223,7 +222,7 @@ ConvertZeroEffectToNOP( if (IsTargetAddress(&targets, currentInstPtr + size)) { continue; } - nextInst = currentInstPtr[size]; + nextInst = *(currentInstPtr + size); switch (*currentInstPtr) { case INST_PUSH1: if (nextInst == INST_POP) { @@ -232,7 +231,7 @@ ConvertZeroEffectToNOP( && TclGetUInt1AtPtr(currentInstPtr + size + 1) == 2) { Tcl_Obj *litPtr = TclFetchLiteral(envPtr, TclGetUInt1AtPtr(currentInstPtr + 1)); - Tcl_Size numBytes; + int numBytes; (void) TclGetStringFromObj(litPtr, &numBytes); if (numBytes == 0) { @@ -247,7 +246,7 @@ ConvertZeroEffectToNOP( && TclGetUInt1AtPtr(currentInstPtr + size + 1) == 2) { Tcl_Obj *litPtr = TclFetchLiteral(envPtr, TclGetUInt4AtPtr(currentInstPtr + 1)); - Tcl_Size numBytes; + int numBytes; (void) TclGetStringFromObj(litPtr, &numBytes); if (numBytes == 0) { @@ -260,19 +259,19 @@ ConvertZeroEffectToNOP( switch (nextInst) { case INST_JUMP_TRUE1: blank = size; - currentInstPtr[size] = INST_JUMP_FALSE1; + *(currentInstPtr + size) = INST_JUMP_FALSE1; break; case INST_JUMP_FALSE1: blank = size; - currentInstPtr[size] = INST_JUMP_TRUE1; + *(currentInstPtr + size) = INST_JUMP_TRUE1; break; case INST_JUMP_TRUE4: blank = size; - currentInstPtr[size] = INST_JUMP_FALSE4; + *(currentInstPtr + size) = INST_JUMP_FALSE4; break; case INST_JUMP_FALSE4: blank = size; - currentInstPtr[size] = INST_JUMP_TRUE4; + *(currentInstPtr + size) = INST_JUMP_TRUE4; break; } break; @@ -288,6 +287,8 @@ ConvertZeroEffectToNOP( case INST_INCR_ARRAY_STK: case INST_INCR_SCALAR_STK: case INST_INCR_STK: + case INST_LOR: + case INST_LAND: case INST_EQ: case INST_NEQ: case INST_LT: @@ -318,7 +319,7 @@ ConvertZeroEffectToNOP( if (blank > 0) { for (i=0 ; i<blank ; i++) { - currentInstPtr[i] = INST_NOP; + *(currentInstPtr + i) = INST_NOP; } size = blank; } @@ -366,7 +367,7 @@ AdvanceJumps( break; } offset += delta; - switch (currentInstPtr[offset]) { + switch (*(currentInstPtr + offset)) { case INST_NOP: delta = InstLength(INST_NOP); continue; @@ -394,7 +395,7 @@ AdvanceJumps( offset = TclGetInt4AtPtr(currentInstPtr + 1); break; } - switch (currentInstPtr[offset]) { + switch (*(currentInstPtr + offset)) { case INST_NOP: offset += InstLength(INST_NOP); continue; diff --git a/generic/tclPanic.c b/generic/tclPanic.c index dcceb25..1887e0f 100644 --- a/generic/tclPanic.c +++ b/generic/tclPanic.c @@ -15,7 +15,7 @@ #include "tclInt.h" #if defined(_WIN32) || defined(__CYGWIN__) - MODULE_SCOPE void tclWinDebugPanic(const char *format, ...); + MODULE_SCOPE TCL_NORETURN void tclWinDebugPanic(const char *format, ...); #endif /* @@ -23,7 +23,11 @@ * procedure. */ +#if defined(__CYGWIN__) || (defined(_WIN32) && (defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8)) +static Tcl_PanicProc *panicProc = tclWinDebugPanic; +#else static Tcl_PanicProc *panicProc = NULL; +#endif /* *---------------------------------------------------------------------- @@ -41,10 +45,19 @@ static Tcl_PanicProc *panicProc = NULL; *---------------------------------------------------------------------- */ +#undef Tcl_SetPanicProc const char * Tcl_SetPanicProc( Tcl_PanicProc *proc) { +#if defined(_WIN32) + /* tclWinDebugPanic only installs if there is no panicProc yet. */ + if ((proc != tclWinDebugPanic) || (panicProc == NULL)) +#elif defined(__CYGWIN__) + if (proc == NULL) + panicProc = tclWinDebugPanic; + else +#endif panicProc = proc; return Tcl_InitSubsystems(); } @@ -52,7 +65,7 @@ Tcl_SetPanicProc( /* *---------------------------------------------------------------------- * - * Tcl_Panic -- + * Tcl_PanicVA -- * * Print an error message and kill the process. * @@ -65,24 +78,16 @@ Tcl_SetPanicProc( *---------------------------------------------------------------------- */ -/* - * The following comment is here so that Coverity's static analyzer knows that - * a Tcl_Panic() call can never return and avoids lots of false positives. - */ - -/* coverity[+kill] */ TCL_NORETURN void -Tcl_Panic( - const char *format, - ...) +Tcl_PanicVA( + const char *format, /* Format string, suitable for passing to + * fprintf. */ + va_list argList) /* Variable argument list. */ { - va_list argList; char *arg1, *arg2, *arg3; /* Additional arguments (variable in number) * to pass to fprintf. */ char *arg4, *arg5, *arg6, *arg7, *arg8; - - va_start(argList, format); arg1 = va_arg(argList, char *); arg2 = va_arg(argList, char *); arg3 = va_arg(argList, char *); @@ -91,29 +96,30 @@ Tcl_Panic( arg6 = va_arg(argList, char *); arg7 = va_arg(argList, char *); arg8 = va_arg(argList, char *); - va_end (argList); if (panicProc != NULL) { panicProc(format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8); +#ifdef _WIN32 + } else if (IsDebuggerPresent()) { + tclWinDebugPanic(format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8); +#endif } else { -#if defined(_WIN32) || defined(__CYGWIN__) - tclWinDebugPanic(format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8); -#else fprintf(stderr, format, arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8); fprintf(stderr, "\n"); fflush(stderr); -#endif } +#if defined(_WIN32) || defined(__CYGWIN__) #if defined(__GNUC__) __builtin_trap(); #elif defined(_WIN64) __debugbreak(); #elif defined(_MSC_VER) && defined (_M_IX86) _asm {int 3} -#elif defined(_WIN32) +#else DebugBreak(); #endif +#endif #if defined(_WIN32) ExitProcess(1); #else @@ -122,6 +128,39 @@ Tcl_Panic( } /* + *---------------------------------------------------------------------- + * + * Tcl_Panic -- + * + * Print an error message and kill the process. + * + * Results: + * None. + * + * Side effects: + * The process dies, entering the debugger if possible. + * + *---------------------------------------------------------------------- + */ + +/* + * The following comment is here so that Coverity's static analyzer knows that + * a Tcl_Panic() call can never return and avoids lots of false positives. + */ + +/* coverity[+kill] */ +TCL_NORETURN void +Tcl_Panic( + const char *format, + ...) +{ + va_list argList; + + va_start(argList, format); + Tcl_PanicVA(format, argList); +} + +/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclParse.c b/generic/tclParse.c index 13e5c1e..281eee5 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -33,13 +33,12 @@ * meaning in ParseTokens: backslash, dollar sign, or * open bracket. * TYPE_QUOTE - Character is a double quote. - * TYPE_OPEN_PAREN - Character is a left parenthesis. * TYPE_CLOSE_PAREN - Character is a right parenthesis. * TYPE_CLOSE_BRACK - Character is a right square bracket. * TYPE_BRACE - Character is a curly brace (either left or right). */ -const unsigned char tclCharTypeTable[] = { +const char tclCharTypeTable[] = { /* * Positive character values, from 0-127: @@ -55,7 +54,7 @@ const unsigned char tclCharTypeTable[] = { TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, TYPE_SPACE, TYPE_NORMAL, TYPE_QUOTE, TYPE_NORMAL, TYPE_SUBS, TYPE_NORMAL, TYPE_NORMAL, TYPE_NORMAL, - TYPE_OPEN_PAREN, TYPE_CLOSE_PAREN, TYPE_NORMAL, TYPE_NORMAL, + TYPE_NORMAL, TYPE_CLOSE_PAREN, 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, @@ -120,16 +119,16 @@ const unsigned char tclCharTypeTable[] = { * Prototypes for local functions defined in this file: */ -static int CommandComplete(const char *script, Tcl_Size numBytes); -static Tcl_Size ParseComment(const char *src, Tcl_Size numBytes, +static int CommandComplete(const char *script, int numBytes); +static int ParseComment(const char *src, int numBytes, Tcl_Parse *parsePtr); -static int ParseTokens(const char *src, Tcl_Size numBytes, int mask, +static int ParseTokens(const char *src, int numBytes, int mask, int flags, Tcl_Parse *parsePtr); -static Tcl_Size ParseWhiteSpace(const char *src, Tcl_Size numBytes, +static int ParseWhiteSpace(const char *src, int numBytes, int *incompletePtr, char *typePtr); -static Tcl_Size ParseAllWhiteSpace(const char *src, Tcl_Size numBytes, +static int ParseAllWhiteSpace(const char *src, int numBytes, int *incompletePtr); -static int ParseHex(const char *src, Tcl_Size numBytes, +static int ParseHex(const char *src, int numBytes, int *resultPtr); /* @@ -152,7 +151,7 @@ void TclParseInit( Tcl_Interp *interp, /* Interpreter to use for error reporting */ const char *start, /* Start of string to be parsed. */ - Tcl_Size numBytes, /* Total number of bytes in string. If -1, + int numBytes, /* Total number of bytes in string. If < 0, * the script consists of all bytes up to the * first null character. */ Tcl_Parse *parsePtr) /* Points to struct to initialize */ @@ -198,7 +197,7 @@ Tcl_ParseCommand( * NULL, then no error message is provided. */ const char *start, /* First character of string containing one or * more Tcl commands. */ - Tcl_Size numBytes, /* Total number of bytes in string. If -1, + int numBytes, /* Total number of bytes in string. If < 0, * the script consists of all bytes up to the * first null character. */ int nested, /* Non-zero means this is a nested command: @@ -210,16 +209,16 @@ Tcl_ParseCommand( * the parsed command; any previous * information in the structure is ignored. */ { - const char *src; /* Points to current character in the + const char *src; /* Points to current character in the * command. */ char type; /* Result returned by CHAR_TYPE(*src). */ Tcl_Token *tokenPtr; /* Pointer to token being filled in. */ - Tcl_Size wordIndex; /* Index of word token for current word. */ + int wordIndex; /* Index of word token for current word. */ int terminators; /* CHAR_TYPE bits that indicate the end of a * command. */ const char *termPtr; /* Set by Tcl_ParseBraces/QuotedString to * point to char after terminating one. */ - Tcl_Size scanned; + int scanned; if (numBytes < 0 && start) { numBytes = strlen(start); @@ -327,7 +326,7 @@ Tcl_ParseCommand( src = termPtr; numBytes = parsePtr->end - src; } else if (*src == '{') { - Tcl_Size expIdx = wordIndex + 1; + int expIdx = wordIndex + 1; Tcl_Token *expPtr; if (Tcl_ParseBraces(interp, src, numBytes, parsePtr, 1, @@ -345,9 +344,9 @@ Tcl_ParseCommand( expPtr = &parsePtr->tokenPtr[expIdx]; if ((0 == expandWord) /* Haven't seen prefix already */ - && (expIdx + 1 == parsePtr->numTokens) + && (1 == parsePtr->numTokens - expIdx) /* Only one token */ - && (((1 == expPtr->size) + && (((1 == (size_t) expPtr->size) /* Same length as prefix */ && (expPtr->start[0] == '*'))) /* Is the prefix */ @@ -382,8 +381,7 @@ Tcl_ParseCommand( tokenPtr->size = src - tokenPtr->start; tokenPtr->numComponents = parsePtr->numTokens - (wordIndex + 1); if (expandWord) { - Tcl_Size i; - int isLiteral = 1; + int i, isLiteral = 1; /* * When a command includes a word that is an expanded literal; for @@ -407,8 +405,7 @@ Tcl_ParseCommand( } if (isLiteral) { - Tcl_Size elemCount = 0; - int code = TCL_OK, literal = 1; + int elemCount = 0, code = TCL_OK, literal = 1; const char *nextElem, *listEnd, *elemStart; /* @@ -430,7 +427,7 @@ Tcl_ParseCommand( */ while (nextElem < listEnd) { - Tcl_Size size; + int size; code = TclFindElement(NULL, nextElem, listEnd - nextElem, &elemStart, &nextElem, &size, &literal); @@ -472,7 +469,7 @@ Tcl_ParseCommand( */ const char *listStart; - Tcl_Size growthNeeded = wordIndex + 2*elemCount + int growthNeeded = wordIndex + 2*elemCount - parsePtr->numTokens; parsePtr->numWords += elemCount - 1; @@ -622,10 +619,10 @@ TclIsBareword( *---------------------------------------------------------------------- */ -static Tcl_Size +static int ParseWhiteSpace( const char *src, /* First character to parse. */ - Tcl_Size numBytes, /* Max number of bytes to scan. */ + int numBytes, /* Max number of bytes to scan. */ int *incompletePtr, /* Set this boolean memory to true if parsing * indicates an incomplete command. */ char *typePtr) /* Points to location to store character type @@ -676,17 +673,17 @@ ParseWhiteSpace( *---------------------------------------------------------------------- */ -static Tcl_Size +static int ParseAllWhiteSpace( const char *src, /* First character to parse. */ - Tcl_Size numBytes, /* Max number of byes to scan */ + int numBytes, /* Max number of byes to scan */ int *incompletePtr) /* Set true if parse is incomplete. */ { char type; const char *p = src; do { - Tcl_Size scanned = ParseWhiteSpace(p, numBytes, incompletePtr, &type); + int scanned = ParseWhiteSpace(p, numBytes, incompletePtr, &type); p += scanned; numBytes -= scanned; @@ -694,10 +691,10 @@ ParseAllWhiteSpace( return (p-src); } -Tcl_Size +int TclParseAllWhiteSpace( const char *src, /* First character to parse. */ - Tcl_Size numBytes) /* Max number of byes to scan */ + int numBytes) /* Max number of byes to scan */ { int dummy; return ParseAllWhiteSpace(src, numBytes, &dummy); @@ -728,8 +725,8 @@ TclParseAllWhiteSpace( int ParseHex( const char *src, /* First character to parse. */ - Tcl_Size numBytes, /* Max number of byes to scan */ - int *resultPtr) /* Points to storage provided by caller where + int numBytes, /* Max number of byes to scan */ + int *resultPtr) /* Points to storage provided by caller where * the character resulting from the * conversion is to be written. */ { @@ -784,8 +781,8 @@ int TclParseBackslash( const char *src, /* Points to the backslash character of a * backslash sequence. */ - Tcl_Size numBytes, /* Max number of bytes to scan. */ - Tcl_Size *readPtr, /* NULL, or points to storage where the number + int numBytes, /* Max number of bytes to scan. */ + int *readPtr, /* NULL, or points to storage where the number * 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 @@ -794,7 +791,7 @@ TclParseBackslash( const char *p = src+1; int unichar; int result; - Tcl_Size count; + int count; char buf[4] = ""; if (numBytes == 0) { @@ -871,6 +868,16 @@ TclParseBackslash( * No hexdigits -> This is just "u". */ result = 'u'; + } else if (((result & 0xFC00) == 0xD800) && (count == 6) + && (p[5] == '\\') && (p[6] == 'u') && (numBytes >= 10)) { + /* If high surrogate is immediately followed by a low surrogate + * escape, combine them into one character. */ + int low; + int count2 = ParseHex(p+7, 4, &low); + if ((count2 == 4) && ((low & 0xFC00) == 0xDC00)) { + result = ((result & 0x3FF)<<10 | (low & 0x3FF)) + 0x10000; + count += count2 + 2; + } } break; case 'U': @@ -880,6 +887,9 @@ TclParseBackslash( * No hexdigits -> This is just "U". */ result = 'U'; + } else if ((result | 0x7FF) == 0xDFFF) { + /* Upper or lower surrogate, not allowed in this syntax. */ + result = 0xFFFD; } break; case '\n': @@ -943,6 +953,10 @@ TclParseBackslash( *readPtr = count; } count = Tcl_UniCharToUtf(result, dst); + if ((result >= 0xD800) && (count < 3)) { + /* Special case for handling high surrogates. */ + count += Tcl_UniCharToUtf(-1, dst + count); + } return count; } @@ -964,10 +978,10 @@ TclParseBackslash( *---------------------------------------------------------------------- */ -static Tcl_Size +static int ParseComment( const char *src, /* First character to parse. */ - Tcl_Size numBytes, /* Max number of bytes to scan. */ + int numBytes, /* Max number of bytes to scan. */ Tcl_Parse *parsePtr) /* Information about parse in progress. * Updated if parsing indicates an incomplete * command. */ @@ -976,7 +990,7 @@ ParseComment( int incomplete = parsePtr->incomplete; while (numBytes) { - Tcl_Size scanned = ParseAllWhiteSpace(p, numBytes, &incomplete); + int scanned = ParseAllWhiteSpace(p, numBytes, &incomplete); p += scanned; numBytes -= scanned; @@ -1040,7 +1054,7 @@ ParseComment( static int ParseTokens( const char *src, /* First character to parse. */ - Tcl_Size numBytes, /* Max number of bytes to scan. */ + int numBytes, /* Max number of bytes to scan. */ int mask, /* Specifies when to stop parsing. The parse * stops at the first unquoted character whose * CHAR_TYPE contains any of the bits in @@ -1054,7 +1068,7 @@ ParseTokens( * termination information. */ { char type; - Tcl_Size originalTokens; + int originalTokens; int noSubstCmds = !(flags & TCL_SUBST_COMMANDS); int noSubstVars = !(flags & TCL_SUBST_VARIABLES); int noSubstBS = !(flags & TCL_SUBST_BACKSLASHES); @@ -1088,7 +1102,7 @@ ParseTokens( tokenPtr->size = src - tokenPtr->start; parsePtr->numTokens++; } else if (*src == '$') { - Tcl_Size varToken; + int varToken; if (noSubstVars) { tokenPtr->type = TCL_TOKEN_TEXT; @@ -1280,7 +1294,7 @@ Tcl_FreeParse( * call to Tcl_ParseCommand. */ { if (parsePtr->tokenPtr != parsePtr->staticTokens) { - Tcl_Free(parsePtr->tokenPtr); + ckfree(parsePtr->tokenPtr); parsePtr->tokenPtr = parsePtr->staticTokens; } } @@ -1318,7 +1332,7 @@ Tcl_ParseVarName( * NULL, then no error message is provided. */ const char *start, /* Start of variable substitution string. * First character must be "$". */ - Tcl_Size numBytes, /* Total number of bytes in string. If -1, + int numBytes, /* Total number of bytes in string. If < 0, * the string consists of all bytes up to the * first null character. */ Tcl_Parse *parsePtr, /* Structure to fill in with information about @@ -1382,28 +1396,15 @@ Tcl_ParseVarName( */ if (*src == '{') { - char ch; int braceCount = 0; src++; numBytes--; tokenPtr->type = TCL_TOKEN_TEXT; tokenPtr->start = src; tokenPtr->numComponents = 0; - ch = *src; - while (numBytes && (braceCount>0 || ch != '}')) { - switch (ch) { - case '{': braceCount++; break; - case '}': braceCount--; break; - case '\\': - /* if 2 or more left, consume 2, else consume - just the \ and let it run into the end */ - if (numBytes > 1) { - src++; numBytes--; - } - } + while (numBytes && (*src != '}')) { numBytes--; src++; - ch= *src; } if (numBytes == 0) { if (parsePtr->interp != NULL) { @@ -1459,11 +1460,11 @@ Tcl_ParseVarName( * any number of substitutions. */ - if (TCL_OK != ParseTokens(src+1, numBytes-1, TYPE_BAD_ARRAY_INDEX, + if (TCL_OK != ParseTokens(src+1, numBytes-1, TYPE_CLOSE_PAREN, TCL_SUBST_ALL, parsePtr)) { goto error; } - if (parsePtr->term == src+numBytes){ + if ((parsePtr->term == src+numBytes) || (*parsePtr->term != ')')){ if (parsePtr->interp != NULL) { Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj( "missing )", -1)); @@ -1472,14 +1473,6 @@ Tcl_ParseVarName( parsePtr->term = src; parsePtr->incomplete = 1; goto error; - } else if ((*parsePtr->term != ')')){ - if (parsePtr->interp != NULL) { - Tcl_SetObjResult(parsePtr->interp, Tcl_NewStringObj( - "invalid character in array index", -1)); - } - parsePtr->errorType = TCL_PARSE_SYNTAX; - parsePtr->term = src; - goto error; } src = parsePtr->term + 1; } @@ -1541,7 +1534,7 @@ Tcl_ParseVar( int code; Tcl_Parse *parsePtr = (Tcl_Parse *)TclStackAlloc(interp, sizeof(Tcl_Parse)); - if (Tcl_ParseVarName(interp, start, TCL_INDEX_NONE, parsePtr, 0) != TCL_OK) { + if (Tcl_ParseVarName(interp, start, -1, parsePtr, 0) != TCL_OK) { TclStackFree(interp, parsePtr); return NULL; } @@ -1616,7 +1609,7 @@ Tcl_ParseBraces( * NULL, then no error message is provided. */ const char *start, /* Start of string enclosed in braces. The * first character must be {'. */ - Tcl_Size numBytes, /* Total number of bytes in string. If -1, + int numBytes, /* Total number of bytes in string. If < 0, * the string consists of all bytes up to the * first null character. */ Tcl_Parse *parsePtr, @@ -1633,7 +1626,7 @@ Tcl_ParseBraces( { Tcl_Token *tokenPtr; const char *src; - Tcl_Size length, startIndex, level; + int startIndex, level, length; if (numBytes < 0 && start) { numBytes = strlen(start); @@ -1817,7 +1810,7 @@ Tcl_ParseQuotedString( * NULL, then no error message is provided. */ const char *start, /* Start of the quoted string. The first * character must be '"'. */ - Tcl_Size numBytes, /* Total number of bytes in string. If -1, + int numBytes, /* Total number of bytes in string. If < 0, * the string consists of all bytes up to the * first null character. */ Tcl_Parse *parsePtr, @@ -1898,12 +1891,12 @@ void TclSubstParse( Tcl_Interp *interp, const char *bytes, - Tcl_Size numBytes, + int numBytes, int flags, Tcl_Parse *parsePtr, Tcl_InterpState *statePtr) { - Tcl_Size length = numBytes; + int length = numBytes; const char *p = bytes; TclParseInit(interp, p, length, parsePtr); @@ -2097,13 +2090,13 @@ TclSubstTokens( * errors. */ Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to * evaluate and concatenate. */ - Tcl_Size count, /* Number of tokens to consider at tokenPtr. + int count, /* Number of tokens to consider at tokenPtr. * Must be at least 1. */ int *tokensLeftPtr, /* If not NULL, points to memory where an * integer representing the number of tokens * left to be substituted will be written */ - Tcl_Size line, /* The line the script starts on. */ - Tcl_Size *clNextOuter, /* Information about an outer context for */ + int line, /* The line the script starts on. */ + int *clNextOuter, /* Information about an outer context for */ const char *outerScript) /* continuation line data. This is set by * EvalEx() to properly handle [...]-nested * commands. The 'outerScript' refers to the @@ -2124,9 +2117,8 @@ TclSubstTokens( Tcl_Obj *result; int code = TCL_OK; #define NUM_STATIC_POS 20 - int isLiteral; - Tcl_Size i, maxNumCL, numCL, adjust; - Tcl_Size *clPosition = NULL; + int isLiteral, maxNumCL, numCL, i, adjust; + int *clPosition = NULL; Interp *iPtr = (Interp *) interp; int inFile = iPtr->evalFlags & TCL_EVAL_FILE; @@ -2161,7 +2153,7 @@ TclSubstTokens( if (isLiteral) { maxNumCL = NUM_STATIC_POS; - clPosition = (Tcl_Size *)Tcl_Alloc(maxNumCL * sizeof(Tcl_Size)); + clPosition = (int *)ckalloc(maxNumCL * sizeof(int)); } adjust = 0; @@ -2201,18 +2193,18 @@ TclSubstTokens( if ((appendByteLength == 1) && (utfCharBytes[0] == ' ') && (tokenPtr->start[1] == '\n')) { if (isLiteral) { - Tcl_Size clPos; + int clPos; if (result == 0) { clPos = 0; } else { - (void)TclGetStringFromObj(result, &clPos); + TclGetStringFromObj(result, &clPos); } if (numCL >= maxNumCL) { maxNumCL *= 2; - clPosition = (Tcl_Size *)Tcl_Realloc(clPosition, - maxNumCL * sizeof(Tcl_Size)); + clPosition = (int *)ckrealloc(clPosition, + maxNumCL * sizeof(int)); } clPosition[numCL] = clPos; numCL++; @@ -2230,7 +2222,7 @@ TclSubstTokens( * Test cases: info-30.{6,8,9} */ - Tcl_Size theline; + int theline; TclAdvanceContinuations(&line, &clNextOuter, tokenPtr->start - outerScript); @@ -2369,7 +2361,7 @@ TclSubstTokens( */ if (maxNumCL) { - Tcl_Free(clPosition); + ckfree(clPosition); } } else { Tcl_ResetResult(interp); @@ -2407,7 +2399,7 @@ TclSubstTokens( static int CommandComplete( const char *script, /* Script to check. */ - Tcl_Size numBytes) /* Number of bytes in script. */ + int numBytes) /* Number of bytes in script. */ { Tcl_Parse parse; const char *p, *end; @@ -2455,7 +2447,7 @@ int Tcl_CommandComplete( const char *script) /* Script to check. */ { - return CommandComplete(script, strlen(script)); + return CommandComplete(script, (int) strlen(script)); } /* @@ -2481,7 +2473,7 @@ TclObjCommandComplete( Tcl_Obj *objPtr) /* Points to object holding script to * check. */ { - Tcl_Size length; + int length; const char *script = TclGetStringFromObj(objPtr, &length); return CommandComplete(script, length); diff --git a/generic/tclParse.h b/generic/tclParse.h index b28ac8c..5f75c9a 100644 --- a/generic/tclParse.h +++ b/generic/tclParse.h @@ -11,9 +11,7 @@ #define TYPE_CLOSE_PAREN 0x10 #define TYPE_CLOSE_BRACK 0x20 #define TYPE_BRACE 0x40 -#define TYPE_OPEN_PAREN 0x80 -#define TYPE_BAD_ARRAY_INDEX (TYPE_OPEN_PAREN|TYPE_CLOSE_PAREN|TYPE_QUOTE|TYPE_BRACE) #define CHAR_TYPE(c) tclCharTypeTable[(unsigned char)(c)] -MODULE_SCOPE const unsigned char tclCharTypeTable[]; +MODULE_SCOPE const char tclCharTypeTable[]; diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 80954bc..ec70add 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -25,7 +25,7 @@ static void DupFsPathInternalRep(Tcl_Obj *srcPtr, static void FreeFsPathInternalRep(Tcl_Obj *pathPtr); static void UpdateStringOfFsPath(Tcl_Obj *pathPtr); static int SetFsPathFromAny(Tcl_Interp *interp, Tcl_Obj *pathPtr); -static Tcl_Size FindSplitPos(const char *path, int separator); +static int FindSplitPos(const char *path, int separator); static int IsSeparatorOrNull(int ch); static Tcl_Obj * GetExtension(Tcl_Obj *pathPtr); static int MakePathFromNormalized(Tcl_Interp *interp, @@ -44,8 +44,7 @@ static const Tcl_ObjType fsPathType = { FreeFsPathInternalRep, /* freeIntRepProc */ DupFsPathInternalRep, /* dupIntRepProc */ UpdateStringOfFsPath, /* updateStringProc */ - SetFsPathFromAny, /* setFromAnyProc */ - TCL_OBJTYPE_V0 + SetFsPathFromAny /* setFromAnyProc */ }; /* @@ -54,7 +53,7 @@ static const Tcl_ObjType fsPathType = { * Internal representation of a Tcl_Obj of fsPathType */ -typedef struct { +typedef struct FsPath { Tcl_Obj *translatedPathPtr; /* If the path has been normalized (flags == * 0), this is NULL. Otherwise it is a path * in which any ~user sequences have been @@ -68,9 +67,9 @@ typedef struct { * normPathPtr exists and is absolute. */ int flags; /* Flags to describe interpretation - see * below. */ - void *nativePathPtr; /* Native representation of this path, which + ClientData nativePathPtr; /* Native representation of this path, which * is filesystem dependent. */ - size_t filesystemEpoch; /* Used to ensure the path representation was + int filesystemEpoch; /* Used to ensure the path representation was * generated during the correct filesystem * epoch. The epoch changes when * filesystem-mounts are changed. */ @@ -217,14 +216,14 @@ TclFSNormalizeAbsolutePath( /* * Need to skip '.' in the path. */ - Tcl_Size curLen; + int curLen; if (retVal == NULL) { const char *path = TclGetString(pathPtr); retVal = Tcl_NewStringObj(path, dirSep - path); Tcl_IncrRefCount(retVal); } - (void)TclGetStringFromObj(retVal, &curLen); + TclGetStringFromObj(retVal, &curLen); if (curLen == 0) { Tcl_AppendToObj(retVal, dirSep, 1); } @@ -237,7 +236,7 @@ TclFSNormalizeAbsolutePath( } if (dirSep[2] == '.' && IsSeparatorOrNull(dirSep[3])) { Tcl_Obj *linkObj; - Tcl_Size curLen; + int curLen; char *linkStr; /* @@ -250,7 +249,7 @@ TclFSNormalizeAbsolutePath( retVal = Tcl_NewStringObj(path, dirSep - path); Tcl_IncrRefCount(retVal); } - (void)TclGetStringFromObj(retVal, &curLen); + TclGetStringFromObj(retVal, &curLen); if (curLen == 0) { Tcl_AppendToObj(retVal, dirSep, 1); } @@ -276,7 +275,8 @@ TclFSNormalizeAbsolutePath( */ if (tclPlatform != TCL_PLATFORM_WINDOWS - && Tcl_FSGetPathType(linkObj) == TCL_PATH_RELATIVE) { + && Tcl_FSGetPathType(linkObj) + == TCL_PATH_RELATIVE) { /* * We need to follow this link which is relative * to retVal's directory. This means concatenating @@ -286,7 +286,7 @@ TclFSNormalizeAbsolutePath( const char *path = TclGetStringFromObj(retVal, &curLen); - while (curLen-- > 0) { + while (--curLen >= 0) { if (IsSeparatorOrNull(path[curLen])) { break; } @@ -319,7 +319,7 @@ TclFSNormalizeAbsolutePath( */ if (tclPlatform == TCL_PLATFORM_WINDOWS) { - Tcl_Size i; + int i; for (i = 0; i < curLen; i++) { if (linkStr[i] == '\\') { @@ -402,12 +402,11 @@ TclFSNormalizeAbsolutePath( */ if (zipVolumeLen || (tclPlatform == TCL_PLATFORM_WINDOWS)) { int needTrailingSlash = 0; - Tcl_Size len; + int len; const char *path = TclGetStringFromObj(retVal, &len); if (zipVolumeLen) { - if (len == (zipVolumeLen - 1)) { + if (len == (zipVolumeLen - 1)) needTrailingSlash = 1; - } } else { if (len == 2 && path[0] != 0 && path[1] == ':') { needTrailingSlash = 1; @@ -502,7 +501,7 @@ Tcl_PathType TclFSGetPathType( Tcl_Obj *pathPtr, const Tcl_Filesystem **filesystemPtrPtr, - Tcl_Size *driveNameLengthPtr) + int *driveNameLengthPtr) { FsPath *fsPathPtr; @@ -566,7 +565,7 @@ TclFSGetPathType( Tcl_Obj * TclPathPart( - TCL_UNUSED(Tcl_Interp *), /* Used for error reporting */ + Tcl_Interp *interp, /* Used for error reporting */ Tcl_Obj *pathPtr, /* Path to take dirname of */ Tcl_PathPart portion) /* Requested portion of name */ { @@ -584,8 +583,9 @@ TclPathPart( * the standardPath code. */ - Tcl_Size numBytes; - const char *rest = TclGetStringFromObj(fsPathPtr->normPathPtr, &numBytes); + int numBytes; + const char *rest = + TclGetStringFromObj(fsPathPtr->normPathPtr, &numBytes); if (strchr(rest, '/') != NULL) { goto standardPath; @@ -621,8 +621,9 @@ TclPathPart( * we don't, and instead just use the standardPath code. */ - Tcl_Size numBytes; - const char *rest = TclGetStringFromObj(fsPathPtr->normPathPtr, &numBytes); + int numBytes; + const char *rest = + TclGetStringFromObj(fsPathPtr->normPathPtr, &numBytes); if (strchr(rest, '/') != NULL) { goto standardPath; @@ -649,7 +650,7 @@ TclPathPart( return GetExtension(fsPathPtr->normPathPtr); case TCL_PATH_ROOT: { const char *fileName, *extension; - Tcl_Size length; + int length; fileName = TclGetStringFromObj(fsPathPtr->normPathPtr, &length); @@ -672,7 +673,7 @@ TclPathPart( Tcl_Obj *resultPtr = TclNewFSPathObj(fsPathPtr->cwdPtr, fileName, - length - strlen(extension)); + (int)(length - strlen(extension))); Tcl_IncrRefCount(resultPtr); return resultPtr; @@ -692,7 +693,7 @@ TclPathPart( goto standardPath; } } else { - Tcl_Size splitElements; + int splitElements; Tcl_Obj *splitPtr, *resultPtr; standardPath: @@ -700,7 +701,7 @@ TclPathPart( if (portion == TCL_PATH_EXTENSION) { return GetExtension(pathPtr); } else if (portion == TCL_PATH_ROOT) { - Tcl_Size length; + int length; const char *fileName, *extension; fileName = TclGetStringFromObj(pathPtr, &length); @@ -710,7 +711,7 @@ TclPathPart( return pathPtr; } else { Tcl_Obj *root = Tcl_NewStringObj(fileName, - length - strlen(extension)); + (int) (length - strlen(extension))); Tcl_IncrRefCount(root); return root; @@ -725,8 +726,18 @@ TclPathPart( splitPtr = Tcl_FSSplitPath(pathPtr, &splitElements); Tcl_IncrRefCount(splitPtr); + if (splitElements == 1 && TclGetString(pathPtr)[0] == '~') { + Tcl_Obj *norm; - if (portion == TCL_PATH_TAIL) { + TclDecrRefCount(splitPtr); + norm = Tcl_FSGetNormalizedPath(interp, pathPtr); + if (norm == NULL) { + return NULL; + } + splitPtr = Tcl_FSSplitPath(norm, &splitElements); + Tcl_IncrRefCount(splitPtr); + } + if (portion == TCL_PATH_TAIL) { /* * Return the last component, unless it is the only component, and * it is the root of an absolute path. @@ -820,10 +831,10 @@ Tcl_Obj * Tcl_FSJoinPath( Tcl_Obj *listObj, /* Path elements to join, may have a zero * reference count. */ - Tcl_Size elements) /* Number of elements to use (-1 = all) */ + int elements) /* Number of elements to use (-1 = all) */ { Tcl_Obj *res; - Tcl_Size objc; + int objc; Tcl_Obj **objv; if (TclListObjLength(NULL, listObj, &objc) != TCL_OK) { @@ -838,15 +849,17 @@ Tcl_FSJoinPath( Tcl_Obj * TclJoinPath( - Tcl_Size elements, /* Number of elements to use */ + int elements, /* Number of elements to use (-1 = all) */ Tcl_Obj * const objv[], /* Path elements to join */ int forceRelative) /* If non-zero, assume all more paths are * relative (e.g. simple normalization) */ { Tcl_Obj *res = NULL; - Tcl_Size i; + int i; const Tcl_Filesystem *fsPtr = NULL; + assert ( elements >= 0 ); + if (elements == 0) { TclNewObj(res); return res; @@ -881,7 +894,7 @@ TclJoinPath( TclGetPathType(tailObj, NULL, NULL, NULL); if (type == TCL_PATH_RELATIVE) { const char *str; - Tcl_Size len; + int len; str = TclGetStringFromObj(tailObj, &len); if (len == 0) { @@ -948,8 +961,7 @@ TclJoinPath( assert ( res == NULL ); for (i = 0; i < elements; i++) { - Tcl_Size driveNameLength; - Tcl_Size strEltLen, length; + int driveNameLength, strEltLen, length; Tcl_PathType type; char *strElt, *ptr; Tcl_Obj *driveName = NULL; @@ -1054,8 +1066,18 @@ TclJoinPath( } ptr = TclGetStringFromObj(res, &length); - /* - * A NULL value for fsPtr at this stage basically means we're trying + /* + * Strip off any './' before a tilde, unless this is the beginning of + * the path. + */ + + if (length > 0 && strEltLen > 0 && (strElt[0] == '.') && + (strElt[1] == '/') && (strElt[2] == '~')) { + strElt += 2; + } + + /* + * A NULL value for fsPtr at this stage basically means we're trying * to join a relative path onto something which is also relative (or * empty). There's nothing particularly wrong with that. */ @@ -1087,9 +1109,9 @@ TclJoinPath( if (length > 0 && ptr[length -1] != '/') { Tcl_AppendToObj(res, &separator, 1); - (void)TclGetStringFromObj(res, &length); + TclGetStringFromObj(res, &length); } - Tcl_SetObjLength(res, length + strlen(strElt)); + Tcl_SetObjLength(res, length + (int) strlen(strElt)); ptr = TclGetString(res) + length; for (; *strElt != '\0'; strElt++) { @@ -1191,7 +1213,7 @@ IsSeparatorOrNull( * of the end of the string. */ -static Tcl_Size +static int FindSplitPos( const char *path, int separator) @@ -1245,17 +1267,14 @@ Tcl_Obj * TclNewFSPathObj( Tcl_Obj *dirPtr, const char *addStrRep, - Tcl_Size len) + int len) { FsPath *fsPathPtr; Tcl_Obj *pathPtr; const char *p; int state = 0, count = 0; - /* - * This comment is kept from the days of tilde expansion because - * it is illustrative of a more general problem. - * [Bug 2806250] - this is only a partial solution of the problem. + /* [Bug 2806250] - this is only a partial solution of the problem. * The PATHFLAGS != 0 representation assumes in many places that * the "tail" part stored in the normPathPtr field is itself a * relative path. Strings that begin with "~" are not relative paths, @@ -1271,9 +1290,16 @@ TclNewFSPathObj( * that by mounting on path prefixes like foo:// which cannot be the * name of a file or directory read from a native [glob] operation. */ + if (addStrRep[0] == '~') { + Tcl_Obj *tail = Tcl_NewStringObj(addStrRep, len); + + pathPtr = AppendPath(dirPtr, tail); + Tcl_DecrRefCount(tail); + return pathPtr; + } TclNewObj(pathPtr); - fsPathPtr = (FsPath *)Tcl_Alloc(sizeof(FsPath)); + fsPathPtr = (FsPath *)ckalloc(sizeof(FsPath)); /* * Set up the path. @@ -1303,7 +1329,7 @@ TclNewFSPathObj( case 0: /* So far only "." since last dirsep or start */ switch (*p) { case '.': - count = 1; + count++; break; case '/': case '\\': @@ -1340,9 +1366,9 @@ AppendPath( Tcl_Obj *head, Tcl_Obj *tail) { + int numBytes; const char *bytes; Tcl_Obj *copy = Tcl_DuplicateObj(head); - Tcl_Size length; /* * This is likely buggy when dealing with virtual filesystem drivers @@ -1352,8 +1378,8 @@ AppendPath( * internalrep produce the same results; that is, bugward compatibility. If * we need to fix that bug here, it needs fixing in TclJoinPath() too. */ - bytes = TclGetStringFromObj(tail, &length); - if (length == 0) { + bytes = TclGetStringFromObj(tail, &numBytes); + if (numBytes == 0) { Tcl_AppendToObj(copy, "/", 1); } else { TclpNativeJoinPath(copy, bytes); @@ -1389,7 +1415,7 @@ TclFSMakePathRelative( Tcl_Obj *pathPtr, /* The path we have. */ Tcl_Obj *cwdPtr) /* Make it relative to this. */ { - Tcl_Size cwdLen, len; + int cwdLen, len; const char *tempStr; Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(pathPtr, &fsPathType); @@ -1465,7 +1491,7 @@ MakePathFromNormalized( return TCL_OK; } - fsPathPtr = (FsPath *)Tcl_Alloc(sizeof(FsPath)); + fsPathPtr = (FsPath *)ckalloc(sizeof(FsPath)); /* * It's a pure normalized absolute path. @@ -1500,7 +1526,7 @@ MakePathFromNormalized( * Any memory which is allocated for 'clientData' should be retained * until clientData is passed to the filesystem's freeInternalRepProc * when it can be freed. The built in platform-specific filesystems use - * 'Tcl_Alloc' to allocate clientData, and Tcl_Free to free it. + * 'ckalloc' to allocate clientData, and ckfree to free it. * * Results: * NULL or a valid path object pointer, with refCount zero. @@ -1514,7 +1540,7 @@ MakePathFromNormalized( Tcl_Obj * Tcl_FSNewNativePath( const Tcl_Filesystem *fromFilesystem, - void *clientData) + ClientData clientData) { Tcl_Obj *pathPtr = NULL; FsPath *fsPathPtr; @@ -1533,7 +1559,7 @@ Tcl_FSNewNativePath( */ Tcl_StoreInternalRep(pathPtr, &fsPathType, NULL); - fsPathPtr = (FsPath *)Tcl_Alloc(sizeof(FsPath)); + fsPathPtr = (FsPath *)ckalloc(sizeof(FsPath)); fsPathPtr->translatedPathPtr = NULL; @@ -1657,9 +1683,9 @@ Tcl_FSGetTranslatedStringPath( Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr); if (transPtr != NULL) { - Tcl_Size len; + int len; const char *orig = TclGetStringFromObj(transPtr, &len); - char *result = (char *)Tcl_Alloc(len+1); + char *result = (char *)ckalloc(len+1); memcpy(result, orig, len+1); TclDecrRefCount(transPtr); @@ -1707,8 +1733,7 @@ Tcl_FSGetNormalizedPath( */ Tcl_Obj *dir, *copy; - Tcl_Size tailLen, cwdLen; - int pathType; + int tailLen, cwdLen, pathType; pathType = Tcl_FSGetPathType(fsPathPtr->cwdPtr); dir = Tcl_FSGetNormalizedPath(interp, fsPathPtr->cwdPtr); @@ -1718,7 +1743,7 @@ Tcl_FSGetNormalizedPath( /* TODO: Figure out why this is needed. */ TclGetString(pathPtr); - (void)TclGetStringFromObj(fsPathPtr->normPathPtr, &tailLen); + TclGetStringFromObj(fsPathPtr->normPathPtr, &tailLen); if (tailLen) { copy = AppendPath(dir, fsPathPtr->normPathPtr); } else { @@ -1809,7 +1834,7 @@ Tcl_FSGetNormalizedPath( } fsPathPtr = PATHOBJ(pathPtr); } else if (fsPathPtr->normPathPtr == NULL) { - Tcl_Size cwdLen; + int cwdLen; Tcl_Obj *copy; copy = AppendPath(fsPathPtr->cwdPtr, pathPtr); @@ -1952,7 +1977,7 @@ Tcl_FSGetNormalizedPath( *--------------------------------------------------------------------------- */ -void * +ClientData Tcl_FSGetInternalRep( Tcl_Obj *pathPtr, const Tcl_Filesystem *fsPtr) @@ -2099,7 +2124,7 @@ void TclFSSetPathDetails( Tcl_Obj *pathPtr, const Tcl_Filesystem *fsPtr, - void *clientData) + ClientData clientData) { FsPath *srcFsPathPtr; @@ -2142,8 +2167,7 @@ Tcl_FSEqualPaths( Tcl_Obj *secondPtr) { const char *firstStr, *secondStr; - Tcl_Size firstLen, secondLen; - int tempErrno; + int firstLen, secondLen, tempErrno; if (firstPtr == secondPtr) { return 1; @@ -2185,6 +2209,10 @@ Tcl_FSEqualPaths( * Attempt to convert the internal representation of pathPtr to * fsPathType. * + * A tilde ("~") character at the beginnig of the filename indicates the + * current user's home directory, and "~<user>" indicates a particular + * user's directory. + * * Results: * Standard Tcl error code. * @@ -2196,12 +2224,13 @@ Tcl_FSEqualPaths( static int SetFsPathFromAny( - TCL_UNUSED(Tcl_Interp *), /* Used for error reporting if not NULL. */ + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ Tcl_Obj *pathPtr) /* The object to convert. */ { - Tcl_Size len; + int len; FsPath *fsPathPtr; Tcl_Obj *transPtr; + const char *name; if (TclHasInternalRep(pathPtr, &fsPathType)) { return TCL_OK; @@ -2221,23 +2250,137 @@ SetFsPathFromAny( * cmdAH.test exercise most of the code). */ - TclGetStringFromObj(pathPtr, &len); /* TODO: Is this needed? */ - transPtr = TclJoinPath(1, &pathPtr, 1); + name = TclGetStringFromObj(pathPtr, &len); + + /* + * Handle tilde substitutions, if needed. + */ + + if (len && name[0] == '~') { + Tcl_DString temp; + int split; + char separator = '/'; + + /* + * We have multiple cases '~/foo/bar...', '~user/foo/bar...', etc. + * split becomes value 1 for '~/...' as well as for '~'. + */ + split = FindSplitPos(name, separator); + + /* + * Do some tilde substitution. + */ + + if (split == 1) { + /* + * We have just '~' (or '~/...') + */ + + const char *dir; + Tcl_DString dirString; + + dir = TclGetEnv("HOME", &dirString); + if (dir == NULL) { + if (interp) { + Tcl_SetObjResult(interp, Tcl_NewStringObj( + "couldn't find HOME environment variable to" + " expand path", -1)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", + "HOMELESS", (char *)NULL); + } + return TCL_ERROR; + } + Tcl_DStringInit(&temp); + Tcl_JoinPath(1, &dir, &temp); + Tcl_DStringFree(&dirString); + } else { + /* + * There is a '~user' + */ + + const char *expandedUser; + Tcl_DString userName; + + Tcl_DStringInit(&userName); + Tcl_DStringAppend(&userName, name+1, split-1); + expandedUser = Tcl_DStringValue(&userName); + + Tcl_DStringInit(&temp); + if (TclpGetUserHome(expandedUser, &temp) == NULL) { + if (interp != NULL) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "user \"%s\" doesn't exist", expandedUser)); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "NOUSER", + (char *)NULL); + } + Tcl_DStringFree(&userName); + Tcl_DStringFree(&temp); + return TCL_ERROR; + } + Tcl_DStringFree(&userName); + } + + transPtr = Tcl_DStringToObj(&temp); + + if (split != len) { + /* + * Join up the tilde substitution with the rest. + */ + + if (name[split+1] == separator) { + /* + * Somewhat tricky case like ~//foo/bar. Make use of + * Split/Join machinery to get it right. Assumes all paths + * beginning with ~ are part of the native filesystem. + */ + + int objc; + Tcl_Obj **objv; + Tcl_Obj *parts = TclpNativeSplitPath(pathPtr, NULL); + + TclListObjGetElements(NULL, parts, &objc, &objv); + + /* + * Skip '~'. It's replaced by its expansion. + */ + + objc--; objv++; + while (objc--) { + TclpNativeJoinPath(transPtr, Tcl_GetString(*objv++)); + } + TclDecrRefCount(parts); + } else { + Tcl_Obj *pair[2]; + + pair[0] = transPtr; + pair[1] = Tcl_NewStringObj(name+split+1, -1); + transPtr = TclJoinPath(2, pair, 1); + if (transPtr != pair[0]) { + Tcl_DecrRefCount(pair[0]); + } + if (transPtr != pair[1]) { + Tcl_DecrRefCount(pair[1]); + } + } + } + } else { + transPtr = TclJoinPath(1, &pathPtr, 1); + } /* * Now we have a translated filename in 'transPtr'. This will have forward * slashes on Windows, and will not contain any ~user sequences. */ - fsPathPtr = (FsPath *)Tcl_Alloc(sizeof(FsPath)); + fsPathPtr = (FsPath *)ckalloc(sizeof(FsPath)); if (transPtr == pathPtr) { - (void) Tcl_GetString(pathPtr); + (void)TclGetString(pathPtr); TclFreeInternalRep(pathPtr); - transPtr = Tcl_DuplicateObj(pathPtr); - fsPathPtr->filesystemEpoch = 0; + transPtr = Tcl_DuplicateObj(pathPtr); + fsPathPtr->filesystemEpoch = 0; } else { - fsPathPtr->filesystemEpoch = TclFSEpoch(); + fsPathPtr->filesystemEpoch = TclFSEpoch(); } Tcl_IncrRefCount(transPtr); fsPathPtr->translatedPathPtr = transPtr; @@ -2282,7 +2425,7 @@ FreeFsPathInternalRep( } } - Tcl_Free(fsPathPtr); + ckfree(fsPathPtr); } static void @@ -2291,7 +2434,7 @@ DupFsPathInternalRep( Tcl_Obj *copyPtr) /* Path obj with internal rep to set. */ { FsPath *srcFsPathPtr = PATHOBJ(srcPtr); - FsPath *copyFsPathPtr = (FsPath *)Tcl_Alloc(sizeof(FsPath)); + FsPath *copyFsPathPtr = (FsPath *)ckalloc(sizeof(FsPath)); SETPATHOBJ(copyPtr, copyFsPathPtr); @@ -2351,19 +2494,14 @@ UpdateStringOfFsPath( Tcl_Obj *pathPtr) /* path obj with string rep to update. */ { FsPath *fsPathPtr = PATHOBJ(pathPtr); - Tcl_Size cwdLen; + int cwdLen; Tcl_Obj *copy; if (PATHFLAGS(pathPtr) == 0 || fsPathPtr->cwdPtr == NULL) { - if (fsPathPtr->translatedPathPtr == NULL) { - Tcl_Panic("Called UpdateStringOfFsPath with invalid object"); - } else { - copy = Tcl_DuplicateObj(fsPathPtr->translatedPathPtr); - } - } else { - copy = AppendPath(fsPathPtr->cwdPtr, fsPathPtr->normPathPtr); + Tcl_Panic("Called UpdateStringOfFsPath with invalid object"); } + copy = AppendPath(fsPathPtr->cwdPtr, fsPathPtr->normPathPtr); if (Tcl_IsShared(copy)) { copy = Tcl_DuplicateObj(copy); } @@ -2400,7 +2538,7 @@ UpdateStringOfFsPath( int TclNativePathInFilesystem( Tcl_Obj *pathPtr, - TCL_UNUSED(void **)) + TCL_UNUSED(ClientData *)) { /* * A special case is required to handle the empty path "". This is a valid @@ -2428,7 +2566,7 @@ TclNativePathInFilesystem( * situation. */ - Tcl_Size len; + int len; (void) TclGetStringFromObj(pathPtr, &len); if (len == 0) { @@ -2474,7 +2612,7 @@ MakeTildeRelativePath( const char *user, /* User name. NULL -> current user */ const char *subPath, /* Rest of path. May be NULL */ Tcl_DString *dsPtr) /* Output. Is initialized by the function. Must be - * freed on success */ + freed on success */ { const char *dir; Tcl_DString dirString; @@ -2489,10 +2627,10 @@ MakeTildeRelativePath( if (dir == NULL) { if (interp) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "couldn't find HOME environment variable to expand path", - -1)); + "couldn't find HOME environment variable to" + " expand path", -1)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", - "HOMELESS", (void *)NULL); + "HOMELESS", (char *)NULL); } return TCL_ERROR; } @@ -2502,9 +2640,9 @@ MakeTildeRelativePath( if (dir == NULL) { if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "user \"%s\" doesn't exist", user)); + "user \"%s\" doesn't exist", user)); Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "NOUSER", - (void *)NULL); + (char *)NULL); } return TCL_ERROR; } @@ -2574,8 +2712,8 @@ TclResolveTildePath( Tcl_Obj *pathObj) { const char *path; - Tcl_Size len; - Tcl_Size split; + int len; + int split; Tcl_DString resolvedPath; path = TclGetStringFromObj(pathObj, &len); @@ -2593,8 +2731,9 @@ TclResolveTildePath( if (split == 1) { /* No user name specified -> current user */ - if (MakeTildeRelativePath(interp, NULL, path[1] ? 2 + path : NULL, - &resolvedPath) != TCL_OK) { + if (MakeTildeRelativePath( + interp, NULL, path[1] ? 2 + path : NULL, &resolvedPath) + != TCL_OK) { return NULL; } } else { @@ -2607,9 +2746,11 @@ TclResolveTildePath( expandedUser = Tcl_DStringValue(&userName); /* path[split] is / or \0 */ - if (MakeTildeRelativePath(interp, expandedUser, - path[split] ? &path[split+1] : NULL, - &resolvedPath) != TCL_OK) { + if (MakeTildeRelativePath(interp, + expandedUser, + path[split] ? &path[split+1] : NULL, + &resolvedPath) + != TCL_OK) { Tcl_DStringFree(&userName); return NULL; } @@ -2648,8 +2789,8 @@ TclResolveTildePathList( Tcl_Obj *pathsObj) { Tcl_Obj **objv; - Tcl_Size objc; - Tcl_Size i; + int objc; + int i; Tcl_Obj *resolvedPaths; const char *path; @@ -2664,7 +2805,7 @@ TclResolveTildePathList( * Figure out if any paths need resolving to avoid unnecessary allocations. */ for (i = 0; i < objc; ++i) { - path = Tcl_GetString(objv[i]); + path = TclGetString(objv[i]); if (path[0] == '~') { break; /* At least one path needs resolution */ } @@ -2676,7 +2817,7 @@ TclResolveTildePathList( resolvedPaths = Tcl_NewListObj(objc, NULL); for (i = 0; i < objc; ++i) { Tcl_Obj *resolvedPath; - path = Tcl_GetString(objv[i]); + path = TclGetString(objv[i]); if (path[0] == 0) { continue; /* Skip empty strings */ } diff --git a/generic/tclPipe.c b/generic/tclPipe.c index 854ecd5..8b6eb11 100644 --- a/generic/tclPipe.c +++ b/generic/tclPipe.c @@ -179,16 +179,16 @@ FileForRedirect( void Tcl_DetachPids( - Tcl_Size numPids, /* Number of pids to detach: gives size of + int numPids, /* Number of pids to detach: gives size of * array pointed to by pidPtr. */ Tcl_Pid *pidPtr) /* Array of pids to detach. */ { Detached *detPtr; - Tcl_Size i; + int i; Tcl_MutexLock(&pipeMutex); for (i = 0; i < numPids; i++) { - detPtr = (Detached *)Tcl_Alloc(sizeof(Detached)); + detPtr = (Detached *)ckalloc(sizeof(Detached)); detPtr->pid = pidPtr[i]; detPtr->nextPtr = detList; detList = detPtr; @@ -238,7 +238,7 @@ Tcl_ReapDetachedProcs(void) } else { prevPtr->nextPtr = detPtr->nextPtr; } - Tcl_Free(detPtr); + ckfree(detPtr); detPtr = nextPtr; } Tcl_MutexUnlock(&pipeMutex); @@ -269,16 +269,16 @@ Tcl_ReapDetachedProcs(void) int TclCleanupChildren( Tcl_Interp *interp, /* Used for error messages. */ - Tcl_Size numPids, /* Number of entries in pidPtr array. */ + int numPids, /* Number of entries in pidPtr array. */ Tcl_Pid *pidPtr, /* Array of process ids of children. */ Tcl_Channel errorChan) /* Channel for file containing stderr output * from pipeline. NULL means there isn't any * stderr output. */ { int result = TCL_OK; - int code, abnormalExit, anyErrorInfo; + int i, abnormalExit, anyErrorInfo; TclProcessWaitStatus waitStatus; - Tcl_Size i; + int code; Tcl_Obj *msg, *error; abnormalExit = 0; @@ -335,8 +335,8 @@ TclCleanupChildren( Tcl_Seek(errorChan, 0, SEEK_SET); TclNewObj(objPtr); - count = Tcl_ReadChars(errorChan, objPtr, TCL_INDEX_NONE, 0); - if (count == -1) { + count = Tcl_ReadChars(errorChan, objPtr, -1, 0); + if (count < 0) { result = TCL_ERROR; Tcl_DecrRefCount(objPtr); Tcl_ResetResult(interp); @@ -351,7 +351,7 @@ TclCleanupChildren( Tcl_DecrRefCount(objPtr); } } - Tcl_CloseEx(NULL, errorChan, 0); + Tcl_Close(NULL, errorChan); } /* @@ -378,7 +378,7 @@ TclCleanupChildren( * * Results: * The return value is a count of the number of new processes created, or - * TCL_INDEX_NONE if an error occurred while creating the pipeline. *pidArrayPtr is + * -1 if an error occurred while creating the pipeline. *pidArrayPtr is * filled in with the address of a dynamically allocated array giving the * ids of all of the processes. It is up to the caller to free this array * when it isn't needed anymore. If inPipePtr is non-NULL, *inPipePtr is @@ -395,10 +395,10 @@ TclCleanupChildren( *---------------------------------------------------------------------- */ -Tcl_Size +int TclCreatePipeline( Tcl_Interp *interp, /* Interpreter to use for error reporting. */ - Tcl_Size argc, /* Number of entries in argv. */ + int argc, /* Number of entries in argv. */ const char **argv, /* Array of strings describing commands in * pipeline plus I/O redirection with <, <<, * >, etc. Argv[argc] must be NULL. */ @@ -431,9 +431,9 @@ TclCreatePipeline( { Tcl_Pid *pidPtr = NULL; /* Points to malloc-ed array holding all the * pids of child processes. */ - Tcl_Size numPids; /* Actual number of processes that exist at + int numPids; /* Actual number of processes that exist at * *pidPtr right now. */ - Tcl_Size cmdCount; /* Count of number of distinct commands found + int cmdCount; /* Count of number of distinct commands found * in argc/argv. */ const char *inputLiteral = NULL; /* If non-null, then this points to a string @@ -460,8 +460,7 @@ TclCreatePipeline( int errorRelease = 0; const char *p; const char *nextArg; - int skip, atOK, flags, needCmd, errorToOutput = 0; - Tcl_Size i, j, lastArg, lastBar; + int skip, lastBar, lastArg, i, j, atOK, flags, needCmd, errorToOutput = 0; Tcl_DString execBuffer; TclFile pipeIn; TclFile curInFile, curOutFile, curErrFile; @@ -825,7 +824,7 @@ TclCreatePipeline( */ Tcl_ReapDetachedProcs(); - pidPtr = (Tcl_Pid *)Tcl_Alloc(cmdCount * sizeof(Tcl_Pid)); + pidPtr = (Tcl_Pid *)ckalloc(cmdCount * sizeof(Tcl_Pid)); curInFile = inputFile; @@ -975,11 +974,11 @@ TclCreatePipeline( } if (pidPtr != NULL) { for (i = 0; i < numPids; i++) { - if (pidPtr[i] != (Tcl_Pid)-1) { + if (pidPtr[i] != (Tcl_Pid) -1) { Tcl_DetachPids(1, &pidPtr[i]); } } - Tcl_Free(pidPtr); + ckfree(pidPtr); } numPids = -1; goto cleanup; @@ -1021,15 +1020,15 @@ Tcl_Channel Tcl_OpenCommandChannel( Tcl_Interp *interp, /* Interpreter for error reporting. Can NOT be * NULL. */ - Tcl_Size argc, /* How many arguments. */ + int argc, /* How many arguments. */ const char **argv, /* Array of arguments for command pipe. */ int flags) /* Or'ed combination of TCL_STDIN, TCL_STDOUT, * TCL_STDERR, and TCL_ENFORCE_MODE. */ { TclFile *inPipePtr, *outPipePtr, *errFilePtr; TclFile inPipe, outPipe, errFile; - Tcl_Size numPids; - Tcl_Pid *pidPtr = NULL; + int numPids; + Tcl_Pid *pidPtr; Tcl_Channel channel; inPipe = outPipe = errFile = NULL; @@ -1081,9 +1080,9 @@ Tcl_OpenCommandChannel( return channel; error: - if (pidPtr) { + if (numPids > 0) { Tcl_DetachPids(numPids, pidPtr); - Tcl_Free(pidPtr); + ckfree(pidPtr); } if (inPipe != NULL) { TclpCloseFile(inPipe); diff --git a/generic/tclPkg.c b/generic/tclPkg.c index 50884a1..ddb98fa 100644 --- a/generic/tclPkg.c +++ b/generic/tclPkg.c @@ -57,7 +57,7 @@ typedef struct PkgFiles { * "Tk" (no version number). */ -typedef struct { +typedef struct Package { Tcl_Obj *version; PkgAvail *availPtr; /* First in list of all available versions of * this package. */ @@ -96,22 +96,22 @@ static void AddRequirementsToResult(Tcl_Interp *interp, int reqc, static void AddRequirementsToDString(Tcl_DString *dstring, int reqc, Tcl_Obj *const reqv[]); static Package * FindPackage(Tcl_Interp *interp, const char *name); -static int PkgRequireCore(void *data[], Tcl_Interp *interp, int result); -static int PkgRequireCoreFinal(void *data[], Tcl_Interp *interp, int result); -static int PkgRequireCoreCleanup(void *data[], Tcl_Interp *interp, int result); -static int PkgRequireCoreStep1(void *data[], Tcl_Interp *interp, int result); -static int PkgRequireCoreStep2(void *data[], Tcl_Interp *interp, int result); -static int TclNRPkgRequireProc(void *clientData, Tcl_Interp *interp, int reqc, Tcl_Obj *const reqv[]); -static int SelectPackage(void *data[], Tcl_Interp *interp, int result); -static int SelectPackageFinal(void *data[], Tcl_Interp *interp, int result); -static int TclNRPackageObjCmdCleanup(void *data[], Tcl_Interp *interp, int result); +static int PkgRequireCore(ClientData data[], Tcl_Interp *interp, int result); +static int PkgRequireCoreFinal(ClientData data[], Tcl_Interp *interp, int result); +static int PkgRequireCoreCleanup(ClientData data[], Tcl_Interp *interp, int result); +static int PkgRequireCoreStep1(ClientData data[], Tcl_Interp *interp, int result); +static int PkgRequireCoreStep2(ClientData data[], Tcl_Interp *interp, int result); +static int TclNRPkgRequireProc(ClientData clientData, Tcl_Interp *interp, int reqc, Tcl_Obj *const reqv[]); +static int SelectPackage(ClientData data[], Tcl_Interp *interp, int result); +static int SelectPackageFinal(ClientData data[], Tcl_Interp *interp, int result); +static int TclNRPackageObjCmdCleanup(ClientData data[], Tcl_Interp *interp, int result); /* * Helper macros. */ #define DupBlock(v,s,len) \ - ((v) = (char *)Tcl_Alloc(len), memcpy((v),(s),(len))) + ((v) = (char *)ckalloc(len), memcpy((v),(s),(len))) #define DupString(v,s) \ do { \ size_t local__len = strlen(s) + 1; \ @@ -171,17 +171,17 @@ Tcl_PkgProvideEx( return TCL_OK; } - if (CheckVersionAndConvert(interp, Tcl_GetString(pkgPtr->version), &pvi, + if (CheckVersionAndConvert(interp, TclGetString(pkgPtr->version), &pvi, NULL) != TCL_OK) { return TCL_ERROR; } else if (CheckVersionAndConvert(interp, version, &vi, NULL) != TCL_OK) { - Tcl_Free(pvi); + ckfree(pvi); return TCL_ERROR; } res = CompareVersions(pvi, vi, NULL); - Tcl_Free(pvi); - Tcl_Free(vi); + ckfree(pvi); + ckfree(vi); if (res == 0) { if (clientData != NULL) { @@ -191,8 +191,8 @@ Tcl_PkgProvideEx( } Tcl_SetObjResult(interp, Tcl_ObjPrintf( "conflicting versions provided for package \"%s\": %s, then %s", - name, Tcl_GetString(pkgPtr->version), version)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", (void *)NULL); + name, TclGetString(pkgPtr->version), version)); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", (char *)NULL); return TCL_ERROR; } @@ -225,7 +225,7 @@ Tcl_PkgProvideEx( static void PkgFilesCleanupProc( - void *clientData, + ClientData clientData, TCL_UNUSED(Tcl_Interp *)) { PkgFiles *pkgFiles = (PkgFiles *) clientData; @@ -236,7 +236,7 @@ PkgFilesCleanupProc( PkgName *name = pkgFiles->names; pkgFiles->names = name->nextPtr; - Tcl_Free(name); + ckfree(name); } entry = Tcl_FirstHashEntry(&pkgFiles->table, &search); while (entry) { @@ -246,7 +246,7 @@ PkgFilesCleanupProc( entry = Tcl_NextHashEntry(&search); } Tcl_DeleteHashTable(&pkgFiles->table); - Tcl_Free(pkgFiles); + ckfree(pkgFiles); return; } @@ -261,7 +261,7 @@ TclInitPkgFiles( PkgFiles *pkgFiles = (PkgFiles *)Tcl_GetAssocData(interp, "tclPkgFiles", NULL); if (!pkgFiles) { - pkgFiles = (PkgFiles *)Tcl_Alloc(sizeof(PkgFiles)); + pkgFiles = (PkgFiles *)ckalloc(sizeof(PkgFiles)); pkgFiles->names = NULL; Tcl_InitHashTable(&pkgFiles->table, TCL_STRING_KEYS); Tcl_SetAssocData(interp, "tclPkgFiles", PkgFilesCleanupProc, pkgFiles); @@ -389,7 +389,7 @@ Tcl_PkgRequireEx( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "Cannot load package \"%s\" in standalone executable:" " This package is not compiled with stub support", name)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNSTUBBED", (void *)NULL); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNSTUBBED", (char *)NULL); return NULL; } @@ -399,7 +399,7 @@ Tcl_PkgRequireEx( if (version == NULL) { if (Tcl_PkgRequireProc(interp, name, 0, NULL, clientDataPtr) == TCL_OK) { - result = Tcl_GetStringResult(interp); + result = Tcl_GetString(Tcl_GetObjResult(interp)); Tcl_ResetResult(interp); } } else { @@ -409,11 +409,11 @@ Tcl_PkgRequireEx( } ov = Tcl_NewStringObj(version, -1); if (exact) { - Tcl_AppendStringsToObj(ov, "-", version, (void *)NULL); + Tcl_AppendStringsToObj(ov, "-", version, (char *)NULL); } Tcl_IncrRefCount(ov); if (Tcl_PkgRequireProc(interp, name, 1, &ov, clientDataPtr) == TCL_OK) { - result = Tcl_GetStringResult(interp); + result = Tcl_GetString(Tcl_GetObjResult(interp)); Tcl_ResetResult(interp); } TclDecrRefCount(ov); @@ -426,7 +426,7 @@ Tcl_PkgRequireProc( Tcl_Interp *interp, /* Interpreter in which package is now * available. */ const char *name, /* Name of desired package. */ - Tcl_Size reqc, /* Requirements constraining the desired + int reqc, /* Requirements constraining the desired * version. */ Tcl_Obj *const reqv[], /* 0 means to use the latest version * available. */ @@ -442,7 +442,7 @@ Tcl_PkgRequireProc( static int TclNRPkgRequireProc( - void *clientData, + ClientData clientData, Tcl_Interp *interp, int reqc, Tcl_Obj *const reqv[]) @@ -457,12 +457,12 @@ TclNRPkgRequireProc( static int PkgRequireCore( - void *data[], + ClientData data[], Tcl_Interp *interp, TCL_UNUSED(int)) { const char *name = (const char *)data[0]; - int reqc = (int)PTR2INT(data[1]); + int reqc = PTR2INT(data[1]); Tcl_Obj **reqv = (Tcl_Obj **)data[2]; int code = CheckAllRequirements(interp, reqc, reqv); Require *reqPtr; @@ -470,7 +470,7 @@ PkgRequireCore( if (code != TCL_OK) { return code; } - reqPtr = (Require *)Tcl_Alloc(sizeof(Require)); + reqPtr = (Require *)ckalloc(sizeof(Require)); Tcl_NRAddCallback(interp, PkgRequireCoreCleanup, reqPtr, NULL, NULL, NULL); reqPtr->clientDataPtr = data[3]; reqPtr->name = name; @@ -488,14 +488,14 @@ PkgRequireCore( static int PkgRequireCoreStep1( - void *data[], + ClientData data[], Tcl_Interp *interp, TCL_UNUSED(int)) { Tcl_DString command; char *script; Require *reqPtr = (Require *)data[0]; - int reqc = (int)PTR2INT(data[1]); + int reqc = PTR2INT(data[1]); Tcl_Obj **const reqv = (Tcl_Obj **)data[2]; const char *name = reqPtr->name /* Name of desired package. */; @@ -547,19 +547,19 @@ PkgRequireCoreStep1( static int PkgRequireCoreStep2( - void *data[], + ClientData data[], Tcl_Interp *interp, int result) { Require *reqPtr = (Require *)data[0]; - int reqc = (int)PTR2INT(data[1]); + int reqc = PTR2INT(data[1]); Tcl_Obj **const reqv = (Tcl_Obj **)data[2]; 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)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", (void *)NULL); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", (char *)NULL); result = TCL_ERROR; } if (result == TCL_ERROR) { @@ -582,12 +582,12 @@ PkgRequireCoreStep2( static int PkgRequireCoreFinal( - void *data[], + ClientData data[], Tcl_Interp *interp, TCL_UNUSED(int)) { Require *reqPtr = (Require *)data[0]; - int reqc = (int)PTR2INT(data[1]), satisfies; + int reqc = PTR2INT(data[1]), satisfies; Tcl_Obj **const reqv = (Tcl_Obj **)data[2]; char *pkgVersionI; void *clientDataPtr = reqPtr->clientDataPtr; @@ -596,7 +596,7 @@ PkgRequireCoreFinal( if (reqPtr->pkgPtr->version == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't find package %s", name)); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", (void *)NULL); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", (char *)NULL); AddRequirementsToResult(interp, reqc, reqv); return TCL_ERROR; } @@ -606,18 +606,18 @@ PkgRequireCoreFinal( */ if (reqc != 0) { - CheckVersionAndConvert(interp, Tcl_GetString(reqPtr->pkgPtr->version), + CheckVersionAndConvert(interp, TclGetString(reqPtr->pkgPtr->version), &pkgVersionI, NULL); satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv); - Tcl_Free(pkgVersionI); + ckfree(pkgVersionI); if (!satisfies) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "version conflict for package \"%s\": have %s, need", - name, Tcl_GetString(reqPtr->pkgPtr->version))); + name, TclGetString(reqPtr->pkgPtr->version))); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", - (void *)NULL); + (char *)NULL); AddRequirementsToResult(interp, reqc, reqv); return TCL_ERROR; } @@ -634,17 +634,17 @@ PkgRequireCoreFinal( static int PkgRequireCoreCleanup( - void *data[], + ClientData data[], TCL_UNUSED(Tcl_Interp *), int result) { - Tcl_Free(data[0]); + ckfree(data[0]); return result; } static int SelectPackage( - void *data[], + ClientData data[], Tcl_Interp *interp, TCL_UNUSED(int)) { @@ -653,7 +653,7 @@ SelectPackage( /* Internal rep. of versions */ int availStable, satisfies; Require *reqPtr = (Require *)data[0]; - int reqc = (int)PTR2INT(data[1]); + int reqc = PTR2INT(data[1]); Tcl_Obj **const reqv = (Tcl_Obj **)data[2]; const char *name = reqPtr->name; Package *pkgPtr = reqPtr->pkgPtr; @@ -670,7 +670,7 @@ SelectPackage( " attempt to provide %s %s requires %s", name, (char *) pkgPtr->clientData, name)); AddRequirementsToResult(interp, reqc, reqv); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", (void *)NULL); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", (char *)NULL); return TCL_ERROR; } @@ -707,7 +707,7 @@ SelectPackage( if (reqc > 0) { satisfies = SomeRequirementSatisfied(availVersion, reqc, reqv); if (!satisfies) { - Tcl_Free(availVersion); + ckfree(availVersion); availVersion = NULL; continue; } @@ -726,7 +726,7 @@ SelectPackage( * currently selected version. */ - Tcl_Free(bestVersion); + ckfree(bestVersion); bestVersion = NULL; goto newbest; } @@ -741,7 +741,7 @@ SelectPackage( } if (!availStable) { - Tcl_Free(availVersion); + ckfree(availVersion); availVersion = NULL; continue; } @@ -759,7 +759,7 @@ SelectPackage( * the currently selected stable version. */ - Tcl_Free(bestStableVersion); + ckfree(bestStableVersion); bestStableVersion = NULL; goto newstable; } @@ -775,7 +775,7 @@ SelectPackage( &bestStableVersion, NULL); } - Tcl_Free(availVersion); + ckfree(availVersion); availVersion = NULL; } /* end for */ @@ -784,12 +784,12 @@ SelectPackage( */ if (bestVersion != NULL) { - Tcl_Free(bestVersion); + ckfree(bestVersion); bestVersion = NULL; } if (bestStableVersion != NULL) { - Tcl_Free(bestStableVersion); + ckfree(bestStableVersion); bestStableVersion = NULL; } @@ -828,7 +828,7 @@ SelectPackage( * Push "ifneeded" package name in "tclPkgFiles" assocdata. */ - pkgName = (PkgName *)Tcl_Alloc(offsetof(PkgName, name) + 1 + strlen(name)); + pkgName = (PkgName *)ckalloc(offsetof(PkgName, name) + 1 + strlen(name)); pkgName->nextPtr = pkgFiles->names; strcpy(pkgName->name, name); pkgFiles->names = pkgName; @@ -847,12 +847,12 @@ SelectPackage( static int SelectPackageFinal( - void *data[], + ClientData data[], Tcl_Interp *interp, int result) { Require *reqPtr = (Require *)data[0]; - int reqc = (int)PTR2INT(data[1]); + int reqc = PTR2INT(data[1]); Tcl_Obj **const reqv = (Tcl_Obj **)data[2]; const char *name = reqPtr->name; char *versionToProvide = reqPtr->versionToProvide; @@ -864,7 +864,7 @@ SelectPackageFinal( PkgFiles *pkgFiles = (PkgFiles *)Tcl_GetAssocData(interp, "tclPkgFiles", NULL); PkgName *pkgName = pkgFiles->names; pkgFiles->names = pkgName->nextPtr; - Tcl_Free(pkgName); + ckfree(pkgName); reqPtr->pkgPtr = FindPackage(interp, name); if (result == TCL_OK) { @@ -876,31 +876,31 @@ SelectPackageFinal( " no version of package %s provided", name, versionToProvide, name)); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED", - (void *)NULL); + (char *)NULL); } else { char *pvi, *vi; if (TCL_OK != CheckVersionAndConvert(interp, - Tcl_GetString(reqPtr->pkgPtr->version), &pvi, NULL)) { + TclGetString(reqPtr->pkgPtr->version), &pvi, NULL)) { result = TCL_ERROR; } else if (CheckVersionAndConvert(interp, versionToProvide, &vi, NULL) != TCL_OK) { - Tcl_Free(pvi); + ckfree(pvi); result = TCL_ERROR; } else { int res = CompareVersions(pvi, vi, NULL); - Tcl_Free(pvi); - Tcl_Free(vi); + ckfree(pvi); + ckfree(vi); if (res != 0) { result = TCL_ERROR; Tcl_SetObjResult(interp, Tcl_ObjPrintf( "attempt to provide package %s %s failed:" " package %s %s provided instead", name, versionToProvide, - name, Tcl_GetString(reqPtr->pkgPtr->version))); + name, TclGetString(reqPtr->pkgPtr->version))); Tcl_SetErrorCode(interp, "TCL", "PACKAGE", - "WRONGPROVIDE", (void *)NULL); + "WRONGPROVIDE", (char *)NULL); } } } @@ -912,7 +912,7 @@ SelectPackageFinal( "attempt to provide package %s %s failed:" " bad return code: %s", name, versionToProvide, TclGetString(codePtr))); - Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", (void *)NULL); + Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", (char *)NULL); TclDecrRefCount(codePtr); result = TCL_ERROR; } @@ -1018,7 +1018,7 @@ Tcl_PkgPresentEx( if (foundVersion == NULL) { Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PACKAGE", name, - (void *)NULL); + (char *)NULL); } return foundVersion; } @@ -1031,7 +1031,7 @@ Tcl_PkgPresentEx( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "package %s is not present", name)); } - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PACKAGE", name, (void *)NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PACKAGE", name, (char *)NULL); return NULL; } @@ -1053,7 +1053,7 @@ Tcl_PkgPresentEx( */ int Tcl_PackageObjCmd( - void *clientData, + ClientData clientData, Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -1063,7 +1063,7 @@ Tcl_PackageObjCmd( int TclNRPackageObjCmd( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -1077,10 +1077,9 @@ TclNRPackageObjCmd( PKG_FILES, PKG_FORGET, PKG_IFNEEDED, PKG_NAMES, PKG_PREFER, PKG_PRESENT, PKG_PROVIDE, PKG_REQUIRE, PKG_UNKNOWN, PKG_VCOMPARE, PKG_VERSIONS, PKG_VSATISFIES - } optionIndex; + }; Interp *iPtr = (Interp *) interp; - int exact, satisfies; - Tcl_Size i, newobjc; + int optionIndex, exact, i, newobjc, satisfies; PkgAvail *availPtr, *prevPtr; Package *pkgPtr; Tcl_HashEntry *hPtr; @@ -1100,7 +1099,7 @@ TclNRPackageObjCmd( &optionIndex) != TCL_OK) { return TCL_ERROR; } - switch (optionIndex) { + switch ((enum pkgOptionsEnum) optionIndex) { case PKG_FILES: { PkgFiles *pkgFiles; @@ -1110,9 +1109,8 @@ TclNRPackageObjCmd( } pkgFiles = (PkgFiles *) Tcl_GetAssocData(interp, "tclPkgFiles", NULL); if (pkgFiles) { - Tcl_HashEntry *entry = Tcl_FindHashEntry(&pkgFiles->table, - TclGetString(objv[2])); - + Tcl_HashEntry *entry = + Tcl_FindHashEntry(&pkgFiles->table, TclGetString(objv[2])); if (entry) { Tcl_SetObjResult(interp, (Tcl_Obj *)Tcl_GetHashValue(entry)); } @@ -1153,15 +1151,14 @@ TclNRPackageObjCmd( Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC); availPtr->pkgIndex = NULL; } - Tcl_Free(availPtr); + ckfree(availPtr); } - Tcl_Free(pkgPtr); + ckfree(pkgPtr); } break; } case PKG_IFNEEDED: { - Tcl_Size length; - int res; + int length, res; char *argv3i, *avi; if ((objc != 4) && (objc != 5)) { @@ -1176,7 +1173,7 @@ TclNRPackageObjCmd( if (objc == 4) { hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2); if (hPtr == NULL) { - Tcl_Free(argv3i); + ckfree(argv3i); return TCL_OK; } pkgPtr = (Package *)Tcl_GetHashValue(hPtr); @@ -1189,16 +1186,16 @@ TclNRPackageObjCmd( prevPtr = availPtr, availPtr = availPtr->nextPtr) { if (CheckVersionAndConvert(interp, availPtr->version, &avi, NULL) != TCL_OK) { - Tcl_Free(argv3i); + ckfree(argv3i); return TCL_ERROR; } res = CompareVersions(avi, argv3i, NULL); - Tcl_Free(avi); + ckfree(avi); if (res == 0) { if (objc == 4) { - Tcl_Free(argv3i); + ckfree(argv3i); Tcl_SetObjResult(interp, Tcl_NewStringObj(availPtr->script, -1)); return TCL_OK; @@ -1211,13 +1208,13 @@ TclNRPackageObjCmd( break; } } - Tcl_Free(argv3i); + ckfree(argv3i); if (objc == 4) { return TCL_OK; } if (availPtr == NULL) { - availPtr = (PkgAvail *)Tcl_Alloc(sizeof(PkgAvail)); + availPtr = (PkgAvail *)ckalloc(sizeof(PkgAvail)); availPtr->pkgIndex = NULL; DupBlock(availPtr->version, argv3, length + 1); @@ -1354,7 +1351,7 @@ TclNRPackageObjCmd( */ ov = Tcl_NewStringObj(version, -1); - Tcl_AppendStringsToObj(ov, "-", version, (void *)NULL); + Tcl_AppendStringsToObj(ov, "-", version, (char *)NULL); version = NULL; argv3 = TclGetString(objv[3]); Tcl_IncrRefCount(objv[3]); @@ -1399,7 +1396,7 @@ TclNRPackageObjCmd( } break; case PKG_UNKNOWN: { - Tcl_Size length; + int length; if (objc == 2) { if (iPtr->packageUnknown != NULL) { @@ -1408,7 +1405,7 @@ TclNRPackageObjCmd( } } else if (objc == 3) { if (iPtr->packageUnknown != NULL) { - Tcl_Free(iPtr->packageUnknown); + ckfree(iPtr->packageUnknown); } argv2 = TclGetStringFromObj(objv[2], &length); if (argv2[0] == 0) { @@ -1469,7 +1466,7 @@ TclNRPackageObjCmd( if (CheckVersionAndConvert(interp, argv2, &iva, NULL) != TCL_OK || CheckVersionAndConvert(interp, argv3, &ivb, NULL) != TCL_OK) { if (iva != NULL) { - Tcl_Free(iva); + ckfree(iva); } /* @@ -1485,8 +1482,8 @@ TclNRPackageObjCmd( Tcl_SetObjResult(interp, Tcl_NewWideIntObj(CompareVersions(iva, ivb, NULL))); - Tcl_Free(iva); - Tcl_Free(ivb); + ckfree(iva); + ckfree(ivb); break; case PKG_VERSIONS: if (objc != 3) { @@ -1521,12 +1518,12 @@ TclNRPackageObjCmd( if (CheckVersionAndConvert(interp, argv2, &argv2i, NULL) != TCL_OK) { return TCL_ERROR; } else if (CheckAllRequirements(interp, objc-3, objv+3) != TCL_OK) { - Tcl_Free(argv2i); + ckfree(argv2i); return TCL_ERROR; } satisfies = SomeRequirementSatisfied(argv2i, objc-3, objv+3); - Tcl_Free(argv2i); + ckfree(argv2i); Tcl_SetObjResult(interp, Tcl_NewBooleanObj(satisfies)); break; @@ -1539,7 +1536,7 @@ TclNRPackageObjCmd( static int TclNRPackageObjCmdCleanup( - void *data[], + ClientData data[], TCL_UNUSED(Tcl_Interp *), int result) { @@ -1578,7 +1575,7 @@ FindPackage( hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &isNew); if (isNew) { - pkgPtr = (Package *)Tcl_Alloc(sizeof(Package)); + pkgPtr = (Package *)ckalloc(sizeof(Package)); pkgPtr->version = NULL; pkgPtr->availPtr = NULL; pkgPtr->clientData = NULL; @@ -1630,13 +1627,13 @@ TclFreePackageInfo( Tcl_EventuallyFree(availPtr->pkgIndex, TCL_DYNAMIC); availPtr->pkgIndex = NULL; } - Tcl_Free(availPtr); + ckfree(availPtr); } - Tcl_Free(pkgPtr); + ckfree(pkgPtr); } Tcl_DeleteHashTable(&iPtr->packageTable); if (iPtr->packageUnknown != NULL) { - Tcl_Free(iPtr->packageUnknown); + ckfree(iPtr->packageUnknown); } } @@ -1676,7 +1673,7 @@ CheckVersionAndConvert( * 4* assuming that each char is a separator (a,b become ' -x '). * 4+ to have space for an additional -2 at the end */ - char *ibuf = (char *)Tcl_Alloc(4 + 4*strlen(string)); + char *ibuf = (char *)ckalloc(4 + 4*strlen(string)); char *ip = ibuf; /* @@ -1744,7 +1741,7 @@ CheckVersionAndConvert( if (internal != NULL) { *internal = ibuf; } else { - Tcl_Free(ibuf); + ckfree(ibuf); } if (stable != NULL) { *stable = !hasunstable; @@ -1753,10 +1750,10 @@ CheckVersionAndConvert( } error: - Tcl_Free(ibuf); + ckfree(ibuf); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected version number but got \"%s\"", string)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSION", (void *)NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSION", (char *)NULL); return TCL_ERROR; } @@ -2019,7 +2016,7 @@ CheckRequirement( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected versionMin-versionMax but got \"%s\"", string)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSIONRANGE", (void *)NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSIONRANGE", (char *)NULL); return TCL_ERROR; } @@ -2027,7 +2024,7 @@ CheckRequirement( * Exactly one dash is present. Copy the string, split at the location of * dash and check that both parts are versions. Note that the max part can * be empty. Also note that the string allocated with strdup() must be - * freed with free() and not Tcl_Free(). + * freed with free() and not ckfree(). */ DupString(buf, string); @@ -2038,11 +2035,11 @@ CheckRequirement( if ((CheckVersionAndConvert(interp, buf, NULL, NULL) != TCL_OK) || ((*dash != '\0') && (CheckVersionAndConvert(interp, dash, NULL, NULL) != TCL_OK))) { - Tcl_Free(buf); + ckfree(buf); return TCL_ERROR; } - Tcl_Free(buf); + ckfree(buf); return TCL_OK; } @@ -2071,8 +2068,7 @@ AddRequirementsToResult( * available. */ { Tcl_Obj *result = Tcl_GetObjResult(interp); - int i; - Tcl_Size length; + int i, length; for (i = 0; i < reqc; i++) { const char *v = TclGetStringFromObj(reqv[i], &length); @@ -2208,7 +2204,7 @@ RequirementSatisfied( strcat(reqi, " -2"); res = CompareVersions(havei, reqi, &thisIsMajor); satisfied = (res == 0) || ((res == 1) && !thisIsMajor); - Tcl_Free(reqi); + ckfree(reqi); return satisfied; } @@ -2232,8 +2228,8 @@ RequirementSatisfied( CheckVersionAndConvert(NULL, buf, &min, NULL); strcat(min, " -2"); satisfied = (CompareVersions(havei, min, NULL) >= 0); - Tcl_Free(min); - Tcl_Free(buf); + ckfree(min); + ckfree(buf); return satisfied; } @@ -2255,9 +2251,9 @@ RequirementSatisfied( (CompareVersions(havei, max, NULL) < 0)); } - Tcl_Free(min); - Tcl_Free(max); - Tcl_Free(buf); + ckfree(min); + ckfree(max); + ckfree(buf); return satisfied; } @@ -2286,7 +2282,7 @@ Tcl_PkgInitStubsCheck( const char * version, int exact) { - const char *actualVersion = Tcl_PkgPresentEx(interp, "Tcl", version, 0, NULL); + const char *actualVersion = Tcl_PkgPresent(interp, "Tcl", version, 0); if ((exact&1) && actualVersion) { const char *p = version; @@ -2298,11 +2294,11 @@ Tcl_PkgInitStubsCheck( if (count == 1) { if (0 != strncmp(version, actualVersion, strlen(version))) { /* Construct error message */ - Tcl_PkgPresentEx(interp, "Tcl", version, 1, NULL); + Tcl_PkgPresent(interp, "Tcl", version, 1); return NULL; } } else { - return Tcl_PkgPresentEx(interp, "Tcl", version, 1, NULL); + return Tcl_PkgPresent(interp, "Tcl", version, 1); } } return actualVersion; diff --git a/generic/tclPkgConfig.c b/generic/tclPkgConfig.c index d84472c..a0dae51 100644 --- a/generic/tclPkgConfig.c +++ b/generic/tclPkgConfig.c @@ -93,6 +93,7 @@ #endif static Tcl_Config const cfg[] = { +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 {"debug", CFG_DEBUG}, {"threaded", CFG_THREADED}, {"profiled", CFG_PROFILED}, @@ -101,6 +102,7 @@ static Tcl_Config const cfg[] = { {"mem_debug", CFG_MEMDEBUG}, {"compile_debug", CFG_COMPILE_DEBUG}, {"compile_stats", CFG_COMPILE_STATS}, +#endif /* Runtime paths to various stuff */ diff --git a/generic/tclPlatDecls.h b/generic/tclPlatDecls.h index b8243d2..8d1eee1 100644 --- a/generic/tclPlatDecls.h +++ b/generic/tclPlatDecls.h @@ -48,7 +48,7 @@ # endif #endif -#if TCL_MAJOR_VERSION < 9 +/* !BEGIN!: Do not edit below this line. */ #ifdef __cplusplus extern "C" { @@ -134,67 +134,8 @@ extern const TclPlatStubs *tclPlatStubsPtr; #endif /* defined(USE_TCL_STUBS) */ -#else /* TCL_MAJOR_VERSION > 8 */ - -/* !BEGIN!: Do not edit below this line. */ - -#ifdef __cplusplus -extern "C" { -#endif - -/* - * Exported function declarations: - */ - -/* Slot 0 is reserved */ -/* 1 */ -EXTERN int Tcl_MacOSXOpenVersionedBundleResources( - Tcl_Interp *interp, const char *bundleName, - const char *bundleVersion, - int hasResourceFile, Tcl_Size maxPathLen, - char *libraryPath); -/* 2 */ -EXTERN void Tcl_MacOSXNotifierAddRunLoopMode( - const void *runLoopMode); -/* 3 */ -EXTERN void Tcl_WinConvertError(unsigned errCode); - -typedef struct TclPlatStubs { - int magic; - void *hooks; - - void (*reserved0)(void); - int (*tcl_MacOSXOpenVersionedBundleResources) (Tcl_Interp *interp, const char *bundleName, const char *bundleVersion, int hasResourceFile, Tcl_Size maxPathLen, char *libraryPath); /* 1 */ - void (*tcl_MacOSXNotifierAddRunLoopMode) (const void *runLoopMode); /* 2 */ - void (*tcl_WinConvertError) (unsigned errCode); /* 3 */ -} TclPlatStubs; - -extern const TclPlatStubs *tclPlatStubsPtr; - -#ifdef __cplusplus -} -#endif - -#if defined(USE_TCL_STUBS) - -/* - * Inline function declarations: - */ - -/* Slot 0 is reserved */ -#define Tcl_MacOSXOpenVersionedBundleResources \ - (tclPlatStubsPtr->tcl_MacOSXOpenVersionedBundleResources) /* 1 */ -#define Tcl_MacOSXNotifierAddRunLoopMode \ - (tclPlatStubsPtr->tcl_MacOSXNotifierAddRunLoopMode) /* 2 */ -#define Tcl_WinConvertError \ - (tclPlatStubsPtr->tcl_WinConvertError) /* 3 */ - -#endif /* defined(USE_TCL_STUBS) */ - /* !END!: Do not edit above this line. */ -#endif /* TCL_MAJOR_VERSION */ - #ifdef MAC_OSX_TCL /* MACOSX */ #undef Tcl_MacOSXOpenBundleResources #define Tcl_MacOSXOpenBundleResources(a,b,c,d,e) Tcl_MacOSXOpenVersionedBundleResources(a,b,NULL,c,d,e) @@ -203,16 +144,6 @@ extern const TclPlatStubs *tclPlatStubsPtr; #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLIMPORT -#ifdef _WIN32 -# undef Tcl_CreateFileHandler -# undef Tcl_DeleteFileHandler -# undef Tcl_GetOpenFile -#endif -#ifndef MAC_OSX_TCL -# undef Tcl_MacOSXOpenVersionedBundleResources -# undef Tcl_MacOSXNotifierAddRunLoopMode -#endif - #if defined(USE_TCL_STUBS) && (defined(_WIN32) || defined(__CYGWIN__))\ && (defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8) #undef Tcl_WinUtfToTChar diff --git a/generic/tclPreserve.c b/generic/tclPreserve.c index 36a9537..b32dd63 100644 --- a/generic/tclPreserve.c +++ b/generic/tclPreserve.c @@ -21,7 +21,7 @@ */ typedef struct { - void *clientData; /* Address of preserved block. */ + ClientData clientData; /* Address of preserved block. */ size_t refCount; /* Number of Tcl_Preserve calls in effect for * block. */ int mustFree; /* Non-zero means Tcl_EventuallyFree was @@ -37,9 +37,9 @@ typedef struct { */ static Reference *refArray = NULL; /* First in array of references. */ -static size_t spaceAvl = 0; /* Total number of structures available at +static int spaceAvl = 0; /* Total number of structures available at * *firstRefPtr. */ -static size_t inUse = 0; /* Count of structures currently in use in +static int inUse = 0; /* Count of structures currently in use in * refArray. */ TCL_DECLARE_MUTEX(preserveMutex)/* To protect the above statics */ @@ -53,7 +53,7 @@ TCL_DECLARE_MUTEX(preserveMutex)/* To protect the above statics */ * objects that we don't want to live any longer than necessary. */ -typedef struct { +typedef struct HandleStruct { void *ptr; /* Pointer to the memory block being tracked. * This field will become NULL when the memory * block is deleted. This field must be the @@ -88,7 +88,7 @@ TclFinalizePreserve(void) { Tcl_MutexLock(&preserveMutex); if (spaceAvl != 0) { - Tcl_Free(refArray); + ckfree(refArray); refArray = NULL; inUse = 0; spaceAvl = 0; @@ -117,10 +117,10 @@ TclFinalizePreserve(void) void Tcl_Preserve( - void *clientData) /* Pointer to malloc'ed block of memory. */ + ClientData clientData) /* Pointer to malloc'ed block of memory. */ { Reference *refPtr; - size_t i; + int i; /* * See if there is already a reference for this pointer. If so, just @@ -143,7 +143,7 @@ Tcl_Preserve( if (inUse == spaceAvl) { spaceAvl = spaceAvl ? 2*spaceAvl : INITIAL_SIZE; - refArray = (Reference *)Tcl_Realloc(refArray, spaceAvl * sizeof(Reference)); + refArray = (Reference *)ckrealloc(refArray, spaceAvl * sizeof(Reference)); } /* @@ -180,10 +180,10 @@ Tcl_Preserve( void Tcl_Release( - void *clientData) /* Pointer to malloc'ed block of memory. */ + ClientData clientData) /* Pointer to malloc'ed block of memory. */ { Reference *refPtr; - size_t i; + int i; Tcl_MutexLock(&preserveMutex); for (i=0, refPtr=refArray ; i<inUse ; i++, refPtr++) { @@ -223,7 +223,7 @@ Tcl_Release( Tcl_MutexUnlock(&preserveMutex); if (mustFree) { if (freeProc == TCL_DYNAMIC) { - Tcl_Free(clientData); + ckfree(clientData); } else { freeProc((char *)clientData); } @@ -259,11 +259,11 @@ Tcl_Release( void Tcl_EventuallyFree( - void *clientData, /* Pointer to malloc'ed block of memory. */ + ClientData clientData, /* Pointer to malloc'ed block of memory. */ Tcl_FreeProc *freeProc) /* Function to actually do free. */ { Reference *refPtr; - size_t i; + int i; /* * See if there is a reference for this pointer. If so, set its "mustFree" @@ -290,9 +290,9 @@ Tcl_EventuallyFree( */ if (freeProc == TCL_DYNAMIC) { - Tcl_Free(clientData); + ckfree(clientData); } else { - freeProc(clientData); + freeProc((char *)clientData); } } @@ -326,7 +326,7 @@ TclHandleCreate( * be tracked for deletion. Must not be * NULL. */ { - HandleStruct *handlePtr = (HandleStruct *)Tcl_Alloc(sizeof(HandleStruct)); + HandleStruct *handlePtr = (HandleStruct *)ckalloc(sizeof(HandleStruct)); handlePtr->ptr = ptr; #ifdef TCL_MEM_DEBUG @@ -376,7 +376,7 @@ TclHandleFree( #endif handlePtr->ptr = NULL; if (handlePtr->refCount == 0) { - Tcl_Free(handlePtr); + ckfree(handlePtr); } } @@ -459,7 +459,7 @@ TclHandleRelease( } #endif if ((handlePtr->refCount-- <= 1) && (handlePtr->ptr == NULL)) { - Tcl_Free(handlePtr); + ckfree(handlePtr); } } diff --git a/generic/tclProc.c b/generic/tclProc.c index 40c6f32..31566da 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -34,14 +34,14 @@ typedef struct { static void DupLambdaInternalRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr); static void FreeLambdaInternalRep(Tcl_Obj *objPtr); -static int InitArgsAndLocals(Tcl_Interp *interp, int skip); +static int InitArgsAndLocals(Tcl_Interp *interp, Tcl_Size skip); static void InitResolvedLocals(Tcl_Interp *interp, ByteCode *codePtr, Var *defPtr, Namespace *nsPtr); static void InitLocalCache(Proc *procPtr); static void ProcBodyDup(Tcl_Obj *srcPtr, Tcl_Obj *dupPtr); static void ProcBodyFree(Tcl_Obj *objPtr); -static int ProcWrongNumArgs(Tcl_Interp *interp, int skip); +static int ProcWrongNumArgs(Tcl_Interp *interp, Tcl_Size skip); static void MakeProcError(Tcl_Interp *interp, Tcl_Obj *procNameObj); static void MakeLambdaError(Tcl_Interp *interp, @@ -51,7 +51,6 @@ static int SetLambdaFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static Tcl_NRPostProc ApplyNR2; static Tcl_NRPostProc InterpProcNR2; static Tcl_NRPostProc Uplevel_Callback; -static Tcl_ObjCmdProc NRInterpProc; /* * The ProcBodyObjType type @@ -64,9 +63,8 @@ const Tcl_ObjType tclProcBodyType = { NULL, /* UpdateString function; Tcl_GetString and * Tcl_GetStringFromObj should panic * instead. */ - NULL, /* SetFromAny function; Tcl_ConvertToType + NULL /* SetFromAny function; Tcl_ConvertToType * should panic instead. */ - TCL_OBJTYPE_V0 }; #define ProcSetInternalRep(objPtr, procPtr) \ @@ -95,7 +93,7 @@ const Tcl_ObjType tclProcBodyType = { static const Tcl_ObjType levelReferenceType = { "levelReference", - NULL, NULL, NULL, NULL, TCL_OBJTYPE_V0 + NULL, NULL, NULL, NULL }; /* @@ -112,8 +110,7 @@ static const Tcl_ObjType lambdaType = { FreeLambdaInternalRep, /* freeIntRepProc */ DupLambdaInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ - SetLambdaFromAny, /* setFromAnyProc */ - TCL_OBJTYPE_V0 + SetLambdaFromAny /* setFromAnyProc */ }; #define LambdaSetInternalRep(objPtr, procPtr, nsObjPtr) \ @@ -185,14 +182,14 @@ Tcl_ProcObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create procedure \"%s\": unknown namespace", procName)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", (void *)NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", (char *)NULL); return TCL_ERROR; } if (simpleName == NULL) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't create procedure \"%s\": bad procedure name", procName)); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", (void *)NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", (char *)NULL); return TCL_ERROR; } @@ -209,7 +206,7 @@ Tcl_ProcObjCmd( } cmd = TclNRCreateCommandInNs(interp, simpleName, (Tcl_Namespace *) nsPtr, - TclObjInterpProc, NRInterpProc, procPtr, TclProcDeleteProc); + TclObjInterpProc, TclNRInterpProc, procPtr, TclProcDeleteProc); /* * Now initialize the new procedure's cmdPtr field. This will be used @@ -265,11 +262,11 @@ Tcl_ProcObjCmd( && (contextPtr->nline >= 4) && (contextPtr->line[3] >= 0)) { int isNew; Tcl_HashEntry *hePtr; - CmdFrame *cfPtr = (CmdFrame *)Tcl_Alloc(sizeof(CmdFrame)); + CmdFrame *cfPtr = (CmdFrame *)ckalloc(sizeof(CmdFrame)); cfPtr->level = -1; cfPtr->type = contextPtr->type; - cfPtr->line = (Tcl_Size *)Tcl_Alloc(sizeof(Tcl_Size)); + cfPtr->line = (Tcl_Size *)ckalloc(sizeof(Tcl_Size)); cfPtr->line[0] = contextPtr->line[3]; cfPtr->nline = 1; cfPtr->framePtr = NULL; @@ -297,9 +294,9 @@ Tcl_ProcObjCmd( Tcl_DecrRefCount(cfOldPtr->data.eval.path); cfOldPtr->data.eval.path = NULL; } - Tcl_Free(cfOldPtr->line); + ckfree(cfOldPtr->line); cfOldPtr->line = NULL; - Tcl_Free(cfOldPtr); + ckfree(cfOldPtr); } Tcl_SetHashValue(hePtr, cfPtr); } @@ -471,7 +468,7 @@ TclCreateProc( Tcl_IncrRefCount(bodyPtr); - procPtr = (Proc *)Tcl_Alloc(sizeof(Proc)); + procPtr = (Proc *)ckalloc(sizeof(Proc)); procPtr->iPtr = iPtr; procPtr->refCount = 1; procPtr->bodyPtr = bodyPtr; @@ -500,7 +497,7 @@ TclCreateProc( "precompiled header expects %" TCL_SIZE_MODIFIER "d", procName, numArgs, procPtr->numArgs)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "BYTECODELIES", (void *)NULL); + "BYTECODELIES", (char *)NULL); goto procError; } localPtr = procPtr->firstLocalPtr; @@ -530,14 +527,14 @@ TclCreateProc( Tcl_AppendToObj(errorObj, "\"", -1); Tcl_SetObjResult(interp, errorObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "FORMALARGUMENTFORMAT", (void *)NULL); + "FORMALARGUMENTFORMAT", (char *)NULL); goto procError; } - if ((fieldCount == 0) || (Tcl_GetCharLength(fieldValues[0]) == 0)) { + if ((fieldCount == 0) || (TclGetCharLength(fieldValues[0]) == 0)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "argument with no name", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "FORMALARGUMENTFORMAT", (void *)NULL); + "FORMALARGUMENTFORMAT", (char *)NULL); goto procError; } @@ -556,17 +553,17 @@ TclCreateProc( "formal parameter \"%s\" is an array element", TclGetString(fieldValues[0]))); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "FORMALARGUMENTFORMAT", (void *)NULL); + "FORMALARGUMENTFORMAT", (char *)NULL); goto procError; } - } else if (argnamei[0] == ':' && argnamei[1] == ':') { + } else if (*argnamei == ':' && *(argnamei+1) == ':') { Tcl_Obj *errorObj = Tcl_NewStringObj( - "formal parameter \"", -1); + "formal parameter \"", -1); Tcl_AppendObjToObj(errorObj, fieldValues[0]); Tcl_AppendToObj(errorObj, "\" is not a simple name", -1); Tcl_SetObjResult(interp, errorObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "FORMALARGUMENTFORMAT", (void *)NULL); + "FORMALARGUMENTFORMAT", (char *)NULL); goto procError; } argnamei++; @@ -594,7 +591,7 @@ TclCreateProc( "procedure \"%s\": formal parameter %" TCL_SIZE_MODIFIER "d is " "inconsistent with precompiled body", procName, i)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "BYTECODELIES", (void *)NULL); + "BYTECODELIES", (char *)NULL); goto procError; } @@ -608,7 +605,8 @@ TclCreateProc( const char *value = TclGetStringFromObj(fieldValues[1], &valueLength); if ((valueLength != tmpLength) - || memcmp(value, tmpPtr, tmpLength) != 0) { + || memcmp(value, tmpPtr, tmpLength) != 0 + ) { Tcl_Obj *errorObj = Tcl_ObjPrintf( "procedure \"%s\": formal parameter \"", procName); Tcl_AppendObjToObj(errorObj, fieldValues[0]); @@ -616,7 +614,7 @@ TclCreateProc( "default value inconsistent with precompiled body", -1); Tcl_SetObjResult(interp, errorObj); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "BYTECODELIES", (void *)NULL); + "BYTECODELIES", (char *)NULL); goto procError; } } @@ -634,7 +632,7 @@ TclCreateProc( * local variables for the argument. */ - localPtr = (CompiledLocal *)Tcl_Alloc( + localPtr = (CompiledLocal *)ckalloc( offsetof(CompiledLocal, name) + 1U + fieldValues[0]->length); if (procPtr->firstLocalPtr == NULL) { procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; @@ -680,9 +678,9 @@ TclCreateProc( Tcl_DecrRefCount(localPtr->defValuePtr); } - Tcl_Free(localPtr); + ckfree(localPtr); } - Tcl_Free(procPtr); + ckfree(procPtr); } return TCL_ERROR; } @@ -783,7 +781,7 @@ TclObjGetFrame( if (objPtr == NULL) { /* Do nothing */ } else if (TCL_OK == Tcl_GetIntFromObj(NULL, objPtr, &level)) { - TclGetWideIntFromObj(NULL, objPtr, &w); + Tcl_GetWideIntFromObj(NULL, objPtr, &w); if (w < 0 || w > INT_MAX || curLevel > w + INT_MAX) { result = -1; } else { @@ -832,7 +830,7 @@ TclObjGetFrame( CallFrame *framePtr; for (framePtr = iPtr->varFramePtr; framePtr != NULL; framePtr = framePtr->callerVarPtr) { - if ((int)framePtr->level == level) { + if (framePtr->level == level) { *framePtrPtr = framePtr; return result; } @@ -844,7 +842,7 @@ badLevel: name = objPtr ? TclGetString(objPtr) : "1" ; } Tcl_SetObjResult(interp, Tcl_ObjPrintf("bad level \"%s\"", name)); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", name, (void *)NULL); + Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "LEVEL", name, (char *)NULL); return -1; } @@ -1063,7 +1061,7 @@ TclIsProc( static int ProcWrongNumArgs( Tcl_Interp *interp, - int skip) + Tcl_Size skip) { CallFrame *framePtr = ((Interp *)interp)->varFramePtr; Proc *procPtr = framePtr->procPtr; @@ -1082,7 +1080,11 @@ ProcWrongNumArgs( if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) { desiredObjs[0] = Tcl_NewStringObj("lambdaExpr", -1); } else { +#ifdef AVOID_HACKS_FOR_ITCL desiredObjs[0] = framePtr->objv[skip-1]; +#else + desiredObjs[0] = Tcl_NewListObj(1, framePtr->objv + skip - 1); +#endif /* AVOID_HACKS_FOR_ITCL */ } Tcl_IncrRefCount(desiredObjs[0]); @@ -1095,7 +1097,7 @@ ProcWrongNumArgs( if (defPtr->value.objPtr != NULL) { TclNewObj(argObj); - Tcl_AppendStringsToObj(argObj, "?", TclGetString(namePtr), "?", (void *)NULL); + Tcl_AppendStringsToObj(argObj, "?", TclGetString(namePtr), "?", (char *)NULL); } else if (defPtr->flags & VAR_IS_ARGS) { numArgs--; final = "?arg ...?"; @@ -1121,6 +1123,56 @@ ProcWrongNumArgs( /* *---------------------------------------------------------------------- * + * TclInitCompiledLocals -- + * + * This routine is invoked in order to initialize the compiled locals + * table for a new call frame. + * + * DEPRECATED: functionality has been inlined elsewhere; this function + * remains to insure binary compatibility with Itcl. + * + * Results: + * None. + * + * Side effects: + * May invoke various name resolvers in order to determine which + * variables are being referenced at runtime. + * + *---------------------------------------------------------------------- + */ + +#ifndef TCL_NO_DEPRECATED +void +TclInitCompiledLocals( + Tcl_Interp *interp, /* Current interpreter. */ + CallFrame *framePtr, /* Call frame to initialize. */ + Namespace *nsPtr) /* Pointer to current namespace. */ +{ + Var *varPtr = framePtr->compiledLocals; + Tcl_Obj *bodyPtr; + ByteCode *codePtr; + + bodyPtr = framePtr->procPtr->bodyPtr; + ByteCodeGetInternalRep(bodyPtr, &tclByteCodeType, codePtr); + if (codePtr == NULL) { + Tcl_Panic("body object for proc attached to frame is not a byte code type"); + } + + if (framePtr->numCompiledLocals) { + if (!codePtr->localCachePtr) { + InitLocalCache(framePtr->procPtr) ; + } + framePtr->localCachePtr = codePtr->localCachePtr; + framePtr->localCachePtr->refCount++; + } + + InitResolvedLocals(interp, codePtr, varPtr, nsPtr); +} +#endif /* TCL_NO_DEPRECATED */ + +/* + *---------------------------------------------------------------------- + * * InitResolvedLocals -- * * This routine is invoked in order to initialize the compiled locals @@ -1174,7 +1226,7 @@ InitResolvedLocals( if (localPtr->resolveInfo->deleteProc) { localPtr->resolveInfo->deleteProc(localPtr->resolveInfo); } else { - Tcl_Free(localPtr->resolveInfo); + ckfree(localPtr->resolveInfo); } localPtr->resolveInfo = NULL; } @@ -1260,7 +1312,7 @@ TclFreeLocalCache( TclReleaseLiteral(interp, objPtr); } } - Tcl_Free(localCachePtr); + ckfree(localCachePtr); } static void @@ -1286,7 +1338,7 @@ InitLocalCache( * for future calls. */ - localCachePtr = (LocalCache *)Tcl_Alloc(offsetof(LocalCache, varName0) + localCachePtr = (LocalCache *)ckalloc(offsetof(LocalCache, varName0) + localCt * sizeof(Tcl_Obj *) + numArgs * sizeof(Var)); @@ -1298,7 +1350,7 @@ InitLocalCache( *namePtr = NULL; } else { *namePtr = TclCreateLiteral(iPtr, localPtr->name, - localPtr->nameLength, /* hash */ TCL_INDEX_NONE, + localPtr->nameLength, /* hash */ (unsigned int) -1, &isNew, /* nsPtr */ NULL, 0, NULL); Tcl_IncrRefCount(*namePtr); } @@ -1341,7 +1393,7 @@ static int InitArgsAndLocals( Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ - int skip) /* Number of initial arguments to be skipped, + Tcl_Size skip) /* Number of initial arguments to be skipped, * i.e., words in the "command name". */ { CallFrame *framePtr = ((Interp *)interp)->varFramePtr; @@ -1545,7 +1597,8 @@ TclPushProcCallFrame( || (codePtr->compileEpoch != iPtr->compileEpoch) || (codePtr->nsPtr != nsPtr) || (codePtr->nsEpoch != nsPtr->resolverEpoch) - || ((codePtr->procPtr != procPtr) && procPtr->bodyPtr->bytes)) { + || ((codePtr->procPtr != procPtr) && procPtr->bodyPtr->bytes) + ) { goto doCompilation; } } else { @@ -1609,7 +1662,7 @@ TclObjInterpProc( * Not used much in the core; external interface for iTcl */ - return Tcl_NRCallObjProc(interp, NRInterpProc, clientData, objc, objv); + return Tcl_NRCallObjProc(interp, TclNRInterpProc, clientData, objc, objv); } int @@ -1618,26 +1671,7 @@ TclNRInterpProc( * interpreted. */ Tcl_Interp *interp,/* Interpreter in which procedure was * invoked. */ - Tcl_Size objc, /* Count of number of arguments to this - * procedure. */ - Tcl_Obj *const objv[]) /* Argument value objects. */ -{ - int result = TclPushProcCallFrame(clientData, interp, objc, objv, - /*isLambda*/ 0); - - if (result != TCL_OK) { - return TCL_ERROR; - } - return TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError); -} - -static int -NRInterpProc( - void *clientData, /* Record describing procedure to be - * interpreted. */ - Tcl_Interp *interp, /* Interpreter in which procedure was - * invoked. */ - int objc, /* Count of number of arguments to this + Tcl_Size objc, /* Count of number of arguments to this * procedure. */ Tcl_Obj *const objv[]) /* Argument value objects. */ { @@ -1649,24 +1683,6 @@ NRInterpProc( } return TclNRInterpProcCore(interp, objv[0], 1, &MakeProcError); } - -static int -ObjInterpProc2( - void *clientData, /* Record describing procedure to be - * interpreted. */ - Tcl_Interp *interp, /* Interpreter in which procedure was - * invoked. */ - Tcl_Size objc, /* Count of number of arguments to this - * procedure. */ - Tcl_Obj *const objv[]) /* Argument value objects. */ -{ - /* - * Not used much in the core; external interface for iTcl - */ - - return Tcl_NRCallObjProc2(interp, TclNRInterpProc, clientData, objc, objv); -} - /* *---------------------------------------------------------------------- @@ -1858,7 +1874,7 @@ InterpProcNR2( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invoked \"%s\" outside of a loop", ((result == TCL_BREAK) ? "break" : "continue"))); - Tcl_SetErrorCode(interp, "TCL", "RESULT", "UNEXPECTED", (void *)NULL); + Tcl_SetErrorCode(interp, "TCL", "RESULT", "UNEXPECTED", (char *)NULL); result = TCL_ERROR; /* FALLTHRU */ @@ -1932,7 +1948,8 @@ TclProcCompileProc( && (codePtr->compileEpoch == iPtr->compileEpoch) && (codePtr->nsPtr == nsPtr) && (codePtr->nsEpoch == nsPtr->resolverEpoch) - && ((codePtr->procPtr == procPtr) || !bodyPtr->bytes)) { + && ((codePtr->procPtr == procPtr) || !bodyPtr->bytes) + ) { return TCL_OK; } @@ -1941,7 +1958,7 @@ TclProcCompileProc( Tcl_SetObjResult(interp, Tcl_NewStringObj( "a precompiled script jumped interps", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC", - "CROSSINTERPBYTECODE", (void *)NULL); + "CROSSINTERPBYTECODE", (char *)NULL); return TCL_ERROR; } codePtr->compileEpoch = iPtr->compileEpoch; @@ -1966,7 +1983,7 @@ TclProcCompileProc( TclNewLiteralStringObj(message, "Compiling "); Tcl_IncrRefCount(message); - Tcl_AppendStringsToObj(message, description, " \"", (void *)NULL); + Tcl_AppendStringsToObj(message, description, " \"", (char *)NULL); Tcl_AppendLimitedToObj(message, procName, TCL_INDEX_NONE, 50, NULL); fprintf(stdout, "%s\"\n", TclGetString(message)); Tcl_DecrRefCount(message); @@ -2012,10 +2029,10 @@ TclProcCompileProc( if (toFree->resolveInfo->deleteProc) { toFree->resolveInfo->deleteProc(toFree->resolveInfo); } else { - Tcl_Free(toFree->resolveInfo); + ckfree(toFree->resolveInfo); } } - Tcl_Free(toFree); + ckfree(toFree); } procPtr->numCompiledLocals = procPtr->numArgs; } @@ -2080,7 +2097,7 @@ MakeProcError( Tcl_Size nameLen; const char *procName = TclGetStringFromObj(procNameObj, &nameLen); - overflow = (nameLen > (Tcl_Size)limit); + overflow = (nameLen > limit); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (procedure \"%.*s%s\" line %d)", (overflow ? limit : (int)nameLen), procName, @@ -2165,7 +2182,7 @@ TclProcCleanupProc( if (resVarInfo->deleteProc) { resVarInfo->deleteProc(resVarInfo); } else { - Tcl_Free(resVarInfo); + ckfree(resVarInfo); } } @@ -2173,10 +2190,10 @@ TclProcCleanupProc( defPtr = localPtr->defValuePtr; Tcl_DecrRefCount(defPtr); } - Tcl_Free(localPtr); + ckfree(localPtr); localPtr = nextPtr; } - Tcl_Free(procPtr); + ckfree(procPtr); /* * TIP #280: Release the location data associated with this Proc @@ -2200,9 +2217,9 @@ TclProcCleanupProc( Tcl_DecrRefCount(cfPtr->data.eval.path); cfPtr->data.eval.path = NULL; } - Tcl_Free(cfPtr->line); + ckfree(cfPtr->line); cfPtr->line = NULL; - Tcl_Free(cfPtr); + ckfree(cfPtr); } Tcl_DeleteHashEntry(hePtr); } @@ -2258,15 +2275,15 @@ TclUpdateReturnInfo( /* *---------------------------------------------------------------------- * - * TclGetObjInterpProc/TclGetObjInterpProc2 -- + * TclGetObjInterpProc -- * - * Returns a pointer to the TclObjInterpProc/ObjInterpProc2 functions; + * Returns a pointer to the TclObjInterpProc function; * this is different from the value obtained from the TclObjInterpProc * reference on systems like Windows where import and export versions * of a function exported by a DLL exist. * * Results: - * Returns the internal address of the TclObjInterpProc/ObjInterpProc2 + * Returns the internal address of the TclObjInterpProc * functions. * * Side effects: @@ -2280,12 +2297,6 @@ TclGetObjInterpProc(void) { return TclObjInterpProc; } - -Tcl_ObjCmdProc2 * -TclGetObjInterpProc2(void) -{ - return ObjInterpProc2; -} /* *---------------------------------------------------------------------- @@ -2458,8 +2469,8 @@ SetLambdaFromAny( if ((result != TCL_OK) || ((objc != 2) && (objc != 3))) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't interpret \"%s\" as a lambda expression", - Tcl_GetString(objPtr))); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "LAMBDA", (void *)NULL); + TclGetString(objPtr))); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "LAMBDA", (char *)NULL); return TCL_ERROR; } result = TclListObjGetElements(NULL, objPtr, &objc, &objv); @@ -2467,7 +2478,7 @@ SetLambdaFromAny( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "can't interpret \"%s\" as a lambda expression", TclGetString(objPtr))); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "LAMBDA", (void *)NULL); + Tcl_SetErrorCode(interp, "TCL", "VALUE", "LAMBDA", (char *)NULL); return TCL_ERROR; } @@ -2552,12 +2563,12 @@ SetLambdaFromAny( * location (line of 2nd list element). */ - cfPtr = (CmdFrame *)Tcl_Alloc(sizeof(CmdFrame)); + cfPtr = (CmdFrame *)ckalloc(sizeof(CmdFrame)); TclListLines(objPtr, contextPtr->line[1], 2, buf, NULL); cfPtr->level = -1; cfPtr->type = contextPtr->type; - cfPtr->line = (Tcl_Size *)Tcl_Alloc(sizeof(Tcl_Size)); + cfPtr->line = (Tcl_Size *)ckalloc(sizeof(Tcl_Size)); cfPtr->line[0] = buf[1]; cfPtr->nline = 1; cfPtr->framePtr = NULL; @@ -2592,7 +2603,7 @@ SetLambdaFromAny( } else { const char *nsName = TclGetString(objv[2]); - if ((nsName[0] != ':') || (nsName[1] != ':')) { + if ((*nsName != ':') || (*(nsName+1) != ':')) { TclNewLiteralStringObj(nsObjPtr, "::"); Tcl_AppendObjToObj(nsObjPtr, objv[2]); } else { @@ -2774,7 +2785,7 @@ MakeLambdaError( Tcl_Size nameLen; const char *procName = TclGetStringFromObj(procNameObj, &nameLen); - overflow = (nameLen > (Tcl_Size)limit); + overflow = (nameLen > limit); Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (lambda term \"%.*s%s\" line %d)", (overflow ? limit : (int)nameLen), procName, diff --git a/generic/tclProcess.c b/generic/tclProcess.c index 968e191..1a4bf8c 100644 --- a/generic/tclProcess.c +++ b/generic/tclProcess.c @@ -26,15 +26,14 @@ static int autopurge = 1; /* Autopurge flag. */ typedef struct ProcessInfo { Tcl_Pid pid; /* Process id. */ - int resolvedPid; /* Resolved process id. */ + Tcl_Size resolvedPid; /* Resolved process id. */ int purge; /* Purge eventualy. */ TclProcessWaitStatus status;/* Process status. */ int code; /* Error code, exit status or signal - * number. */ + 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. */ @@ -77,7 +76,7 @@ void InitProcessInfo( ProcessInfo *info, /* Structure to initialize. */ Tcl_Pid pid, /* Process id. */ - Tcl_Size resolvedPid) /* Resolved process id. */ + Tcl_Size resolvedPid) /* Resolved process id. */ { info->pid = pid; info->resolvedPid = resolvedPid; @@ -123,7 +122,7 @@ FreeProcessInfo( * Free allocated structure. */ - Tcl_Free(info); + ckfree(info); } /* @@ -145,7 +144,8 @@ FreeProcessInfo( int RefreshProcessInfo( ProcessInfo *info, /* Structure to refresh. */ - int options) /* Options passed to WaitProcessStatus. */ + int options /* Options passed to WaitProcessStatus. */ +) { if (info->status == TCL_PROCESS_UNCHANGED) { /* @@ -154,12 +154,8 @@ RefreshProcessInfo( 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); - } + if (info->msg) Tcl_IncrRefCount(info->msg); + if (info->error) Tcl_IncrRefCount(info->error); return (info->status != TCL_PROCESS_UNCHANGED); } else { /* @@ -189,14 +185,15 @@ RefreshProcessInfo( TclProcessWaitStatus WaitProcessStatus( Tcl_Pid pid, /* Process id. */ - Tcl_Size resolvedPid, /* Resolved process id. */ + Tcl_Size 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_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. */ { @@ -232,13 +229,9 @@ WaitProcessStatus( 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 (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); @@ -247,20 +240,14 @@ WaitProcessStatus( } return TCL_PROCESS_ERROR; } else if (WIFEXITED(waitStatus)) { - if (codePtr) { - *codePtr = WEXITSTATUS(waitStatus); - } + if (codePtr) *codePtr = WEXITSTATUS(waitStatus); if (!WEXITSTATUS(waitStatus)) { /* * Normal exit. */ - if (msgObjPtr) { - *msgObjPtr = NULL; - } - if (errorObjPtr) { - *errorObjPtr = NULL; - } + if (msgObjPtr) *msgObjPtr = NULL; + if (errorObjPtr) *errorObjPtr = NULL; } else { /* * CHILDSTATUS pid code @@ -268,10 +255,8 @@ WaitProcessStatus( * Child exited with a non-zero exit status. */ - if (msgObjPtr) { - *msgObjPtr = Tcl_NewStringObj( - "child process exited abnormally", -1); - } + if (msgObjPtr) *msgObjPtr = Tcl_NewStringObj( + "child process exited abnormally", -1); if (errorObjPtr) { errorStrings[0] = Tcl_NewStringObj("CHILDSTATUS", -1); TclNewIntObj(errorStrings[1], resolvedPid); @@ -288,12 +273,9 @@ WaitProcessStatus( */ msg = Tcl_SignalMsg(WTERMSIG(waitStatus)); - if (codePtr) { - *codePtr = WTERMSIG(waitStatus); - } - if (msgObjPtr) { - *msgObjPtr = Tcl_ObjPrintf("child killed: %s", msg); - } + if (codePtr) *codePtr = WTERMSIG(waitStatus); + if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf( + "child killed: %s", msg); if (errorObjPtr) { errorStrings[0] = Tcl_NewStringObj("CHILDKILLED", -1); TclNewIntObj(errorStrings[1], resolvedPid); @@ -310,12 +292,9 @@ WaitProcessStatus( */ msg = Tcl_SignalMsg(WSTOPSIG(waitStatus)); - if (codePtr) { - *codePtr = WSTOPSIG(waitStatus); - } - if (msgObjPtr) { - *msgObjPtr = Tcl_ObjPrintf("child suspended: %s", msg); - } + if (codePtr) *codePtr = WSTOPSIG(waitStatus); + if (msgObjPtr) *msgObjPtr = Tcl_ObjPrintf( + "child suspended: %s", msg); if (errorObjPtr) { errorStrings[0] = Tcl_NewStringObj("CHILDSUSP", -1); TclNewIntObj(errorStrings[1], resolvedPid); @@ -331,13 +310,9 @@ WaitProcessStatus( * 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 (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); @@ -380,8 +355,9 @@ BuildProcessStatusObj( /* * Process still running, return empty obj. */ - - return Tcl_NewObj(); + Tcl_Obj *obj; + TclNewObj(obj); + return obj; } if (info->status == TCL_PROCESS_EXITED && info->code == 0) { /* @@ -424,7 +400,7 @@ ProcessListObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Obj *list; + Tcl_Obj *list, *elemPtr; Tcl_HashEntry *entry; Tcl_HashSearch search; ProcessInfo *info; @@ -443,8 +419,8 @@ ProcessListObjCmd( for (entry = Tcl_FirstHashEntry(&infoTablePerResolvedPid, &search); entry != NULL; entry = Tcl_NextHashEntry(&search)) { info = (ProcessInfo *) Tcl_GetHashValue(entry); - Tcl_ListObjAppendElement(interp, list, - Tcl_NewWideIntObj(info->resolvedPid)); + TclNewIntObj(elemPtr, info->resolvedPid); + Tcl_ListObjAppendElement(interp, list, elemPtr); } Tcl_MutexUnlock(&infoTablesMutex); Tcl_SetObjResult(interp, list); @@ -475,12 +451,12 @@ ProcessStatusObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_Obj *dict; - int options = WNOHANG; + Tcl_Obj *dict, *elemPtr; + int index, options = WNOHANG; Tcl_HashEntry *entry; Tcl_HashSearch search; ProcessInfo *info; - Tcl_Size i, numPids; + int i, numPids; Tcl_Obj **pidObjs; int result; int pid; @@ -490,7 +466,7 @@ ProcessStatusObjCmd( }; enum switchesEnum { STATUS_WAIT, STATUS_LAST - } index; + }; while (objc > 1) { if (TclGetString(objv[1])[0] != '-') { @@ -501,7 +477,7 @@ ProcessStatusObjCmd( return TCL_ERROR; } ++objv; --objc; - if (STATUS_WAIT == index) { + if (STATUS_WAIT == (enum switchesEnum) index) { options = 0; } else { break; @@ -539,7 +515,8 @@ ProcessStatusObjCmd( * Add to result. */ - Tcl_DictObjPut(interp, dict, Tcl_NewWideIntObj(info->resolvedPid), + TclNewIntObj(elemPtr, info->resolvedPid); + Tcl_DictObjPut(interp, dict, elemPtr, BuildProcessStatusObj(info)); } } @@ -589,7 +566,8 @@ ProcessStatusObjCmd( * Add to result. */ - Tcl_DictObjPut(interp, dict, Tcl_NewWideIntObj(info->resolvedPid), + TclNewIntObj(elemPtr, info->resolvedPid); + Tcl_DictObjPut(interp, dict, elemPtr, BuildProcessStatusObj(info)); } } @@ -627,7 +605,8 @@ ProcessPurgeObjCmd( ProcessInfo *info; Tcl_Size i, numPids; Tcl_Obj **pidObjs; - int result, pid; + int result; + int pid; if (objc != 1 && objc != 2) { Tcl_WrongNumArgs(interp, 1, objv, "?pids?"); @@ -840,9 +819,7 @@ TclProcessCreated( info = (ProcessInfo *) Tcl_GetHashValue(entry); entry2 = Tcl_FindHashEntry(&infoTablePerResolvedPid, INT2PTR(resolvedPid)); - if (entry2) { - Tcl_DeleteHashEntry(entry2); - } + if (entry2) Tcl_DeleteHashEntry(entry2); FreeProcessInfo(info); } @@ -850,7 +827,7 @@ TclProcessCreated( * Allocate and initialize info structure. */ - info = (ProcessInfo *)Tcl_Alloc(sizeof(ProcessInfo)); + info = (ProcessInfo *)ckalloc(sizeof(ProcessInfo)); InitProcessInfo(info, pid, resolvedPid); /* @@ -913,13 +890,9 @@ TclProcessWait( result = WaitProcessStatus(pid, TclpGetPid(pid), options, codePtr, msgObjPtr, errorObjPtr); - if (msgObjPtr && *msgObjPtr) { - Tcl_IncrRefCount(*msgObjPtr); - } - if (errorObjPtr && *errorObjPtr) { - Tcl_IncrRefCount(*errorObjPtr); - } - Tcl_MutexUnlock(&infoTablesMutex); + if (msgObjPtr && *msgObjPtr) Tcl_IncrRefCount(*msgObjPtr); + if (errorObjPtr && *errorObjPtr) Tcl_IncrRefCount(*errorObjPtr); + Tcl_MutexUnlock(&infoTablesMutex); return result; } @@ -929,8 +902,8 @@ TclProcessWait( * Process has completed but TclProcessWait has already been called, * so report no change. */ + Tcl_MutexUnlock(&infoTablesMutex); - Tcl_MutexUnlock(&infoTablesMutex); return TCL_PROCESS_UNCHANGED; } @@ -939,8 +912,8 @@ TclProcessWait( /* * No change, stop there. */ + Tcl_MutexUnlock(&infoTablesMutex); - Tcl_MutexUnlock(&infoTablesMutex); return TCL_PROCESS_UNCHANGED; } @@ -949,21 +922,11 @@ TclProcessWait( */ 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 (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) { /* @@ -986,11 +949,3 @@ TclProcessWait( Tcl_MutexUnlock(&infoTablesMutex); return result; } - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c index bc6468d..aaf8010 100644 --- a/generic/tclRegexp.c +++ b/generic/tclRegexp.c @@ -13,7 +13,6 @@ #include "tclInt.h" #include "tclRegexp.h" -#include "tclTomMath.h" #include <assert.h> /* @@ -71,7 +70,7 @@ typedef struct { char *patterns[NUM_REGEXPS];/* Strings corresponding to compiled regular * expression patterns. NULL means that this * slot isn't used. Malloc-ed. */ - size_t patLengths[NUM_REGEXPS];/* Number of non-null characters in + int patLengths[NUM_REGEXPS];/* Number of non-null characters in * corresponding entry in patterns. -1 means * entry isn't used. */ struct TclRegexp *regexps[NUM_REGEXPS]; @@ -86,15 +85,15 @@ static Tcl_ThreadDataKey dataKey; */ static TclRegexp * CompileRegexp(Tcl_Interp *interp, const char *pattern, - size_t length, int flags); + int length, int flags); static void DupRegexpInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); -static void FinalizeRegexp(void *clientData); +static void FinalizeRegexp(ClientData clientData); static void FreeRegexp(TclRegexp *regexpPtr); static void FreeRegexpInternalRep(Tcl_Obj *objPtr); static int RegExpExecUniChar(Tcl_Interp *interp, Tcl_RegExp re, - const Tcl_UniChar *uniString, size_t numChars, - size_t nmatches, int flags); + const Tcl_UniChar *uniString, int numChars, + int nmatches, int flags); static int SetRegexpFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); /* @@ -107,8 +106,7 @@ const Tcl_ObjType tclRegexpType = { FreeRegexpInternalRep, /* freeIntRepProc */ DupRegexpInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ - SetRegexpFromAny, /* setFromAnyProc */ - TCL_OBJTYPE_V0 + SetRegexpFromAny /* setFromAnyProc */ }; #define RegexpSetInternalRep(objPtr, rePtr) \ @@ -157,7 +155,7 @@ Tcl_RegExpCompile( const char *pattern) /* String for which to produce compiled * regular expression. */ { - return (Tcl_RegExp) CompileRegexp(interp, pattern, strlen(pattern), + return (Tcl_RegExp) CompileRegexp(interp, pattern, (int) strlen(pattern), REG_ADVANCED); } @@ -192,8 +190,7 @@ Tcl_RegExpExec( * identifies beginning of larger string, so * that "^" won't match. */ { - int flags, result; - size_t numChars; + int flags, result, numChars; TclRegexp *regexp = (TclRegexp *) re; Tcl_DString ds; const Tcl_UniChar *ustr; @@ -221,9 +218,9 @@ Tcl_RegExpExec( */ Tcl_DStringInit(&ds); - ustr = Tcl_UtfToUniCharDString(text, TCL_INDEX_NONE, &ds); + ustr = Tcl_UtfToUniCharDString(text, -1, &ds); numChars = Tcl_DStringLength(&ds) / sizeof(Tcl_UniChar); - result = RegExpExecUniChar(interp, re, ustr, numChars, TCL_INDEX_NONE /* nmatches */, + result = RegExpExecUniChar(interp, re, ustr, numChars, -1 /* nmatches */, flags); Tcl_DStringFree(&ds); @@ -253,7 +250,7 @@ void Tcl_RegExpRange( Tcl_RegExp re, /* Compiled regular expression that has been * passed to Tcl_RegExpExec. */ - Tcl_Size index, /* 0 means give the range of the entire match, + int index, /* 0 means give the range of the entire match, * > 0 means give the range of a matching * subrange. */ const char **startPtr, /* Store address of first character in @@ -264,9 +261,9 @@ Tcl_RegExpRange( TclRegexp *regexpPtr = (TclRegexp *) re; const char *string; - if (index < 0 || (size_t) index > regexpPtr->re.re_nsub) { + if ((size_t) index > regexpPtr->re.re_nsub) { *startPtr = *endPtr = NULL; - } else if (regexpPtr->matches[index].rm_so == (size_t) -1) { + } else if (regexpPtr->matches[index].rm_so == TCL_INDEX_NONE) { *startPtr = *endPtr = NULL; } else { if (regexpPtr->objPtr) { @@ -274,8 +271,8 @@ Tcl_RegExpRange( } else { string = regexpPtr->string; } - *startPtr = Tcl_UtfAtIndex(string, regexpPtr->matches[index].rm_so); - *endPtr = Tcl_UtfAtIndex(string, regexpPtr->matches[index].rm_eo); + *startPtr = TclUtfAtIndex(string, regexpPtr->matches[index].rm_so); + *endPtr = TclUtfAtIndex(string, regexpPtr->matches[index].rm_eo); } } @@ -305,8 +302,9 @@ RegExpExecUniChar( Tcl_RegExp re, /* Compiled regular expression; returned by a * previous call to Tcl_GetRegExpFromObj */ const Tcl_UniChar *wString, /* String against which to match re. */ - size_t numChars, /* Length of Tcl_UniChar string. */ - size_t nm, /* How many subexpression matches (counting + int numChars, /* Length of Tcl_UniChar string (must be + * >=0). */ + int nmatches, /* How many subexpression matches (counting * the whole match as subexpression 0) are of * interest. -1 means "don't know". */ int flags) /* Regular expression flags. */ @@ -314,12 +312,13 @@ RegExpExecUniChar( int status; TclRegexp *regexpPtr = (TclRegexp *) re; size_t last = regexpPtr->re.re_nsub + 1; + size_t nm = last; - if (nm >= last) { - nm = last; + if (nmatches >= 0 && (size_t) nmatches < nm) { + nm = (size_t) nmatches; } - status = TclReExec(®expPtr->re, wString, numChars, + status = TclReExec(®expPtr->re, wString, (size_t) numChars, ®expPtr->details, nm, regexpPtr->matches, flags); /* @@ -363,23 +362,23 @@ void TclRegExpRangeUniChar( Tcl_RegExp re, /* Compiled regular expression that has been * passed to Tcl_RegExpExec. */ - Tcl_Size index, /* 0 means give the range of the entire match, + 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. */ - Tcl_Size *startPtr, /* Store address of first character in + int *startPtr, /* Store address of first character in * (sub-)range here. */ - Tcl_Size *endPtr) /* Store address of character just after last + int *endPtr) /* Store address of character just after last * in (sub-)range here. */ { 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 (index < 0 || (size_t) index > regexpPtr->re.re_nsub + 1) { - *startPtr = -1; - *endPtr = -1; + } else if ((size_t) index > regexpPtr->re.re_nsub) { + *startPtr = TCL_INDEX_NONE; + *endPtr = TCL_INDEX_NONE; } else { *startPtr = regexpPtr->matches[index].rm_so; *endPtr = regexpPtr->matches[index].rm_eo; @@ -443,16 +442,16 @@ Tcl_RegExpExecObj( * returned by previous call to * Tcl_GetRegExpFromObj. */ Tcl_Obj *textObj, /* Text against which to match re. */ - Tcl_Size offset, /* Character index that marks where matching + int offset, /* Character index that marks where matching * should begin. */ - Tcl_Size nmatches, /* How many subexpression matches (counting + int nmatches, /* How many subexpression matches (counting * the whole match as subexpression 0) are of * interest. -1 means all of them. */ int flags) /* Regular expression execution flags. */ { TclRegexp *regexpPtr = (TclRegexp *) re; Tcl_UniChar *udata; - Tcl_Size length; + int length; int reflags = regexpPtr->flags; #define TCL_REG_GLOBOK_FLAGS \ (TCL_REG_ADVANCED | TCL_REG_NOSUB | TCL_REG_NOCASE) @@ -483,7 +482,7 @@ Tcl_RegExpExecObj( regexpPtr->string = NULL; regexpPtr->objPtr = textObj; - udata = Tcl_GetUnicodeFromObj(textObj, &length); + udata = TclGetUnicodeFromObj(textObj, &length); if (offset > length) { offset = length; @@ -529,8 +528,8 @@ Tcl_RegExpMatchObj( */ if (!(re = Tcl_GetRegExpFromObj(interp, patternObj, - TCL_REG_ADVANCED | TCL_REG_NOSUB)) && - !(re = Tcl_GetRegExpFromObj(interp, patternObj, TCL_REG_ADVANCED))) { + TCL_REG_ADVANCED | TCL_REG_NOSUB)) + && !(re = Tcl_GetRegExpFromObj(interp, patternObj, TCL_REG_ADVANCED))) { return -1; } return Tcl_RegExpExecObj(interp, re, textObj, 0 /* offset */, @@ -595,7 +594,7 @@ Tcl_GetRegExpFromObj( * expression. */ int flags) /* Regular expression compilation flags. */ { - Tcl_Size length; + int length; TclRegexp *regexpPtr; const char *pattern; @@ -859,7 +858,7 @@ static TclRegexp * CompileRegexp( Tcl_Interp *interp, /* Used for error reporting if not NULL. */ const char *string, /* The regexp to compile (UTF-8). */ - size_t length, /* The length of the string in bytes. */ + int length, /* The length of the string in bytes. */ int flags) /* Compilation flags. */ { TclRegexp *regexpPtr; @@ -917,11 +916,11 @@ CompileRegexp( * This is a new expression, so compile it and add it to the cache. */ - regexpPtr = (TclRegexp*)Tcl_Alloc(sizeof(TclRegexp)); + regexpPtr = (TclRegexp*)ckalloc(sizeof(TclRegexp)); regexpPtr->objPtr = NULL; regexpPtr->string = NULL; - regexpPtr->details.rm_extend.rm_so = TCL_INDEX_NONE; - regexpPtr->details.rm_extend.rm_eo = TCL_INDEX_NONE; + regexpPtr->details.rm_extend.rm_so = -1; + regexpPtr->details.rm_extend.rm_eo = -1; /* * Get the up-to-date string representation and map to unicode. @@ -944,7 +943,7 @@ CompileRegexp( * Clean up and report errors in the interpreter, if possible. */ - Tcl_Free(regexpPtr); + ckfree(regexpPtr); if (interp) { TclRegError(interp, "couldn't compile regular expression pattern: ", status); @@ -972,7 +971,7 @@ CompileRegexp( */ regexpPtr->matches = - (regmatch_t*)Tcl_Alloc(sizeof(regmatch_t) * (regexpPtr->re.re_nsub + 1)); + (regmatch_t*)ckalloc(sizeof(regmatch_t) * (regexpPtr->re.re_nsub + 1)); /* * Initialize the refcount to one initially, since it is in the cache. @@ -991,14 +990,14 @@ CompileRegexp( if (oldRegexpPtr->refCount-- <= 1) { FreeRegexp(oldRegexpPtr); } - Tcl_Free(tsdPtr->patterns[NUM_REGEXPS-1]); + ckfree(tsdPtr->patterns[NUM_REGEXPS-1]); } for (i = NUM_REGEXPS - 2; i >= 0; i--) { tsdPtr->patterns[i+1] = tsdPtr->patterns[i]; tsdPtr->patLengths[i+1] = tsdPtr->patLengths[i]; tsdPtr->regexps[i+1] = tsdPtr->regexps[i]; } - tsdPtr->patterns[0] = (char *)Tcl_Alloc(length + 1); + tsdPtr->patterns[0] = (char *)ckalloc(length + 1); memcpy(tsdPtr->patterns[0], string, length + 1); tsdPtr->patLengths[0] = length; tsdPtr->regexps[0] = regexpPtr; @@ -1031,9 +1030,9 @@ FreeRegexp( TclDecrRefCount(regexpPtr->globObjPtr); } if (regexpPtr->matches) { - Tcl_Free(regexpPtr->matches); + ckfree(regexpPtr->matches); } - Tcl_Free(regexpPtr); + ckfree(regexpPtr); } /* @@ -1054,7 +1053,7 @@ FreeRegexp( static void FinalizeRegexp( - TCL_UNUSED(void *)) + TCL_UNUSED(ClientData)) { int i; TclRegexp *regexpPtr; @@ -1065,7 +1064,7 @@ FinalizeRegexp( if (regexpPtr->refCount-- <= 1) { FreeRegexp(regexpPtr); } - Tcl_Free(tsdPtr->patterns[i]); + ckfree(tsdPtr->patterns[i]); tsdPtr->patterns[i] = NULL; } diff --git a/generic/tclResolve.c b/generic/tclResolve.c index f321515..ff88ffd 100644 --- a/generic/tclResolve.c +++ b/generic/tclResolve.c @@ -101,9 +101,9 @@ Tcl_AddInterpResolvers( * list, so that it overrides existing schemes. */ - resPtr = (ResolverScheme *)Tcl_Alloc(sizeof(ResolverScheme)); + resPtr = (ResolverScheme *)ckalloc(sizeof(ResolverScheme)); len = strlen(name) + 1; - resPtr->name = (char *)Tcl_Alloc(len); + resPtr->name = (char *)ckalloc(len); memcpy(resPtr->name, name, len); resPtr->cmdResProc = cmdProc; resPtr->varResProc = varProc; @@ -225,8 +225,8 @@ Tcl_RemoveInterpResolvers( } *prevPtrPtr = resPtr->nextPtr; - Tcl_Free(resPtr->name); - Tcl_Free(resPtr); + ckfree(resPtr->name); + ckfree(resPtr); return 1; } diff --git a/generic/tclResult.c b/generic/tclResult.c index 7151fc4..5497622 100644 --- a/generic/tclResult.c +++ b/generic/tclResult.c @@ -10,7 +10,6 @@ */ #include "tclInt.h" -#include <assert.h> /* * Indices of the standard return options dictionary keys. @@ -26,8 +25,11 @@ enum returnKeys { */ static Tcl_Obj ** GetKeys(void); -static void ReleaseKeys(void *clientData); +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 @@ -75,7 +77,7 @@ Tcl_SaveInterpState( int status) /* status code for current operation */ { Interp *iPtr = (Interp *) interp; - InterpState *statePtr = (InterpState *)Tcl_Alloc(sizeof(InterpState)); + InterpState *statePtr = (InterpState *)ckalloc(sizeof(InterpState)); statePtr->status = status; statePtr->flags = iPtr->flags & ERR_ALREADY_LOGGED; @@ -205,43 +207,359 @@ Tcl_DiscardInterpState( Tcl_DecrRefCount(statePtr->errorStack); } Tcl_DecrRefCount(statePtr->objResult); - Tcl_Free(statePtr); + ckfree(statePtr); } /* *---------------------------------------------------------------------- * - * Tcl_SetObjResult -- - * Makes objPtr the interpreter's result value. + * Tcl_SaveResult -- + * + * Takes a snapshot of the current result state of the interpreter. The + * snapshot can be restored at any point by Tcl_RestoreResult. Note that + * this routine does not preserve the errorCode, errorInfo, or flags + * fields so it should not be used if an error is in progress. + * + * Once a snapshot is saved, it must be restored by calling + * Tcl_RestoreResult, or discarded by calling Tcl_DiscardResult. * * Results: * None. * * Side effects: - * Stores objPtr interp->objResultPtr, increments its reference count, and - * decrements the reference count of any existing interp->objResultPtr. + * Resets the interpreter result. + * + *---------------------------------------------------------------------- + */ + +#ifndef TCL_NO_DEPRECATED +#undef Tcl_SaveResult +void +Tcl_SaveResult( + Tcl_Interp *interp, /* Interpreter to save. */ + Tcl_SavedResult *statePtr) /* Pointer to state structure. */ +{ + Interp *iPtr = (Interp *) interp; + + /* + * Move the result object into the save state. Note that we don't need to + * change its refcount because we're moving it, not adding a new + * reference. Put an empty object into the interpreter. + */ + + statePtr->objResultPtr = iPtr->objResultPtr; + TclNewObj(iPtr->objResultPtr); + Tcl_IncrRefCount(iPtr->objResultPtr); + + /* + * Save the string result. + */ + + statePtr->freeProc = iPtr->freeProc; + if (iPtr->result == iPtr->resultSpace) { + /* + * Copy the static string data out of the interp buffer. + */ + + statePtr->result = statePtr->resultSpace; + strcpy(statePtr->result, iPtr->result); + statePtr->appendResult = NULL; + } else if (iPtr->result == iPtr->appendResult) { + /* + * Move the append buffer out of the interp. + */ + + statePtr->appendResult = iPtr->appendResult; + statePtr->appendAvl = iPtr->appendAvl; + statePtr->appendUsed = iPtr->appendUsed; + statePtr->result = statePtr->appendResult; + iPtr->appendResult = NULL; + iPtr->appendAvl = 0; + iPtr->appendUsed = 0; + } else { + /* + * Move the dynamic or static string out of the interpreter. + */ + + statePtr->result = iPtr->result; + statePtr->appendResult = NULL; + } + + iPtr->result = iPtr->resultSpace; + iPtr->resultSpace[0] = 0; + iPtr->freeProc = 0; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_RestoreResult -- + * + * Restores the state of the interpreter to a snapshot taken by + * Tcl_SaveResult. After this call, the token for the interpreter state + * is no longer valid. * - * The string result is reset. + * Results: + * None. + * + * Side effects: + * Restores the interpreter result. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_RestoreResult +void +Tcl_RestoreResult( + Tcl_Interp *interp, /* Interpreter being restored. */ + Tcl_SavedResult *statePtr) /* State returned by Tcl_SaveResult. */ +{ + Interp *iPtr = (Interp *) interp; + + Tcl_ResetResult(interp); + + /* + * Restore the string result. + */ + + iPtr->freeProc = statePtr->freeProc; + if (statePtr->result == statePtr->resultSpace) { + /* + * Copy the static string data into the interp buffer. + */ + + iPtr->result = iPtr->resultSpace; + strcpy(iPtr->result, statePtr->result); + } else if (statePtr->result == statePtr->appendResult) { + /* + * Move the append buffer back into the interp. + */ + + if (iPtr->appendResult != NULL) { + ckfree(iPtr->appendResult); + } + + iPtr->appendResult = statePtr->appendResult; + iPtr->appendAvl = statePtr->appendAvl; + iPtr->appendUsed = statePtr->appendUsed; + iPtr->result = iPtr->appendResult; + } else { + /* + * Move the dynamic or static string back into the interpreter. + */ + + iPtr->result = statePtr->result; + } + + /* + * Restore the object result. + */ + + Tcl_DecrRefCount(iPtr->objResultPtr); + iPtr->objResultPtr = statePtr->objResultPtr; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_DiscardResult -- + * + * Frees the memory associated with an interpreter snapshot taken by + * Tcl_SaveResult. If the snapshot is not restored, this function must be + * called to discard it, or the memory will be lost. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_DiscardResult +void +Tcl_DiscardResult( + Tcl_SavedResult *statePtr) /* State returned by Tcl_SaveResult. */ +{ + TclDecrRefCount(statePtr->objResultPtr); + + if (statePtr->result == statePtr->appendResult) { + ckfree(statePtr->appendResult); + } else if (statePtr->freeProc == TCL_DYNAMIC) { + ckfree(statePtr->result); + } else if (statePtr->freeProc) { + statePtr->freeProc(statePtr->result); + } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetResult -- + * + * Arrange for "result" to be the Tcl return value. + * + * Results: + * None. + * + * Side effects: + * interp->result is left pointing either to "result" or to a copy of it. + * Also, the object result is reset. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetResult( + Tcl_Interp *interp, /* Interpreter with which to associate the + * return value. */ + char *result, /* Value to be returned. If NULL, the result + * is set to an empty string. */ + Tcl_FreeProc *freeProc) /* Gives information about the string: + * TCL_STATIC, TCL_VOLATILE, or the address of + * a Tcl_FreeProc such as free. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_FreeProc *oldFreeProc = iPtr->freeProc; + char *oldResult = iPtr->result; + + if (result == NULL) { + iPtr->resultSpace[0] = 0; + iPtr->result = iPtr->resultSpace; + iPtr->freeProc = 0; + } else if (freeProc == TCL_VOLATILE) { + int length = strlen(result); + + if (length > TCL_RESULT_SIZE) { + iPtr->result = (char *)ckalloc(length + 1); + iPtr->freeProc = TCL_DYNAMIC; + } else { + iPtr->result = iPtr->resultSpace; + iPtr->freeProc = 0; + } + memcpy(iPtr->result, result, length+1); + } else { + iPtr->result = (char *) result; + iPtr->freeProc = freeProc; + } + + /* + * If the old result was dynamically-allocated, free it up. Do it here, + * rather than at the beginning, in case the new result value was part of + * the old result value. + */ + + if (oldFreeProc != 0) { + if (oldFreeProc == TCL_DYNAMIC) { + ckfree(oldResult); + } else { + oldFreeProc(oldResult); + } + } + + /* + * Reset the object result since we just set the string result. + */ + + ResetObjResult(iPtr); +} +#endif /* !TCL_NO_DEPRECATED */ + +/* + *---------------------------------------------------------------------- + * + * Tcl_GetStringResult -- + * + * Returns an interpreter's result value as a string. + * + * Results: + * The interpreter's result as a string. + * + * Side effects: + * If the string result is empty, the object result is moved to the + * string result, then the object result is reset. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_GetStringResult +const char * +Tcl_GetStringResult( + Tcl_Interp *interp)/* Interpreter whose result to return. */ +{ +#ifndef TCL_NO_DEPRECATED + Interp *iPtr = (Interp *) interp; + /* + * If the string result is empty, move the object result to the string + * result, then reset the object result. + */ + + if (*(iPtr->result) == 0) { + Tcl_SetResult(interp, Tcl_GetString(Tcl_GetObjResult(interp)), + TCL_VOLATILE); + } + return iPtr->result; +#else + return TclGetString(Tcl_GetObjResult(interp)); +#endif +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetObjResult -- + * + * Arrange for objPtr to be an interpreter's result value. + * + * Results: + * None. + * + * Side effects: + * interp->objResultPtr is left pointing to the object referenced by + * objPtr. The object's reference count is incremented since there is now + * a new reference to it. The reference count for any old objResultPtr + * value is decremented. Also, the string result is reset. * *---------------------------------------------------------------------- */ void Tcl_SetObjResult( - Tcl_Interp *interp, /* Interpreter to set the result for. */ - Tcl_Obj *objPtr) /* The value to set as the result. */ + Tcl_Interp *interp, /* Interpreter with which to associate the + * return object value. */ + Tcl_Obj *objPtr) /* Tcl object to be returned. If NULL, the obj + * result is made an empty string object. */ { Interp *iPtr = (Interp *) interp; Tcl_Obj *oldObjResult = iPtr->objResultPtr; - if (objPtr == oldObjResult) { - /* This should be impossible */ - assert(objPtr->refCount != 0); - return; - } else { - iPtr->objResultPtr = objPtr; - Tcl_IncrRefCount(objPtr); - TclDecrRefCount(oldObjResult); + + iPtr->objResultPtr = objPtr; + Tcl_IncrRefCount(objPtr); /* since interp result is a reference */ + + /* + * We wait until the end to release the old object result, in case we are + * setting the result to itself. + */ + + TclDecrRefCount(oldObjResult); + +#ifndef TCL_NO_DEPRECATED + /* + * Reset the string result since we just set the result object. + */ + + if (iPtr->freeProc != NULL) { + if (iPtr->freeProc == TCL_DYNAMIC) { + ckfree(iPtr->result); + } else { + iPtr->freeProc(iPtr->result); + } + iPtr->freeProc = 0; } + iPtr->result = iPtr->resultSpace; + iPtr->resultSpace[0] = 0; +#endif } /* @@ -270,13 +588,75 @@ Tcl_GetObjResult( Tcl_Interp *interp) /* Interpreter whose result to return. */ { Interp *iPtr = (Interp *) interp; +#ifndef TCL_NO_DEPRECATED + Tcl_Obj *objResultPtr; + int length; + + /* + * If the string result is non-empty, move the string result to the object + * result, then reset the string result. + */ + + if (iPtr->result[0] != 0) { + ResetObjResult(iPtr); + objResultPtr = iPtr->objResultPtr; + length = strlen(iPtr->result); + TclInitStringRep(objResultPtr, iPtr->result, length); + + if (iPtr->freeProc != NULL) { + if (iPtr->freeProc == TCL_DYNAMIC) { + ckfree(iPtr->result); + } else { + iPtr->freeProc(iPtr->result); + } + iPtr->freeProc = 0; + } + iPtr->result = iPtr->resultSpace; + iPtr->result[0] = 0; + } +#endif /* !TCL_NO_DEPRECATED */ return iPtr->objResultPtr; } /* *---------------------------------------------------------------------- * + * Tcl_AppendResultVA -- + * + * Append a variable number of strings onto the interpreter's result. + * + * Results: + * None. + * + * Side effects: + * The result of the interpreter given by the first argument is extended + * by the strings in the va_list (up to a terminating NULL argument). + * + * If the string result is non-empty, the object result forced to be a + * duplicate of it first. There will be a string result afterwards. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AppendResultVA( + Tcl_Interp *interp, /* Interpreter with which to associate the + * return value. */ + va_list argList) /* Variable argument list. */ +{ + Tcl_Obj *objPtr = Tcl_GetObjResult(interp); + + if (Tcl_IsShared(objPtr)) { + objPtr = Tcl_DuplicateObj(objPtr); + } + Tcl_AppendStringsToObjVA(objPtr, argList); + Tcl_SetObjResult(interp, objPtr); +} + +/* + *---------------------------------------------------------------------- + * * Tcl_AppendResult -- * * Append a variable number of strings onto the interpreter's result. @@ -300,23 +680,9 @@ Tcl_AppendResult( Tcl_Interp *interp, ...) { va_list argList; - Tcl_Obj *objPtr; va_start(argList, interp); - objPtr = Tcl_GetObjResult(interp); - - if (Tcl_IsShared(objPtr)) { - objPtr = Tcl_DuplicateObj(objPtr); - } - while (1) { - const char *bytes = va_arg(argList, char *); - - if (bytes == NULL) { - break; - } - Tcl_AppendToObj(objPtr, bytes, -1); - } - Tcl_SetObjResult(interp, objPtr); + Tcl_AppendResultVA(interp, argList); va_end(argList); } @@ -351,25 +717,201 @@ 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; - Tcl_Size length; if (Tcl_IsShared(iPtr->objResultPtr)) { Tcl_SetObjResult(interp, Tcl_DuplicateObj(iPtr->objResultPtr)); } - bytes = TclGetStringFromObj(iPtr->objResultPtr, &length); - if (TclNeedSpace(bytes, bytes + length)) { + 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; + int quoteHash = 1; + + /* + * If the string result is empty, move the object result to the string + * result, then reset the object result. + */ + + (void) Tcl_GetStringResult(interp); + + /* + * See how much space is needed, and grow the append buffer if needed to + * accommodate the list element. + */ + + size = Tcl_ScanElement(element, &flags) + 1; + if ((iPtr->result != iPtr->appendResult) + || (iPtr->appendResult[iPtr->appendUsed] != 0) + || ((size + iPtr->appendUsed) >= iPtr->appendAvl)) { + SetupAppendBuffer(iPtr, size+iPtr->appendUsed); + } + + /* + * Convert the string into a list element and copy it to the buffer that's + * forming, with a space separator if needed. + */ + + dst = iPtr->appendResult + iPtr->appendUsed; + if (TclNeedSpace(iPtr->appendResult, dst)) { + iPtr->appendUsed++; + *dst = ' '; + dst++; + + /* + * If we need a space to separate this element from preceding stuff, + * then this element will not lead a list, and need not have it's + * leading '#' quoted. + */ + quoteHash = 0; + } else { + while ((--dst >= iPtr->appendResult) && TclIsSpaceProcM(*dst)) { + } + quoteHash = !TclNeedSpace(iPtr->appendResult, dst+1); + } + dst = iPtr->appendResult + iPtr->appendUsed; + if (!quoteHash) { + flags |= TCL_DONT_QUOTE_HASH; + } + + iPtr->appendUsed += Tcl_ConvertElement(element, dst, flags); +#endif /* !TCL_NO_DEPRECATED */ +} + +/* + *---------------------------------------------------------------------- + * + * SetupAppendBuffer -- + * + * This function makes sure that there is an append buffer properly + * initialized, if necessary, from the interpreter's result, and that it + * has at least enough room to accommodate newSpace new bytes of + * information. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#ifndef TCL_NO_DEPRECATED +static void +SetupAppendBuffer( + Interp *iPtr, /* Interpreter whose result is being set up. */ + int newSpace) /* Make sure that at least this many bytes of + * new information may be added. */ +{ + int totalSpace; + + /* + * Make the append buffer larger, if that's necessary, then copy the + * result into the append buffer and make the append buffer the official + * Tcl result. + */ + + if (iPtr->result != iPtr->appendResult) { + /* + * If an oversized buffer was used recently, then free it up so we go + * back to a smaller buffer. This avoids tying up memory forever after + * a large operation. + */ + + if (iPtr->appendAvl > 500) { + ckfree(iPtr->appendResult); + iPtr->appendResult = NULL; + iPtr->appendAvl = 0; + } + iPtr->appendUsed = strlen(iPtr->result); + } else if (iPtr->result[iPtr->appendUsed] != 0) { + /* + * Most likely someone has modified a result created by + * Tcl_AppendResult et al. so that it has a different size. Just + * recompute the size. + */ + + iPtr->appendUsed = strlen(iPtr->result); + } + + totalSpace = newSpace + iPtr->appendUsed; + if (totalSpace >= iPtr->appendAvl) { + char *newSpacePtr; + + if (totalSpace < 100) { + totalSpace = 200; + } else { + totalSpace *= 2; + } + newSpacePtr = (char *)ckalloc(totalSpace); + strcpy(newSpacePtr, iPtr->result); + if (iPtr->appendResult != NULL) { + ckfree(iPtr->appendResult); + } + iPtr->appendResult = newSpacePtr; + iPtr->appendAvl = totalSpace; + } else if (iPtr->result != iPtr->appendResult) { + strcpy(iPtr->appendResult, iPtr->result); + } + + Tcl_FreeResult((Tcl_Interp *) iPtr); + iPtr->result = iPtr->appendResult; } /* *---------------------------------------------------------------------- * + * Tcl_FreeResult -- + * + * This function frees up the memory associated with an interpreter's + * string result. It also resets the interpreter's result object. + * Tcl_FreeResult is most commonly used when a function is about to + * replace one result value with another. + * + * Results: + * None. + * + * Side effects: + * Frees the memory associated with interp's string result and sets + * interp->freeProc to zero, but does not change interp->result or clear + * error state. Resets interp's result object to an unshared empty + * object. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_FreeResult( + Tcl_Interp *interp)/* Interpreter for which to free result. */ +{ + Interp *iPtr = (Interp *) interp; + + if (iPtr->freeProc != NULL) { + if (iPtr->freeProc == TCL_DYNAMIC) { + ckfree(iPtr->result); + } else { + iPtr->freeProc(iPtr->result); + } + iPtr->freeProc = 0; + } + + ResetObjResult(iPtr); +} +#endif /* !TCL_NO_DEPRECATED */ + +/* + *---------------------------------------------------------------------- + * * Tcl_ResetResult -- * * This function resets both the interpreter's string and object results. @@ -393,6 +935,18 @@ Tcl_ResetResult( Interp *iPtr = (Interp *) interp; ResetObjResult(iPtr); +#ifndef TCL_NO_DEPRECATED + if (iPtr->freeProc != NULL) { + if (iPtr->freeProc == TCL_DYNAMIC) { + ckfree(iPtr->result); + } else { + iPtr->freeProc(iPtr->result); + } + iPtr->freeProc = 0; + } + iPtr->result = iPtr->resultSpace; + iPtr->resultSpace[0] = 0; +#endif /* !TCL_NO_DEPRECATED */ if (iPtr->errorCode) { /* Legacy support */ if (iPtr->flags & ERR_LEGACY_COPY) { @@ -454,7 +1008,7 @@ ResetObjResult( } else { if (objResultPtr->bytes != &tclEmptyString) { if (objResultPtr->bytes) { - Tcl_Free(objResultPtr->bytes); + ckfree(objResultPtr->bytes); } objResultPtr->bytes = &tclEmptyString; objResultPtr->length = 0; @@ -466,7 +1020,7 @@ ResetObjResult( /* *---------------------------------------------------------------------- * - * Tcl_SetErrorCode -- + * Tcl_SetErrorCodeVA -- * * This function is called to record machine-readable information about * an error that is about to be returned. @@ -483,10 +1037,10 @@ ResetObjResult( */ void -Tcl_SetErrorCode( - Tcl_Interp *interp, ...) +Tcl_SetErrorCodeVA( + Tcl_Interp *interp, /* Interpreter in which to set errorCode */ + va_list argList) /* Variable argument list. */ { - va_list argList; Tcl_Obj *errorObj; /* @@ -494,14 +1048,7 @@ Tcl_SetErrorCode( * errorCode field as list elements. */ - va_start(argList, interp); TclNewObj(errorObj); - - /* - * Scan through the arguments one at a time, appending them to the - * errorCode field as list elements. - */ - while (1) { char *elem = va_arg(argList, char *); @@ -511,6 +1058,40 @@ Tcl_SetErrorCode( Tcl_ListObjAppendElement(NULL, errorObj, Tcl_NewStringObj(elem, -1)); } Tcl_SetObjErrorCode(interp, errorObj); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SetErrorCode -- + * + * This function is called to record machine-readable information about + * an error that is about to be returned. + * + * Results: + * None. + * + * Side effects: + * The errorCode field of the interp is modified to hold all of the + * arguments to this function, in a list form with each argument becoming + * one element of the list. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_SetErrorCode( + Tcl_Interp *interp, ...) +{ + va_list argList; + + /* + * Scan through the arguments one at a time, appending them to the + * errorCode field as list elements. + */ + + va_start(argList, interp); + Tcl_SetErrorCodeVA(interp, argList); va_end(argList); } @@ -556,6 +1137,7 @@ Tcl_SetObjErrorCode( *---------------------------------------------------------------------- */ +#undef Tcl_GetErrorLine int Tcl_GetErrorLine( Tcl_Interp *interp) @@ -573,6 +1155,7 @@ Tcl_GetErrorLine( *---------------------------------------------------------------------- */ +#undef Tcl_SetErrorLine void Tcl_SetErrorLine( Tcl_Interp *interp, @@ -656,7 +1239,7 @@ GetKeys(void) static void ReleaseKeys( - void *clientData) + ClientData clientData) { Tcl_Obj **keys = (Tcl_Obj **)clientData; int i; @@ -718,10 +1301,8 @@ TclProcessReturn( Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORINFO], &valuePtr); if (valuePtr != NULL) { - Tcl_Size length; - - (void)TclGetStringFromObj(valuePtr, &length); - if (length) { + (void) TclGetString(valuePtr); + if (valuePtr->length) { iPtr->errorInfo = valuePtr; Tcl_IncrRefCount(iPtr->errorInfo); iPtr->flags |= ERR_ALREADY_LOGGED; @@ -730,7 +1311,7 @@ TclProcessReturn( Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORSTACK], &valuePtr); if (valuePtr != NULL) { - Tcl_Size len, valueObjc; + int len, valueObjc; Tcl_Obj **valueObjv; if (Tcl_IsShared(iPtr->errorStack)) { @@ -766,7 +1347,7 @@ TclProcessReturn( if (valuePtr != NULL) { Tcl_SetObjErrorCode(interp, valuePtr); } else { - Tcl_SetErrorCode(interp, "NONE", (void *)NULL); + Tcl_SetErrorCode(interp, "NONE", (char *)NULL); } Tcl_DictObjGet(NULL, iPtr->returnOpts, keys[KEY_ERRORLINE], @@ -807,7 +1388,7 @@ TclProcessReturn( int TclMergeReturnOptions( Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[], /* Argument objects. */ Tcl_Obj **optionsPtrPtr, /* If not NULL, points to space for a (Tcl_Obj * *) where the pointer to the merged return @@ -846,7 +1427,7 @@ TclMergeReturnOptions( "bad %s value: expected dictionary but got \"%s\"", compare, TclGetString(objv[1]))); Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_OPTIONS", - (void *)NULL); + (char *)NULL); goto error; } @@ -895,7 +1476,7 @@ TclMergeReturnOptions( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad -level value: expected non-negative integer but got" " \"%s\"", TclGetString(valuePtr))); - Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_LEVEL", (void *)NULL); + Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_LEVEL", (char *)NULL); goto error; } Tcl_DictObjRemove(NULL, returnOpts, keys[KEY_LEVEL]); @@ -907,7 +1488,7 @@ TclMergeReturnOptions( Tcl_DictObjGet(NULL, returnOpts, keys[KEY_ERRORCODE], &valuePtr); if (valuePtr != NULL) { - Tcl_Size length; + int length; if (TCL_ERROR == TclListObjLength(NULL, valuePtr, &length )) { /* @@ -918,7 +1499,7 @@ TclMergeReturnOptions( "bad -errorcode value: expected a list but got \"%s\"", TclGetString(valuePtr))); Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_ERRORCODE", - (void *)NULL); + (char *)NULL); goto error; } } @@ -929,9 +1510,9 @@ TclMergeReturnOptions( Tcl_DictObjGet(NULL, returnOpts, keys[KEY_ERRORSTACK], &valuePtr); if (valuePtr != NULL) { - Tcl_Size length; + int length; - if (TCL_ERROR == TclListObjLength(NULL, valuePtr, &length)) { + if (TCL_ERROR == TclListObjLength(NULL, valuePtr, &length )) { /* * Value is not a list, which is illegal for -errorstack. */ @@ -940,7 +1521,7 @@ TclMergeReturnOptions( "bad -errorstack value: expected a list but got \"%s\"", TclGetString(valuePtr))); Tcl_SetErrorCode(interp, "TCL", "RESULT", "NONLIST_ERRORSTACK", - (void *)NULL); + (char *)NULL); goto error; } if (length % 2) { @@ -952,7 +1533,7 @@ TclMergeReturnOptions( "forbidden odd-sized list for -errorstack: \"%s\"", TclGetString(valuePtr))); Tcl_SetErrorCode(interp, "TCL", "RESULT", - "ODDSIZEDLIST_ERRORSTACK", (void *)NULL); + "ODDSIZEDLIST_ERRORSTACK", (char *)NULL); goto error; } } @@ -1097,8 +1678,7 @@ Tcl_SetReturnOptions( Tcl_Interp *interp, Tcl_Obj *options) { - Tcl_Size objc; - int level, code; + int objc, level, code; Tcl_Obj **objv, *mergedOpts; Tcl_IncrRefCount(options); @@ -1106,7 +1686,7 @@ Tcl_SetReturnOptions( || (objc % 2)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected dict but got \"%s\"", TclGetString(options))); - Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_OPTIONS", (void *)NULL); + Tcl_SetErrorCode(interp, "TCL", "RESULT", "ILLEGAL_OPTIONS", (char *)NULL); code = TCL_ERROR; } else if (TCL_ERROR == TclMergeReturnOptions(interp, objc, objv, &mergedOpts, &code, &level)) { diff --git a/generic/tclScan.c b/generic/tclScan.c index cccdd7a..8969240 100644 --- a/generic/tclScan.c +++ b/generic/tclScan.c @@ -11,7 +11,6 @@ #include "tclInt.h" #include "tclTomMath.h" -#include <assert.h> /* * Flag values used by Tcl_ScanObjCmd. @@ -105,9 +104,9 @@ BuildCharSet( end += TclUtfToUniChar(end, &ch); } - cset->chars = (Tcl_UniChar *)Tcl_Alloc(sizeof(Tcl_UniChar) * (end - format - 1)); + cset->chars = (Tcl_UniChar *)ckalloc(sizeof(Tcl_UniChar) * (end - format - 1)); if (nranges > 0) { - cset->ranges = (Range *)Tcl_Alloc(sizeof(Range) * nranges); + cset->ranges = (Range *)ckalloc(sizeof(Range) * nranges); } else { cset->ranges = NULL; } @@ -227,9 +226,9 @@ static void ReleaseCharSet( CharSet *cset) { - Tcl_Free(cset->chars); + ckfree(cset->chars); if (cset->ranges) { - Tcl_Free(cset->ranges); + ckfree(cset->ranges); } } @@ -259,7 +258,7 @@ ValidateFormat( int *totalSubs) /* The number of variables that will be * required. */ { - int gotXpg, gotSequential, i, flags; + int gotXpg, gotSequential, value, i, flags; char *end; Tcl_UniChar ch = 0; int objIndex, xpgSize, nspace = numVars; @@ -307,8 +306,7 @@ ValidateFormat( * format string. */ - /* assert(value is >= 0) because of the isdigit() check above */ - unsigned long long ull = strtoull(format-1, &end, 10); /* INTL: "C" locale. */ + unsigned long ul = strtoul(format-1, &end, 10); /* INTL: "C" locale. */ if (*end != '$') { goto notXpg; } @@ -318,21 +316,20 @@ ValidateFormat( if (gotSequential) { goto mixedXPG; } - /* >=INT_MAX because 9.0 does not support more than INT_MAX-1 args */ - if (ull == 0 || ull >= INT_MAX) { + if (ul == 0 || ul >= INT_MAX) { goto badIndex; } - objIndex = (int) ull - 1; + objIndex = (int) ul - 1; if (numVars && (objIndex >= numVars)) { goto badIndex; } else if (numVars == 0) { /* * In the case where no vars are specified, the user can * specify %9999$ legally, so we have to consider special - * rules for growing the assign array. 'ull' is guaranteed + * rules for growing the assign array. 'ul' is guaranteed * to be > 0 and < INT_MAX as per checks above. */ - xpgSize = (xpgSize > (int)ull) ? xpgSize : (int)ull; + xpgSize = (xpgSize > (int)ul) ? xpgSize : (int)ul; } goto xpgCheckDone; } @@ -354,22 +351,7 @@ ValidateFormat( */ if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ - /* Note ull >= 0 because of isdigit check above */ - unsigned long long ull; - ull = strtoull( - format - 1, (char **)&format, 10); /* INTL: "C" locale. */ - /* Note >=, not >, to leave room for a nul */ - if (ull >= TCL_SIZE_MAX) { - Tcl_SetObjResult( - interp, - Tcl_ObjPrintf("specified field width %" TCL_LL_MODIFIER - "u exceeds limit %" TCL_SIZE_MODIFIER "d.", - ull, - (Tcl_Size)TCL_SIZE_MAX-1)); - Tcl_SetErrorCode( - interp, "TCL", "FORMAT", "WIDTHLIMIT", (void *)NULL); - goto error; - } + value = strtoul(format-1, (char **) &format, 10); /* INTL: "C" locale. */ flags |= SCAN_WIDTH; format += TclUtfToUniChar(format, &ch); } @@ -494,7 +476,7 @@ ValidateFormat( * guaranteed to be at least one larger than objIndex. */ - int nspaceOrig = nspace; + value = nspace; if (xpgSize) { nspace = xpgSize; } else { @@ -502,7 +484,7 @@ ValidateFormat( } nassign = (int *)TclStackRealloc(interp, nassign, nspace * sizeof(int)); - for (i = nspaceOrig; i < nspace; i++) { + for (i = value; i < nspace; i++) { nassign[i] = 0; } } @@ -585,7 +567,7 @@ ValidateFormat( int Tcl_ScanObjCmd( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -596,8 +578,7 @@ Tcl_ScanObjCmd( long value; const char *string, *end, *baseString; char op = 0; - int underflow = 0; - Tcl_Size width; + int width, underflow = 0; Tcl_WideInt wideValue; Tcl_UniChar ch = 0, sch = 0; Tcl_Obj **objs = NULL, *objPtr = NULL; @@ -625,7 +606,7 @@ Tcl_ScanObjCmd( */ if (totalVars > 0) { - objs = (Tcl_Obj **)Tcl_Alloc(sizeof(Tcl_Obj *) * totalVars); + objs = (Tcl_Obj **)ckalloc(sizeof(Tcl_Obj *) * totalVars); for (i = 0; i < totalVars; i++) { objs[i] = NULL; } @@ -692,7 +673,6 @@ Tcl_ScanObjCmd( format += TclUtfToUniChar(format, &ch); } else if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ char *formatEnd; - /* Note currently XPG3 range limited to INT_MAX to match type of objc */ value = strtoul(format-1, &formatEnd, 10);/* INTL: "C" locale. */ if (*formatEnd == '$') { format = formatEnd+1; @@ -706,10 +686,7 @@ Tcl_ScanObjCmd( */ if ((ch < 0x80) && isdigit(UCHAR(ch))) { /* INTL: "C" locale. */ - unsigned long long ull; - ull = strtoull(format-1, (char **) &format, 10); /* INTL: "C" locale. */ - assert(ull <= TCL_SIZE_MAX); /* Else ValidateFormat should've error'ed */ - width = (Tcl_Size)ull; + width = (int) strtoul(format-1, (char **) &format, 10);/* INTL: "C" locale. */ format += TclUtfToUniChar(format, &ch); } else { width = 0; @@ -922,7 +899,7 @@ Tcl_ScanObjCmd( width = ~0; } if (TCL_OK != TclParseNumber(NULL, objPtr, NULL, string, width, - &end, TCL_PARSE_INTEGER_ONLY | TCL_PARSE_NO_UNDERSCORE | parseFlag)) { + &end, TCL_PARSE_INTEGER_ONLY | TCL_PARSE_NO_UNDERSCORE | parseFlag)) { Tcl_DecrRefCount(objPtr); if (width < 0) { if (*end == '\0') { @@ -941,7 +918,7 @@ Tcl_ScanObjCmd( break; } if (flags & SCAN_LONGER) { - if (TclGetWideIntFromObj(NULL, objPtr, &wideValue) != TCL_OK) { + if (Tcl_GetWideIntFromObj(NULL, objPtr, &wideValue) != TCL_OK) { if (TclGetString(objPtr)[0] == '-') { wideValue = WIDE_MIN; } else { @@ -975,7 +952,7 @@ Tcl_ScanObjCmd( if (res == TCL_ERROR) { if (objs != NULL) { - Tcl_Free(objs); + ckfree(objs); } Tcl_DecrRefCount(objPtr); Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -1093,40 +1070,27 @@ Tcl_ScanObjCmd( } else { /* * Here no vars were specified, we want a list returned (inline scan) - * We create an empty Tcl_Obj to fill missing values rather than - * allocating a new Tcl_Obj every time. See test scan-bigdata-XX. */ - Tcl_Obj *emptyObj; - TclNewObj(emptyObj); - Tcl_IncrRefCount(emptyObj); + TclNewObj(objPtr); - for (i = 0; code == TCL_OK && i < totalVars; i++) { + for (i = 0; i < totalVars; i++) { if (objs[i] != NULL) { - code = Tcl_ListObjAppendElement(interp, objPtr, objs[i]); + Tcl_ListObjAppendElement(NULL, objPtr, objs[i]); Tcl_DecrRefCount(objs[i]); } else { + Tcl_Obj *obj; /* * More %-specifiers than matching chars, so we just spit out * empty strings for these. */ - code = Tcl_ListObjAppendElement(interp, objPtr, emptyObj); - } - } - Tcl_DecrRefCount(emptyObj); - if (code != TCL_OK) { - /* If error'ed out, free up remaining. i contains last index freed */ - while (++i < totalVars) { - if (objs[i] != NULL) { - Tcl_DecrRefCount(objs[i]); - } + TclNewObj(obj); + Tcl_ListObjAppendElement(NULL, objPtr, obj); } - Tcl_DecrRefCount(objPtr); - objPtr = NULL; } } if (objs != NULL) { - Tcl_Free(objs); + ckfree(objs); } if (code == TCL_OK) { if (underflow && (nconversions == 0)) { diff --git a/generic/tclStrIdxTree.c b/generic/tclStrIdxTree.c index 21be447..1c4cff3 100644 --- a/generic/tclStrIdxTree.c +++ b/generic/tclStrIdxTree.c @@ -61,12 +61,11 @@ static void StrIdxTreeObj_FreeIntRepProc(Tcl_Obj *objPtr); static void StrIdxTreeObj_UpdateStringProc(Tcl_Obj *objPtr); static const Tcl_ObjType StrIdxTreeObjType = { - "str-idx-tree", /* name */ - StrIdxTreeObj_FreeIntRepProc, /* freeIntRepProc */ - StrIdxTreeObj_DupIntRepProc, /* dupIntRepProc */ - StrIdxTreeObj_UpdateStringProc, /* updateStringProc */ - NULL, /* setFromAnyProc */ - TCL_OBJTYPE_V0 + "str-idx-tree", /* name */ + StrIdxTreeObj_FreeIntRepProc, /* freeIntRepProc */ + StrIdxTreeObj_DupIntRepProc, /* dupIntRepProc */ + StrIdxTreeObj_UpdateStringProc, /* updateStringProc */ + NULL /* setFromAnyProc */ }; /* @@ -87,13 +86,14 @@ static const Tcl_ObjType StrIdxTreeObjType = { * *---------------------------------------------------------------------- */ + const char * TclStrIdxTreeSearch( - TclStrIdxTree **foundParent,/* Return value of found sub tree (used for tree build) */ - TclStrIdx **foundItem, /* Return value of found item */ - TclStrIdxTree *tree, /* Index tree will be browsed */ - const char *start, /* UTF string to find in tree */ - const char *end) /* End of string */ + TclStrIdxTree **foundParent, /* Return value of found sub tree (used for tree build) */ + TclStrIdx **foundItem, /* Return value of found item */ + TclStrIdxTree *tree, /* Index tree will be browsed */ + const char *start, /* UTF string to find in tree */ + const char *end) /* End of string */ { TclStrIdxTree *parent = tree, *prevParent = tree; TclStrIdx *item = tree->firstPtr, *prevItem = NULL; @@ -115,11 +115,9 @@ TclStrIdxTreeSearch( start = f; goto done; } - /* set new offset and shift start string */ offs += cinf - cin; s = f; - /* if match item, go deeper as long as possible */ if (offs >= item->length && item->childTree.firstPtr) { /* save previuosly found item (if not ambigous) for @@ -133,7 +131,6 @@ TclStrIdxTreeSearch( item = item->childTree.firstPtr; continue; } - /* no children - return this item and current chars found */ start = f; goto done; @@ -171,14 +168,13 @@ TclStrIdxTreeFree( TclStrIdxTreeFree(tree->childTree.firstPtr); } tree = tree->nextPtr; - Tcl_Free(t); + ckfree(t); } } /* * Several bidirectional list primitives */ - static inline void TclStrIdxTreeInsertBranch( TclStrIdxTree *parent, @@ -239,6 +235,7 @@ TclStrIdxTreeAppend( * *---------------------------------------------------------------------- */ + int TclStrIdxTreeBuildFromList( TclStrIdxTree *idxTree, @@ -255,12 +252,15 @@ TclStrIdxTreeBuildFromList( /* create lowercase reflection of the list keys */ - lwrv = (Tcl_Obj **) Tcl_AttemptAlloc(sizeof(Tcl_Obj*) * lstc); + lwrv = (Tcl_Obj **)attemptckalloc(sizeof(Tcl_Obj*) * lstc); if (lwrv == NULL) { return TCL_ERROR; } for (i = 0; i < lstc; i++) { lwrv[i] = Tcl_DuplicateObj(lstv[i]); + if (lwrv[i] == NULL) { + return TCL_ERROR; + } Tcl_IncrRefCount(lwrv[i]); lwrv[i]->length = Tcl_UtfToLower(TclGetString(lwrv[i])); } @@ -282,39 +282,36 @@ TclStrIdxTreeBuildFromList( if (idxTree->firstPtr != NULL) { TclStrIdx *foundItem; - f = TclStrIdxTreeSearch(&foundParent, &foundItem, idxTree, s, e); + f = TclStrIdxTreeSearch(&foundParent, &foundItem, + idxTree, s, e); /* if common prefix was found */ if (f > s) { /* ignore element if fulfilled or ambigous */ if (f == e) { continue; } - /* if shortest key was found with the same value, * just replace its current key with longest key */ if (foundItem->value == val && foundItem->length <= lwrv[i]->length - && foundItem->length <= (f - s) // only if found item is covered in full + && foundItem->length <= (f - s) /* only if found item is covered in full */ && foundItem->childTree.firstPtr == NULL) { TclSetObjRef(foundItem->key, lwrv[i]); foundItem->length = lwrv[i]->length; continue; } - /* split tree (e. g. j->(jan,jun) + jul == j->(jan,ju->(jun,jul)) ) * but don't split by fulfilled child of found item ( ii->iii->iiii ) */ if (foundItem->length != (f - s)) { /* first split found item (insert one between parent and found + new one) */ - item = (TclStrIdx *) Tcl_AttemptAlloc(sizeof(TclStrIdx)); + item = (TclStrIdx *)attemptckalloc(sizeof(TclStrIdx)); if (item == NULL) { goto done; } TclInitObjRef(item->key, foundItem->key); item->length = f - s; - /* set value or mark as ambigous if not the same value of both */ item->value = (foundItem->value == val) ? val : NULL; - /* insert group item between foundParent and foundItem */ TclStrIdxTreeInsertBranch(foundParent, item, foundItem); foundParent = &item->childTree; @@ -324,9 +321,8 @@ TclStrIdxTreeBuildFromList( } } } - /* append item at end of found parent */ - item = (TclStrIdx *) Tcl_AttemptAlloc(sizeof(TclStrIdx)); + item = (TclStrIdx *)attemptckalloc(sizeof(TclStrIdx)); if (item == NULL) { goto done; } @@ -343,7 +339,7 @@ TclStrIdxTreeBuildFromList( for (i = 0; i < lstc; i++) { Tcl_DecrRefCount(lwrv[i]); } - Tcl_Free(lwrv); + ckfree(lwrv); } if (ret != TCL_OK) { if (idxTree->firstPtr != NULL) { @@ -401,7 +397,6 @@ StrIdxTreeObj_DupIntRepProc( { /* follow links (smart pointers) */ srcPtr = FollowPossibleLink(srcPtr); - /* create smart pointer to it (ptr1 != NULL, ptr2 = NULL) */ TclInitObjRef(*((Tcl_Obj **) ©Ptr->internalRep.twoPtrValue.ptr1), srcPtr); @@ -446,10 +441,8 @@ TclStrIdxTreeGetFromObj( if (objPtr->typePtr != &StrIdxTreeObjType) { return NULL; } - /* follow links (smart pointers) */ objPtr = FollowPossibleLink(objPtr); - /* return tree root in internal representation */ return (TclStrIdxTree *) &objPtr->internalRep.twoPtrValue; } @@ -509,7 +502,6 @@ TclStrIdxTreeTestObjCmd( TclGetString(objv[1]), (char *)NULL); return TCL_ERROR; } - switch (optionIndex) { case O_FINDEQUAL: if (objc < 4) { @@ -522,7 +514,6 @@ TclStrIdxTreeTestObjCmd( cs, cs + objv[1]->length, cin, cin + objv[2]->length); Tcl_SetObjResult(interp, Tcl_NewIntObj(ret - cs)); break; - case O_INDEX: case O_PUTS_INDEX: { Tcl_Obj **lstv; diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c index 87aab60..09fd1f3 100644 --- a/generic/tclStrToD.c +++ b/generic/tclStrToD.c @@ -308,7 +308,7 @@ static double MakeNaN(int signum, Tcl_WideUInt tag); #endif static double RefineApproximation(double approx, mp_int *exactSignificand, int exponent); -static mp_err MulPow5(mp_int *, unsigned, mp_int *) MP_WUR; +static mp_err MulPow5(mp_int *, unsigned, mp_int *) MP_WUR; static int NormalizeRightward(Tcl_WideUInt *); static int RequiredPrecision(Tcl_WideUInt); static void DoubleToExpAndSig(double, Tcl_WideUInt *, int *, @@ -386,9 +386,9 @@ static Tcl_WideUInt Nokia770Twiddle(Tcl_WideUInt w); * the first byte to be scanned. If bytes is NULL, then objPtr must be * non-NULL, and the string representation of objPtr will be scanned * (generated first, if necessary). The numBytes argument determines the - * number of bytes to be scanned. If numBytes is TCL_INDEX_NONE, the first NUL - * byte encountered will terminate the scan. Otherwise, - * no more than numBytes bytes will be scanned. + * number of bytes to be scanned. If numBytes is negative, the first NUL + * byte encountered will terminate the scan. If numBytes is non-negative, + * then no more than numBytes bytes will be scanned. * * The argument flags is an input that controls the numeric formats * recognized by the parser. The flag bits are: @@ -484,7 +484,7 @@ TclParseNumber( * ("integer", "boolean value", etc.). */ const char *bytes, /* Pointer to the start of the string to * scan. */ - Tcl_Size numBytes, /* Maximum number of bytes to scan, see + int numBytes, /* Maximum number of bytes to scan, see * above. */ const char **endPtrPtr, /* Place to store pointer to the character * that terminated the scan. */ @@ -493,7 +493,7 @@ TclParseNumber( enum State { INITIAL, SIGNUM, ZERO, ZERO_X, ZERO_O, ZERO_B, ZERO_D, BINARY, - HEXADECIMAL, OCTAL, DECIMAL, + HEXADECIMAL, OCTAL, BAD_OCTAL, DECIMAL, LEADING_RADIX_POINT, FRACTION, EXPONENT_START, EXPONENT_SIGNUM, EXPONENT, sI, sIN, sINF, sINFI, sINFIN, sINFINI, sINFINIT, sINFINITY @@ -529,15 +529,16 @@ TclParseNumber( * number. */ long exponent = 0; /* Exponent of a floating point number. */ const char *p; /* Pointer to next character to scan. */ - Tcl_Size len; /* Number of characters remaining after p. */ + size_t len; /* Number of characters remaining after p. */ const char *acceptPoint; /* Pointer to position after last character in * an acceptable number. */ - Tcl_Size acceptLen; /* Number of characters following that + size_t acceptLen; /* Number of characters following that * point. */ int status = TCL_OK; /* Status to return to caller. */ char d = 0; /* Last hexadecimal digit scanned; initialized * to avoid a compiler warning. */ int shift = 0; /* Amount to shift when accumulating binary */ + int explicitOctal = 0; mp_err err = MP_OKAY; #define MOST_BITS (UWIDE_MAX >> 1) @@ -554,7 +555,7 @@ TclParseNumber( return TCL_ERROR; } if (TclHasInternalRep(objPtr, &tclListType)) { - Tcl_Size length; + int length; /* A list can only be a (single) number if its length == 1 */ TclListObjLength(NULL, objPtr, &length); if (length != 1) { @@ -592,18 +593,18 @@ TclParseNumber( * V * example: 5___6 */ - for (before = (p - 1); - (before && *before == '_'); - before = (before > p ? (before - 1) : NULL)); - for (after = (p + 1); - (after && *after && *after == '_'); - after = (*after && *after == '_') ? (after + 1) : NULL); + for (before=(p-1); + (before && *before=='_'); + before=(before>p ? (before-1):NULL)); + for (after=(p+1); + (after && *after && *after=='_'); + after=(*after&&*after=='_')?(after+1):NULL); switch (state) { case ZERO_B: case BINARY: if ((before && (*before != '0' && *before != '1')) || - (after && (*after != '0' && *after != '1'))) { + (after && (*after != '0' && *after != '1'))) { /* Not a valid digit */ goto endgame; } @@ -611,7 +612,7 @@ TclParseNumber( case ZERO_O: case OCTAL: if (((before && (*before < '0' || '7' < *before))) || - ((after && (*after < '0' || '7' < *after)))) { + ((after && (*after < '0' || '7' < *after)))) { goto endgame; } break; @@ -624,7 +625,7 @@ TclParseNumber( case EXPONENT_SIGNUM: case EXPONENT: if ((!before || isdigit(UCHAR(*before))) && - (!after || isdigit(UCHAR(*after)))) { + (!after || isdigit(UCHAR(*after)))) { break; } if (after && *after=='(') { @@ -635,7 +636,7 @@ TclParseNumber( case ZERO_X: case HEXADECIMAL: if ( (!before || isxdigit(UCHAR(*before))) && - (!after || isxdigit(UCHAR(*after)))) { + (!after || isxdigit(UCHAR(*after)))) { break; } goto endgame; @@ -750,6 +751,7 @@ TclParseNumber( goto zerob; } if (c == 'o' || c == 'O') { + explicitOctal = 1; state = ZERO_O; break; } @@ -757,7 +759,10 @@ TclParseNumber( state = ZERO_D; break; } +#ifdef TCL_NO_DEPRECATED goto decimal; +#endif + /* FALLTHROUGH */ case OCTAL: /* @@ -836,6 +841,58 @@ TclParseNumber( state = OCTAL; break; } + /* FALLTHROUGH */ + + case BAD_OCTAL: + if (explicitOctal) { + /* + * No forgiveness for bad digits in explicitly octal numbers. + */ + + goto endgame; + } + if (flags & TCL_PARSE_INTEGER_ONLY) { + /* + * No seeking floating point when parsing only integer. + */ + + goto endgame; + } +#ifndef TCL_NO_DEPRECATED + + /* + * Scanned a number with a leading zero that contains an 8, 9, + * radix point or E. This is an invalid octal number, but might + * still be floating point. + */ + + if (c == '0') { + numTrailZeros++; + state = BAD_OCTAL; + break; + } else if (isdigit(UCHAR(c))) { + if (objPtr != NULL) { + significandOverflow = AccumulateDecimalDigit( + (unsigned)(c-'0'), numTrailZeros, + &significandWide, &significandBig, + significandOverflow); + } + if (numSigDigs != 0) { + numSigDigs += (numTrailZeros + 1); + } else { + numSigDigs = 1; + } + numTrailZeros = 0; + state = BAD_OCTAL; + break; + } else if (c == '.') { + state = FRACTION; + break; + } else if (c == 'E' || c == 'e') { + state = EXPONENT_START; + break; + } +#endif goto endgame; /* @@ -981,7 +1038,9 @@ TclParseNumber( * digits. */ +#ifdef TCL_NO_DEPRECATED decimal: +#endif acceptState = state; acceptPoint = p; acceptLen = len; @@ -1253,7 +1312,7 @@ TclParseNumber( } } if (endPtrPtr == NULL) { - if ((len != 0) && ((numBytes + 1 > 1) || (*p != '\0'))) { + if ((len != 0) && ((numBytes > 0) || (*p != '\0'))) { status = TCL_ERROR; } } else { @@ -1269,6 +1328,7 @@ TclParseNumber( TclFreeInternalRep(objPtr); switch (acceptState) { case SIGNUM: + case BAD_OCTAL: case ZERO_X: case ZERO_O: case ZERO_B: @@ -1531,6 +1591,9 @@ TclParseNumber( Tcl_AppendLimitedToObj(msg, bytes, numBytes, 50, ""); Tcl_AppendToObj(msg, "\"", -1); + if (state == BAD_OCTAL) { + Tcl_AppendToObj(msg, " (looks like invalid octal number)", -1); + } Tcl_SetObjResult(interp, msg); Tcl_SetErrorCode(interp, "TCL", "VALUE", "NUMBER", (void *)NULL); } @@ -2416,7 +2479,7 @@ TakeAbsoluteValue( * * Results: * Returns one of the strings 'Infinity' and 'NaN'. The string returned - * must be freed by the caller using 'Tcl_Free'. + * must be freed by the caller using 'ckfree'. * * Side effects: * Stores 9999 in *decpt, and sets '*endPtr' to designate the terminating @@ -2435,13 +2498,13 @@ FormatInfAndNaN( *decpt = 9999; if (!(d->w.word1) && !(d->w.word0 & HI_ORDER_SIG_MASK)) { - retval = (char *)Tcl_Alloc(9); + retval = (char *)ckalloc(9); strcpy(retval, "Infinity"); if (endPtr) { *endPtr = retval + 8; } } else { - retval = (char *)Tcl_Alloc(4); + retval = (char *)ckalloc(4); strcpy(retval, "NaN"); if (endPtr) { *endPtr = retval + 3; @@ -2472,7 +2535,7 @@ FormatZero( int *decpt, /* Location of the decimal point. */ char **endPtr) /* Pointer to the end of the formatted data */ { - char *retval = (char *)Tcl_Alloc(2); + char *retval = (char *)ckalloc(2); strcpy(retval, "0"); if (endPtr) { @@ -3018,7 +3081,7 @@ QuickConversion( * Handle the peculiar case where the result has no significant digits. */ - retval = (char *)Tcl_Alloc(len + 1); + retval = (char *)ckalloc(len + 1); if (ilim == 0) { d = d - 5.; if (d > eps.d) { @@ -3029,7 +3092,7 @@ QuickConversion( *decpt = k; return retval; } else { - Tcl_Free(retval); + ckfree(retval); return NULL; } } @@ -3044,7 +3107,7 @@ QuickConversion( end = StrictQuickFormat(d, k, ilim, eps.d, retval, decpt); } if (end == NULL) { - Tcl_Free(retval); + ckfree(retval); return NULL; } *end = '\0'; @@ -3129,7 +3192,7 @@ ShorteningInt64Conversion( char **endPtr) /* OUTPUT: Position of the terminal '\0' at * the end of the returned string. */ { - char *retval = (char *)Tcl_Alloc(len + 1); + char *retval = (char *)ckalloc(len + 1); /* Output buffer. */ Tcl_WideUInt b = (bw * wuipow5[b5]) << b2; /* Numerator of the fraction being @@ -3292,7 +3355,7 @@ StrictInt64Conversion( char **endPtr) /* OUTPUT: Position of the terminal '\0' at * the end of the returned string. */ { - char *retval = (char *)Tcl_Alloc(len + 1); + char *retval = (char *)ckalloc(len + 1); /* Output buffer. */ Tcl_WideUInt b = (bw * wuipow5[b5]) << b2; /* Numerator of the fraction being @@ -3492,7 +3555,7 @@ ShorteningBignumConversionPowD( char **endPtr) /* OUTPUT: Position of the terminal '\0' at * the end of the returned string. */ { - char *retval = (char *)Tcl_Alloc(len + 1); + char *retval = (char *)ckalloc(len + 1); /* Output buffer. */ mp_int b; /* Numerator of the fraction being * converted. */ @@ -3699,7 +3762,7 @@ StrictBignumConversionPowD( char **endPtr) /* OUTPUT: Position of the terminal '\0' at * the end of the returned string. */ { - char *retval = (char *)Tcl_Alloc(len + 1); + char *retval = (char *)ckalloc(len + 1); /* Output buffer. */ mp_int b; /* Numerator of the fraction being * converted. */ @@ -3853,7 +3916,7 @@ ShouldBankerRoundUpToNext( } r = mp_cmp_mag(&temp, S); mp_clear(&temp); - switch (r) { + switch(r) { case MP_EQ: return isodd; case MP_GT: @@ -3895,7 +3958,7 @@ ShorteningBignumConversion( int *decpt, /* OUTPUT: Position of the decimal point. */ char **endPtr) /* OUTPUT: Pointer to the end of the number */ { - char *retval = (char *)Tcl_Alloc(len+1); + char *retval = (char *)ckalloc(len+1); /* Buffer of digits to return. */ char *s = retval; /* Cursor in the return value. */ mp_int b; /* Numerator of the result. */ @@ -4129,7 +4192,7 @@ StrictBignumConversion( int *decpt, /* OUTPUT: Position of the decimal point. */ char **endPtr) /* OUTPUT: Pointer to the end of the number */ { - char *retval = (char *)Tcl_Alloc(len+1); + char *retval = (char *)ckalloc(len+1); /* Buffer of digits to return. */ char *s = retval; /* Cursor in the return value. */ mp_int b; /* Numerator of the result. */ @@ -4295,14 +4358,15 @@ StrictBignumConversion( * This function is a service routine that produces the string of digits for * floating-point-to-decimal conversion. It can do a number of things * according to the 'flags' argument. Valid values for 'flags' include: - * TCL_DD_SHORTEST - This is the default for floating point conversion. - * It constructs the shortest string of + * TCL_DD_SHORTEST - This is the default for floating point conversion if + * ::tcl_precision is 0. It constructs the shortest string of * digits that will reconvert to the given number when scanned. * 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_E_FORMAT - This value is used to prepare numbers for %e format - * conversion. It constructs a string of at most 'ndigits' digits, + * conversion (or for default floating->string if tcl_precision + * is not 0). It constructs a string of at most 'ndigits' digits, * choosing the one that is closest to the given number (and * resolving ties with 'round to even'). It is allowed to return * fewer than 'ndigits' if the number converts exactly; if the @@ -4638,7 +4702,7 @@ TclInitDoubleConversion(void) maxpow10_wide = (int) floor(sizeof(Tcl_WideUInt) * CHAR_BIT * log(2.) / log(10.)); pow10_wide = (Tcl_WideUInt *) - Tcl_Alloc((maxpow10_wide + 1) * sizeof(Tcl_WideUInt)); + ckalloc((maxpow10_wide + 1) * sizeof(Tcl_WideUInt)); u = 1; for (i = 0; i < maxpow10_wide; ++i) { pow10_wide[i] = u; @@ -4748,7 +4812,7 @@ TclFinalizeDoubleConversion(void) { int i; - Tcl_Free(pow10_wide); + ckfree(pow10_wide); for (i=0; i<9; ++i) { mp_clear(pow5 + i); } diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c index 73391fe..967fdd0 100644 --- a/generic/tclStringObj.c +++ b/generic/tclStringObj.c @@ -8,7 +8,7 @@ * * Conceptually, a string is a sequence of Unicode code points. Internally * it may be stored in an encoding form such as a modified version of - * UTF-8 or UTF-32. + * UTF-8 or UTF-16 (when TCL_UTF_MAX=3) or UTF-32. * * The String object is optimized for the case where each UTF char * in a string is only one byte. In this case, we store the value of @@ -65,24 +65,167 @@ static int SetStringFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); static void SetUnicodeObj(Tcl_Obj *objPtr, const Tcl_UniChar *unicode, Tcl_Size numChars); static Tcl_Size UnicodeLength(const Tcl_UniChar *unicode); +#if !defined(TCL_NO_DEPRECATED) +static int UTF16Length(const unsigned short *unicode); +#endif static void UpdateStringOfString(Tcl_Obj *objPtr); +#if !defined(TCL_NO_DEPRECATED) +static void DupUTF16StringInternalRep(Tcl_Obj *objPtr, + Tcl_Obj *copyPtr); +static int SetUTF16StringFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); +static void UpdateStringOfUTF16String(Tcl_Obj *objPtr); +#endif #define ISCONTINUATION(bytes) (\ - ((bytes)[0] & 0xC0) == 0x80) + ((((bytes)[0] & 0xC0) == 0x80) || (((bytes)[0] == '\xED') \ + && (((bytes)[1] & 0xF0) == 0xB0) && (((bytes)[2] & 0xC0) == 0x80)))) + +#define SURROGATE(c_) (((c_) & ~0x7FF) == 0xD800) +#define HIGH_SURROGATE(c_) (((c_) & ~0x3FF) == 0xD800) +#define LOW_SURROGATE(c_) (((c_) & ~0x3FF) == 0xDC00) /* * The structure below defines the string Tcl object type by means of * functions that can be invoked by generic object code. */ +#ifndef TCL_NO_DEPRECATED const Tcl_ObjType tclStringType = { "string", /* name */ FreeStringInternalRep, /* freeIntRepPro */ + DupUTF16StringInternalRep, /* dupIntRepProc */ + UpdateStringOfUTF16String, /* updateStringProc */ + SetUTF16StringFromAny /* setFromAnyProc */ +}; +#endif + +const Tcl_ObjType tclUniCharStringType = { + "utf32string", /* name */ + FreeStringInternalRep, /* freeIntRepPro */ DupStringInternalRep, /* dupIntRepProc */ UpdateStringOfString, /* updateStringProc */ - SetStringFromAny, /* setFromAnyProc */ - TCL_OBJTYPE_V0 + SetStringFromAny /* setFromAnyProc */ }; + +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 + * that the number of UTF bytes == the number + * of chars. */ + int allocated; /* The amount of space actually allocated for + * the UTF string (minus 1 byte for the + * termination char). */ + int maxChars; /* Max number of chars that can fit in the + * space allocated for the unicode array. */ + int hasUnicode; /* Boolean determining whether the string has + * a Unicode representation. */ + Tcl_UniChar unicode[TCLFLEXARRAY]; /* The array of Unicode chars. The actual size + * of this field depends on the 'maxChars' + * field above. */ +} UniCharString; + +#define UNICHAR_STRING_MAXCHARS \ + (int)(((size_t)UINT_MAX - offsetof(UniCharString, unicode))/sizeof(Tcl_UniChar) - 1) +#define UNICHAR_STRING_SIZE(numChars) \ + (offsetof(UniCharString, unicode) + sizeof(Tcl_UniChar) + ((numChars) * sizeof(Tcl_UniChar))) +#define uniCharStringCheckLimits(numChars) \ + do { \ + if ((numChars) < 0 || (numChars) > UNICHAR_STRING_MAXCHARS) { \ + Tcl_Panic("max length for a Tcl unicode value (%d chars) exceeded", \ + UNICHAR_STRING_MAXCHARS); \ + } \ + } while (0) +#define uniCharStringAttemptAlloc(numChars) \ + (UniCharString *) attemptckalloc(UNICHAR_STRING_SIZE(numChars)) +#define uniCharStringAlloc(numChars) \ + (UniCharString *) ckalloc(UNICHAR_STRING_SIZE(numChars)) +#define uniCharStringRealloc(ptr, numChars) \ + (UniCharString *) ckrealloc((ptr), UNICHAR_STRING_SIZE(numChars)) +#define uniCharStringAttemptRealloc(ptr, numChars) \ + (UniCharString *) attemptckrealloc((ptr), UNICHAR_STRING_SIZE(numChars)) +#define GET_UNICHAR_STRING(objPtr) \ + ((UniCharString *) (objPtr)->internalRep.twoPtrValue.ptr1) +#define SET_UNICHAR_STRING(objPtr, stringPtr) \ + ((objPtr)->internalRep.twoPtrValue.ptr2 = NULL), \ + ((objPtr)->internalRep.twoPtrValue.ptr1 = (void *) (stringPtr)) + + +#ifndef TCL_NO_DEPRECATED +static void +DupUTF16StringInternalRep( + Tcl_Obj *srcPtr, /* Object with internal rep to copy. Must have + * an internal rep of type "String". */ + Tcl_Obj *copyPtr) /* Object with internal rep to set. Must not + * currently have an internal rep.*/ +{ + String *srcStringPtr = GET_STRING(srcPtr); + size_t size = offsetof(String, unicode) + (((srcStringPtr->allocated) + 1U) * sizeof(unsigned short)); + String *copyStringPtr = (String *)ckalloc(size); + memcpy(copyStringPtr, srcStringPtr, size); + + SET_STRING(copyPtr, copyStringPtr); + copyPtr->typePtr = &tclStringType; +} + +static int +SetUTF16StringFromAny( + TCL_UNUSED(Tcl_Interp *), + Tcl_Obj *objPtr) /* The object to convert. */ +{ + if (!TclHasInternalRep(objPtr, &tclStringType)) { + Tcl_DString ds; + + /* + * Convert whatever we have into an untyped value. Just A String. + */ + + (void) TclGetString(objPtr); + TclFreeInternalRep(objPtr); + + /* + * Create a basic String internalrep that just points to the UTF-8 string + * already in place at objPtr->bytes. + */ + + Tcl_DStringInit(&ds); + unsigned short *utf16string = Tcl_UtfToChar16DString(objPtr->bytes, objPtr->length, &ds); + int size = Tcl_DStringLength(&ds); + String *stringPtr = (String *)ckalloc((offsetof(String, unicode) + sizeof(unsigned short)) + size); + + memcpy(stringPtr->unicode, utf16string, size); + Tcl_DStringFree(&ds); + size /= sizeof(unsigned short); + stringPtr->unicode[size] = 0; + + stringPtr->numChars = size; + stringPtr->allocated = size; + stringPtr->maxChars = size; + stringPtr->hasUnicode = 1; + SET_STRING(objPtr, stringPtr); + objPtr->typePtr = &tclStringType; + } + return TCL_OK; +} + +static void +UpdateStringOfUTF16String( + Tcl_Obj *objPtr) /* Object with string rep to update. */ +{ + Tcl_DString ds; + String *stringPtr = GET_STRING(objPtr); + + Tcl_DStringInit(&ds); + const char *string = Tcl_Char16ToUtfDString(stringPtr->unicode, stringPtr->numChars, &ds); + + char *bytes = (char *)ckalloc(Tcl_DStringLength(&ds) + 1U); + memcpy(bytes, string, Tcl_DStringLength(&ds)); + bytes[Tcl_DStringLength(&ds)] = 0; + objPtr->bytes = bytes; + objPtr->length = Tcl_DStringLength(&ds); + Tcl_DStringFree(&ds); +} +#endif /* * TCL STRING GROWTH ALGORITHM @@ -134,30 +277,43 @@ GrowStringBuffer( * flag || objPtr->bytes != NULL */ - String *stringPtr = GET_STRING(objPtr); - char *ptr; + UniCharString *stringPtr = GET_UNICHAR_STRING(objPtr); + char *ptr = NULL; Tcl_Size capacity; - assert(needed <= TCL_SIZE_MAX - 1); - needed += 1; /* Include terminating nul */ - if (objPtr->bytes == &tclEmptyString) { objPtr->bytes = NULL; } - /* - * In code below, note 'capacity' and 'needed' include terminating nul, - * while stringPtr->allocated does not. - */ if (flag == 0 || stringPtr->allocated > 0) { - ptr = (char *)TclReallocEx(objPtr->bytes, needed, &capacity); - } else { - /* Allocate exact size */ - ptr = (char *)Tcl_Realloc(objPtr->bytes, needed); - capacity = needed; + if (needed <= INT_MAX / 2) { + capacity = 2 * needed; + ptr = (char *)attemptckrealloc(objPtr->bytes, capacity + 1U); + } + if (ptr == NULL) { + /* + * Take care computing the amount of modest growth to avoid + * overflow into invalid argument values for capacity. + */ + + unsigned int limit = INT_MAX - needed; + unsigned int extra = needed - objPtr->length + TCL_MIN_GROWTH; + int growth = (int) ((extra > limit) ? limit : extra); + + capacity = needed + growth; + ptr = (char *)attemptckrealloc(objPtr->bytes, capacity + 1U); + } } + if (ptr == NULL) { + /* + * First allocation - just big enough; or last chance fallback. + */ + capacity = needed; + ptr = (char *)ckrealloc(objPtr->bytes, capacity + 1U); + } objPtr->bytes = ptr; - stringPtr->allocated = capacity - 1; /* Does not include slot for end nul */ + stringPtr->allocated = capacity; + memset(ptr + objPtr->length, 0, capacity + 1U - objPtr->length); } static void @@ -169,32 +325,47 @@ GrowUnicodeBuffer( * Preconditions: * TclHasInternalRep(objPtr, &tclStringType) * needed > stringPtr->maxChars + * needed < UNICHAR_STRING_MAXCHARS */ - String *stringPtr = GET_STRING(objPtr); - Tcl_Size maxChars; + UniCharString *ptr = NULL, *stringPtr = GET_UNICHAR_STRING(objPtr); + Tcl_Size capacity; - /* Note STRING_MAXCHARS already takes into account space for nul */ - if (needed > STRING_MAXCHARS) { - Tcl_Panic("max size for a Tcl unicode rep (%" TCL_Z_MODIFIER "d bytes) exceeded", - STRING_MAXCHARS); - } if (stringPtr->maxChars > 0) { - /* Expansion - try allocating extra space */ - stringPtr = (String *) TclReallocElemsEx(stringPtr, - needed + 1, /* +1 for nul */ - sizeof(Tcl_UniChar), offsetof(String, unicode), &maxChars); - maxChars -= 1; /* End nul not included */ - } else { /* - * First allocation - just big enough. Note needed does - * not include terminating nul but STRING_SIZE does + * Subsequent appends - apply the growth algorithm. + */ + + if (needed <= UNICHAR_STRING_MAXCHARS / 2) { + capacity = 2 * needed; + ptr = uniCharStringAttemptRealloc(stringPtr, capacity); + } + if (ptr == NULL) { + /* + * Take care computing the amount of modest growth to avoid + * overflow into invalid argument values for capacity. + */ + + unsigned int limit = UNICHAR_STRING_MAXCHARS - needed; + unsigned int extra = needed - stringPtr->numChars + + TCL_MIN_UNICHAR_GROWTH; + int growth = (int) ((extra > limit) ? limit : extra); + + capacity = needed + growth; + ptr = uniCharStringAttemptRealloc(stringPtr, capacity); + } + } + if (ptr == NULL) { + /* + * First allocation - just big enough; or last chance fallback. */ - stringPtr = (String *)Tcl_Realloc(stringPtr, STRING_SIZE(needed)); - maxChars = needed; + + capacity = needed; + ptr = uniCharStringRealloc(stringPtr, capacity); } - stringPtr->maxChars = maxChars; - SET_STRING(objPtr, stringPtr); + stringPtr = ptr; + stringPtr->maxChars = capacity; + SET_UNICHAR_STRING(objPtr, stringPtr); } /* @@ -214,7 +385,7 @@ GrowUnicodeBuffer( * * Side effects: * The new object's internal string representation will be set to a copy - * of the length bytes starting at "bytes". If "length" is TCL_INDEX_NONE, use + * of the length bytes starting at "bytes". If "length" is negative, use * bytes up to the first NUL byte; i.e., assume "bytes" points to a * C-style NUL-terminated string. The object's type is set to NULL. An * extra NUL is added to the end of the new object's byte array. @@ -230,7 +401,7 @@ Tcl_NewStringObj( * used to initialize the new object. */ Tcl_Size length) /* The number of bytes to copy from "bytes" * when initializing the new object. If - * TCL_INDEX_NONE, use bytes up to the first NUL + * negative, use bytes up to the first NUL * byte. */ { return Tcl_DbNewStringObj(bytes, length, "unknown", 0); @@ -241,7 +412,7 @@ Tcl_NewStringObj( const char *bytes, /* Points to the first of the length bytes * used to initialize the new object. */ Tcl_Size length) /* The number of bytes to copy from "bytes" - * when initializing the new object. If -1, + * when initializing the new object. If negative, * use bytes up to the first NUL byte. */ { Tcl_Obj *objPtr; @@ -275,7 +446,7 @@ Tcl_NewStringObj( * * Side effects: * The new object's internal string representation will be set to a copy - * of the length bytes starting at "bytes". If "length" is TCL_INDEX_NONE, use + * of the length bytes starting at "bytes". If "length" is negative, use * bytes up to the first NUL byte; i.e., assume "bytes" points to a * C-style NUL-terminated string. The object's type is set to NULL. An * extra NUL is added to the end of the new object's byte array. @@ -289,7 +460,7 @@ Tcl_DbNewStringObj( const char *bytes, /* Points to the first of the length bytes * used to initialize the new object. */ Tcl_Size length, /* The number of bytes to copy from "bytes" - * when initializing the new object. If -1, + * when initializing the new object. If negative, * use bytes up to the first NUL byte. */ const char *file, /* The name of the source file calling this * function; used for debugging. */ @@ -298,7 +469,7 @@ Tcl_DbNewStringObj( { Tcl_Obj *objPtr; - if (length == TCL_INDEX_NONE) { + if (length < 0) { length = (bytes? strlen(bytes) : 0); } TclDbNewObj(objPtr, file, line); @@ -311,8 +482,9 @@ Tcl_DbNewStringObj( const char *bytes, /* Points to the first of the length bytes * used to initialize the new object. */ Tcl_Size length, /* The number of bytes to copy from "bytes" - * when initializing the new object. If -1, - * use bytes up to the first NUL byte. */ + * when initializing the new object. If + * negative, use bytes up to the first NUL + * byte. */ TCL_UNUSED(const char *) /*file*/, TCL_UNUSED(int) /*line*/) { @@ -340,7 +512,7 @@ Tcl_DbNewStringObj( */ Tcl_Obj * -Tcl_NewUnicodeObj( +TclNewUnicodeObj( const Tcl_UniChar *unicode, /* The unicode string used to initialize the * new object. */ Tcl_Size numChars) /* Number of characters in the unicode @@ -353,6 +525,39 @@ Tcl_NewUnicodeObj( return objPtr; } +#if !defined(TCL_NO_DEPRECATED) +Tcl_Obj * +Tcl_NewUnicodeObj( + const unsigned short *unicode, /* The unicode string used to initialize the + * new object. */ + int numChars) /* Number of characters in the unicode + * string. */ +{ + Tcl_Obj *objPtr; + + TclNewObj(objPtr); + TclInvalidateStringRep(objPtr); + + if (numChars < 0) { + numChars = UTF16Length(unicode); + } + + String *stringPtr = (String *)ckalloc((offsetof(String, unicode) + + sizeof(unsigned short)) + numChars * sizeof(unsigned short)); + memcpy(stringPtr->unicode, unicode, numChars * sizeof(unsigned short)); + stringPtr->unicode[numChars] = 0; + + stringPtr->numChars = numChars; + stringPtr->allocated = numChars; + stringPtr->maxChars = numChars; + stringPtr->hasUnicode = 1; + SET_STRING(objPtr, stringPtr); + objPtr->typePtr = &tclStringType; + + return objPtr; +} +#endif + /* *---------------------------------------------------------------------- * @@ -371,12 +576,12 @@ Tcl_NewUnicodeObj( */ Tcl_Size -Tcl_GetCharLength( +TclGetCharLength( Tcl_Obj *objPtr) /* The String object to get the num chars * of. */ { - String *stringPtr; - Tcl_Size numChars = 0; + UniCharString *stringPtr; + Tcl_Size numChars; /* * Quick, no-shimmer return for short string reps. @@ -399,7 +604,7 @@ Tcl_GetCharLength( */ if (TclIsPureByteArray(objPtr)) { - (void) Tcl_GetBytesFromObj(NULL, objPtr, &numChars); + (void) Tcl_GetByteArrayFromObj(objPtr, &numChars); return numChars; } @@ -408,7 +613,7 @@ Tcl_GetCharLength( */ SetStringFromAny(NULL, objPtr); - stringPtr = GET_STRING(objPtr); + stringPtr = GET_UNICHAR_STRING(objPtr); numChars = stringPtr->numChars; /* @@ -422,8 +627,10 @@ Tcl_GetCharLength( return numChars; } +#if !defined(TCL_NO_DEPRECATED) +#undef Tcl_GetCharLength Tcl_Size -TclGetCharLength( +Tcl_GetCharLength( Tcl_Obj *objPtr) /* The String object to get the num chars * of. */ { @@ -450,7 +657,7 @@ TclGetCharLength( */ if (TclIsPureByteArray(objPtr)) { - (void) Tcl_GetBytesFromObj(NULL, objPtr, &numChars); + (void) Tcl_GetByteArrayFromObj(objPtr, &numChars); } else { TclGetString(objPtr); numChars = TclNumUtfChars(objPtr->bytes, objPtr->length); @@ -458,6 +665,7 @@ TclGetCharLength( return numChars; } +#endif /* @@ -487,7 +695,7 @@ TclCheckEmptyString( } if (TclIsPureByteArray(objPtr) - && Tcl_GetCharLength(objPtr) == 0) { + && TclGetCharLength(objPtr) == 0) { return TCL_EMPTYSTRING_YES; } @@ -525,6 +733,8 @@ TclCheckEmptyString( *---------------------------------------------------------------------- */ +#if !defined(TCL_NO_DEPRECATED) +#undef Tcl_GetUniChar int Tcl_GetUniChar( Tcl_Obj *objPtr, /* The object to get the Unicode charater @@ -544,8 +754,8 @@ Tcl_GetUniChar( */ if (TclIsPureByteArray(objPtr)) { - Tcl_Size length = 0; - unsigned char *bytes = Tcl_GetBytesFromObj(NULL, objPtr, &length); + Tcl_Size length; + unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length); if (index >= length) { return -1; } @@ -557,33 +767,30 @@ Tcl_GetUniChar( * OK, need to work with the object as a string. */ - SetStringFromAny(NULL, objPtr); + SetUTF16StringFromAny(NULL, objPtr); stringPtr = GET_STRING(objPtr); - if (stringPtr->hasUnicode == 0) { - /* - * If numChars is unknown, compute it. - */ - - if (stringPtr->numChars == TCL_INDEX_NONE) { - TclNumUtfCharsM(stringPtr->numChars, objPtr->bytes, objPtr->length); - } - if (index >= stringPtr->numChars) { - return -1; - } - if (stringPtr->numChars == objPtr->length) { - return (unsigned char) objPtr->bytes[index]; - } - FillUnicodeRep(objPtr); - stringPtr = GET_STRING(objPtr); - } - if (index >= stringPtr->numChars) { return -1; } ch = stringPtr->unicode[index]; + /* See: bug [11ae2be95dac9417] */ + if (SURROGATE(ch)) { + if (ch & 0x400) { + if ((index > 0) + && HIGH_SURROGATE(stringPtr->unicode[index-1])) { + ch = -1; /* low surrogate preceded by high surrogate */ + } + } else if ((++index < stringPtr->numChars) + && LOW_SURROGATE(stringPtr->unicode[index])) { + /* high surrogate followed by low surrogate */ + ch = (((ch & 0x3FF) << 10) | + (stringPtr->unicode[index] & 0x3FF)) + 0x10000; + } + } return ch; } +#endif int TclGetUniChar( @@ -591,20 +798,21 @@ TclGetUniChar( * from. */ Tcl_Size index) /* Get the index'th Unicode character. */ { - int ch = 0; + UniCharString *stringPtr; + int ch; if (index < 0) { return -1; } /* - * Optimize the ByteArray case: N need need to convert to a string to - * perform the indexing operation. + * Optimize the case where we're really dealing with a ByteArray object + * we don't need to convert to a string to perform the indexing operation. */ if (TclIsPureByteArray(objPtr)) { - Tcl_Size length = 0; - unsigned char *bytes = Tcl_GetBytesFromObj(NULL, objPtr, &length); + Tcl_Size length; + unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length); if (index >= length) { return -1; } @@ -612,19 +820,71 @@ TclGetUniChar( return bytes[index]; } - Tcl_Size numChars = TclNumUtfChars(objPtr->bytes, objPtr->length); + /* + * OK, need to work with the object as a string. + */ + + SetStringFromAny(NULL, objPtr); + stringPtr = GET_UNICHAR_STRING(objPtr); + + if (stringPtr->hasUnicode == 0) { + /* + * If numChars is unknown, compute it. + */ - if (index >= numChars) { + if (stringPtr->numChars == TCL_INDEX_NONE) { + TclNumUtfCharsM(stringPtr->numChars, objPtr->bytes, objPtr->length); + } + if (index >= stringPtr->numChars) { + return -1; + } + if (stringPtr->numChars == objPtr->length) { + return (unsigned char) objPtr->bytes[index]; + } + FillUnicodeRep(objPtr); + stringPtr = GET_UNICHAR_STRING(objPtr); + } + + if (index >= stringPtr->numChars) { return -1; } - const char *begin = TclUtfAtIndex(objPtr->bytes, index); - TclUtfToUniChar(begin, &ch); + ch = stringPtr->unicode[index]; return ch; } /* *---------------------------------------------------------------------- * + * Tcl_GetUnicode -- + * + * Get the Unicode form of the String object. If the object is not + * already a String object, it will be converted to one. If the String + * object does not have a Unicode rep, then one is created from the UTF + * string format. + * + * Results: + * Returns a pointer to the object's internal Unicode string. + * + * Side effects: + * Converts the object to have the String internal rep. + * + *---------------------------------------------------------------------- + */ + +#ifndef TCL_NO_DEPRECATED +#undef Tcl_GetUnicode +unsigned short * +Tcl_GetUnicode( + Tcl_Obj *objPtr) /* The object to find the Unicode string + * for. */ +{ + return Tcl_GetUnicodeFromObj(objPtr, NULL); +} +#endif /* TCL_NO_DEPRECATED */ + +/* + *---------------------------------------------------------------------- + * * Tcl_GetUnicodeFromObj/TclGetUnicodeFromObj -- * * Get the Unicode form of the String object with length. If the object @@ -641,60 +901,50 @@ TclGetUniChar( *---------------------------------------------------------------------- */ -#undef Tcl_GetUnicodeFromObj -#if !defined(TCL_NO_DEPRECATED) Tcl_UniChar * TclGetUnicodeFromObj( Tcl_Obj *objPtr, /* The object to find the Unicode string * for. */ - void *lengthPtr) /* If non-NULL, the location where the string + int *lengthPtr) /* If non-NULL, the location where the string * rep's Tcl_UniChar length should be stored. If * NULL, no length is stored. */ { - String *stringPtr; + UniCharString *stringPtr; SetStringFromAny(NULL, objPtr); - stringPtr = GET_STRING(objPtr); + stringPtr = GET_UNICHAR_STRING(objPtr); if (stringPtr->hasUnicode == 0) { FillUnicodeRep(objPtr); - stringPtr = GET_STRING(objPtr); + stringPtr = GET_UNICHAR_STRING(objPtr); } if (lengthPtr != NULL) { - if (stringPtr->numChars > INT_MAX) { - Tcl_Panic("Tcl_GetUnicodeFromObj with 'int' lengthPtr" - " cannot handle such long strings. Please use 'Tcl_Size'"); - } - *(int *)lengthPtr = (int)stringPtr->numChars; + *lengthPtr = stringPtr->numChars; } return stringPtr->unicode; } -#endif /* !defined(TCL_NO_DEPRECATED) */ -Tcl_UniChar * +#if !defined(TCL_NO_DEPRECATED) +unsigned short * Tcl_GetUnicodeFromObj( - Tcl_Obj *objPtr, /* The object to find the unicode string + Tcl_Obj *objPtr, /* The object to find the Unicode string * for. */ Tcl_Size *lengthPtr) /* If non-NULL, the location where the string - * rep's unichar length should be stored. If + * rep's Tcl_UniChar length should be stored. If * NULL, no length is stored. */ { String *stringPtr; - SetStringFromAny(NULL, objPtr); + SetUTF16StringFromAny(NULL, objPtr); stringPtr = GET_STRING(objPtr); - if (stringPtr->hasUnicode == 0) { - FillUnicodeRep(objPtr); - stringPtr = GET_STRING(objPtr); - } - if (lengthPtr != NULL) { *lengthPtr = stringPtr->numChars; } return stringPtr->unicode; } +#endif /* *---------------------------------------------------------------------- @@ -703,9 +953,9 @@ Tcl_GetUnicodeFromObj( * * Create a Tcl Object that contains the chars between first and last of * the object indicated by "objPtr". If the object is not already a - * String object, convert it to one. If first is TCL_INDEX_NONE, the + * String object, convert it to one. If first is negative, the * returned string start at the beginning of objPtr. If last is - * TCL_INDEX_NONE, the returned string ends at the end of objPtr. + * negative, the returned string ends at the end of objPtr. * * Results: * Returns a new Tcl Object of the String type. @@ -716,6 +966,8 @@ Tcl_GetUnicodeFromObj( *---------------------------------------------------------------------- */ +#if !defined(TCL_NO_DEPRECATED) +#undef Tcl_GetRange Tcl_Obj * Tcl_GetRange( Tcl_Obj *objPtr, /* The Tcl object to find the range of. */ @@ -723,8 +975,7 @@ Tcl_GetRange( Tcl_Size last) /* Last index of the range. */ { Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */ - String *stringPtr; - Tcl_Size length = 0; + Tcl_Size length; if (first < 0) { first = 0; @@ -736,7 +987,54 @@ Tcl_GetRange( */ if (TclIsPureByteArray(objPtr)) { - unsigned char *bytes = Tcl_GetBytesFromObj(NULL, objPtr, &length); + unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length); + + if (last < 0 || last >= length) { + last = length - 1; + } + if (last < first) { + TclNewObj(newObjPtr); + return newObjPtr; + } + return Tcl_NewByteArrayObj(bytes + first, last - first + 1); + } + + Tcl_Size numChars = TclNumUtfChars(objPtr->bytes, objPtr->length); + + if (last < 0 || last >= numChars) { + last = numChars - 1; + } + if (last < first) { + TclNewObj(newObjPtr); + return newObjPtr; + } + const char *begin = Tcl_UtfAtIndex(objPtr->bytes, first); + const char *end = Tcl_UtfAtIndex(objPtr->bytes, last + 1); + return Tcl_NewStringObj(begin, end - begin); +} +#endif + +Tcl_Obj * +TclGetRange( + Tcl_Obj *objPtr, /* The Tcl object to find the range of. */ + Tcl_Size first, /* First index of the range. */ + Tcl_Size last) /* Last index of the range. */ +{ + Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */ + UniCharString *stringPtr; + Tcl_Size length; + + if (first < 0) { + first = 0; + } + + /* + * Optimize the case where we're really dealing with a bytearray object + * we don't need to convert to a string to perform the substring operation. + */ + + if (TclIsPureByteArray(objPtr)) { + unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &length); if (last < 0 || last >= length) { last = length - 1; @@ -753,7 +1051,7 @@ Tcl_GetRange( */ SetStringFromAny(NULL, objPtr); - stringPtr = GET_STRING(objPtr); + stringPtr = GET_UNICHAR_STRING(objPtr); if (stringPtr->hasUnicode == 0) { /* @@ -778,12 +1076,12 @@ Tcl_GetRange( */ SetStringFromAny(NULL, newObjPtr); - stringPtr = GET_STRING(newObjPtr); + stringPtr = GET_UNICHAR_STRING(newObjPtr); stringPtr->numChars = newObjPtr->length; return newObjPtr; } FillUnicodeRep(objPtr); - stringPtr = GET_STRING(objPtr); + stringPtr = GET_UNICHAR_STRING(objPtr); } if (last < 0 || last >= stringPtr->numChars) { last = stringPtr->numChars - 1; @@ -792,52 +1090,7 @@ Tcl_GetRange( TclNewObj(newObjPtr); return newObjPtr; } - return Tcl_NewUnicodeObj(stringPtr->unicode + first, last - first + 1); -} - -Tcl_Obj * -TclGetRange( - Tcl_Obj *objPtr, /* The Tcl object to find the range of. */ - Tcl_Size first, /* First index of the range. */ - Tcl_Size last) /* Last index of the range. */ -{ - Tcl_Obj *newObjPtr; /* The Tcl object to find the range of. */ - Tcl_Size length = 0; - - if (first < 0) { - first = TCL_INDEX_START; - } - - /* - * Optimize the case where we're really dealing with a bytearray object - * we don't need to convert to a string to perform the substring operation. - */ - - if (TclIsPureByteArray(objPtr)) { - unsigned char *bytes = Tcl_GetBytesFromObj(NULL, objPtr, &length); - - if (last < 0 || last >= length) { - last = length - 1; - } - if (last < first) { - TclNewObj(newObjPtr); - return newObjPtr; - } - return Tcl_NewByteArrayObj(bytes + first, last - first + 1); - } - - Tcl_Size numChars = TclNumUtfChars(objPtr->bytes, objPtr->length); - - if (last < 0 || last >= numChars) { - last = numChars - 1; - } - if (last < first) { - TclNewObj(newObjPtr); - return newObjPtr; - } - const char *begin = TclUtfAtIndex(objPtr->bytes, first); - const char *end = TclUtfAtIndex(objPtr->bytes, last + 1); - return Tcl_NewStringObj(begin, end - begin); + return TclNewUnicodeObj(stringPtr->unicode + first, last - first + 1); } /* @@ -853,7 +1106,7 @@ TclGetRange( * * Side effects: * The object's string representation will be set to a copy of the - * "length" bytes starting at "bytes". If "length" is TCL_INDEX_NONE, use bytes + * "length" bytes starting at "bytes". If "length" is negative, use bytes * up to the first NUL byte; i.e., assume "bytes" points to a C-style * NUL-terminated string. The object's old string and internal * representations are freed and the object's type is set NULL. @@ -867,7 +1120,7 @@ Tcl_SetStringObj( const char *bytes, /* Points to the first of the length bytes * used to initialize the object. */ Tcl_Size length) /* The number of bytes to copy from "bytes" - * when initializing the object. If -1, + * when initializing the object. If negative, * use bytes up to the first NUL byte.*/ { if (Tcl_IsShared(objPtr)) { @@ -886,7 +1139,7 @@ Tcl_SetStringObj( */ TclInvalidateStringRep(objPtr); - if (length == TCL_INDEX_NONE) { + if (length < 0) { length = (bytes? strlen(bytes) : 0); } TclInitStringRep(objPtr, bytes, length); @@ -922,7 +1175,7 @@ Tcl_SetObjLength( * representation of object, not including * terminating null byte. */ { - String *stringPtr; + UniCharString *stringPtr; if (length < 0) { Tcl_Panic("Tcl_SetObjLength: length requested is negative: " @@ -937,7 +1190,7 @@ Tcl_SetObjLength( } SetStringFromAny(NULL, objPtr); - stringPtr = GET_STRING(objPtr); + stringPtr = GET_UNICHAR_STRING(objPtr); if (objPtr->bytes != NULL) { /* @@ -948,9 +1201,9 @@ Tcl_SetObjLength( * Need to enlarge the buffer. */ if (objPtr->bytes == &tclEmptyString) { - objPtr->bytes = (char *)Tcl_Alloc(length + 1); + objPtr->bytes = (char *)ckalloc(length + 1U); } else { - objPtr->bytes = (char *)Tcl_Realloc(objPtr->bytes, length + 1); + objPtr->bytes = (char *)ckrealloc(objPtr->bytes, length + 1U); } stringPtr->allocated = length; } @@ -965,9 +1218,14 @@ Tcl_SetObjLength( stringPtr->numChars = TCL_INDEX_NONE; stringPtr->hasUnicode = 0; } else { + /* + * Changing length of pure unicode string. + */ + + uniCharStringCheckLimits(length); if (length > stringPtr->maxChars) { - stringPtr = stringRealloc(stringPtr, length); - SET_STRING(objPtr, stringPtr); + stringPtr = uniCharStringRealloc(stringPtr, length); + SET_UNICHAR_STRING(objPtr, stringPtr); stringPtr->maxChars = length; } @@ -1017,7 +1275,7 @@ Tcl_AttemptSetObjLength( * representation of object, not including * terminating null byte. */ { - String *stringPtr; + UniCharString *stringPtr; if (length < 0) { /* Negative lengths => most likely integer overflow */ @@ -1032,7 +1290,7 @@ Tcl_AttemptSetObjLength( } SetStringFromAny(NULL, objPtr); - stringPtr = GET_STRING(objPtr); + stringPtr = GET_UNICHAR_STRING(objPtr); if (objPtr->bytes != NULL) { /* @@ -1046,9 +1304,9 @@ Tcl_AttemptSetObjLength( char *newBytes; if (objPtr->bytes == &tclEmptyString) { - newBytes = (char *)Tcl_AttemptAlloc(length + 1U); + newBytes = (char *)attemptckalloc(length + 1U); } else { - newBytes = (char *)Tcl_AttemptRealloc(objPtr->bytes, length + 1U); + newBytes = (char *)attemptckrealloc(objPtr->bytes, length + 1U); } if (newBytes == NULL) { return 0; @@ -1071,12 +1329,15 @@ Tcl_AttemptSetObjLength( * Changing length of pure Unicode string. */ + if (length > UNICHAR_STRING_MAXCHARS) { + return 0; + } if (length > stringPtr->maxChars) { - stringPtr = stringAttemptRealloc(stringPtr, length); + stringPtr = uniCharStringAttemptRealloc(stringPtr, length); if (stringPtr == NULL) { return 0; } - SET_STRING(objPtr, stringPtr); + SET_UNICHAR_STRING(objPtr, stringPtr); stringPtr->maxChars = length; } @@ -1112,33 +1373,68 @@ Tcl_AttemptSetObjLength( *--------------------------------------------------------------------------- */ +#if !defined(TCL_NO_DEPRECATED) void Tcl_SetUnicodeObj( Tcl_Obj *objPtr, /* The object to set the string of. */ - const Tcl_UniChar *unicode, /* The Unicode string used to initialize the + const unsigned short *unicode, /* The Unicode string used to initialize the * object. */ Tcl_Size numChars) /* Number of characters in the Unicode * string. */ { - if (Tcl_IsShared(objPtr)) { - Tcl_Panic("%s called with shared object", "Tcl_SetUnicodeObj"); + String *stringPtr; + + if (numChars < 0) { + numChars = UTF16Length(unicode); } - TclFreeInternalRep(objPtr); - SetUnicodeObj(objPtr, unicode, numChars); + + /* + * Allocate enough space for the String structure + Unicode string. + */ + + stringCheckLimits(numChars); + stringPtr = stringAlloc(numChars); + SET_STRING(objPtr, stringPtr); + objPtr->typePtr = &tclStringType; + + stringPtr->maxChars = numChars; + memcpy(stringPtr->unicode, unicode, numChars * sizeof(unsigned char)); + stringPtr->unicode[numChars] = 0; + stringPtr->numChars = numChars; + stringPtr->hasUnicode = 1; + + TclInvalidateStringRep(objPtr); + stringPtr->allocated = numChars; } static Tcl_Size +UTF16Length( + const unsigned short *ucs2Ptr) +{ + Tcl_Size numChars = 0; + + if (ucs2Ptr) { + while (numChars >= 0 && ucs2Ptr[numChars] != 0) { + numChars++; + } + } + stringCheckLimits(numChars); + return numChars; +} +#endif + +static Tcl_Size UnicodeLength( const Tcl_UniChar *unicode) { Tcl_Size numChars = 0; if (unicode) { - /* TODO - is this overflow check really necessary? */ while ((numChars >= 0) && (unicode[numChars] != 0)) { numChars++; } } + uniCharStringCheckLimits(numChars); return numChars; } @@ -1150,7 +1446,7 @@ SetUnicodeObj( Tcl_Size numChars) /* Number of characters in the Unicode * string. */ { - String *stringPtr; + UniCharString *stringPtr; if (numChars < 0) { numChars = UnicodeLength(unicode); @@ -1160,9 +1456,10 @@ SetUnicodeObj( * Allocate enough space for the String structure + Unicode string. */ - stringPtr = stringAlloc(numChars); - SET_STRING(objPtr, stringPtr); - objPtr->typePtr = &tclStringType; + uniCharStringCheckLimits(numChars); + stringPtr = uniCharStringAlloc(numChars); + SET_UNICHAR_STRING(objPtr, stringPtr); + objPtr->typePtr = &tclUniCharStringType; stringPtr->maxChars = numChars; memcpy(stringPtr->unicode, unicode, numChars * sizeof(Tcl_UniChar)); @@ -1206,7 +1503,7 @@ Tcl_AppendLimitedToObj( * object to indicate not all available bytes * at "bytes" were appended. */ { - String *stringPtr; + UniCharString *stringPtr; Tcl_Size toCopy = 0; Tcl_Size eLen = 0; @@ -1245,13 +1542,13 @@ Tcl_AppendLimitedToObj( } SetStringFromAny(NULL, objPtr); - stringPtr = GET_STRING(objPtr); + stringPtr = GET_UNICHAR_STRING(objPtr); /* If appended string starts with a continuation byte or a lower surrogate, * force objPtr to unicode representation. See [7f1162a867] */ if (bytes && ISCONTINUATION(bytes)) { - Tcl_GetUnicode(objPtr); - stringPtr = GET_STRING(objPtr); + TclGetUnicodeFromObj(objPtr, NULL); + stringPtr = GET_UNICHAR_STRING(objPtr); } if (stringPtr->hasUnicode && (stringPtr->numChars > 0)) { AppendUtfToUnicodeRep(objPtr, bytes, toCopy); @@ -1263,7 +1560,7 @@ Tcl_AppendLimitedToObj( return; } - stringPtr = GET_STRING(objPtr); + stringPtr = GET_UNICHAR_STRING(objPtr); if (stringPtr->hasUnicode && (stringPtr->numChars > 0)) { AppendUtfToUnicodeRep(objPtr, ellipsis, eLen); } else { @@ -1294,7 +1591,7 @@ Tcl_AppendToObj( const char *bytes, /* Points to the bytes to append to the * object. */ Tcl_Size length) /* The number of bytes to append from "bytes". - * If TCL_INDEX_NONE, then append all bytes up to NUL + * If negative, then append all bytes up to NUL * byte. */ { Tcl_AppendLimitedToObj(objPtr, bytes, length, TCL_SIZE_MAX, NULL); @@ -1318,14 +1615,14 @@ Tcl_AppendToObj( */ void -Tcl_AppendUnicodeToObj( +TclAppendUnicodeToObj( Tcl_Obj *objPtr, /* Points to the object to append to. */ const Tcl_UniChar *unicode, /* The Unicode string to append to the * object. */ Tcl_Size length) /* Number of chars in Unicode. Negative * lengths means nul terminated */ { - String *stringPtr; + UniCharString *stringPtr; if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_AppendUnicodeToObj"); @@ -1336,7 +1633,7 @@ Tcl_AppendUnicodeToObj( } SetStringFromAny(NULL, objPtr); - stringPtr = GET_STRING(objPtr); + stringPtr = GET_UNICHAR_STRING(objPtr); /* * If objPtr has a valid Unicode rep, then append the "unicode" to the @@ -1351,6 +1648,35 @@ Tcl_AppendUnicodeToObj( } } +#if !defined(TCL_NO_DEPRECATED) +void +Tcl_AppendUnicodeToObj( + Tcl_Obj *objPtr, /* Points to the object to append to. */ + const unsigned short *unicode, /* The unicode string to append to the + * object. */ + Tcl_Size length) /* Number of chars in Unicode. Negative + * lengths means nul terminated */ +{ + String *stringPtr; + + if (Tcl_IsShared(objPtr)) { + Tcl_Panic("%s called with shared object", "Tcl_AppendUnicodeToObj"); + } + + if (length == 0) { + return; + } + + SetUTF16StringFromAny(NULL, objPtr); + stringPtr = GET_STRING(objPtr); + stringPtr = stringAttemptRealloc(stringPtr, stringPtr->numChars + length); + memcpy(&stringPtr->unicode[stringPtr->numChars], unicode, length); + stringPtr->maxChars = stringPtr->allocated = stringPtr->numChars += length; + stringPtr->unicode[stringPtr->numChars] = 0; + SET_STRING(objPtr, stringPtr); +} +#endif + /* *---------------------------------------------------------------------- * @@ -1376,31 +1702,33 @@ Tcl_AppendObjToObj( Tcl_Obj *objPtr, /* Points to the object to append to. */ Tcl_Obj *appendObjPtr) /* Object to append. */ { - String *stringPtr; - Tcl_Size length = 0, numChars; + UniCharString *stringPtr; + Tcl_Size length, numChars; Tcl_Size appendNumChars = TCL_INDEX_NONE; const char *bytes; - if (TclCheckEmptyString(appendObjPtr) == TCL_EMPTYSTRING_YES) { - return; - } + /* + * Special case: second object is standard-empty is fast case. We know + * that appending nothing to anything leaves that starting anything... + */ - if (TclCheckEmptyString(objPtr) == TCL_EMPTYSTRING_YES) { - TclSetDuplicateObj(objPtr, appendObjPtr); + if (appendObjPtr->bytes == &tclEmptyString) { return; } - if (TclIsPureByteArray(appendObjPtr) - && (TclIsPureByteArray(objPtr) || objPtr->bytes == &tclEmptyString)) { - /* - * Both bytearray objects are pure, so the second internal bytearray value - * can be appended to the first, with no need to modify the "bytes" field. - */ + /* + * Handle append of one ByteArray object to another as a special case. + * 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 == &tclEmptyString) + && TclIsPureByteArray(appendObjPtr)) { /* * One might expect the code here to be * - * bytes = Tcl_GetBytesFromObj(NULL, appendObjPtr, &length); + * bytes = Tcl_GetByteArrayFromObj(appendObjPtr, &length); * TclAppendBytesToByteArray(objPtr, bytes, length); * * and essentially all of the time that would be fine. However, it @@ -1416,10 +1744,10 @@ Tcl_AppendObjToObj( * First, get the lengths. */ - Tcl_Size lengthSrc = 0; + Tcl_Size lengthSrc; - (void) Tcl_GetBytesFromObj(NULL, objPtr, &length); - (void) Tcl_GetBytesFromObj(NULL, appendObjPtr, &lengthSrc); + (void) Tcl_GetByteArrayFromObj(objPtr, &length); + (void) Tcl_GetByteArrayFromObj(appendObjPtr, &lengthSrc); /* * Grow buffer enough for the append. @@ -1439,7 +1767,7 @@ Tcl_AppendObjToObj( */ TclAppendBytesToByteArray(objPtr, - Tcl_GetBytesFromObj(NULL, appendObjPtr, (Tcl_Size *) NULL), lengthSrc); + Tcl_GetByteArrayFromObj(appendObjPtr, (Tcl_Size *) NULL), lengthSrc); return; } @@ -1448,14 +1776,14 @@ Tcl_AppendObjToObj( */ SetStringFromAny(NULL, objPtr); - stringPtr = GET_STRING(objPtr); + stringPtr = GET_UNICHAR_STRING(objPtr); /* If appended string starts with a continuation byte or a lower surrogate, * force objPtr to unicode representation. See [7f1162a867] * This fixes append-3.4, append-3.7 and utf-1.18 testcases. */ if (ISCONTINUATION(TclGetString(appendObjPtr))) { - Tcl_GetUnicode(objPtr); - stringPtr = GET_STRING(objPtr); + TclGetUnicodeFromObj(objPtr, NULL); + stringPtr = GET_UNICHAR_STRING(objPtr); } /* * If objPtr has a valid Unicode rep, then get a Unicode string from @@ -1467,9 +1795,9 @@ Tcl_AppendObjToObj( * If appendObjPtr is not of the "String" type, don't convert it. */ - if (TclHasInternalRep(appendObjPtr, &tclStringType)) { + if (TclHasInternalRep(appendObjPtr, &tclUniCharStringType)) { Tcl_UniChar *unicode = - Tcl_GetUnicodeFromObj(appendObjPtr, &numChars); + TclGetUnicodeFromObj(appendObjPtr, &numChars); AppendUnicodeToUnicodeRep(objPtr, unicode, numChars); } else { @@ -1488,8 +1816,8 @@ Tcl_AppendObjToObj( bytes = TclGetStringFromObj(appendObjPtr, &length); numChars = stringPtr->numChars; - if ((numChars >= 0) && TclHasInternalRep(appendObjPtr, &tclStringType)) { - String *appendStringPtr = GET_STRING(appendObjPtr); + if ((numChars >= 0) && TclHasInternalRep(appendObjPtr, &tclUniCharStringType)) { + UniCharString *appendStringPtr = GET_UNICHAR_STRING(appendObjPtr); appendNumChars = appendStringPtr->numChars; } @@ -1524,7 +1852,7 @@ AppendUnicodeToUnicodeRep( const Tcl_UniChar *unicode, /* String to append. */ Tcl_Size appendNumChars) /* Number of chars of "unicode" to append. */ { - String *stringPtr; + UniCharString *stringPtr; Tcl_Size numChars; if (appendNumChars < 0) { @@ -1535,7 +1863,7 @@ AppendUnicodeToUnicodeRep( } SetStringFromAny(NULL, objPtr); - stringPtr = GET_STRING(objPtr); + stringPtr = GET_UNICHAR_STRING(objPtr); /* * If not enough space has been allocated for the Unicode rep, reallocate @@ -1546,9 +1874,10 @@ AppendUnicodeToUnicodeRep( */ numChars = stringPtr->numChars + appendNumChars; + uniCharStringCheckLimits(numChars); if (numChars > stringPtr->maxChars) { - Tcl_Size offset = -1; + Tcl_Size offset = TCL_INDEX_NONE; /* * Protect against case where Unicode points into the existing @@ -1562,7 +1891,7 @@ AppendUnicodeToUnicodeRep( } GrowUnicodeBuffer(objPtr, numChars); - stringPtr = GET_STRING(objPtr); + stringPtr = GET_UNICHAR_STRING(objPtr); /* * Relocate Unicode if needed; see above. @@ -1612,7 +1941,7 @@ AppendUnicodeToUtfRep( const Tcl_UniChar *unicode, /* String to convert to UTF. */ Tcl_Size numChars) /* Number of chars of Unicode to convert. */ { - String *stringPtr = GET_STRING(objPtr); + UniCharString *stringPtr = GET_UNICHAR_STRING(objPtr); numChars = ExtendStringRepWithUnicode(objPtr, unicode, numChars); @@ -1645,7 +1974,7 @@ AppendUtfToUnicodeRep( const char *bytes, /* String to convert to Unicode. */ Tcl_Size numBytes) /* Number of bytes of "bytes" to convert. */ { - String *stringPtr; + UniCharString *stringPtr; if (numBytes == 0) { return; @@ -1653,7 +1982,7 @@ AppendUtfToUnicodeRep( ExtendUnicodeRepWithString(objPtr, bytes, numBytes, -1); TclInvalidateStringRep(objPtr); - stringPtr = GET_STRING(objPtr); + stringPtr = GET_UNICHAR_STRING(objPtr); stringPtr->allocated = 0; } @@ -1681,7 +2010,7 @@ AppendUtfToUtfRep( const char *bytes, /* String to append. */ Tcl_Size numBytes) /* Number of bytes of "bytes" to append. */ { - String *stringPtr; + UniCharString *stringPtr; Tcl_Size newLength, oldLength; if (numBytes == 0) { @@ -1702,9 +2031,9 @@ AppendUtfToUtfRep( } newLength = numBytes + oldLength; - stringPtr = GET_STRING(objPtr); + stringPtr = GET_UNICHAR_STRING(objPtr); if (newLength > stringPtr->allocated) { - Tcl_Size offset = -1; + Tcl_Size offset = TCL_INDEX_NONE; /* * Protect against case where unicode points into the existing @@ -1783,7 +2112,7 @@ TclAppendUtfToUtf( /* *---------------------------------------------------------------------- * - * Tcl_AppendStringsToObj -- + * Tcl_AppendStringsToObjVA -- * * This function appends one or more null-terminated strings to an * object. @@ -1799,13 +2128,10 @@ TclAppendUtfToUtf( */ void -Tcl_AppendStringsToObj( - Tcl_Obj *objPtr, - ...) +Tcl_AppendStringsToObjVA( + Tcl_Obj *objPtr, /* Points to the object to append to. */ + va_list argList) /* Variable argument list. */ { - va_list argList; - - va_start(argList, objPtr); if (Tcl_IsShared(objPtr)) { Tcl_Panic("%s called with shared object", "Tcl_AppendStringsToObj"); } @@ -1818,6 +2144,35 @@ Tcl_AppendStringsToObj( } Tcl_AppendToObj(objPtr, bytes, -1); } +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_AppendStringsToObj -- + * + * This function appends one or more null-terminated strings to an + * object. + * + * Results: + * None. + * + * Side effects: + * The contents of all the string arguments are appended to the string + * representation of objPtr. + * + *---------------------------------------------------------------------- + */ + +void +Tcl_AppendStringsToObj( + Tcl_Obj *objPtr, + ...) +{ + va_list argList; + + va_start(argList, objPtr); + Tcl_AppendStringsToObjVA(objPtr, argList); va_end(argList); } @@ -1864,7 +2219,7 @@ Tcl_AppendFormatToObj( if (Tcl_IsShared(appendObj)) { Tcl_Panic("%s called with shared object", "Tcl_AppendFormatToObj"); } - (void)TclGetStringFromObj(appendObj, &originalLength); + TclGetStringFromObj(appendObj, &originalLength); limit = TCL_SIZE_MAX - originalLength; /* @@ -2128,12 +2483,12 @@ Tcl_AppendFormatToObj( goto errorMsg; case 's': if (gotPrecision) { - numChars = Tcl_GetCharLength(segment); + numChars = TclGetCharLength(segment); if (precision < numChars) { if (precision < 1) { TclNewObj(segment); } else { - segment = Tcl_GetRange(segment, 0, precision - 1); + segment = TclGetRange(segment, 0, precision - 1); } numChars = precision; Tcl_IncrRefCount(segment); @@ -2152,6 +2507,10 @@ Tcl_AppendFormatToObj( code = 0xFFFD; } length = Tcl_UniCharToUtf(code, buf); + if ((code >= 0xD800) && (length < 3)) { + /* Special case for handling high surrogates. */ + length += Tcl_UniCharToUtf(-1, buf + length); + } segment = Tcl_NewStringObj(buf, length); Tcl_IncrRefCount(segment); allocSegment = 1; @@ -2186,9 +2545,7 @@ Tcl_AppendFormatToObj( } cmpResult = mp_cmp_d(&big, 0); isNegative = (cmpResult == MP_LT); - if (cmpResult == MP_EQ) { - gotHash = 0; - } + if (cmpResult == MP_EQ) gotHash = 0; if (ch == 'u') { if (isNegative) { mp_clear(&big); @@ -2205,9 +2562,7 @@ Tcl_AppendFormatToObj( goto error; } isNegative = (w < (Tcl_WideInt) 0); - if (w == (Tcl_WideInt) 0) { - gotHash = 0; - } + if (w == (Tcl_WideInt) 0) gotHash = 0; #endif } else if (TclGetLongFromObj(NULL, segment, &l) != TCL_OK) { if (TclGetWideBitsFromObj(interp, segment, &w) != TCL_OK) { @@ -2218,26 +2573,18 @@ Tcl_AppendFormatToObj( if (useShort) { s = (short) l; isNegative = (s < (short) 0); - if (s == (short) 0) { - gotHash = 0; - } + if (s == (short) 0) gotHash = 0; } else { isNegative = (l < (long) 0); - if (l == (long) 0) { - gotHash = 0; - } + if (l == (long) 0) gotHash = 0; } } else if (useShort) { s = (short) l; isNegative = (s < (short) 0); - if (s == (short) 0) { - gotHash = 0; - } + if (s == (short) 0) gotHash = 0; } else { isNegative = (l < (long) 0); - if (l == (long) 0) { - gotHash = 0; - } + if (l == (long) 0) gotHash = 0; } TclNewObj(segment); @@ -2321,7 +2668,7 @@ Tcl_AppendFormatToObj( gotZero = 0; } if (gotZero) { - length += Tcl_GetCharLength(segment); + length += TclGetCharLength(segment); if (length < width) { segmentLimit -= width - length; } @@ -2453,7 +2800,7 @@ Tcl_AppendFormatToObj( gotZero = 0; } if (gotZero) { - length += Tcl_GetCharLength(segment); + length += TclGetCharLength(segment); if (length < width) { segmentLimit -= width - length; } @@ -2550,9 +2897,7 @@ Tcl_AppendFormatToObj( char *q = TclGetString(segment) + 1; *q = 'x'; q = strchr(q, 'P'); - if (q) { - *q = 'p'; - } + if (q) *q = 'p'; } break; } @@ -2566,7 +2911,7 @@ Tcl_AppendFormatToObj( } if (width>0 && numChars<0) { - numChars = Tcl_GetCharLength(segment); + numChars = TclGetCharLength(segment); } if (!gotMinus && width>0) { if (numChars < width) { @@ -2578,7 +2923,7 @@ Tcl_AppendFormatToObj( } } - (void)TclGetStringFromObj(segment, &segmentNumBytes); + TclGetStringFromObj(segment, &segmentNumBytes); if (segmentNumBytes > limit) { if (allocSegment) { Tcl_DecrRefCount(segment); @@ -2750,7 +3095,7 @@ AppendPrintfToObjVA( */ q = Tcl_UtfPrev(end, bytes); - if (!Tcl_UtfCharComplete(q, (end - q))) { + if (!Tcl_UtfCharComplete(q, end - q)) { end = q; } @@ -2761,7 +3106,7 @@ AppendPrintfToObjVA( } Tcl_ListObjAppendElement(NULL, list, - Tcl_NewStringObj(bytes , (end - bytes))); + Tcl_NewStringObj(bytes , end - bytes)); break; } @@ -2956,15 +3301,15 @@ Tcl_ObjPrintf( char * TclGetStringStorage( Tcl_Obj *objPtr, - Tcl_Size *sizePtr) + unsigned int *sizePtr) { - String *stringPtr; + UniCharString *stringPtr; - if (!TclHasInternalRep(objPtr, &tclStringType) || objPtr->bytes == NULL) { - return TclGetStringFromObj(objPtr, sizePtr); + if (!TclHasInternalRep(objPtr, &tclUniCharStringType) || objPtr->bytes == NULL) { + return TclGetStringFromObj(objPtr, (Tcl_Size *)sizePtr); } - stringPtr = GET_STRING(objPtr); + stringPtr = GET_UNICHAR_STRING(objPtr); *sizePtr = stringPtr->allocated; return objPtr->bytes; } @@ -2999,7 +3344,6 @@ TclStringRepeat( int unichar = 0; Tcl_Size done = 1; int binary = TclIsPureByteArray(objPtr); - Tcl_Size maxCount; /* * Analyze to determine what representation result should be. @@ -3009,8 +3353,8 @@ TclStringRepeat( */ if (!binary) { - if (TclHasInternalRep(objPtr, &tclStringType)) { - String *stringPtr = GET_STRING(objPtr); + if (TclHasInternalRep(objPtr, &tclUniCharStringType)) { + UniCharString *stringPtr = GET_UNICHAR_STRING(objPtr); if (stringPtr->hasUnicode) { unichar = 1; } @@ -3019,16 +3363,13 @@ TclStringRepeat( if (binary) { /* Result will be pure byte array. Pre-size it */ - (void)Tcl_GetBytesFromObj(NULL, objPtr, &length); - maxCount = TCL_SIZE_MAX; + Tcl_GetByteArrayFromObj(objPtr, &length); } else if (unichar) { /* Result will be pure Tcl_UniChar array. Pre-size it. */ - (void)Tcl_GetUnicodeFromObj(objPtr, &length); - maxCount = TCL_SIZE_MAX/sizeof(Tcl_UniChar); + TclGetUnicodeFromObj(objPtr, &length); } else { /* Result will be concat of string reps. Pre-size it. */ - (void)TclGetStringFromObj(objPtr, &length); - maxCount = TCL_SIZE_MAX; + TclGetStringFromObj(objPtr, &length); } if (length == 0) { @@ -3036,14 +3377,11 @@ TclStringRepeat( return objPtr; } - /* maxCount includes space for null */ - if (count > (maxCount-1)) { + if (count > INT_MAX/length) { if (interp) { - Tcl_SetObjResult( - interp, - Tcl_ObjPrintf("max size for a Tcl value (%" TCL_SIZE_MODIFIER - "d bytes) exceeded", - TCL_SIZE_MAX)); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "max size for a Tcl value (%" TCL_SIZE_MODIFIER + "d bytes) exceeded", TCL_SIZE_MAX)); Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL); } return NULL; @@ -3054,7 +3392,6 @@ TclStringRepeat( objResultPtr = (!inPlace || Tcl_IsShared(objPtr)) ? Tcl_DuplicateObj(objPtr) : objPtr; - /* Allocate count*length space */ Tcl_SetByteArrayLength(objResultPtr, count*length); /* PANIC? */ Tcl_SetByteArrayLength(objResultPtr, length); while (count - done > done) { @@ -3062,7 +3399,7 @@ TclStringRepeat( done *= 2; } TclAppendBytesToByteArray(objResultPtr, - Tcl_GetBytesFromObj(NULL, objResultPtr, (Tcl_Size *) NULL), + Tcl_GetByteArrayFromObj(objResultPtr, (Tcl_Size *) NULL), (count - done) * length); } else if (unichar) { /* @@ -3070,19 +3407,18 @@ TclStringRepeat( */ if (!inPlace || Tcl_IsShared(objPtr)) { - objResultPtr = Tcl_NewUnicodeObj(Tcl_GetUnicode(objPtr), length); + objResultPtr = TclNewUnicodeObj(TclGetUnicodeFromObj(objPtr, NULL), length); } else { TclInvalidateStringRep(objPtr); objResultPtr = objPtr; } - /* TODO - overflow check */ if (0 == Tcl_AttemptSetObjLength(objResultPtr, count*length)) { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "string size overflow: unable to alloc %" - TCL_SIZE_MODIFIER "d bytes", - STRING_SIZE(count*length))); + TCL_Z_MODIFIER "u bytes", + UNICHAR_STRING_SIZE(count*length))); Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL); } return NULL; @@ -3092,7 +3428,7 @@ TclStringRepeat( Tcl_AppendObjToObj(objResultPtr, objResultPtr); done *= 2; } - Tcl_AppendUnicodeToObj(objResultPtr, Tcl_GetUnicode(objResultPtr), + TclAppendUnicodeToObj(objResultPtr, TclGetUnicodeFromObj(objResultPtr, NULL), (count - done) * length); } else { /* @@ -3105,7 +3441,6 @@ TclStringRepeat( TclFreeInternalRep(objPtr); objResultPtr = objPtr; } - /* TODO - overflow check */ if (0 == Tcl_AttemptSetObjLength(objResultPtr, count*length)) { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -3156,7 +3491,7 @@ TclStringCat( int allowUniChar = 1, requestUniChar = 0, forceUniChar = 0; Tcl_Size first = objc - 1; /* Index of first value possibly not empty */ Tcl_Size last = 0; /* Index of last value possibly not empty */ - int inPlace = (flags & TCL_STRING_IN_PLACE) && !Tcl_IsShared(*objv); + int inPlace = flags & TCL_STRING_IN_PLACE; if (objc <= 1) { if (objc != 1) { @@ -3193,14 +3528,14 @@ TclStringCat( binary = 0; if (ov > objv+1 && ISCONTINUATION(TclGetString(objPtr))) { forceUniChar = 1; - } else if ((objPtr->typePtr) && TclHasInternalRep(objPtr, &tclStringType)) { + } else if ((objPtr->typePtr) && !TclHasInternalRep(objPtr, &tclUniCharStringType)) { /* Prevent shimmer of non-string types. */ allowUniChar = 0; } } } else { binary = 0; - if (TclHasInternalRep(objPtr, &tclStringType)) { + if (TclHasInternalRep(objPtr, &tclUniCharStringType)) { /* Have a pure Unicode value; ask to preserve it */ requestUniChar = 1; } else { @@ -3215,7 +3550,7 @@ TclStringCat( * Result will be pure byte array. Pre-size it */ - Tcl_Size numBytes = 0; + Tcl_Size numBytes; ov = objv; oc = objc; do { @@ -3228,7 +3563,7 @@ TclStringCat( */ if (TclIsPureByteArray(objPtr)) { - (void)Tcl_GetBytesFromObj(NULL, objPtr, &numBytes); /* PANIC? */ + Tcl_GetByteArrayFromObj(objPtr, &numBytes); /* PANIC? */ if (numBytes) { last = objc - oc; @@ -3255,13 +3590,12 @@ TclStringCat( if ((objPtr->bytes == NULL) || (objPtr->length)) { Tcl_Size numChars; - (void)Tcl_GetUnicodeFromObj(objPtr, &numChars); /* PANIC? */ + TclGetUnicodeFromObj(objPtr, &numChars); /* PANIC? */ if (numChars) { last = objc - oc; if (length == 0) { first = last; - } - if (length > (Tcl_Size) ((TCL_SIZE_MAX/sizeof(Tcl_UniChar))-numChars)) { + } else if (length > TCL_SIZE_MAX - numChars) { goto overflow; } length += numChars; @@ -3282,12 +3616,11 @@ TclStringCat( do { Tcl_Obj *objPtr = *ov++; - if (objPtr->bytes == NULL - && TclCheckEmptyString(objPtr) != TCL_EMPTYSTRING_YES) { + if (objPtr->bytes == NULL) { /* No string rep; Take the chance we can avoid making it */ pendingPtr = objPtr; } else { - (void) TclGetStringFromObj(objPtr, &length); /* PANIC? */ + TclGetStringFromObj(objPtr, &length); /* PANIC? */ } } while (--oc && (length == 0) && (pendingPtr == NULL)); @@ -3311,20 +3644,20 @@ TclStringCat( do { Tcl_Obj *objPtr = *ov++; - (void)TclGetStringFromObj(objPtr, &numBytes); /* PANIC? */ + TclGetStringFromObj(objPtr, &numBytes); /* PANIC? */ } while (--oc && numBytes == 0 && pendingPtr->bytes == NULL); if (numBytes) { last = objc -oc -1; } if (oc || numBytes) { - (void)TclGetStringFromObj(pendingPtr, &length); + TclGetStringFromObj(pendingPtr, &length); } if (length == 0) { if (numBytes) { first = last; } - } else if (numBytes > (TCL_SIZE_MAX - length)) { + } else if (numBytes > TCL_SIZE_MAX - length) { goto overflow; } length += numBytes; @@ -3335,11 +3668,10 @@ TclStringCat( Tcl_Size numBytes; Tcl_Obj *objPtr = *ov++; - TclGetString(objPtr); /* PANIC? */ - numBytes = objPtr->length; + TclGetStringFromObj(objPtr, &numBytes); /* PANIC? */ if (numBytes) { last = objc - oc; - if (numBytes > (TCL_SIZE_MAX - length)) { + if (numBytes > TCL_SIZE_MAX - length) { goto overflow; } length += numBytes; @@ -3355,7 +3687,6 @@ TclStringCat( } objv += first; objc = (last - first + 1); - inPlace = (flags & TCL_STRING_IN_PLACE) && !Tcl_IsShared(*objv); if (binary) { /* Efficiently produce a pure byte array result */ @@ -3366,11 +3697,11 @@ TclStringCat( * failure to allocate enough space. Following stanza may panic. */ - if (inPlace) { - Tcl_Size start = 0; + if (inPlace && !Tcl_IsShared(*objv)) { + Tcl_Size start; objResultPtr = *objv++; objc--; - (void)Tcl_GetBytesFromObj(NULL, objResultPtr, &start); + Tcl_GetByteArrayFromObj(objResultPtr, &start); dst = Tcl_SetByteArrayLength(objResultPtr, length) + start; } else { objResultPtr = Tcl_NewByteArrayObj(NULL, length); @@ -3386,8 +3717,8 @@ TclStringCat( */ if (TclIsPureByteArray(objPtr)) { - Tcl_Size more = 0; - unsigned char *src = Tcl_GetBytesFromObj(NULL, objPtr, &more); + Tcl_Size more; + unsigned char *src = Tcl_GetByteArrayFromObj(objPtr, &more); memcpy(dst, src, more); dst += more; } @@ -3396,49 +3727,49 @@ TclStringCat( /* Efficiently produce a pure Tcl_UniChar array result */ Tcl_UniChar *dst; - if (inPlace) { + if (inPlace && !Tcl_IsShared(*objv)) { Tcl_Size start; objResultPtr = *objv++; objc--; /* Ugly interface! Force resize of the unicode array. */ - (void)Tcl_GetUnicodeFromObj(objResultPtr, &start); + TclGetUnicodeFromObj(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))); + UNICHAR_STRING_SIZE(length))); Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL); } return NULL; } - dst = Tcl_GetUnicode(objResultPtr) + start; + dst = TclGetUnicodeFromObj(objResultPtr, NULL) + start; } else { Tcl_UniChar ch = 0; /* Ugly interface! No scheme to init array size. */ - objResultPtr = Tcl_NewUnicodeObj(&ch, 0); /* PANIC? */ + objResultPtr = TclNewUnicodeObj(&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))); + UNICHAR_STRING_SIZE(length))); Tcl_SetErrorCode(interp, "TCL", "MEMORY", (char *)NULL); } return NULL; } - dst = Tcl_GetUnicode(objResultPtr); + dst = TclGetUnicodeFromObj(objResultPtr, NULL); } while (objc--) { Tcl_Obj *objPtr = *objv++; if ((objPtr->bytes == NULL) || (objPtr->length)) { Tcl_Size more; - Tcl_UniChar *src = Tcl_GetUnicodeFromObj(objPtr, &more); + Tcl_UniChar *src = TclGetUnicodeFromObj(objPtr, &more); memcpy(dst, src, more * sizeof(Tcl_UniChar)); dst += more; } @@ -3447,12 +3778,12 @@ TclStringCat( /* Efficiently concatenate string reps */ char *dst; - if (inPlace) { + if (inPlace && !Tcl_IsShared(*objv)) { Tcl_Size start; objResultPtr = *objv++; objc--; - (void)TclGetStringFromObj(objResultPtr, &start); + TclGetStringFromObj(objResultPtr, &start); if (0 == Tcl_AttemptSetObjLength(objResultPtr, length)) { if (interp) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -3520,116 +3851,36 @@ TclStringCat( *--------------------------------------------------------------------------- */ - -static int -UniCharNcasememcmp( - const void *ucsPtr, /* Unicode string to compare to uct. */ - const void *uctPtr, /* Unicode string ucs is compared to. */ - size_t numChars) /* Number of Unichars to compare. */ -{ - const Tcl_UniChar *ucs = (const Tcl_UniChar *)ucsPtr; - const Tcl_UniChar *uct = (const Tcl_UniChar *)uctPtr; - for ( ; numChars != 0; numChars--, ucs++, uct++) { - if (*ucs != *uct) { - Tcl_UniChar lcs = Tcl_UniCharToLower(*ucs); - Tcl_UniChar lct = Tcl_UniCharToLower(*uct); - - if (lcs != lct) { - return (lcs - lct); - } - } - } - return 0; -} - static int UtfNmemcmp( const void *csPtr, /* UTF string to compare to ct. */ const void *ctPtr, /* UTF string cs is compared to. */ - size_t numChars) /* Number of UTF chars to compare. */ + size_t numBytes) /* Number of *bytes* to compare. */ { - Tcl_UniChar ch1 = 0, ch2 = 0; const char *cs = (const char *)csPtr; const char *ct = (const char *)ctPtr; - /* - * Cannot use 'memcmp(cs, ct, n);' as byte representation of \u0000 (the - * pair of bytes 0xC0,0x80) is larger than byte representation of \u0001 - * (the byte 0x01.) + * We can't simply call 'memcmp(cs, ct, numBytes);' because we need to + * check for Tcl's \xC0\x80 non-utf-8 null encoding. Otherwise utf-8 lexes + * fine in the strcmp manner. */ - while (numChars-- > 0) { - /* - * n must be interpreted as chars, not bytes. This should be called - * only when both strings are of at least n chars long (no need for \0 - * check) - */ - - cs += TclUtfToUniChar(cs, &ch1); - ct += TclUtfToUniChar(ct, &ch2); - if (ch1 != ch2) { - return (ch1 - ch2); - } - } - return 0; -} - -static int -UtfNcasememcmp( - const void *csPtr, /* UTF string to compare to ct. */ - const void *ctPtr, /* UTF string cs is compared to. */ - size_t numChars) /* Number of UTF chars to compare. */ -{ - Tcl_UniChar ch1 = 0, ch2 = 0; - const char *cs = (const char *)csPtr; - const char *ct = (const char *)ctPtr; + int result = 0; - while (numChars-- > 0) { - /* - * n must be interpreted as chars, not bytes. - * This should be called only when both strings are of - * at least n chars long (no need for \0 check) - */ - cs += TclUtfToUniChar(cs, &ch1); - ct += TclUtfToUniChar(ct, &ch2); - if (ch1 != ch2) { - ch1 = Tcl_UniCharToLower(ch1); - ch2 = Tcl_UniCharToLower(ch2); - if (ch1 != ch2) { - return (ch1 - ch2); - } + for ( ; numBytes != 0; numBytes--, cs++, ct++) { + if (*cs != *ct) { + result = UCHAR(*cs) - UCHAR(*ct); + break; } } - return 0; -} - -static int -UniCharNmemcmp( - const void *ucsPtr, /* Unicode string to compare to uct. */ - const void *uctPtr, /* Unicode string ucs is compared to. */ - size_t numChars) /* Number of unichars to compare. */ -{ - const Tcl_UniChar *ucs = (const Tcl_UniChar *)ucsPtr; - const Tcl_UniChar *uct = (const Tcl_UniChar *)uctPtr; -#if defined(WORDS_BIGENDIAN) - /* - * We are definitely on a big-endian machine; memcmp() is safe - */ - - return memcmp(ucs, uct, numChars*sizeof(Tcl_UniChar)); + if (numBytes && ((UCHAR(*cs) == 0xC0) || (UCHAR(*ct) == 0xC0))) { + unsigned char c1, c2; -#else /* !WORDS_BIGENDIAN */ - /* - * We can't simply call memcmp() because that is not lexically correct. - */ - - for ( ; numChars != 0; ucs++, uct++, numChars--) { - if (*ucs != *uct) { - return (*ucs - *uct); - } + c1 = ((UCHAR(*cs) == 0xC0) && (UCHAR(cs[1]) == 0x80)) ? 0 : UCHAR(*cs); + c2 = ((UCHAR(*ct) == 0xC0) && (UCHAR(ct[1]) == 0x80)) ? 0 : UCHAR(*ct); + result = (c1 - c2); } - return 0; -#endif /* WORDS_BIGENDIAN */ + return result; } int @@ -3639,11 +3890,11 @@ TclStringCmp( int checkEq, /* comparison is only for equality */ int nocase, /* comparison is not case sensitive */ Tcl_Size reqlength) /* requested length in characters; - * TCL_INDEX_NONE to compare whole strings */ + * negative to compare whole strings */ { const char *s1, *s2; int empty, match; - Tcl_Size length, s1len = 0, s2len = 0; + Tcl_Size length, s1len, s2len; memCmpFn_t memCmpFn; if ((reqlength == 0) || (value1Ptr == value2Ptr)) { @@ -3662,11 +3913,11 @@ TclStringCmp( * arrays anyway, and we have no memcasecmp() for some reason... :^) */ - s1 = (char *) Tcl_GetBytesFromObj(NULL, value1Ptr, &s1len); - s2 = (char *) Tcl_GetBytesFromObj(NULL, value2Ptr, &s2len); + s1 = (char *) Tcl_GetByteArrayFromObj(value1Ptr, &s1len); + s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len); memCmpFn = memcmp; - } else if (TclHasInternalRep(value1Ptr, &tclStringType) - && TclHasInternalRep(value2Ptr, &tclStringType)) { + } else if (TclHasInternalRep(value1Ptr, &tclUniCharStringType) + && TclHasInternalRep(value2Ptr, &tclUniCharStringType)) { /* * 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 @@ -3675,12 +3926,12 @@ TclStringCmp( */ if (nocase) { - s1 = (char *) Tcl_GetUnicodeFromObj(value1Ptr, &s1len); - s2 = (char *) Tcl_GetUnicodeFromObj(value2Ptr, &s2len); - memCmpFn = UniCharNcasememcmp; + s1 = (char *) TclGetUnicodeFromObj(value1Ptr, &s1len); + s2 = (char *) TclGetUnicodeFromObj(value2Ptr, &s2len); + memCmpFn = TclUniCharNcasememcmp; } else { - s1len = Tcl_GetCharLength(value1Ptr); - s2len = Tcl_GetCharLength(value2Ptr); + s1len = TclGetCharLength(value1Ptr); + s2len = TclGetCharLength(value2Ptr); if ((s1len == value1Ptr->length) && (value1Ptr->bytes != NULL) && (s2len == value2Ptr->length) @@ -3692,8 +3943,8 @@ TclStringCmp( s2 = value2Ptr->bytes; memCmpFn = memcmp; } else { - s1 = (char *) Tcl_GetUnicode(value1Ptr); - s2 = (char *) Tcl_GetUnicode(value2Ptr); + s1 = (char *) TclGetUnicodeFromObj(value1Ptr, NULL); + s2 = (char *) TclGetUnicodeFromObj(value2Ptr, NULL); if ( #if defined(WORDS_BIGENDIAN) 1 @@ -3708,7 +3959,7 @@ TclStringCmp( reqlength *= sizeof(Tcl_UniChar); } } else { - memCmpFn = UniCharNmemcmp; + memCmpFn = TclUniCharNmemcmp; } } } @@ -3766,11 +4017,11 @@ TclStringCmp( */ if ((reqlength < 0) && !nocase) { - memCmpFn = TclpUtfNcmp2; + memCmpFn = UtfNmemcmp; } else { - s1len = Tcl_NumUtfChars(s1, s1len); - s2len = Tcl_NumUtfChars(s2, s2len); - memCmpFn = nocase ? UtfNcasememcmp : UtfNmemcmp; + s1len = TclNumUtfChars(s1, s1len); + s2len = TclNumUtfChars(s2, s2len); + memCmpFn = nocase ? TclUtfNcasememcmp : TclUtfNmemcmp; } } } @@ -3834,8 +4085,8 @@ TclStringFirst( Tcl_Obj *haystack, Tcl_Size start) { - Tcl_Size lh = 0, ln = Tcl_GetCharLength(needle); - Tcl_Size value = -1; + Tcl_Size lh, ln = TclGetCharLength(needle); + Tcl_Size value = TCL_INDEX_NONE; Tcl_UniChar *checkStr, *endStr, *uh, *un; Tcl_Obj *obj; @@ -3851,10 +4102,10 @@ TclStringFirst( if (TclIsPureByteArray(needle) && TclIsPureByteArray(haystack)) { unsigned char *end, *check, *bh; - unsigned char *bn = Tcl_GetBytesFromObj(NULL, needle, &ln); + unsigned char *bn = Tcl_GetByteArrayFromObj(needle, &ln); /* Find bytes in bytes */ - bh = Tcl_GetBytesFromObj(NULL, haystack, &lh); + bh = Tcl_GetByteArrayFromObj(haystack, &lh); if ((lh < ln) || (start > lh - ln)) { /* Don't start the loop if there cannot be a valid answer */ goto firstEnd; @@ -3897,8 +4148,8 @@ TclStringFirst( * do only the well-defined Tcl_UniChar array search. */ - un = Tcl_GetUnicodeFromObj(needle, &ln); - uh = Tcl_GetUnicodeFromObj(haystack, &lh); + un = TclGetUnicodeFromObj(needle, &ln); + uh = TclGetUnicodeFromObj(haystack, &lh); if ((lh < ln) || (start > lh - ln)) { /* Don't start the loop if there cannot be a valid answer */ goto firstEnd; @@ -3941,8 +4192,8 @@ TclStringLast( Tcl_Obj *haystack, Tcl_Size last) { - Tcl_Size lh = 0, ln = Tcl_GetCharLength(needle); - Tcl_Size value = -1; + Tcl_Size lh, ln = TclGetCharLength(needle); + Tcl_Size value = TCL_INDEX_NONE; Tcl_UniChar *checkStr, *uh, *un; Tcl_Obj *obj; @@ -3957,8 +4208,8 @@ TclStringLast( } if (TclIsPureByteArray(needle) && TclIsPureByteArray(haystack)) { - unsigned char *check, *bh = Tcl_GetBytesFromObj(NULL, haystack, &lh); - unsigned char *bn = Tcl_GetBytesFromObj(NULL, needle, &ln); + unsigned char *check, *bh = Tcl_GetByteArrayFromObj(haystack, &lh); + unsigned char *bn = Tcl_GetByteArrayFromObj(needle, &ln); if (last >= lh) { last = lh - 1; @@ -3980,8 +4231,8 @@ TclStringLast( goto lastEnd; } - uh = Tcl_GetUnicodeFromObj(haystack, &lh); - un = Tcl_GetUnicodeFromObj(needle, &ln); + uh = TclGetUnicodeFromObj(haystack, &lh); + un = TclGetUnicodeFromObj(needle, &ln); if (last >= lh) { last = lh - 1; @@ -4051,27 +4302,27 @@ TclStringReverse( Tcl_Obj *objPtr, int flags) { - String *stringPtr; + UniCharString *stringPtr; Tcl_UniChar ch = 0; int inPlace = flags & TCL_STRING_IN_PLACE; if (TclIsPureByteArray(objPtr)) { - Tcl_Size numBytes = 0; - unsigned char *from = Tcl_GetBytesFromObj(NULL, objPtr, &numBytes); + Tcl_Size numBytes; + unsigned char *from = Tcl_GetByteArrayFromObj(objPtr, &numBytes); if (!inPlace || Tcl_IsShared(objPtr)) { objPtr = Tcl_NewByteArrayObj(NULL, numBytes); } - ReverseBytes(Tcl_GetBytesFromObj(NULL, objPtr, (Tcl_Size *)NULL), from, numBytes); + ReverseBytes(Tcl_GetByteArrayFromObj(objPtr, (Tcl_Size *)NULL), from, numBytes); return objPtr; } SetStringFromAny(NULL, objPtr); - stringPtr = GET_STRING(objPtr); + stringPtr = GET_UNICHAR_STRING(objPtr); if (stringPtr->hasUnicode) { - Tcl_UniChar *from = Tcl_GetUnicode(objPtr); - stringPtr = GET_STRING(objPtr); + Tcl_UniChar *from = TclGetUnicodeFromObj(objPtr, NULL); + stringPtr = GET_UNICHAR_STRING(objPtr); Tcl_UniChar *src = from + stringPtr->numChars; Tcl_UniChar *to; @@ -4081,10 +4332,10 @@ TclStringReverse( * Tcl_SetObjLength into growing the Unicode rep buffer. */ - objPtr = Tcl_NewUnicodeObj(&ch, 1); + objPtr = TclNewUnicodeObj(&ch, 1); Tcl_SetObjLength(objPtr, stringPtr->numChars); - to = Tcl_GetUnicode(objPtr); - stringPtr = GET_STRING(objPtr); + to = TclGetUnicodeFromObj(objPtr, NULL); + stringPtr = GET_UNICHAR_STRING(objPtr); while (--src >= from) { *to++ = *src; } @@ -4208,8 +4459,8 @@ TclStringReplace( */ if (TclIsPureByteArray(objPtr)) { - Tcl_Size numBytes = 0; - unsigned char *bytes = Tcl_GetBytesFromObj(NULL, objPtr, &numBytes); + Tcl_Size numBytes; + unsigned char *bytes = Tcl_GetByteArrayFromObj(objPtr, &numBytes); if (insertPtr == NULL) { /* Replace something with nothing. */ @@ -4231,9 +4482,9 @@ TclStringReplace( } if (TclIsPureByteArray(insertPtr)) { - Tcl_Size newBytes = 0; + Tcl_Size newBytes; unsigned char *iBytes - = Tcl_GetBytesFromObj(NULL, insertPtr, &newBytes); + = Tcl_GetByteArrayFromObj(insertPtr, &newBytes); if (count == newBytes && inPlace && !Tcl_IsShared(objPtr)) { /* @@ -4277,16 +4528,16 @@ TclStringReplace( /* The traditional implementation... */ { Tcl_Size numChars; - Tcl_UniChar *ustring = Tcl_GetUnicodeFromObj(objPtr, &numChars); + Tcl_UniChar *ustring = TclGetUnicodeFromObj(objPtr, &numChars); /* TODO: Is there an in-place option worth pursuing here? */ - result = Tcl_NewUnicodeObj(ustring, first); + result = TclNewUnicodeObj(ustring, first); if (insertPtr) { Tcl_AppendObjToObj(result, insertPtr); } if ((first + count) < numChars) { - Tcl_AppendUnicodeToObj(result, ustring + first + count, + TclAppendUnicodeToObj(result, ustring + first + count, numChars - first - count); } @@ -4316,7 +4567,7 @@ FillUnicodeRep( Tcl_Obj *objPtr) /* The object in which to fill the unicode * rep. */ { - String *stringPtr = GET_STRING(objPtr); + UniCharString *stringPtr = GET_UNICHAR_STRING(objPtr); ExtendUnicodeRepWithString(objPtr, objPtr->bytes, objPtr->length, stringPtr->numChars); @@ -4329,21 +4580,22 @@ ExtendUnicodeRepWithString( Tcl_Size numBytes, Tcl_Size numAppendChars) { - String *stringPtr = GET_STRING(objPtr); + UniCharString *stringPtr = GET_UNICHAR_STRING(objPtr); Tcl_Size needed, numOrigChars = 0; Tcl_UniChar *dst, unichar = 0; if (stringPtr->hasUnicode) { numOrigChars = stringPtr->numChars; } - if (numAppendChars == TCL_INDEX_NONE) { + if (numAppendChars < 0) { TclNumUtfCharsM(numAppendChars, bytes, numBytes); } needed = numOrigChars + numAppendChars; + uniCharStringCheckLimits(needed); if (needed > stringPtr->maxChars) { GrowUnicodeBuffer(objPtr, needed); - stringPtr = GET_STRING(objPtr); + stringPtr = GET_UNICHAR_STRING(objPtr); } stringPtr->hasUnicode = 1; @@ -4355,6 +4607,12 @@ ExtendUnicodeRepWithString( dst = stringPtr->unicode + numOrigChars; if (numAppendChars-- > 0) { bytes += TclUtfToUniChar(bytes, &unichar); + /* join upper/lower surrogate */ + if (bytes && (stringPtr->unicode[numOrigChars - 1] | 0x3FF) == 0xDBFF && (unichar | 0x3FF) == 0xDFFF) { + stringPtr->numChars--; + unichar = ((stringPtr->unicode[numOrigChars - 1] & 0x3FF) << 10) + (unichar & 0x3FF) + 0x10000; + dst--; + } *dst++ = unichar; while (numAppendChars-- > 0) { bytes += TclUtfToUniChar(bytes, &unichar); @@ -4389,8 +4647,8 @@ DupStringInternalRep( Tcl_Obj *copyPtr) /* Object with internal rep to set. Must not * currently have an internal rep.*/ { - String *srcStringPtr = GET_STRING(srcPtr); - String *copyStringPtr = NULL; + UniCharString *srcStringPtr = GET_UNICHAR_STRING(srcPtr); + UniCharString *copyStringPtr = NULL; if (srcStringPtr->numChars == TCL_INDEX_NONE) { /* @@ -4409,17 +4667,17 @@ DupStringInternalRep( } else { copyMaxChars = srcStringPtr->maxChars; } - copyStringPtr = stringAttemptAlloc(copyMaxChars); + copyStringPtr = uniCharStringAttemptAlloc(copyMaxChars); if (copyStringPtr == NULL) { copyMaxChars = srcStringPtr->numChars; - copyStringPtr = stringAlloc(copyMaxChars); + copyStringPtr = uniCharStringAlloc(copyMaxChars); } copyStringPtr->maxChars = copyMaxChars; memcpy(copyStringPtr->unicode, srcStringPtr->unicode, srcStringPtr->numChars * sizeof(Tcl_UniChar)); copyStringPtr->unicode[srcStringPtr->numChars] = 0; } else { - copyStringPtr = stringAlloc(0); + copyStringPtr = uniCharStringAlloc(0); copyStringPtr->maxChars = 0; copyStringPtr->unicode[0] = 0; } @@ -4434,8 +4692,8 @@ DupStringInternalRep( copyStringPtr->allocated = copyPtr->bytes ? copyPtr->length : 0; - SET_STRING(copyPtr, copyStringPtr); - copyPtr->typePtr = &tclStringType; + SET_UNICHAR_STRING(copyPtr, copyStringPtr); + copyPtr->typePtr = &tclUniCharStringType; } /* @@ -4460,8 +4718,8 @@ SetStringFromAny( TCL_UNUSED(Tcl_Interp *), Tcl_Obj *objPtr) /* The object to convert. */ { - if (!TclHasInternalRep(objPtr, &tclStringType)) { - String *stringPtr = stringAlloc(0); + if (!TclHasInternalRep(objPtr, &tclUniCharStringType)) { + UniCharString *stringPtr = uniCharStringAlloc(0); /* * Convert whatever we have into an untyped value. Just A String. @@ -4479,8 +4737,8 @@ SetStringFromAny( stringPtr->allocated = objPtr->length; stringPtr->maxChars = 0; stringPtr->hasUnicode = 0; - SET_STRING(objPtr, stringPtr); - objPtr->typePtr = &tclStringType; + SET_UNICHAR_STRING(objPtr, stringPtr); + objPtr->typePtr = &tclUniCharStringType; } return TCL_OK; } @@ -4507,7 +4765,7 @@ static void UpdateStringOfString( Tcl_Obj *objPtr) /* Object with string rep to update. */ { - String *stringPtr = GET_STRING(objPtr); + UniCharString *stringPtr = GET_UNICHAR_STRING(objPtr); /* * This routine is only called when we need to generate the @@ -4539,7 +4797,7 @@ ExtendStringRepWithUnicode( Tcl_Size i, origLength, size = 0; char *dst; - String *stringPtr = GET_STRING(objPtr); + UniCharString *stringPtr = GET_UNICHAR_STRING(objPtr); if (numChars < 0) { numChars = UnicodeLength(unicode); @@ -4564,7 +4822,6 @@ ExtendStringRepWithUnicode( } for (i = 0; i < numChars && size >= 0; i++) { - /* TODO - overflow check! I don't think check below at end suffices */ size += TclUtfCount(unicode[i]); } if (size < 0) { @@ -4582,7 +4839,13 @@ ExtendStringRepWithUnicode( copyBytes: dst = objPtr->bytes + origLength; for (i = 0; i < numChars; i++) { + if (LOW_SURROGATE(unicode[i]) && ((i == 0) || !HIGH_SURROGATE(unicode[i-1]))) { + *dst = 0; /* In case of lower surrogate, don't try to combine */ + } dst += Tcl_UniCharToUtf(unicode[i], dst); + if (HIGH_SURROGATE(unicode[i]) && ((i+1 >= numChars) || !LOW_SURROGATE(unicode[i+1]))) { + dst += Tcl_UniCharToUtf(-1, dst); + } } *dst = '\0'; objPtr->length = dst - objPtr->bytes; @@ -4594,7 +4857,7 @@ ExtendStringRepWithUnicode( * * FreeStringInternalRep -- * - * Deallocate the storage associated with a String data object's internal + * Deallocate the storage associated with a (UniChar)String data object's internal * representation. * * Results: @@ -4610,7 +4873,7 @@ static void FreeStringInternalRep( Tcl_Obj *objPtr) /* Object with internal rep to free. */ { - Tcl_Free(GET_STRING(objPtr)); + ckfree(GET_STRING(objPtr)); objPtr->typePtr = NULL; } diff --git a/generic/tclStringRep.h b/generic/tclStringRep.h index 4e38a64..aee378d 100644 --- a/generic/tclStringRep.h +++ b/generic/tclStringRep.h @@ -6,7 +6,7 @@ * * Conceptually, a string is a sequence of Unicode code points. Internally * it may be stored in an encoding form such as a modified version of UTF-8 - * or UTF-32. + * or UTF-16 (when TCL_UTF_MAX=3) or UTF-32. * * Copyright (c) 1995-1997 Sun Microsystems, Inc. * Copyright (c) 1999 by Scriptics Corporation. @@ -42,25 +42,31 @@ typedef struct { * space allocated for the Unicode array. */ int hasUnicode; /* Boolean determining whether the string has * a Tcl_UniChar representation. */ - Tcl_UniChar unicode[TCLFLEXARRAY]; /* The array of Tcl_UniChar units. + unsigned short unicode[TCLFLEXARRAY]; /* The array of Tcl_UniChar units. * The actual size of this field depends on * the maxChars field above. */ } String; /* Limit on string lengths. The -1 because limit does not include the nul */ #define STRING_MAXCHARS \ - ((Tcl_Size)((TCL_SIZE_MAX - offsetof(String, unicode))/sizeof(Tcl_UniChar) - 1)) -/* Memory needed to hold a string of length numChars - including NUL */ + (Tcl_Size)(((size_t)UINT_MAX - offsetof(String, unicode))/sizeof(unsigned short) - 1) #define STRING_SIZE(numChars) \ - (offsetof(String, unicode) + sizeof(Tcl_UniChar) + ((numChars) * sizeof(Tcl_UniChar))) + (offsetof(String, unicode) + sizeof(unsigned short) + ((numChars) * sizeof(unsigned short))) +#define stringCheckLimits(numChars) \ + do { \ + if ((numChars) < 0 || (numChars) > STRING_MAXCHARS) { \ + Tcl_Panic("max length for a Tcl unicode value (%d chars) exceeded", \ + STRING_MAXCHARS); \ + } \ + } while (0) #define stringAttemptAlloc(numChars) \ - (String *) Tcl_AttemptAlloc(STRING_SIZE(numChars)) + (String *) attemptckalloc(STRING_SIZE(numChars)) #define stringAlloc(numChars) \ - (String *) Tcl_Alloc(STRING_SIZE(numChars)) + (String *) ckalloc(STRING_SIZE(numChars)) #define stringRealloc(ptr, numChars) \ - (String *) Tcl_Realloc((ptr), STRING_SIZE(numChars)) + (String *) ckrealloc((ptr), STRING_SIZE(numChars)) #define stringAttemptRealloc(ptr, numChars) \ - (String *) Tcl_AttemptRealloc((ptr), STRING_SIZE(numChars)) + (String *) attemptckrealloc((ptr), STRING_SIZE(numChars)) #define GET_STRING(objPtr) \ ((String *) (objPtr)->internalRep.twoPtrValue.ptr1) #define SET_STRING(objPtr, stringPtr) \ diff --git a/generic/tclStubCall.c b/generic/tclStubCall.c deleted file mode 100644 index 29af44c..0000000 --- a/generic/tclStubCall.c +++ /dev/null @@ -1,117 +0,0 @@ -/* - * tclStubCall.c -- - * - * See the file "license.terms" for information on usage and redistribution of - * this file, and for a DISCLAIMER OF ALL WARRANTIES. - */ - -#include "tclInt.h" -#ifndef _WIN32 -# include <dlfcn.h> -#else -# define dlopen(a,b) (void *)LoadLibraryW(JOIN(L,a)) -# define dlsym(a,b) (void *)GetProcAddress((HMODULE)(a),b) -# define dlerror() "" -#endif - -MODULE_SCOPE void *tclStubsHandle; - -/* - *---------------------------------------------------------------------- - * - * TclStubCall -- - * - * Load the Tcl core dynamically, version "9.0" (or higher, in future versions). - * - * Results: - * Returns a function from the Tcl dynamic library or a function - * returning NULL if that function cannot be found. See PROCNAME table. - * - * The functions Tcl_MainEx and Tcl_MainExW never return. - * Tcl_GetMemoryInfo and Tcl_StaticLibrary return (void), - * Tcl_SetExitProc returns its previous exitProc and - * Tcl_SetPreInitScript returns the previous script. This means that - * those 6 functions cannot be used to initialize the stub-table, - * only the first 4 functions in the table can do that. - * - *---------------------------------------------------------------------- - */ - -/* Table containing which function will be returned, depending on the "arg" */ -static const char PROCNAME[][24] = { - "_Tcl_SetPanicProc", /* Default, whenever "arg" <= 0 or "arg" > 9 */ - "_Tcl_InitSubsystems", /* "arg" == (void *)1 */ - "_Tcl_FindExecutable", /* "arg" == (void *)2 */ - "_TclZipfs_AppHook", /* "arg" == (void *)3 */ - "_Tcl_MainExW", /* "arg" == (void *)4 */ - "_Tcl_MainEx", /* "arg" == (void *)5 */ - "_Tcl_StaticLibrary", /* "arg" == (void *)6 */ - "_Tcl_SetExitProc", /* "arg" == (void *)7 */ - "_Tcl_GetMemoryInfo", /* "arg" == (void *)8 */ - "_Tcl_SetPreInitScript" /* "arg" == (void *)9 */ -}; - -MODULE_SCOPE const void *nullVersionProc(void) { - return NULL; -} - -static const char CANNOTCALL[] = "Cannot call %s from stubbed extension\n"; -static const char CANNOTFIND[] = "Cannot find %s: %s\n"; - -MODULE_SCOPE void * -TclStubCall(void *arg) -{ - static void *stubFn[] = {NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL,NULL}; - size_t index = PTR2UINT(arg); - - if (index >= sizeof(PROCNAME)/sizeof(PROCNAME[0])) { - /* Any other value means Tcl_SetPanicProc() with non-null panicProc */ - index = 0; - } - if (tclStubsHandle == INT2PTR(-1)) { - if ((index == 0) && (arg != NULL)) { - ((Tcl_PanicProc *)arg)(CANNOTCALL, PROCNAME[index] + 1); - } else { - fprintf(stderr, CANNOTCALL, PROCNAME[index] + 1); - abort(); - } - } - if (!stubFn[index]) { - if (!tclStubsHandle) { - tclStubsHandle = dlopen(CFG_RUNTIME_DLLFILE, RTLD_NOW|RTLD_LOCAL); - if (!tclStubsHandle) { -#if defined(_WIN32) - tclStubsHandle = dlopen(CFG_RUNTIME_BINDIR "\\" CFG_RUNTIME_DLLFILE, RTLD_NOW|RTLD_LOCAL); -#elif defined(__CYGWIN__) - tclStubsHandle = dlopen(CFG_RUNTIME_BINDIR "/" CFG_RUNTIME_DLLFILE, RTLD_NOW|RTLD_LOCAL); -#else - tclStubsHandle = dlopen(CFG_RUNTIME_LIBDIR "/" CFG_RUNTIME_DLLFILE, RTLD_NOW|RTLD_LOCAL); -#endif - } - if (!tclStubsHandle) { - if ((index == 0) && (arg != NULL)) { - ((Tcl_PanicProc *)arg)(CANNOTFIND, CFG_RUNTIME_DLLFILE, dlerror()); - } else { - fprintf(stderr, CANNOTFIND, CFG_RUNTIME_DLLFILE, dlerror()); - abort(); - } - } - } - stubFn[index] = dlsym(tclStubsHandle, PROCNAME[index] + 1); - if (!stubFn[index]) { - stubFn[index] = dlsym(tclStubsHandle, PROCNAME[index]); - if (!stubFn[index]) { - stubFn[index] = (void *)nullVersionProc; - } - } - } - return stubFn[index]; -} - -/* - * Local Variables: - * mode: c - * c-basic-offset: 4 - * fill-column: 78 - * End: - */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 90501ff..1ac6801 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -28,6 +28,8 @@ */ #undef Tcl_Alloc +#undef Tcl_AttemptAlloc +#undef Tcl_AttemptRealloc #undef Tcl_Free #undef Tcl_Realloc #undef Tcl_NewBooleanObj @@ -41,8 +43,13 @@ #undef Tcl_NewStringObj #undef Tcl_GetUnicode #undef Tcl_GetUnicodeFromObj +#undef Tcl_AppendUnicodeToObj #undef Tcl_NewUnicodeObj #undef Tcl_SetUnicodeObj +#undef Tcl_UniCharNcasecmp +#undef Tcl_UniCharCaseMatch +#undef Tcl_UniCharLen +#undef Tcl_UniCharNcmp #undef Tcl_DumpActiveMemory #undef Tcl_ValidateAllMemory #undef Tcl_FindHashEntry @@ -55,181 +62,96 @@ #undef TclSockMinimumBuffers #undef Tcl_SetIntObj #undef Tcl_SetLongObj -#undef Tcl_ListObjGetElements -#undef Tcl_ListObjLength -#undef Tcl_DictObjSize -#undef Tcl_SplitList -#undef Tcl_SplitPath -#undef Tcl_FSSplitPath -#undef Tcl_ParseArgsObjv +#undef TclpInetNtoa +#undef TclWinGetServByName +#undef TclWinGetSockOpt +#undef TclWinSetSockOpt +#undef TclWinNToHS #undef TclStaticLibrary +#undef Tcl_BackgroundError +#undef TclGuessPackageName +#undef TclGetLoadedPackages #define TclStaticLibrary Tcl_StaticLibrary +#undef Tcl_UniCharToUtfDString +#undef Tcl_UtfToUniCharDString +#undef Tcl_UtfToUniChar +#undef Tcl_MacOSXOpenBundleResources +#undef TclWinConvertWSAError +#undef TclWinConvertError #undef TclObjInterpProc -#if !defined(_WIN32) && !defined(__CYGWIN__) -# undef Tcl_WinConvertError -# define Tcl_WinConvertError 0 -#endif -#undef TclGetStringFromObj -#if defined(TCL_NO_DEPRECATED) -# define TclGetStringFromObj 0 -# define TclGetBytesFromObj 0 -# define TclGetUnicodeFromObj 0 + +#if defined(_WIN32) || defined(__CYGWIN__) +#define TclWinConvertWSAError (void (*)(DWORD))(void *)Tcl_WinConvertError +#define TclWinConvertError (void (*)(DWORD))(void *)Tcl_WinConvertError #endif -#undef Tcl_Close -#define Tcl_Close 0 -#undef Tcl_GetByteArrayFromObj -#define Tcl_GetByteArrayFromObj 0 -#define TclUnusedStubEntry 0 -#define TclUtfCharComplete Tcl_UtfCharComplete -#define TclUtfNext Tcl_UtfNext -#define TclUtfPrev Tcl_UtfPrev -#undef TclListObjGetElements -#undef TclListObjLength + #if defined(TCL_NO_DEPRECATED) -# define TclListObjGetElements 0 -# define TclListObjLength 0 -# define TclDictObjSize 0 -# define TclSplitList 0 -# define TclSplitPath 0 -# define TclFSSplitPath 0 -# define TclParseArgsObjv 0 -# define TclGetAliasObj 0 -#else /* !defined(TCL_NO_DEPRECATED) */ -int TclListObjGetElements(Tcl_Interp *interp, Tcl_Obj *listPtr, - void *objcPtr, Tcl_Obj ***objvPtr) { - Tcl_Size n = TCL_INDEX_NONE; - int result = Tcl_ListObjGetElements(interp, listPtr, &n, objvPtr); - if (objcPtr) { - if ((sizeof(int) != sizeof(Tcl_Size)) && (result == TCL_OK) && (n > INT_MAX)) { - if (interp) { - Tcl_AppendResult(interp, "List too large to be processed", (void *)NULL); - } - return TCL_ERROR; - } - *(int *)objcPtr = (int)n; - } - return result; +static void uniCodePanic(void) { + Tcl_Panic("Tcl is compiled without the the UTF16 compatibility layer (-DTCL_NO_DEPRECATED)"); } -int TclListObjLength(Tcl_Interp *interp, Tcl_Obj *listPtr, - void *lengthPtr) { - Tcl_Size n = TCL_INDEX_NONE; - int result = Tcl_ListObjLength(interp, listPtr, &n); - if (lengthPtr) { - if ((sizeof(int) != sizeof(Tcl_Size)) && (result == TCL_OK) && (n > INT_MAX)) { - if (interp) { - Tcl_AppendResult(interp, "List too large to be processed", (void *)NULL); - } - return TCL_ERROR; - } - *(int *)lengthPtr = (int)n; - } - return result; -} -int TclDictObjSize(Tcl_Interp *interp, Tcl_Obj *dictPtr, - void *sizePtr) { - Tcl_Size n = TCL_INDEX_NONE; - int result = Tcl_DictObjSize(interp, dictPtr, &n); - if (sizePtr) { - if ((sizeof(int) != sizeof(Tcl_Size)) && (result == TCL_OK) && (n > INT_MAX)) { - if (interp) { - Tcl_AppendResult(interp, "Dict too large to be processed", (void *)NULL); - } - return TCL_ERROR; - } - *(int *)sizePtr = (int)n; - } - return result; -} -int TclSplitList(Tcl_Interp *interp, const char *listStr, void *argcPtr, - const char ***argvPtr) { - Tcl_Size n = TCL_INDEX_NONE; - int result = Tcl_SplitList(interp, listStr, &n, argvPtr); - if (argcPtr) { - if ((sizeof(int) != sizeof(Tcl_Size)) && (result == TCL_OK) && (n > INT_MAX)) { - if (interp) { - Tcl_AppendResult(interp, "List too large to be processed", (void *)NULL); - } - Tcl_Free((void *)*argvPtr); - return TCL_ERROR; - } - *(int *)argcPtr = (int)n; - } - return result; -} -void TclSplitPath(const char *path, void *argcPtr, const char ***argvPtr) { - Tcl_Size n = TCL_INDEX_NONE; - Tcl_SplitPath(path, &n, argvPtr); - if (argcPtr) { - if ((sizeof(int) != sizeof(Tcl_Size)) && (n > INT_MAX)) { - n = TCL_INDEX_NONE; /* No other way to return an error-situation */ - Tcl_Free((void *)*argvPtr); - *argvPtr = NULL; - } - *(int *)argcPtr = (int)n; +# define Tcl_GetUnicode (unsigned short *(*)(Tcl_Obj *))(void *)uniCodePanic +# define Tcl_GetUnicodeFromObj (unsigned short *(*)(Tcl_Obj *, int *))(void *)uniCodePanic +# define Tcl_NewUnicodeObj (Tcl_Obj *(*)(const unsigned short *, int))(void *)uniCodePanic +# define Tcl_SetUnicodeObj (void(*)(Tcl_Obj *, const unsigned short *, int))(void *)uniCodePanic +# define Tcl_AppendUnicodeToObj (void(*)(Tcl_Obj *, const unsigned short *, int))(void *)uniCodePanic +# define Tcl_UtfAtIndex (const char *(*)(const char *, int))(void *)uniCodePanic +# define Tcl_GetCharLength (int(*)(Tcl_Obj *))(void *)uniCodePanic +# define Tcl_UniCharNcmp (int(*)(const unsigned short *, const unsigned short *, unsigned long))(void *)uniCodePanic +# define Tcl_UniCharNcasecmp (int(*)(const unsigned short *, const unsigned short *, unsigned long))(void *)uniCodePanic +# define Tcl_UniCharCaseMatch (int(*)(const unsigned short *, const unsigned short *, int))(void *)uniCodePanic +# define Tcl_GetRange (Tcl_Obj *(*)(Tcl_Obj *, int, int))(void *)uniCodePanic +# define Tcl_GetUniChar (int(*)(Tcl_Obj *, int))(void *)uniCodePanic +# define Tcl_NumUtfChars (int(*)(const char *, int))(void *)uniCodePanic +# define Tcl_UtfNcmp (int(*)(const char *, const char *, unsigned long))(void *)uniCodePanic +# define Tcl_UtfNcasecmp (int(*)(const char *, const char *, unsigned long))(void *)uniCodePanic +#endif + +#define TclUtfCharComplete UtfCharComplete +#define TclUtfNext UtfNext +#define TclUtfPrev UtfPrev + +static int TclUtfCharComplete(const char *src, int length) { + if ((unsigned)((unsigned char)*(src) - 0xF0) < 5) { + return length < 3; } + return Tcl_UtfCharComplete(src, length); } -Tcl_Obj *TclFSSplitPath(Tcl_Obj *pathPtr, void *lenPtr) { - Tcl_Size n = TCL_INDEX_NONE; - Tcl_Obj *result = Tcl_FSSplitPath(pathPtr, &n); - if (lenPtr) { - if ((sizeof(int) != sizeof(Tcl_Size)) && result && (n > INT_MAX)) { - Tcl_DecrRefCount(result); - return NULL; - } - *(int *)lenPtr = (int)n; + +static const char *TclUtfNext(const char *src) { + if ((unsigned)((unsigned char)*(src) - 0xF0) < 5) { + return src + 1; } - return result; + return Tcl_UtfNext(src); } -int TclParseArgsObjv(Tcl_Interp *interp, - const Tcl_ArgvInfo *argTable, void *objcPtr, Tcl_Obj *const *objv, - Tcl_Obj ***remObjv) { - Tcl_Size n = (*(int *)objcPtr < 0) ? TCL_INDEX_NONE: (Tcl_Size)*(int *)objcPtr ; - int result = Tcl_ParseArgsObjv(interp, argTable, &n, objv, remObjv); - *(int *)objcPtr = (int)n; - return result; -} -int TclGetAliasObj(Tcl_Interp *interp, const char *childCmd, - Tcl_Interp **targetInterpPtr, const char **targetCmdPtr, - int *objcPtr, Tcl_Obj ***objv) { - Tcl_Size n = TCL_INDEX_NONE; - int result = Tcl_GetAliasObj(interp, childCmd, targetInterpPtr, targetCmdPtr, &n, objv); - if (objcPtr) { - if ((sizeof(int) != sizeof(Tcl_Size)) && (result == TCL_OK) && (n > INT_MAX)) { - if (interp) { - Tcl_AppendResult(interp, "List too large to be processed", NULL); - } - return TCL_ERROR; - } - *objcPtr = (int)n; + +static const char *TclUtfPrev(const char *src, const char *start) { + if ((src >= start + 3) && ((src[-1] & 0xC0) == 0x80) + && ((src[-2] & 0xC0) == 0x80) && ((src[-3] & 0xC0) == 0x80)) { + return src - 3; } - return result; + return Tcl_UtfPrev(src, start); } -#endif /* !defined(TCL_NO_DEPRECATED) */ #define TclBN_mp_add mp_add -#define TclBN_mp_add_d mp_add_d #define TclBN_mp_and mp_and #define TclBN_mp_clamp mp_clamp #define TclBN_mp_clear mp_clear #define TclBN_mp_clear_multi mp_clear_multi #define TclBN_mp_cmp mp_cmp -#define TclBN_mp_cmp_d mp_cmp_d #define TclBN_mp_cmp_mag mp_cmp_mag #define TclBN_mp_cnt_lsb mp_cnt_lsb #define TclBN_mp_copy mp_copy #define TclBN_mp_count_bits mp_count_bits #define TclBN_mp_div mp_div -#define TclBN_mp_div_d mp_div_d #define TclBN_mp_div_2 mp_div_2 #define TclBN_mp_div_2d mp_div_2d #define TclBN_mp_exch mp_exch -#define TclBN_mp_get_mag_u64 mp_get_mag_u64 +#define TclBN_mp_get_mag_ull mp_get_mag_u64 #define TclBN_mp_grow mp_grow #define TclBN_mp_init mp_init #define TclBN_mp_init_copy mp_init_copy #define TclBN_mp_init_multi mp_init_multi -#define TclBN_mp_init_set mp_init_set #define TclBN_mp_init_size mp_init_size #define TclBN_mp_init_i64 mp_init_i64 #define TclBN_mp_init_u64 mp_init_u64 @@ -237,7 +159,6 @@ int TclGetAliasObj(Tcl_Interp *interp, const char *childCmd, #define TclBN_mp_mod mp_mod #define TclBN_mp_mod_2d mp_mod_2d #define TclBN_mp_mul mp_mul -#define TclBN_mp_mul_d mp_mul_d #define TclBN_mp_mul_2 mp_mul_2 #define TclBN_mp_mul_2d mp_mul_2d #define TclBN_mp_neg mp_neg @@ -245,46 +166,293 @@ int TclGetAliasObj(Tcl_Interp *interp, const char *childCmd, #define TclBN_mp_pack mp_pack #define TclBN_mp_pack_count mp_pack_count #define TclBN_mp_radix_size mp_radix_size +#define TclBN_mp_reverse mp_reverse #define TclBN_mp_read_radix mp_read_radix #define TclBN_mp_rshd mp_rshd -#define TclBN_mp_set_i64 mp_set_i64 -#define TclBN_mp_set_u64 mp_set_u64 +#define TclBN_mp_set_ll mp_set_i64 +#define TclBN_mp_set_ull mp_set_u64 #define TclBN_mp_shrink mp_shrink #define TclBN_mp_sqr mp_sqr #define TclBN_mp_sqrt mp_sqrt #define TclBN_mp_sub mp_sub -#define TclBN_mp_sub_d mp_sub_d #define TclBN_mp_signed_rsh mp_signed_rsh +#define TclBN_mp_tc_and TclBN_mp_and +#define TclBN_mp_tc_div_2d mp_signed_rsh +#define TclBN_mp_tc_or TclBN_mp_or +#define TclBN_mp_tc_xor TclBN_mp_xor #define TclBN_mp_to_radix mp_to_radix #define TclBN_mp_to_ubin mp_to_ubin -#define TclBN_mp_ubin_size mp_ubin_size +#define TclBN_mp_unsigned_bin_size mp_ubin_size #define TclBN_mp_unpack mp_unpack #define TclBN_mp_xor mp_xor #define TclBN_mp_zero mp_zero #define TclBN_s_mp_add s_mp_add -#define TclBN_mp_balance_mul s_mp_balance_mul -#define TclBN_mp_div_3 s_mp_div_3 +#define TclBN_s_mp_balance_mul s_mp_balance_mul +#define TclBN_s_mp_div_3 s_mp_div_3 #define TclBN_mp_karatsuba_mul s_mp_karatsuba_mul #define TclBN_mp_karatsuba_sqr s_mp_karatsuba_sqr -#define TclBN_mp_mul_digs s_mp_mul_digs -#define TclBN_mp_mul_digs_fast s_mp_mul_digs_fast -#define TclBN_mp_reverse s_mp_reverse +#define TclBN_s_mp_mul_digs s_mp_mul_digs +#define TclBN_fast_s_mp_mul_digs s_mp_mul_digs_fast +#define TclBN_s_mp_reverse s_mp_reverse #define TclBN_s_mp_sqr s_mp_sqr -#define TclBN_mp_sqr_fast s_mp_sqr_fast +#define TclBN_fast_s_mp_sqr s_mp_sqr_fast #define TclBN_s_mp_sub s_mp_sub #define TclBN_mp_toom_mul s_mp_toom_mul #define TclBN_mp_toom_sqr s_mp_toom_sqr +#define TclUnusedStubEntry 0 -#ifndef MAC_OSX_TCL /* On UNIX, fill with other stub entries */ -# define Tcl_MacOSXOpenVersionedBundleResources 0 -# define Tcl_MacOSXNotifierAddRunLoopMode 0 +/* See bug 510001: TclSockMinimumBuffers needs plat imp */ +#if defined(_WIN64) || defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 +# define TclSockMinimumBuffersOld 0 +#else +#define TclSockMinimumBuffersOld sockMinimumBuffersOld +static int TclSockMinimumBuffersOld(int sock, int size) +{ + return TclSockMinimumBuffers(INT2PTR(sock), size); +} #endif -#ifdef _WIN32 -# define Tcl_CreateFileHandler 0 -# define Tcl_DeleteFileHandler 0 -# define Tcl_GetOpenFile 0 + +mp_err TclBN_mp_set_int(mp_int *a, unsigned long i) +{ + TclBN_mp_set_ull(a, i); + return MP_OKAY; +} + +static mp_err TclBN_mp_set_long(mp_int *a, unsigned long i) +{ + TclBN_mp_set_ull(a, i); + return MP_OKAY; +} + +#define TclBN_mp_set_ul (void (*)(mp_int *a, unsigned long i))(void *)TclBN_mp_set_long + +mp_err MP_WUR TclBN_mp_expt_u32(const mp_int *a, unsigned int b, mp_int *c) { + return TclBN_mp_expt_d(a, b, c); +} +mp_err TclBN_mp_add_d(const mp_int *a, unsigned int b, mp_int *c) { + return mp_add_d(a, b, c); +} +mp_err TclBN_mp_cmp_d(const mp_int *a, unsigned int b) { + return mp_cmp_d(a, b); +} +mp_err TclBN_mp_sub_d(const mp_int *a, unsigned int b, mp_int *c) { + return mp_sub_d(a, b, c); +} +mp_err TclBN_mp_div_d(const mp_int *a, unsigned int b, mp_int *c, unsigned int *d) { + mp_digit d2; + mp_err result = mp_div_d(a, b, c, (d ? &d2 : NULL)); + if (d) { + *d = d2; + } + return result; +} +mp_err TclBN_mp_div_ld(const mp_int *a, uint64_t b, mp_int *c, uint64_t *d) { + mp_err result; + mp_digit d2; + + if ((b | (mp_digit)-1) != (mp_digit)-1) { + return MP_VAL; + } + result = mp_div_d(a, (mp_digit)b, c, (d ? &d2 : NULL)); + if (d) { + *d = d2; + } + return result; +} +mp_err TclBN_mp_init_set(mp_int *a, unsigned int b) { + return mp_init_set(a, b); +} +mp_err TclBN_mp_mul_d(const mp_int *a, unsigned int b, mp_int *c) { + return mp_mul_d(a, b, c); +} + +#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 +# define TclBN_mp_expt_d_ex 0 +# define TclBN_mp_to_unsigned_bin 0 +# define TclBN_mp_to_unsigned_bin_n 0 +# define TclBN_mp_toradix_n 0 +# undef TclBN_mp_sqr +# define TclBN_mp_sqr 0 +# define TclBN_mp_div_3 0 +# define TclBN_mp_init_l 0 +# define TclBN_mp_init_set_int 0 +# define TclBN_mp_set 0 +# 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 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 +# define Tcl_FreeResult 0 +# define Tcl_ChannelSeekProc 0 +# define Tcl_ChannelCloseProc 0 +# define Tcl_Close 0 +# define Tcl_MacOSXOpenBundleResources 0 +# define TclGuessPackageName 0 +# define TclGetLoadedPackages 0 +# undef TclSetPreInitScript +# define TclSetPreInitScript 0 +# define TclInitCompiledLocals 0 +# define Tcl_GetAlias 0 #else -# define TclpIsAtty isatty + +#define TclGuessPackageName guessPackageName +static int TclGuessPackageName( + TCL_UNUSED(const char *), + TCL_UNUSED(Tcl_DString *)) { + return 0; +} +#define TclGetLoadedPackages getLoadedPackages +static int TclGetLoadedPackages( + 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. */ +{ + return TclGetLoadedLibraries(interp, targetName, NULL); +} + +mp_err TclBN_mp_div_3(const mp_int *a, mp_int *c, unsigned int *d) { + mp_digit d2; + mp_err result = mp_div_d(a, 3, c, &d2); + if (d) { + *d = d2; + } + return result; +} + +int TclBN_mp_expt_d_ex(const mp_int *a, unsigned int b, mp_int *c, + TCL_UNUSED(int) /*fast*/) +{ + return TclBN_mp_expt_u32(a, b, c); +} + +mp_err TclBN_mp_to_unsigned_bin(const mp_int *a, unsigned char *b) +{ + return TclBN_mp_to_ubin(a, b, INT_MAX, NULL); +} + +mp_err TclBN_mp_to_unsigned_bin_n(const mp_int *a, unsigned char *b, unsigned long *outlen) +{ + size_t n = TclBN_mp_unsigned_bin_size(a); + if (*outlen < (unsigned long)n) { + return MP_VAL; + } + *outlen = (unsigned long)n; + return TclBN_mp_to_ubin(a, b, n, NULL); +} + +void TclBN_reverse(unsigned char *s, int len) +{ + if (len > 0) { + TclBN_s_mp_reverse(s, (size_t)len); + } +} + +mp_err TclBN_mp_init_set_int(mp_int *a, unsigned long b) +{ + return TclBN_mp_init_u64(a,b); +} + +mp_err TclBN_mp_init_l(mp_int *a, long b) +{ + return TclBN_mp_init_i64(a,b); +} + +void TclBN_mp_set(mp_int *a, unsigned int b) { + TclBN_mp_set_ull(a, b); +} + +mp_err TclBN_mp_toradix_n(const mp_int *a, char *str, int radix, int maxlen) +{ + if (maxlen < 0) { + return MP_VAL; + } + return TclBN_mp_to_radix(a, str, maxlen, NULL, radix); +} + +#define TclSetStartupScriptPath setStartupScriptPath +static void TclSetStartupScriptPath(Tcl_Obj *path) +{ + Tcl_SetStartupScript(path, NULL); +} +#define TclGetStartupScriptPath getStartupScriptPath +static Tcl_Obj *TclGetStartupScriptPath(void) +{ + return Tcl_GetStartupScript(NULL); +} +#define TclSetStartupScriptFileName setStartupScriptFileName +static void TclSetStartupScriptFileName( + const char *fileName) +{ + Tcl_SetStartupScript(Tcl_NewStringObj(fileName,-1), NULL); +} +#define TclGetStartupScriptFileName getStartupScriptFileName +static const char *TclGetStartupScriptFileName(void) +{ + Tcl_Obj *path = Tcl_GetStartupScript(NULL); + if (path == NULL) { + return NULL; + } + return TclGetString(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 +#endif /* TCL_NO_DEPRECATED */ + +#define TclpCreateTempFile_ TclpCreateTempFile +#define TclUnixWaitForFile_ TclUnixWaitForFile +#ifdef MAC_OSX_TCL /* On UNIX, fill with other stub entries */ +#define TclMacOSXNotifierAddRunLoopMode Tcl_MacOSXNotifierAddRunLoopMode +#else +#define TclMacOSXGetFileAttribute (int (*)(Tcl_Interp *, int, Tcl_Obj *, Tcl_Obj **))(void *)TclpCreateProcess +#define TclMacOSXSetFileAttribute (int (*)(Tcl_Interp *, int, Tcl_Obj *, Tcl_Obj *))(void *)isatty +#define TclMacOSXCopyFileAttributes (int (*)(const char *, const char *, const Tcl_StatBuf *))(void *)TclUnixCopyFile +#define TclMacOSXMatchType (int (*)(Tcl_Interp *, const char *, const char *, Tcl_StatBuf *, Tcl_GlobTypeData *))(void *)TclpMakeFile +#define TclMacOSXNotifierAddRunLoopMode (void (*)(const void *))(void *)TclpOpenFile #endif #ifdef _WIN32 @@ -292,18 +460,44 @@ int TclGetAliasObj(Tcl_Interp *interp, const char *childCmd, # define TclUnixCopyFile 0 # define TclUnixOpenTemporaryFile 0 # define TclpReaddir 0 -# undef TclpIsAtty # define TclpIsAtty 0 #elif defined(__CYGWIN__) # define TclpIsAtty isatty +#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 *, Tcl_Size)) doNothing # define TclWinFlushDirtyChannels doNothing +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 +#define TclWinSetSockOpt winSetSockOpt +static int +TclWinSetSockOpt(SOCKET s, int level, int optname, + const char *optval, int optlen) +{ + return setsockopt((int) s, level, optname, optval, optlen); +} + +#define TclWinGetSockOpt winGetSockOpt +static int +TclWinGetSockOpt(SOCKET s, int level, int optname, + char *optval, int *optlen) +{ + return getsockopt((int) s, level, optname, optval, optlen); +} + +#define TclWinGetServByName winGetServByName +static struct servent * +TclWinGetServByName(const char *name, const char *proto) +{ + return getservbyname(name, proto); +} +#endif /* TCL_NO_DEPRECATED */ + #define TclWinNoBackslash winNoBackslash static char * TclWinNoBackslash(char *path) @@ -318,7 +512,7 @@ TclWinNoBackslash(char *path) return path; } -void *TclWinGetTclInstance(void) +void *TclWinGetTclInstance() { void *hInstance = NULL; GetModuleHandleExW(GET_MODULE_HANDLE_EX_FLAG_FROM_ADDRESS, @@ -326,12 +520,35 @@ void *TclWinGetTclInstance(void) return hInstance; } -Tcl_Size +int TclpGetPid(Tcl_Pid pid) { - return (Tcl_Size)PTR2INT(pid); + return (TCL_HASH_TYPE)(size_t)pid; } +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 +#undef Tcl_WinUtfToTChar +char * +Tcl_WinUtfToTChar( + const char *string, + int len, + Tcl_DString *dsPtr) +{ + Tcl_DStringInit(dsPtr); + return (char *)Tcl_UtfToChar16DString(string, len, dsPtr); +} +#undef Tcl_WinTCharToUtf +char * +Tcl_WinTCharToUtf( + const char *string, + int len, + Tcl_DString *dsPtr) +{ + Tcl_DStringInit(dsPtr); + return Tcl_Char16ToUtfDString((const unsigned short *)string, len >> 1, dsPtr); +} +#endif /* !defined(TCL_NO_DEPRECATED) */ + #if defined(TCL_WIDE_INT_IS_LONG) /* On Cygwin64, long is 64-bit while on Win64 long is 32-bit. Therefore * we have to make sure that all stub entries on Cygwin64 follow the Win64 @@ -343,8 +560,8 @@ 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)(INT_MIN)) - && (longValue <= (long)(UINT_MAX))) { + if ((longValue >= (long)(INT_MIN)) + && (longValue <= (long)(UINT_MAX))) { *ptr = (int)longValue; } else { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -359,8 +576,8 @@ 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)(INT_MIN)) - && (longValue <= (long)(UINT_MAX))) { + if ((longValue >= (long)(INT_MIN)) + && (longValue <= (long)(UINT_MAX))) { *ptr = (int)longValue; } else { Tcl_SetObjResult(interp, Tcl_NewStringObj( @@ -371,14 +588,178 @@ static int exprIntObj(Tcl_Interp *interp, Tcl_Obj*expr, int *ptr){ return result; } #define Tcl_ExprLongObj (int(*)(Tcl_Interp*,Tcl_Obj*,long*))(void *)exprIntObj +#if !defined(TCL_NO_DEPRECATED) +static int utfNcmp(const char *s1, const char *s2, unsigned int n){ + return Tcl_UtfNcmp(s1, s2, (unsigned long)n); +} +#define Tcl_UtfNcmp (int(*)(const char*,const char*,unsigned long))(void *)utfNcmp +static int utfNcasecmp(const char *s1, const char *s2, unsigned int n){ + return Tcl_UtfNcasecmp(s1, s2, (unsigned long)n); +} +#define Tcl_UtfNcasecmp (int(*)(const char*,const char*,unsigned long))(void *)utfNcasecmp +#endif /* !defined(TCL_NO_DEPRECATED) */ + #endif /* TCL_WIDE_INT_IS_LONG */ -#else /* __CYGWIN__ */ -# define TclWinGetTclInstance 0 -# define TclpGetPid 0 -# define TclWinFlushDirtyChannels 0 -# define TclWinNoBackslash 0 -# define TclWinAddProcess 0 +#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_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 +# undef Tcl_StringMatch +# define Tcl_StringMatch 0 +# define TclBN_reverse 0 +# undef TclBN_fast_s_mp_mul_digs +# define TclBN_fast_s_mp_mul_digs 0 +# undef TclBN_fast_s_mp_sqr +# define TclBN_fast_s_mp_sqr 0 +# undef TclBN_mp_karatsuba_mul +# define TclBN_mp_karatsuba_mul 0 +# undef TclBN_mp_karatsuba_sqr +# define TclBN_mp_karatsuba_sqr 0 +# undef TclBN_mp_toom_mul +# define TclBN_mp_toom_mul 0 +# undef TclBN_mp_toom_sqr +# define TclBN_mp_toom_sqr 0 +# undef TclBN_s_mp_add +# define TclBN_s_mp_add 0 +# undef TclBN_s_mp_mul_digs +# define TclBN_s_mp_mul_digs 0 +# undef TclBN_s_mp_sqr +# define TclBN_s_mp_sqr 0 +# undef TclBN_s_mp_sub +# define TclBN_s_mp_sub 0 +# define Tcl_MakeSafe 0 +# define TclpHasSockets 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 +# define Tcl_MakeSafe TclMakeSafe + +int TclpHasSockets(TCL_UNUSED(Tcl_Interp *)) {return TCL_OK;} + +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 */ + +#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 +#define Tcl_WinUtfToTChar 0 +#define Tcl_WinTCharToUtf 0 #endif /* @@ -402,10 +783,7 @@ MODULE_SCOPE const TclTomMathStubs tclTomMathStubs; #ifdef TCL_WITH_EXTERNAL_TOMMATH /* If Tcl is linked with an external libtommath 1.2.x, then mp_expt_n doesn't * exist (since that was introduced in libtommath 1.3.0. Provide it here.) */ -mp_err MP_WUR TclBN_mp_expt_n(const mp_int *a, int b, mp_int *c) { - if ((unsigned)b > MP_MIN(MP_DIGIT_MAX, INT_MAX)) { - return MP_VAL; - } +mp_err MP_WUR TclBN_mp_expt_d(const mp_int *a, int b, mp_int *c) { return mp_expt_u32(a, (uint32_t)b, c);; } #endif /* TCL_WITH_EXTERNAL_TOMMATH */ @@ -423,7 +801,7 @@ static const TclIntStubs tclIntStubs = { TclCleanupChildren, /* 5 */ TclCleanupCommand, /* 6 */ TclCopyAndCollapse, /* 7 */ - 0, /* 8 */ + TclCopyChannelOld, /* 8 */ TclCreatePipeline, /* 9 */ TclCreateProc, /* 10 */ TclDeleteCompiledLocalVars, /* 11 */ @@ -449,27 +827,27 @@ static const TclIntStubs tclIntStubs = { TclGetExtension, /* 31 */ TclGetFrame, /* 32 */ 0, /* 33 */ - 0, /* 34 */ + TclGetIntForIndex, /* 34 */ 0, /* 35 */ 0, /* 36 */ - 0, /* 37 */ + TclGetLoadedPackages, /* 37 */ TclGetNamespaceForQualName, /* 38 */ TclGetObjInterpProc, /* 39 */ TclGetOpenMode, /* 40 */ TclGetOriginalCommand, /* 41 */ TclpGetUserHome, /* 42 */ - TclGetObjInterpProc2, /* 43 */ - 0, /* 44 */ + 0, /* 43 */ + TclGuessPackageName, /* 44 */ TclHideUnsafeCommands, /* 45 */ TclInExit, /* 46 */ 0, /* 47 */ 0, /* 48 */ 0, /* 49 */ - 0, /* 50 */ + TclInitCompiledLocals, /* 50 */ TclInterpInit, /* 51 */ 0, /* 52 */ - 0, /* 53 */ - 0, /* 54 */ + TclInvokeObjectCommand, /* 53 */ + TclInvokeStringCommand, /* 54 */ TclIsProc, /* 55 */ 0, /* 56 */ 0, /* 57 */ @@ -478,7 +856,7 @@ static const TclIntStubs tclIntStubs = { TclNeedSpace, /* 60 */ TclNewProcBodyObj, /* 61 */ TclObjCommandComplete, /* 62 */ - 0, /* 63 */ + TclObjInterpProc, /* 63 */ TclObjInvoke, /* 64 */ 0, /* 65 */ 0, /* 66 */ @@ -492,7 +870,7 @@ static const TclIntStubs tclIntStubs = { TclpFree, /* 74 */ TclpGetClicks, /* 75 */ TclpGetSeconds, /* 76 */ - 0, /* 77 */ + TclpGetTime, /* 77 */ 0, /* 78 */ 0, /* 79 */ 0, /* 80 */ @@ -503,7 +881,7 @@ static const TclIntStubs tclIntStubs = { 0, /* 85 */ 0, /* 86 */ 0, /* 87 */ - 0, /* 88 */ + TclPrecTraceProc, /* 88 */ TclPreventAliasLoop, /* 89 */ 0, /* 90 */ TclProcCleanupProc, /* 91 */ @@ -516,10 +894,10 @@ static const TclIntStubs tclIntStubs = { TclServiceIdle, /* 98 */ 0, /* 99 */ 0, /* 100 */ - 0, /* 101 */ + TclSetPreInitScript, /* 101 */ TclSetupEnv, /* 102 */ TclSockGetPort, /* 103 */ - 0, /* 104 */ + TclSockMinimumBuffersOld, /* 104 */ 0, /* 105 */ 0, /* 106 */ 0, /* 107 */ @@ -527,28 +905,28 @@ static const TclIntStubs tclIntStubs = { TclUpdateReturnInfo, /* 109 */ TclSockMinimumBuffers, /* 110 */ Tcl_AddInterpResolvers, /* 111 */ - 0, /* 112 */ - 0, /* 113 */ - 0, /* 114 */ - 0, /* 115 */ - 0, /* 116 */ - 0, /* 117 */ + TclAppendExportList, /* 112 */ + TclCreateNamespace, /* 113 */ + TclDeleteNamespace, /* 114 */ + TclExport, /* 115 */ + TclFindCommand, /* 116 */ + TclFindNamespace, /* 117 */ Tcl_GetInterpResolvers, /* 118 */ Tcl_GetNamespaceResolvers, /* 119 */ Tcl_FindNamespaceVar, /* 120 */ - 0, /* 121 */ - 0, /* 122 */ - 0, /* 123 */ - 0, /* 124 */ - 0, /* 125 */ + TclForgetImport, /* 121 */ + TclGetCommandFromObj, /* 122 */ + TclGetCommandFullName, /* 123 */ + TclGetCurrentNamespace_, /* 124 */ + TclGetGlobalNamespace_, /* 125 */ Tcl_GetVariableFullName, /* 126 */ - 0, /* 127 */ + TclImport, /* 127 */ Tcl_PopCallFrame, /* 128 */ Tcl_PushCallFrame, /* 129 */ Tcl_RemoveInterpResolvers, /* 130 */ Tcl_SetNamespaceResolvers, /* 131 */ - 0, /* 132 */ - 0, /* 133 */ + TclpHasSockets, /* 132 */ + TclpGetDate, /* 133 */ 0, /* 134 */ 0, /* 135 */ 0, /* 136 */ @@ -567,14 +945,14 @@ static const TclIntStubs tclIntStubs = { TclHandleRelease, /* 149 */ TclRegAbout, /* 150 */ TclRegExpRangeUniChar, /* 151 */ - 0, /* 152 */ - 0, /* 153 */ + TclSetLibraryPath, /* 152 */ + TclGetLibraryPath, /* 153 */ 0, /* 154 */ 0, /* 155 */ TclRegError, /* 156 */ TclVarTraceExists, /* 157 */ - 0, /* 158 */ - 0, /* 159 */ + TclSetStartupScriptFileName, /* 158 */ + TclGetStartupScriptFileName, /* 159 */ 0, /* 160 */ TclChannelTransform, /* 161 */ TclChannelEventScriptInvoker, /* 162 */ @@ -582,8 +960,8 @@ static const TclIntStubs tclIntStubs = { TclExpandCodeArray, /* 164 */ TclpSetInitialEncodings, /* 165 */ TclListObjSetElement, /* 166 */ - 0, /* 167 */ - 0, /* 168 */ + TclSetStartupScriptPath, /* 167 */ + TclGetStartupScriptPath, /* 168 */ TclpUtfNcmp2, /* 169 */ TclCheckInterpTraces, /* 170 */ TclCheckExecutionTraces, /* 171 */ @@ -593,12 +971,12 @@ static const TclIntStubs tclIntStubs = { TclCallVarTraces, /* 175 */ TclCleanupVar, /* 176 */ TclVarErrMsg, /* 177 */ - 0, /* 178 */ - 0, /* 179 */ + TclSetStartupScript, /* 178 */ + TclGetStartupScript, /* 179 */ 0, /* 180 */ 0, /* 181 */ - 0, /* 182 */ - 0, /* 183 */ + TclpLocaltime, /* 182 */ + TclpGmtime, /* 183 */ 0, /* 184 */ 0, /* 185 */ 0, /* 186 */ @@ -651,7 +1029,7 @@ static const TclIntStubs tclIntStubs = { TclGetSrcInfoForPc, /* 233 */ TclVarHashCreateVar, /* 234 */ TclInitVarHashTable, /* 235 */ - 0, /* 236 */ + TclBackgroundException, /* 236 */ TclResetCancellation, /* 237 */ TclNRInterpProc, /* 238 */ TclNRInterpProcCore, /* 239 */ @@ -682,46 +1060,121 @@ static const TclIntStubs tclIntStubs = { static const TclIntPlatStubs tclIntPlatStubs = { TCL_STUB_MAGIC, 0, - 0, /* 0 */ +#if !defined(_WIN32) && !defined(__CYGWIN__) && !defined(MAC_OSX_TCL) /* UNIX */ + TclGetAndDetachPids, /* 0 */ TclpCloseFile, /* 1 */ TclpCreateCommandChannel, /* 2 */ TclpCreatePipe, /* 3 */ - TclWinGetTclInstance, /* 4 */ - TclUnixWaitForFile, /* 5 */ + TclpCreateProcess, /* 4 */ + TclUnixWaitForFile_, /* 5 */ TclpMakeFile, /* 6 */ TclpOpenFile, /* 7 */ - TclpGetPid, /* 8 */ + TclUnixWaitForFile, /* 8 */ TclpCreateTempFile, /* 9 */ - 0, /* 10 */ + TclpReaddir, /* 10 */ + TclpLocaltime_unix, /* 11 */ + TclpGmtime_unix, /* 12 */ + TclpInetNtoa, /* 13 */ + TclUnixCopyFile, /* 14 */ + TclMacOSXGetFileAttribute, /* 15 */ + TclMacOSXSetFileAttribute, /* 16 */ + TclMacOSXCopyFileAttributes, /* 17 */ + TclMacOSXMatchType, /* 18 */ + TclMacOSXNotifierAddRunLoopMode, /* 19 */ + 0, /* 20 */ + 0, /* 21 */ + TclpCreateTempFile_, /* 22 */ + 0, /* 23 */ + 0, /* 24 */ + 0, /* 25 */ + 0, /* 26 */ + 0, /* 27 */ + 0, /* 28 */ + TclWinCPUID, /* 29 */ + TclUnixOpenTemporaryFile, /* 30 */ +#endif /* UNIX */ +#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ + TclWinConvertError, /* 0 */ + TclWinConvertWSAError, /* 1 */ + TclWinGetServByName, /* 2 */ + TclWinGetSockOpt, /* 3 */ + TclWinGetTclInstance, /* 4 */ + TclUnixWaitForFile, /* 5 */ + TclWinNToHS, /* 6 */ + TclWinSetSockOpt, /* 7 */ + TclpGetPid, /* 8 */ + TclWinGetPlatformId, /* 9 */ + TclpReaddir, /* 10 */ TclGetAndDetachPids, /* 11 */ - 0, /* 12 */ - 0, /* 13 */ - 0, /* 14 */ + TclpCloseFile, /* 12 */ + TclpCreateCommandChannel, /* 13 */ + TclpCreatePipe, /* 14 */ TclpCreateProcess, /* 15 */ TclpIsAtty, /* 16 */ TclUnixCopyFile, /* 17 */ - 0, /* 18 */ - 0, /* 19 */ + TclpMakeFile, /* 18 */ + TclpOpenFile, /* 19 */ TclWinAddProcess, /* 20 */ - 0, /* 21 */ - 0, /* 22 */ + TclpInetNtoa, /* 21 */ + TclpCreateTempFile, /* 22 */ 0, /* 23 */ TclWinNoBackslash, /* 24 */ 0, /* 25 */ - 0, /* 26 */ + TclWinSetInterfaces, /* 26 */ TclWinFlushDirtyChannels, /* 27 */ + TclWinResetInterfaces, /* 28 */ + TclWinCPUID, /* 29 */ + TclUnixOpenTemporaryFile, /* 30 */ +#endif /* WIN */ +#ifdef MAC_OSX_TCL /* MACOSX */ + TclGetAndDetachPids, /* 0 */ + TclpCloseFile, /* 1 */ + TclpCreateCommandChannel, /* 2 */ + TclpCreatePipe, /* 3 */ + TclpCreateProcess, /* 4 */ + TclUnixWaitForFile_, /* 5 */ + TclpMakeFile, /* 6 */ + TclpOpenFile, /* 7 */ + TclUnixWaitForFile, /* 8 */ + TclpCreateTempFile, /* 9 */ + TclpReaddir, /* 10 */ + TclpLocaltime_unix, /* 11 */ + TclpGmtime_unix, /* 12 */ + TclpInetNtoa, /* 13 */ + TclUnixCopyFile, /* 14 */ + TclMacOSXGetFileAttribute, /* 15 */ + TclMacOSXSetFileAttribute, /* 16 */ + TclMacOSXCopyFileAttributes, /* 17 */ + TclMacOSXMatchType, /* 18 */ + TclMacOSXNotifierAddRunLoopMode, /* 19 */ + 0, /* 20 */ + 0, /* 21 */ + TclpCreateTempFile_, /* 22 */ + 0, /* 23 */ + 0, /* 24 */ + 0, /* 25 */ + 0, /* 26 */ + 0, /* 27 */ 0, /* 28 */ TclWinCPUID, /* 29 */ TclUnixOpenTemporaryFile, /* 30 */ +#endif /* MACOSX */ }; static const TclPlatStubs tclPlatStubs = { TCL_STUB_MAGIC, 0, - 0, /* 0 */ +#if defined(_WIN32) || defined(__CYGWIN__) /* WIN */ + Tcl_WinUtfToTChar, /* 0 */ + Tcl_WinTCharToUtf, /* 1 */ + 0, /* 2 */ + Tcl_WinConvertError, /* 3 */ +#endif /* WIN */ +#ifdef MAC_OSX_TCL /* MACOSX */ + Tcl_MacOSXOpenBundleResources, /* 0 */ Tcl_MacOSXOpenVersionedBundleResources, /* 1 */ Tcl_MacOSXNotifierAddRunLoopMode, /* 2 */ - Tcl_WinConvertError, /* 3 */ +#endif /* MACOSX */ }; const TclTomMathStubs tclTomMathStubs = { @@ -744,9 +1197,9 @@ const TclTomMathStubs tclTomMathStubs = { TclBN_mp_div_d, /* 14 */ TclBN_mp_div_2, /* 15 */ TclBN_mp_div_2d, /* 16 */ - 0, /* 17 */ + TclBN_mp_div_3, /* 17 */ TclBN_mp_exch, /* 18 */ - TclBN_mp_expt_n, /* 19 */ + TclBN_mp_expt_d, /* 19 */ TclBN_mp_grow, /* 20 */ TclBN_mp_init, /* 21 */ TclBN_mp_init_copy, /* 22 */ @@ -766,47 +1219,47 @@ const TclTomMathStubs tclTomMathStubs = { TclBN_mp_read_radix, /* 36 */ TclBN_mp_rshd, /* 37 */ TclBN_mp_shrink, /* 38 */ - 0, /* 39 */ - 0, /* 40 */ + TclBN_mp_set, /* 39 */ + TclBN_mp_sqr, /* 40 */ TclBN_mp_sqrt, /* 41 */ TclBN_mp_sub, /* 42 */ TclBN_mp_sub_d, /* 43 */ - 0, /* 44 */ - 0, /* 45 */ - 0, /* 46 */ - TclBN_mp_ubin_size, /* 47 */ + TclBN_mp_to_unsigned_bin, /* 44 */ + TclBN_mp_to_unsigned_bin_n, /* 45 */ + TclBN_mp_toradix_n, /* 46 */ + TclBN_mp_unsigned_bin_size, /* 47 */ TclBN_mp_xor, /* 48 */ TclBN_mp_zero, /* 49 */ - 0, /* 50 */ - 0, /* 51 */ - 0, /* 52 */ - 0, /* 53 */ - 0, /* 54 */ - 0, /* 55 */ - 0, /* 56 */ - 0, /* 57 */ - 0, /* 58 */ - 0, /* 59 */ - 0, /* 60 */ - 0, /* 61 */ - 0, /* 62 */ + TclBN_reverse, /* 50 */ + TclBN_fast_s_mp_mul_digs, /* 51 */ + TclBN_fast_s_mp_sqr, /* 52 */ + TclBN_mp_karatsuba_mul, /* 53 */ + TclBN_mp_karatsuba_sqr, /* 54 */ + TclBN_mp_toom_mul, /* 55 */ + TclBN_mp_toom_sqr, /* 56 */ + TclBN_s_mp_add, /* 57 */ + TclBN_s_mp_mul_digs, /* 58 */ + TclBN_s_mp_sqr, /* 59 */ + TclBN_s_mp_sub, /* 60 */ + TclBN_mp_init_set_int, /* 61 */ + TclBN_mp_set_ul, /* 62 */ TclBN_mp_cnt_lsb, /* 63 */ - 0, /* 64 */ + TclBN_mp_init_l, /* 64 */ TclBN_mp_init_i64, /* 65 */ TclBN_mp_init_u64, /* 66 */ - 0, /* 67 */ - TclBN_mp_set_u64, /* 68 */ - TclBN_mp_get_mag_u64, /* 69 */ - TclBN_mp_set_i64, /* 70 */ + TclBN_mp_expt_d_ex, /* 67 */ + TclBN_mp_set_ull, /* 68 */ + TclBN_mp_get_mag_ull, /* 69 */ + TclBN_mp_set_ll, /* 70 */ TclBN_mp_unpack, /* 71 */ TclBN_mp_pack, /* 72 */ - 0, /* 73 */ - 0, /* 74 */ - 0, /* 75 */ + TclBN_mp_tc_and, /* 73 */ + TclBN_mp_tc_or, /* 74 */ + TclBN_mp_tc_xor, /* 75 */ TclBN_mp_signed_rsh, /* 76 */ TclBN_mp_pack_count, /* 77 */ TclBN_mp_to_ubin, /* 78 */ - 0, /* 79 */ + TclBN_mp_div_ld, /* 79 */ TclBN_mp_to_radix, /* 80 */ }; @@ -828,8 +1281,24 @@ const TclStubs tclStubs = { Tcl_DbCkalloc, /* 6 */ Tcl_DbCkfree, /* 7 */ Tcl_DbCkrealloc, /* 8 */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ + Tcl_CreateFileHandler, /* 9 */ +#endif /* UNIX */ +#if defined(_WIN32) /* WIN */ + 0, /* 9 */ +#endif /* WIN */ +#ifdef MAC_OSX_TCL /* MACOSX */ Tcl_CreateFileHandler, /* 9 */ +#endif /* MACOSX */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ Tcl_DeleteFileHandler, /* 10 */ +#endif /* UNIX */ +#if defined(_WIN32) /* WIN */ + 0, /* 10 */ +#endif /* WIN */ +#ifdef MAC_OSX_TCL /* MACOSX */ + Tcl_DeleteFileHandler, /* 10 */ +#endif /* MACOSX */ Tcl_SetTimer, /* 11 */ Tcl_Sleep, /* 12 */ Tcl_WaitForEvent, /* 13 */ @@ -841,11 +1310,11 @@ const TclStubs tclStubs = { Tcl_DbDecrRefCount, /* 19 */ Tcl_DbIncrRefCount, /* 20 */ Tcl_DbIsShared, /* 21 */ - 0, /* 22 */ + Tcl_DbNewBooleanObj, /* 22 */ Tcl_DbNewByteArrayObj, /* 23 */ Tcl_DbNewDoubleObj, /* 24 */ Tcl_DbNewListObj, /* 25 */ - 0, /* 26 */ + Tcl_DbNewLongObj, /* 26 */ Tcl_DbNewObj, /* 27 */ Tcl_DbNewStringObj, /* 28 */ Tcl_DuplicateObj, /* 29 */ @@ -855,38 +1324,38 @@ const TclStubs tclStubs = { Tcl_GetByteArrayFromObj, /* 33 */ Tcl_GetDouble, /* 34 */ Tcl_GetDoubleFromObj, /* 35 */ - 0, /* 36 */ + Tcl_GetIndexFromObj, /* 36 */ Tcl_GetInt, /* 37 */ Tcl_GetIntFromObj, /* 38 */ Tcl_GetLongFromObj, /* 39 */ Tcl_GetObjType, /* 40 */ - TclGetStringFromObj, /* 41 */ + Tcl_GetStringFromObj, /* 41 */ Tcl_InvalidateStringRep, /* 42 */ Tcl_ListObjAppendList, /* 43 */ Tcl_ListObjAppendElement, /* 44 */ - TclListObjGetElements, /* 45 */ + Tcl_ListObjGetElements, /* 45 */ Tcl_ListObjIndex, /* 46 */ - TclListObjLength, /* 47 */ + Tcl_ListObjLength, /* 47 */ Tcl_ListObjReplace, /* 48 */ - 0, /* 49 */ + Tcl_NewBooleanObj, /* 49 */ Tcl_NewByteArrayObj, /* 50 */ Tcl_NewDoubleObj, /* 51 */ - 0, /* 52 */ + Tcl_NewIntObj, /* 52 */ Tcl_NewListObj, /* 53 */ - 0, /* 54 */ + Tcl_NewLongObj, /* 54 */ Tcl_NewObj, /* 55 */ Tcl_NewStringObj, /* 56 */ - 0, /* 57 */ + Tcl_SetBooleanObj, /* 57 */ Tcl_SetByteArrayLength, /* 58 */ Tcl_SetByteArrayObj, /* 59 */ Tcl_SetDoubleObj, /* 60 */ - 0, /* 61 */ + Tcl_SetIntObj, /* 61 */ Tcl_SetListObj, /* 62 */ - 0, /* 63 */ + Tcl_SetLongObj, /* 63 */ Tcl_SetObjLength, /* 64 */ Tcl_SetStringObj, /* 65 */ - 0, /* 66 */ - 0, /* 67 */ + Tcl_AddErrorInfo, /* 66 */ + Tcl_AddObjErrorInfo, /* 67 */ Tcl_AllowExceptions, /* 68 */ Tcl_AppendElement, /* 69 */ Tcl_AppendResult, /* 70 */ @@ -895,8 +1364,8 @@ const TclStubs tclStubs = { Tcl_AsyncInvoke, /* 73 */ Tcl_AsyncMark, /* 74 */ Tcl_AsyncReady, /* 75 */ - 0, /* 76 */ - 0, /* 77 */ + Tcl_BackgroundError, /* 76 */ + Tcl_Backslash, /* 77 */ Tcl_BadChannelOption, /* 78 */ Tcl_CallWhenDeleted, /* 79 */ Tcl_CancelIdleCall, /* 80 */ @@ -914,7 +1383,7 @@ const TclStubs tclStubs = { Tcl_CreateEventSource, /* 92 */ Tcl_CreateExitHandler, /* 93 */ Tcl_CreateInterp, /* 94 */ - 0, /* 95 */ + Tcl_CreateMathFunc, /* 95 */ Tcl_CreateObjCommand, /* 96 */ Tcl_CreateChild, /* 97 */ Tcl_CreateTimerHandler, /* 98 */ @@ -948,9 +1417,9 @@ const TclStubs tclStubs = { Tcl_Eof, /* 126 */ Tcl_ErrnoId, /* 127 */ Tcl_ErrnoMsg, /* 128 */ - 0, /* 129 */ + Tcl_Eval, /* 129 */ Tcl_EvalFile, /* 130 */ - 0, /* 131 */ + Tcl_EvalObj, /* 131 */ Tcl_EventuallyFree, /* 132 */ Tcl_Exit, /* 133 */ Tcl_ExposeCommand, /* 134 */ @@ -963,12 +1432,12 @@ const TclStubs tclStubs = { Tcl_ExprObj, /* 141 */ Tcl_ExprString, /* 142 */ Tcl_Finalize, /* 143 */ - 0, /* 144 */ + Tcl_FindExecutable, /* 144 */ Tcl_FirstHashEntry, /* 145 */ Tcl_Flush, /* 146 */ - 0, /* 147 */ - 0, /* 148 */ - TclGetAliasObj, /* 149 */ + Tcl_FreeResult, /* 147 */ + Tcl_GetAlias, /* 148 */ + Tcl_GetAliasObj, /* 149 */ Tcl_GetAssocData, /* 150 */ Tcl_GetChannel, /* 151 */ Tcl_GetChannelBufferSize, /* 152 */ @@ -986,18 +1455,26 @@ const TclStubs tclStubs = { Tcl_GetParent, /* 164 */ Tcl_GetNameOfExecutable, /* 165 */ Tcl_GetObjResult, /* 166 */ +#if !defined(_WIN32) && !defined(MAC_OSX_TCL) /* UNIX */ Tcl_GetOpenFile, /* 167 */ +#endif /* UNIX */ +#if defined(_WIN32) /* WIN */ + 0, /* 167 */ +#endif /* WIN */ +#ifdef MAC_OSX_TCL /* MACOSX */ + Tcl_GetOpenFile, /* 167 */ +#endif /* MACOSX */ Tcl_GetPathType, /* 168 */ Tcl_Gets, /* 169 */ Tcl_GetsObj, /* 170 */ Tcl_GetServiceMode, /* 171 */ Tcl_GetChild, /* 172 */ Tcl_GetStdChannel, /* 173 */ - 0, /* 174 */ - 0, /* 175 */ + Tcl_GetStringResult, /* 174 */ + Tcl_GetVar, /* 175 */ Tcl_GetVar2, /* 176 */ - 0, /* 177 */ - 0, /* 178 */ + Tcl_GlobalEval, /* 177 */ + Tcl_GlobalEvalObj, /* 178 */ Tcl_HideCommand, /* 179 */ Tcl_Init, /* 180 */ Tcl_InitHashTable, /* 181 */ @@ -1009,7 +1486,7 @@ const TclStubs tclStubs = { Tcl_LinkVar, /* 187 */ 0, /* 188 */ Tcl_MakeFileChannel, /* 189 */ - 0, /* 190 */ + Tcl_MakeSafe, /* 190 */ Tcl_MakeTcpClientChannel, /* 191 */ Tcl_Merge, /* 192 */ Tcl_NextHashEntry, /* 193 */ @@ -1039,7 +1516,7 @@ const TclStubs tclStubs = { Tcl_ResetResult, /* 217 */ Tcl_ScanElement, /* 218 */ Tcl_ScanCountedElement, /* 219 */ - 0, /* 220 */ + Tcl_SeekOld, /* 220 */ Tcl_ServiceAll, /* 221 */ Tcl_ServiceEvent, /* 222 */ Tcl_SetAssocData, /* 223 */ @@ -1049,67 +1526,67 @@ const TclStubs tclStubs = { Tcl_SetErrno, /* 227 */ Tcl_SetErrorCode, /* 228 */ Tcl_SetMaxBlockTime, /* 229 */ - 0, /* 230 */ + Tcl_SetPanicProc, /* 230 */ Tcl_SetRecursionLimit, /* 231 */ - 0, /* 232 */ + Tcl_SetResult, /* 232 */ Tcl_SetServiceMode, /* 233 */ Tcl_SetObjErrorCode, /* 234 */ Tcl_SetObjResult, /* 235 */ Tcl_SetStdChannel, /* 236 */ - 0, /* 237 */ + Tcl_SetVar, /* 237 */ Tcl_SetVar2, /* 238 */ Tcl_SignalId, /* 239 */ Tcl_SignalMsg, /* 240 */ Tcl_SourceRCFile, /* 241 */ - TclSplitList, /* 242 */ - TclSplitPath, /* 243 */ - 0, /* 244 */ - 0, /* 245 */ - 0, /* 246 */ - 0, /* 247 */ + Tcl_SplitList, /* 242 */ + Tcl_SplitPath, /* 243 */ + Tcl_StaticLibrary, /* 244 */ + Tcl_StringMatch, /* 245 */ + Tcl_TellOld, /* 246 */ + Tcl_TraceVar, /* 247 */ Tcl_TraceVar2, /* 248 */ Tcl_TranslateFileName, /* 249 */ Tcl_Ungets, /* 250 */ Tcl_UnlinkVar, /* 251 */ Tcl_UnregisterChannel, /* 252 */ - 0, /* 253 */ + Tcl_UnsetVar, /* 253 */ Tcl_UnsetVar2, /* 254 */ - 0, /* 255 */ + Tcl_UntraceVar, /* 255 */ Tcl_UntraceVar2, /* 256 */ Tcl_UpdateLinkedVar, /* 257 */ - 0, /* 258 */ + Tcl_UpVar, /* 258 */ Tcl_UpVar2, /* 259 */ Tcl_VarEval, /* 260 */ - 0, /* 261 */ + Tcl_VarTraceInfo, /* 261 */ Tcl_VarTraceInfo2, /* 262 */ Tcl_Write, /* 263 */ Tcl_WrongNumArgs, /* 264 */ Tcl_DumpActiveMemory, /* 265 */ Tcl_ValidateAllMemory, /* 266 */ - 0, /* 267 */ - 0, /* 268 */ + Tcl_AppendResultVA, /* 267 */ + Tcl_AppendStringsToObjVA, /* 268 */ Tcl_HashStats, /* 269 */ Tcl_ParseVar, /* 270 */ - 0, /* 271 */ + Tcl_PkgPresent, /* 271 */ Tcl_PkgPresentEx, /* 272 */ - 0, /* 273 */ - 0, /* 274 */ - 0, /* 275 */ - 0, /* 276 */ + Tcl_PkgProvide, /* 273 */ + Tcl_PkgRequire, /* 274 */ + Tcl_SetErrorCodeVA, /* 275 */ + Tcl_VarEvalVA, /* 276 */ Tcl_WaitPid, /* 277 */ - 0, /* 278 */ + Tcl_PanicVA, /* 278 */ Tcl_GetVersion, /* 279 */ Tcl_InitMemory, /* 280 */ Tcl_StackChannel, /* 281 */ Tcl_UnstackChannel, /* 282 */ Tcl_GetStackedChannel, /* 283 */ Tcl_SetMainLoop, /* 284 */ - Tcl_GetAliasObj, /* 285 */ + 0, /* 285 */ Tcl_AppendObjToObj, /* 286 */ Tcl_CreateEncoding, /* 287 */ Tcl_CreateThreadExitHandler, /* 288 */ Tcl_DeleteThreadExitHandler, /* 289 */ - 0, /* 290 */ + Tcl_DiscardResult, /* 290 */ Tcl_EvalEx, /* 291 */ Tcl_EvalObjv, /* 292 */ Tcl_EvalObjEx, /* 293 */ @@ -1131,10 +1608,10 @@ const TclStubs tclStubs = { Tcl_MutexUnlock, /* 309 */ Tcl_ConditionNotify, /* 310 */ Tcl_ConditionWait, /* 311 */ - TclNumUtfChars, /* 312 */ + Tcl_NumUtfChars, /* 312 */ Tcl_ReadChars, /* 313 */ - 0, /* 314 */ - 0, /* 315 */ + Tcl_RestoreResult, /* 314 */ + Tcl_SaveResult, /* 315 */ Tcl_SetSystemEncoding, /* 316 */ Tcl_SetVar2Ex, /* 317 */ Tcl_ThreadAlert, /* 318 */ @@ -1144,7 +1621,7 @@ const TclStubs tclStubs = { Tcl_UniCharToTitle, /* 322 */ Tcl_UniCharToUpper, /* 323 */ Tcl_UniCharToUtf, /* 324 */ - TclUtfAtIndex, /* 325 */ + Tcl_UtfAtIndex, /* 325 */ TclUtfCharComplete, /* 326 */ Tcl_UtfBackslash, /* 327 */ Tcl_UtfFindFirst, /* 328 */ @@ -1160,8 +1637,8 @@ const TclStubs tclStubs = { Tcl_WriteChars, /* 338 */ Tcl_WriteObj, /* 339 */ Tcl_GetString, /* 340 */ - 0, /* 341 */ - 0, /* 342 */ + Tcl_GetDefaultEncodingDir, /* 341 */ + Tcl_SetDefaultEncodingDir, /* 342 */ Tcl_AlertNotifier, /* 343 */ Tcl_ServiceModeHook, /* 344 */ Tcl_UniCharIsAlnum, /* 345 */ @@ -1172,11 +1649,11 @@ const TclStubs tclStubs = { Tcl_UniCharIsUpper, /* 350 */ Tcl_UniCharIsWordChar, /* 351 */ Tcl_Char16Len, /* 352 */ - 0, /* 353 */ + Tcl_UniCharNcmp, /* 353 */ Tcl_Char16ToUtfDString, /* 354 */ Tcl_UtfToChar16DString, /* 355 */ Tcl_GetRegExpFromObj, /* 356 */ - 0, /* 357 */ + Tcl_EvalTokens, /* 357 */ Tcl_FreeParse, /* 358 */ Tcl_LogCommandInfo, /* 359 */ Tcl_ParseBraces, /* 360 */ @@ -1188,8 +1665,8 @@ const TclStubs tclStubs = { Tcl_Chdir, /* 366 */ Tcl_Access, /* 367 */ Tcl_Stat, /* 368 */ - TclUtfNcmp, /* 369 */ - TclUtfNcasecmp, /* 370 */ + Tcl_UtfNcmp, /* 369 */ + Tcl_UtfNcasecmp, /* 370 */ Tcl_StringCaseMatch, /* 371 */ Tcl_UniCharIsControl, /* 372 */ Tcl_UniCharIsGraph, /* 373 */ @@ -1199,10 +1676,10 @@ const TclStubs tclStubs = { Tcl_RegExpGetInfo, /* 377 */ Tcl_NewUnicodeObj, /* 378 */ Tcl_SetUnicodeObj, /* 379 */ - TclGetCharLength, /* 380 */ - TclGetUniChar, /* 381 */ - 0, /* 382 */ - TclGetRange, /* 383 */ + Tcl_GetCharLength, /* 380 */ + Tcl_GetUniChar, /* 381 */ + Tcl_GetUnicode, /* 382 */ + Tcl_GetRange, /* 383 */ Tcl_AppendUnicodeToObj, /* 384 */ Tcl_RegExpMatchObj, /* 385 */ Tcl_SetNotifier, /* 386 */ @@ -1220,11 +1697,11 @@ const TclStubs tclStubs = { Tcl_ChannelName, /* 398 */ Tcl_ChannelVersion, /* 399 */ Tcl_ChannelBlockModeProc, /* 400 */ - 0, /* 401 */ + Tcl_ChannelCloseProc, /* 401 */ Tcl_ChannelClose2Proc, /* 402 */ Tcl_ChannelInputProc, /* 403 */ Tcl_ChannelOutputProc, /* 404 */ - 0, /* 405 */ + Tcl_ChannelSeekProc, /* 405 */ Tcl_ChannelSetOptionProc, /* 406 */ Tcl_ChannelGetOptionProc, /* 407 */ Tcl_ChannelWatchProc, /* 408 */ @@ -1238,10 +1715,10 @@ const TclStubs tclStubs = { Tcl_SpliceChannel, /* 416 */ Tcl_ClearChannelHandlers, /* 417 */ Tcl_IsChannelExisting, /* 418 */ - 0, /* 419 */ - 0, /* 420 */ - 0, /* 421 */ - 0, /* 422 */ + Tcl_UniCharNcasecmp, /* 419 */ + Tcl_UniCharCaseMatch, /* 420 */ + Tcl_FindHashEntry, /* 421 */ + Tcl_CreateHashEntry, /* 422 */ Tcl_InitCustomHashTable, /* 423 */ Tcl_InitObjHashTable, /* 424 */ Tcl_CommandTraceInfo, /* 425 */ @@ -1253,9 +1730,9 @@ const TclStubs tclStubs = { Tcl_AttemptDbCkrealloc, /* 431 */ Tcl_AttemptSetObjLength, /* 432 */ Tcl_GetChannelThread, /* 433 */ - TclGetUnicodeFromObj, /* 434 */ - 0, /* 435 */ - 0, /* 436 */ + Tcl_GetUnicodeFromObj, /* 434 */ + Tcl_GetMathFuncInfo, /* 435 */ + Tcl_ListMathFuncs, /* 436 */ Tcl_SubstObj, /* 437 */ Tcl_DetachChannel, /* 438 */ Tcl_IsStandardChannel, /* 439 */ @@ -1280,7 +1757,7 @@ const TclStubs tclStubs = { Tcl_FSChdir, /* 458 */ Tcl_FSConvertToPathType, /* 459 */ Tcl_FSJoinPath, /* 460 */ - TclFSSplitPath, /* 461 */ + Tcl_FSSplitPath, /* 461 */ Tcl_FSEqualPaths, /* 462 */ Tcl_FSGetNormalizedPath, /* 463 */ Tcl_FSJoinToPath, /* 464 */ @@ -1316,7 +1793,7 @@ const TclStubs tclStubs = { Tcl_DictObjPut, /* 494 */ Tcl_DictObjGet, /* 495 */ Tcl_DictObjRemove, /* 496 */ - TclDictObjSize, /* 497 */ + Tcl_DictObjSize, /* 497 */ Tcl_DictObjFirst, /* 498 */ Tcl_DictObjNext, /* 499 */ Tcl_DictObjDone, /* 500 */ @@ -1338,7 +1815,7 @@ const TclStubs tclStubs = { Tcl_GetCommandFromObj, /* 516 */ Tcl_GetCommandFullName, /* 517 */ Tcl_FSEvalFileEx, /* 518 */ - 0, /* 519 */ + Tcl_SetExitProc, /* 519 */ Tcl_LimitAddHandler, /* 520 */ Tcl_LimitRemoveHandler, /* 521 */ Tcl_LimitReady, /* 522 */ @@ -1423,7 +1900,7 @@ const TclStubs tclStubs = { Tcl_GetBlockSizeFromStat, /* 601 */ Tcl_SetEnsembleParameterList, /* 602 */ Tcl_GetEnsembleParameterList, /* 603 */ - TclParseArgsObjv, /* 604 */ + Tcl_ParseArgsObjv, /* 604 */ Tcl_GetErrorLine, /* 605 */ Tcl_SetErrorLine, /* 606 */ Tcl_TransferResult, /* 607 */ @@ -1468,11 +1945,11 @@ const TclStubs tclStubs = { Tcl_UtfToUniChar, /* 646 */ Tcl_UniCharToUtfDString, /* 647 */ Tcl_UtfToUniCharDString, /* 648 */ - TclGetBytesFromObj, /* 649 */ - Tcl_GetBytesFromObj, /* 650 */ - Tcl_GetStringFromObj, /* 651 */ - Tcl_GetUnicodeFromObj, /* 652 */ - Tcl_GetSizeIntFromObj, /* 653 */ + Tcl_GetBytesFromObj, /* 649 */ + 0, /* 650 */ + 0, /* 651 */ + 0, /* 652 */ + 0, /* 653 */ Tcl_UtfCharComplete, /* 654 */ Tcl_UtfNext, /* 655 */ Tcl_UtfPrev, /* 656 */ @@ -1480,33 +1957,33 @@ const TclStubs tclStubs = { Tcl_ExternalToUtfDStringEx, /* 658 */ Tcl_UtfToExternalDStringEx, /* 659 */ Tcl_AsyncMarkFromSignal, /* 660 */ - Tcl_ListObjGetElements, /* 661 */ - Tcl_ListObjLength, /* 662 */ - Tcl_DictObjSize, /* 663 */ - Tcl_SplitList, /* 664 */ - Tcl_SplitPath, /* 665 */ - Tcl_FSSplitPath, /* 666 */ - Tcl_ParseArgsObjv, /* 667 */ + 0, /* 661 */ + 0, /* 662 */ + 0, /* 663 */ + 0, /* 664 */ + 0, /* 665 */ + 0, /* 666 */ + 0, /* 667 */ Tcl_UniCharLen, /* 668 */ - Tcl_NumUtfChars, /* 669 */ - Tcl_GetCharLength, /* 670 */ - Tcl_UtfAtIndex, /* 671 */ - Tcl_GetRange, /* 672 */ - Tcl_GetUniChar, /* 673 */ + TclNumUtfChars, /* 669 */ + TclGetCharLength, /* 670 */ + TclUtfAtIndex, /* 671 */ + TclGetRange, /* 672 */ + TclGetUniChar, /* 673 */ Tcl_GetBool, /* 674 */ Tcl_GetBoolFromObj, /* 675 */ - Tcl_CreateObjCommand2, /* 676 */ - Tcl_CreateObjTrace2, /* 677 */ - Tcl_NRCreateCommand2, /* 678 */ - Tcl_NRCallObjProc2, /* 679 */ + 0, /* 676 */ + 0, /* 677 */ + 0, /* 678 */ + 0, /* 679 */ Tcl_GetNumberFromObj, /* 680 */ Tcl_GetNumber, /* 681 */ Tcl_RemoveChannelMode, /* 682 */ Tcl_GetEncodingNulLength, /* 683 */ Tcl_GetWideUIntFromObj, /* 684 */ Tcl_DStringToObj, /* 685 */ - Tcl_UtfNcmp, /* 686 */ - Tcl_UtfNcasecmp, /* 687 */ + TclUtfNcmp, /* 686 */ + TclUtfNcasecmp, /* 687 */ Tcl_NewWideUIntObj, /* 688 */ Tcl_SetWideUIntObj, /* 689 */ TclUnusedStubEntry, /* 690 */ diff --git a/generic/tclStubLib.c b/generic/tclStubLib.c index 55001cf..f06b2d1 100644 --- a/generic/tclStubLib.c +++ b/generic/tclStubLib.c @@ -71,8 +71,8 @@ Tcl_InitStubs( */ if (!stubsPtr || (stubsPtr->magic != (((exact&0xFF00) >= 0x900) ? magic : TCL_STUB_MAGIC))) { - iPtr->legacyResult = "interpreter uses an incompatible stubs mechanism"; - iPtr->legacyFreeProc = 0; /* TCL_STATIC */ + iPtr->result = (char *)"interpreter uses an incompatible stubs mechanism"; + iPtr->freeProc = 0; /* TCL_STATIC */ return NULL; } diff --git a/generic/tclStubLibTbl.c b/generic/tclStubLibTbl.c index ad34494..0391502 100644 --- a/generic/tclStubLibTbl.c +++ b/generic/tclStubLibTbl.c @@ -13,8 +13,6 @@ #include "tclInt.h" -MODULE_SCOPE void *tclStubsHandle; - /* *---------------------------------------------------------------------- * @@ -34,26 +32,18 @@ MODULE_SCOPE void *tclStubsHandle; MODULE_SCOPE const char * TclInitStubTable( const char *version) /* points to the version field of a - structure variable. */ + TclStubInfoType structure variable. */ { - if (version) { - if (tclStubsHandle == NULL) { - /* This can only happen with -DBUILD_STATIC, so simulate - * that the loading of Tcl succeeded, although we didn't - * actually load it dynamically */ - tclStubsHandle = (void *)1; - } - tclStubsPtr = ((const TclStubs **) version)[-1]; + tclStubsPtr = ((const TclStubInfoType *) version)->stubs; - if (tclStubsPtr->hooks) { - tclPlatStubsPtr = tclStubsPtr->hooks->tclPlatStubs; - tclIntStubsPtr = tclStubsPtr->hooks->tclIntStubs; - tclIntPlatStubsPtr = tclStubsPtr->hooks->tclIntPlatStubs; - } else { - tclPlatStubsPtr = NULL; - tclIntStubsPtr = NULL; - tclIntPlatStubsPtr = NULL; - } + if (tclStubsPtr->hooks) { + tclPlatStubsPtr = tclStubsPtr->hooks->tclPlatStubs; + tclIntStubsPtr = tclStubsPtr->hooks->tclIntStubs; + tclIntPlatStubsPtr = tclStubsPtr->hooks->tclIntPlatStubs; + } else { + tclPlatStubsPtr = NULL; + tclIntStubsPtr = NULL; + tclIntPlatStubsPtr = NULL; } return version; diff --git a/generic/tclTest.c b/generic/tclTest.c index 3aa066d..5bfd70f 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -15,15 +15,20 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#define TCL_8_API -#undef BUILD_tcl #undef STATIC_BUILD +#undef BUILD_tcl #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif -#include "tclInt.h" -#undef TCLBOOLWARNING +#undef TCL_UTF_MAX +#ifdef TCL_NO_DEPRECATED +# define TCL_UTF_MAX 4 +#else +# define TCL_NO_DEPRECATED +# define TCL_UTF_MAX 3 +#endif #define TCLBOOLWARNING(boolPtr) /* needed here because we compile with -Wc++-compat */ +#include "tclInt.h" #include "tclOO.h" #include <math.h> @@ -135,6 +140,15 @@ typedef struct { } TclEncoding; /* + * The counter below is used to determine if the TestsaveresultFree routine + * was called for a result. + */ + +#ifndef TCL_NO_DEPRECATED +static int freeCount; +#endif /* TCL_NO_DEPRECATED */ + +/* * Boolean flag used by the "testsetmainloop" and "testexitmainloop" commands. */ @@ -163,6 +177,15 @@ typedef struct TestChannel { static TestChannel *firstDetached; +#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 + /* * Forward declarations for procedures defined later in this file: */ @@ -209,7 +232,7 @@ static Tcl_ResolveCompiledVarProc InterpCompiledVarResolver; static void MainLoop(void); static Tcl_CmdProc NoopCmd; static Tcl_ObjCmdProc NoopObjCmd; -static Tcl_CmdObjTraceProc ObjTraceProc; +static Tcl_CmdObjTraceProc2 ObjTraceProc; static void ObjTraceDeleteProc(void *clientData); static void PrintParse(Tcl_Interp *interp, Tcl_Parse *parsePtr); static Tcl_FreeProc SpecialFree; @@ -220,7 +243,7 @@ static Tcl_ObjCmdProc TestbytestringObjCmd; static Tcl_ObjCmdProc TestsetbytearraylengthObjCmd; static Tcl_ObjCmdProc TestpurebytesobjObjCmd; static Tcl_ObjCmdProc TeststringbytesObjCmd; -static Tcl_ObjCmdProc2 Testcmdobj2ObjCmd; +static Tcl_ObjCmdProc Testutf16stringObjCmd; static Tcl_ObjCmdProc TestcmdinfoObjCmd; static Tcl_CmdProc TestcmdtokenCmd; static Tcl_CmdProc TestcmdtraceCmd; @@ -272,6 +295,10 @@ static Tcl_ObjCmdProc TestregexpObjCmd; static Tcl_ObjCmdProc TestreturnObjCmd; static void TestregexpXflags(const char *string, size_t length, int *cflagsPtr, int *eflagsPtr); +#ifndef TCL_NO_DEPRECATED +static Tcl_ObjCmdProc TestsaveresultCmd; +static Tcl_FreeProc TestsaveresultFree; +#endif /* TCL_NO_DEPRECATED */ static Tcl_CmdProc TestsetassocdataCmd; static Tcl_CmdProc TestsetCmd; static Tcl_CmdProc Testset2Cmd; @@ -330,7 +357,6 @@ static Tcl_ObjCmdProc TestFindFirstCmd; static Tcl_ObjCmdProc TestFindLastCmd; static Tcl_ObjCmdProc TestHashSystemHashCmd; static Tcl_ObjCmdProc TestGetIntForIndexCmd; -static Tcl_ObjCmdProc TestLutilCmd; static Tcl_NRPostProc NREUnwind_callback; static Tcl_ObjCmdProc TestNREUnwind; @@ -528,7 +554,7 @@ Tcltest_Init( "-appinitprocclosestderr", "-appinitprocsetrcfile", NULL }; - if (Tcl_InitStubs(interp, "8.7-", 0) == NULL) { + if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { return TCL_ERROR; } if (Tcl_OOInitStubs(interp) == NULL) { @@ -560,6 +586,7 @@ Tcltest_Init( Tcl_CreateObjCommand(interp, "testsetbytearraylength", TestsetbytearraylengthObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testbytestring", TestbytestringObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "teststringbytes", TeststringbytesObjCmd, NULL, NULL); + Tcl_CreateObjCommand(interp, "testutf16string", Testutf16stringObjCmd, NULL, NULL); Tcl_CreateObjCommand2(interp, "testwrongnumargs", TestWrongNumArgsObjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd, @@ -577,8 +604,6 @@ Tcltest_Init( NULL, NULL); Tcl_CreateCommand(interp, "testcmdtoken", TestcmdtokenCmd, NULL, NULL); - Tcl_CreateObjCommand2(interp, "testcmdobj2", Testcmdobj2ObjCmd, - NULL, NULL); Tcl_CreateObjCommand(interp, "testcmdinfo", TestcmdinfoObjCmd, NULL, NULL); Tcl_CreateCommand(interp, "testcmdtrace", TestcmdtraceCmd, @@ -659,6 +684,10 @@ Tcltest_Init( NULL, NULL); Tcl_CreateObjCommand(interp, "testreturn", TestreturnObjCmd, NULL, NULL); +#ifndef TCL_NO_DEPRECATED + Tcl_CreateObjCommand(interp, "testsaveresult", TestsaveresultCmd, + NULL, NULL); +#endif Tcl_CreateCommand(interp, "testservicemode", TestServiceModeCmd, NULL, NULL); Tcl_CreateCommand(interp, "testsetassocdata", TestsetassocdataCmd, @@ -714,8 +743,6 @@ Tcltest_Init( NULL, NULL); Tcl_CreateObjCommand(interp, "testapplylambda", TestApplyLambdaObjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "testlutil", TestLutilCmd, - NULL, NULL); if (TclObjTest_Init(interp) != TCL_OK) { return TCL_ERROR; @@ -729,10 +756,6 @@ Tcltest_Init( } #endif - if (Tcl_ABSListTest_Init(interp) != TCL_OK) { - return TCL_ERROR; - } - /* * Check for special options used in ../tests/main.test */ @@ -798,7 +821,7 @@ Tcltest_SafeInit( { Tcl_CmdInfo info; - if (Tcl_InitStubs(interp, "8.7-", 0) == NULL) { + if (Tcl_InitStubs(interp, "8.5-", 0) == NULL) { return TCL_ERROR; } if (Tcl_GetCommandInfo(interp, "::tcl::build-info", &info)) { @@ -854,8 +877,8 @@ TestasyncCmd( if (argc != 3) { goto wrongNumArgs; } - asyncPtr = (TestAsyncHandler *)Tcl_Alloc(sizeof(TestAsyncHandler)); - asyncPtr->command = (char *)Tcl_Alloc(strlen(argv[2]) + 1); + asyncPtr = (TestAsyncHandler *)ckalloc(sizeof(TestAsyncHandler)); + asyncPtr->command = (char *)ckalloc(strlen(argv[2]) + 1); strcpy(asyncPtr->command, argv[2]); Tcl_MutexLock(&asyncTestMutex); asyncPtr->id = nextId; @@ -872,8 +895,8 @@ TestasyncCmd( asyncPtr = firstHandler; firstHandler = asyncPtr->nextPtr; Tcl_AsyncDelete(asyncPtr->handler); - Tcl_Free(asyncPtr->command); - Tcl_Free(asyncPtr); + ckfree(asyncPtr->command); + ckfree(asyncPtr); } Tcl_MutexUnlock(&asyncTestMutex); return TCL_OK; @@ -896,8 +919,8 @@ TestasyncCmd( prevPtr->nextPtr = asyncPtr->nextPtr; } Tcl_AsyncDelete(asyncPtr->handler); - Tcl_Free(asyncPtr->command); - Tcl_Free(asyncPtr); + ckfree(asyncPtr->command); + ckfree(asyncPtr); break; } Tcl_MutexUnlock(&asyncTestMutex); @@ -993,7 +1016,7 @@ AsyncHandlerProc( * invoked, it's possible. Better error checking is needed here. */ } - Tcl_Free(cmd); + ckfree(cmd); return code; } @@ -1055,40 +1078,6 @@ TestbumpinterpepochObjCmd( /* *---------------------------------------------------------------------- * - * Testcmdobj2 -- - * - * Mock up to test the Tcl_CreateCommandObj2 functionality - * - * Results: - * Standard Tcl result. - * - * Side effects: - * Sets interpreter result to number of arguments, first arg, last arg. - * - *---------------------------------------------------------------------- - */ - -static int -Testcmdobj2ObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - Tcl_Size objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Tcl_Obj *resultObj; - resultObj = Tcl_NewListObj(0, NULL); - Tcl_ListObjAppendElement(interp, resultObj, Tcl_NewWideIntObj(objc)); - if (objc > 1) { - Tcl_ListObjAppendElement(interp, resultObj, objv[1]); - Tcl_ListObjAppendElement(interp, resultObj, objv[objc-1]); - } - Tcl_SetObjResult(interp, resultObj); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * * TestcmdinfoObjCmd -- * * This procedure implements the "testcmdinfo" command. It is used to @@ -1112,15 +1101,12 @@ TestcmdinfoObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { static const char *const subcmds[] = { - "call", "call2", "create", "delete", "get", "modify", NULL + "create", "delete", "get", "modify", NULL }; enum options { - CMDINFO_CALL, CMDINFO_CALL2, CMDINFO_CREATE, - CMDINFO_DELETE, CMDINFO_GET, CMDINFO_MODIFY + CMDINFO_CREATE, CMDINFO_DELETE, CMDINFO_GET, CMDINFO_MODIFY } idx; Tcl_CmdInfo info; - Tcl_Obj **cmdObjv; - Tcl_Size cmdObjc; if (objc != 3) { Tcl_WrongNumArgs(interp, 1, objv, "command arg"); @@ -1131,29 +1117,6 @@ TestcmdinfoObjCmd( return TCL_ERROR; } switch (idx) { - case CMDINFO_CALL: - case CMDINFO_CALL2: - if (Tcl_ListObjGetElements(interp, objv[2], &cmdObjc, &cmdObjv) != TCL_OK) { - return TCL_ERROR; - } - if (cmdObjc == 0) { - Tcl_AppendResult(interp, "No command name given", NULL); - return TCL_ERROR; - } - if (Tcl_GetCommandInfo(interp, Tcl_GetString(cmdObjv[0]), &info) == 0) { - return TCL_ERROR; - } - if (idx == CMDINFO_CALL) { - /* - * Note when calling through the old 32-bit API, it is the caller's - * responsibility to check that number of arguments is <= INT_MAX. - * We do not do that here just so we can test what happens if the - * caller mistakenly passes more arguments. - */ - return info.objProc(info.objClientData, interp, cmdObjc, cmdObjv); - } else { - return info.objProc2(info.objClientData2, interp, cmdObjc, cmdObjv); - } case CMDINFO_CREATE: Tcl_CreateCommand(interp, Tcl_GetString(objv[2]), CmdProc1, (void *)"original", CmdDelProc1); @@ -1273,7 +1236,7 @@ CmdDelProc0( } prevRefPtr = thisRefPtr; } - Tcl_Free(refPtr); + ckfree(refPtr); } static void @@ -1328,7 +1291,7 @@ TestcmdtokenCmd( return TCL_ERROR; } if (strcmp(argv[1], "create") == 0) { - refPtr = (TestCommandTokenRef *)Tcl_Alloc(sizeof(TestCommandTokenRef)); + refPtr = (TestCommandTokenRef *)ckalloc(sizeof(TestCommandTokenRef)); refPtr->token = Tcl_CreateCommand(interp, argv[2], CmdProc0, refPtr, CmdDelProc0); refPtr->id = nextCommandTokenRefId; @@ -1452,7 +1415,7 @@ TestcmdtraceCmd( static int deleteCalled; deleteCalled = 0; - cmdTrace = Tcl_CreateObjTrace(interp, 50000, + cmdTrace = Tcl_CreateObjTrace2(interp, 50000, TCL_ALLOW_INLINE_COMPILATION, ObjTraceProc, &deleteCalled, ObjTraceDeleteProc); result = Tcl_EvalEx(interp, argv[2], TCL_INDEX_NONE, 0); @@ -1535,10 +1498,10 @@ static int ObjTraceProc( TCL_UNUSED(void *), Tcl_Interp *interp, /* Tcl interpreter */ - TCL_UNUSED(int) /* level */, + TCL_UNUSED(Tcl_Size) /* level */, const char *command, TCL_UNUSED(Tcl_Command), - TCL_UNUSED(int) /* objc */, + TCL_UNUSED(Tcl_Size) /*objc*/, Tcl_Obj *const objv[]) /* Argument objects. */ { const char *word = Tcl_GetString(objv[0]); @@ -1762,9 +1725,9 @@ TestdelCmd( return TCL_ERROR; } - dPtr = (DelCmd *)Tcl_Alloc(sizeof(DelCmd)); + dPtr = (DelCmd *)ckalloc(sizeof(DelCmd)); dPtr->interp = interp; - dPtr->deleteCmd = (char *)Tcl_Alloc(strlen(argv[3]) + 1); + dPtr->deleteCmd = (char *)ckalloc(strlen(argv[3]) + 1); strcpy(dPtr->deleteCmd, argv[3]); Tcl_CreateCommand(child, argv[2], DelCmdProc, dPtr, @@ -1782,8 +1745,8 @@ DelCmdProc( DelCmd *dPtr = (DelCmd *) clientData; Tcl_AppendResult(interp, dPtr->deleteCmd, (char *)NULL); - Tcl_Free(dPtr->deleteCmd); - Tcl_Free(dPtr); + ckfree(dPtr->deleteCmd); + ckfree(dPtr); return TCL_OK; } @@ -1795,8 +1758,8 @@ DelDeleteProc( Tcl_EvalEx(dPtr->interp, dPtr->deleteCmd, TCL_INDEX_NONE, 0); Tcl_ResetResult(dPtr->interp); - Tcl_Free(dPtr->deleteCmd); - Tcl_Free(dPtr); + ckfree(dPtr->deleteCmd); + ckfree(dPtr); } /* @@ -1915,7 +1878,7 @@ TestdoubledigitsObjCmd( } str = TclDoubleDigits(d, ndigits, type, &decpt, &signum, &endPtr); strObj = Tcl_NewStringObj(str, endPtr-str); - Tcl_Free(str); + ckfree(str); retval = Tcl_NewListObj(1, &strObj); Tcl_ListObjAppendElement(NULL, retval, Tcl_NewWideIntObj(decpt)); strObj = Tcl_NewStringObj(signum ? "-" : "+", 1); @@ -1992,11 +1955,11 @@ TestdstringCmd( } else if (strcmp(argv[2], "staticlarge") == 0) { Tcl_AppendResult(interp, "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n", (char *)NULL); } else if (strcmp(argv[2], "free") == 0) { - char *s = (char *)Tcl_Alloc(100); + char *s = (char *)ckalloc(100); strcpy(s, "This is a malloc-ed string"); Tcl_SetResult(interp, s, TCL_DYNAMIC); } else if (strcmp(argv[2], "special") == 0) { - char *s = (char *)Tcl_Alloc(100) + 16; + char *s = (char *)ckalloc(100) + 16; strcpy(s, "This is a specially-allocated string"); Tcl_SetResult(interp, s, SpecialFree); } else { @@ -2056,7 +2019,7 @@ static void SpecialFree( char *blockPtr /* Block to free. */ #endif ) { - Tcl_Free(((char *)blockPtr) - 16); + ckfree((char *)blockPtr - 16); } /* @@ -2209,19 +2172,19 @@ static int UtfExtWrapper( } bufLen = dstLen + 4; /* 4 -> overflow detection */ - bufPtr = (unsigned char *) Tcl_Alloc(bufLen); + bufPtr = (unsigned char *) ckalloc(bufLen); memset(bufPtr, 0xFF, dstLen); /* Need to check nul terminator */ memmove(bufPtr + dstLen, "\xAB\xCD\xEF\xAB", 4); /* overflow detection */ bytes = Tcl_GetByteArrayFromObj(objv[3], &srcLen); /* Last! to avoid shimmering */ result = (*transformer)(interp, encoding, (const char *)bytes, srcLen, flags, - encStatePtr, (char *) bufPtr, dstLen, - srcReadVar ? &srcRead : NULL, - &dstWrote, - dstCharsVar ? &dstChars : NULL); + encStatePtr, (char *) bufPtr, dstLen, + srcReadVar ? &srcRead : NULL, + &dstWrote, + dstCharsVar ? &dstChars : NULL); if (memcmp(bufPtr + bufLen - 4, "\xAB\xCD\xEF\xAB", 4)) { Tcl_SetResult(interp, - "Tcl_ExternalToUtf wrote past output buffer", - TCL_STATIC); + "Tcl_ExternalToUtf wrote past output buffer", + TCL_STATIC); result = TCL_ERROR; } else if (result != TCL_ERROR) { Tcl_Obj *resultObjs[3]; @@ -2270,7 +2233,7 @@ static int UtfExtWrapper( Tcl_SetObjResult(interp, Tcl_NewListObj(3, resultObjs)); } - Tcl_Free(bufPtr); + ckfree(bufPtr); Tcl_FreeEncoding(encoding); /* Free returned reference */ return result; } @@ -2308,7 +2271,8 @@ TestencodingObjCmd( }; enum options { ENC_CREATE, ENC_DELETE, ENC_NULLENGTH, ENC_EXTTOUTF, ENC_UTFTOEXT - } index; + }; + int index; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "command ?args?"); @@ -2320,7 +2284,7 @@ TestencodingObjCmd( return TCL_ERROR; } - switch (index) { + switch ((enum options) index) { case ENC_CREATE: { Tcl_EncodingType type; @@ -2328,15 +2292,15 @@ TestencodingObjCmd( Tcl_WrongNumArgs(interp, 2, objv, "name toutfcmd fromutfcmd"); return TCL_ERROR; } - encodingPtr = (TclEncoding *)Tcl_Alloc(sizeof(TclEncoding)); + encodingPtr = (TclEncoding *)ckalloc(sizeof(TclEncoding)); encodingPtr->interp = interp; string = Tcl_GetStringFromObj(objv[3], &length); - encodingPtr->toUtfCmd = (char *)Tcl_Alloc(length + 1); + encodingPtr->toUtfCmd = (char *)ckalloc(length + 1); memcpy(encodingPtr->toUtfCmd, string, length + 1); string = Tcl_GetStringFromObj(objv[4], &length); - encodingPtr->fromUtfCmd = (char *)Tcl_Alloc(length + 1); + encodingPtr->fromUtfCmd = (char *)ckalloc(length + 1); memcpy(encodingPtr->fromUtfCmd, string, length + 1); string = Tcl_GetStringFromObj(objv[2], &length); @@ -2455,9 +2419,9 @@ EncodingFreeProc( { TclEncoding *encodingPtr = (TclEncoding *)clientData; - Tcl_Free(encodingPtr->toUtfCmd); - Tcl_Free(encodingPtr->fromUtfCmd); - Tcl_Free(encodingPtr); + ckfree(encodingPtr->toUtfCmd); + ckfree(encodingPtr->fromUtfCmd); + ckfree(encodingPtr); } /* @@ -2613,7 +2577,7 @@ TesteventObjCmd( "position specifier", TCL_EXACT, &posIndex) != TCL_OK) { return TCL_ERROR; } - ev = (TestEvent *)Tcl_Alloc(sizeof(TestEvent)); + ev = (TestEvent *)ckalloc(sizeof(TestEvent)); ev->header.proc = TesteventProc; ev->header.nextPtr = NULL; ev->interp = interp; @@ -3464,12 +3428,12 @@ TestlinkCmd( } if (argv[5][0] != 0) { if (stringVar != NULL) { - Tcl_Free(stringVar); + ckfree(stringVar); } if (strcmp(argv[5], "-") == 0) { stringVar = NULL; } else { - stringVar = (char *)Tcl_Alloc(strlen(argv[5]) + 1); + stringVar = (char *)ckalloc(strlen(argv[5]) + 1); strcpy(stringVar, argv[5]); } } @@ -3571,12 +3535,12 @@ TestlinkCmd( } if (argv[5][0] != 0) { if (stringVar != NULL) { - Tcl_Free(stringVar); + ckfree(stringVar); } if (strcmp(argv[5], "-") == 0) { stringVar = NULL; } else { - stringVar = (char *)Tcl_Alloc(strlen(argv[5]) + 1); + stringVar = (char *)ckalloc(strlen(argv[5]) + 1); strcpy(stringVar, argv[5]); } Tcl_UpdateLinkedVar(interp, "string"); @@ -3693,7 +3657,7 @@ TestlinkarrayCmd( static const char *LinkOption[] = { "update", "remove", "create", NULL }; - enum LinkOptionEnum { LINK_UPDATE, LINK_REMOVE, LINK_CREATE } optionIndex; + enum LinkOptionEnum { 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 @@ -3706,7 +3670,7 @@ TestlinkarrayCmd( TCL_LINK_FLOAT, TCL_LINK_DOUBLE, TCL_LINK_STRING, TCL_LINK_CHARS, TCL_LINK_BINARY }; - int typeIndex, readonly, i, size; + int optionIndex, typeIndex, readonly, i, size; Tcl_Size length; char *name, *arg; Tcl_WideInt addr; @@ -3719,7 +3683,7 @@ TestlinkarrayCmd( &optionIndex) != TCL_OK) { return TCL_ERROR; } - switch (optionIndex) { + switch ((enum LinkOptionEnum) optionIndex) { case LINK_UPDATE: for (i=2; i<objc; i++) { Tcl_UpdateLinkedVar(interp, Tcl_GetString(objv[i])); @@ -4022,7 +3986,7 @@ CleanupTestSetassocdataTests( void *clientData, /* Data to be released. */ TCL_UNUSED(Tcl_Interp *)) { - Tcl_Free(clientData); + ckfree(clientData); } /* @@ -4450,7 +4414,8 @@ TestregexpObjCmd( REGEXP_MULTI, REGEXP_NOCROSS, REGEXP_NEWL, REGEXP_XFLAGS, REGEXP_LAST - } index; + }; + int index; indices = 0; about = 0; @@ -4469,7 +4434,7 @@ TestregexpObjCmd( &index) != TCL_OK) { return TCL_ERROR; } - switch (index) { + switch ((enum optionsEnum) index) { case REGEXP_INDICES: indices = 1; break; @@ -4550,7 +4515,7 @@ TestregexpObjCmd( varName = Tcl_GetString(objv[2]); TclRegExpRangeUniChar(regExpr, TCL_INDEX_NONE, &start, &end); - snprintf(resinfo, sizeof(resinfo), "%" TCL_Z_MODIFIER "d %" TCL_Z_MODIFIER "d", start, end-1); + snprintf(resinfo, sizeof(resinfo), "%d %d", start, end-1); value = Tcl_SetVar2(interp, varName, NULL, resinfo, 0); if (value == NULL) { Tcl_AppendResult(interp, "couldn't set variable \"", @@ -4564,7 +4529,7 @@ TestregexpObjCmd( Tcl_RegExpGetInfo(regExpr, &info); varName = Tcl_GetString(objv[2]); - snprintf(resinfo, sizeof(resinfo), "%" TCL_Z_MODIFIER "d", info.extendStart); + snprintf(resinfo, sizeof(resinfo), "%ld", info.extendStart); value = Tcl_SetVar2(interp, varName, NULL, resinfo, 0); if (value == NULL) { Tcl_AppendResult(interp, "couldn't set variable \"", @@ -4619,11 +4584,11 @@ TestregexpObjCmd( } else { if (ii == TCL_INDEX_NONE) { TclRegExpRangeUniChar(regExpr, ii, &start, &end); - newPtr = Tcl_GetRange(objPtr, start, end); + newPtr = TclGetRange(objPtr, start, end); } else if (ii > info.nsubs || info.matches[ii].end <= 0) { newPtr = Tcl_NewObj(); } else { - newPtr = Tcl_GetRange(objPtr, info.matches[ii].start, + newPtr = TclGetRange(objPtr, info.matches[ii].start, info.matches[ii].end - 1); } } @@ -4793,7 +4758,7 @@ TestsetassocdataCmd( return TCL_ERROR; } - buf = (char *)Tcl_Alloc(strlen(argv[2]) + 1); + buf = (char *)ckalloc(strlen(argv[2]) + 1); strcpy(buf, argv[2]); /* @@ -4803,7 +4768,7 @@ TestsetassocdataCmd( oldData = (char *) Tcl_GetAssocData(interp, argv[1], &procPtr); if ((oldData != NULL) && (procPtr == CleanupTestSetassocdataTests)) { - Tcl_Free(oldData); + ckfree(oldData); } Tcl_SetAssocData(interp, argv[1], CleanupTestSetassocdataTests, buf); @@ -5187,7 +5152,7 @@ TestpanicCmd( char *argString = Tcl_Merge(argc-1, argv+1); Tcl_Panic("%s", argString); - Tcl_Free(argString); + ckfree(argString); return TCL_OK; } @@ -5367,8 +5332,8 @@ GetTimesObjCmd( fprintf(stderr, "alloc & free 100000 6 word items\n"); Tcl_GetTime(&start); for (i = 0; i < 100000; i++) { - objPtr = (Tcl_Obj *)Tcl_Alloc(sizeof(Tcl_Obj)); - Tcl_Free(objPtr); + objPtr = (Tcl_Obj *)ckalloc(sizeof(Tcl_Obj)); + ckfree(objPtr); } Tcl_GetTime(&stop); timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); @@ -5376,10 +5341,10 @@ GetTimesObjCmd( /* alloc 5000 times */ fprintf(stderr, "alloc 5000 6 word items\n"); - objv = (Tcl_Obj **)Tcl_Alloc(5000 * sizeof(Tcl_Obj *)); + objv = (Tcl_Obj **)ckalloc(5000 * sizeof(Tcl_Obj *)); Tcl_GetTime(&start); for (i = 0; i < 5000; i++) { - objv[i] = (Tcl_Obj *)Tcl_Alloc(sizeof(Tcl_Obj)); + objv[i] = (Tcl_Obj *)ckalloc(sizeof(Tcl_Obj)); } Tcl_GetTime(&stop); timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); @@ -5389,7 +5354,7 @@ GetTimesObjCmd( fprintf(stderr, "free 5000 6 word items\n"); Tcl_GetTime(&start); for (i = 0; i < 5000; i++) { - Tcl_Free(objv[i]); + ckfree(objv[i]); } Tcl_GetTime(&stop); timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); @@ -5415,7 +5380,7 @@ GetTimesObjCmd( Tcl_GetTime(&stop); timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec); fprintf(stderr, " %.3f usec per Tcl_DecrRefCount\n", timePer/5000); - Tcl_Free(objv); + ckfree(objv); /* TclGetString 100000 times */ fprintf(stderr, "Tcl_GetStringFromObj of \"12345\" 100000 times\n"); @@ -5641,7 +5606,7 @@ TestpurebytesobjObjCmd( if (objc == 2) { const char *s = Tcl_GetString(objv[1]); objPtr->length = objv[1]->length; - objPtr->bytes = (char *)Tcl_Alloc(objPtr->length + 1); + objPtr->bytes = (char *)ckalloc(objPtr->length + 1); memcpy(objPtr->bytes, s, objPtr->length); objPtr->bytes[objPtr->length] = 0; } @@ -5723,11 +5688,7 @@ TestbytestringObjCmd( Tcl_Obj *const objv[]) /* The argument objects. */ { struct { -#if !defined(TCL_NO_DEPRECATED) - int n; /* On purpose, not Tcl_Size, in order to demonstrate what happens */ -#else Tcl_Size n; -#endif int m; /* This variable should not be overwritten */ } x = {0, 1}; const char *p; @@ -5753,6 +5714,43 @@ TestbytestringObjCmd( /* *---------------------------------------------------------------------- * + * Testutf16stringObjCmd -- + * + * This specifically tests the Tcl_GetUnicode and Tcl_NewUnicodeObj + * C functions which broke in Tcl 8.7 and were undetected by the + * existing test suite. Bug [b79df322a9] + * + * Results: + * Returns the TCL_OK result code. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +Testutf16stringObjCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ +{ + const unsigned short *p; + + if (objc != 2) { + Tcl_WrongNumArgs(interp, 1, objv, "string"); + return TCL_ERROR; + } + + p = Tcl_GetUnicode(objv[1]); + Tcl_SetObjResult(interp, Tcl_NewUnicodeObj(p, TCL_INDEX_NONE)); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TestsetCmd -- * * Implements the "testset{err,noerr}" cmds that are used when testing @@ -5835,6 +5833,143 @@ Testset2Cmd( /* *---------------------------------------------------------------------- * + * TestsaveresultCmd -- + * + * Implements the "testsaveresult" cmd that is used when testing the + * Tcl_SaveResult, Tcl_RestoreResult, and Tcl_DiscardResult interfaces. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#ifndef TCL_NO_DEPRECATED +static int +TestsaveresultCmd( + TCL_UNUSED(void *), + Tcl_Interp *interp,/* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* The argument objects. */ +{ + Interp* iPtr = (Interp*) interp; + int discard, result, index; + Tcl_SavedResult state; + Tcl_Obj *objPtr; + static const char *const optionStrings[] = { + "append", "dynamic", "free", "object", "small", NULL + }; + enum options { + RESULT_APPEND, RESULT_DYNAMIC, RESULT_FREE, RESULT_OBJECT, RESULT_SMALL + }; + + /* + * Parse arguments + */ + + if (objc != 4) { + Tcl_WrongNumArgs(interp, 1, objv, "type script discard"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, + &index) != TCL_OK) { + return TCL_ERROR; + } + if (Tcl_GetBooleanFromObj(interp, objv[3], &discard) != TCL_OK) { + return TCL_ERROR; + } + + freeCount = 0; + objPtr = NULL; + switch ((enum options) index) { + case RESULT_SMALL: + Tcl_AppendResult(interp, "small result", (char *)NULL); + break; + case RESULT_APPEND: + Tcl_AppendResult(interp, "append result", (char *)NULL); + break; + case RESULT_FREE: { + char *buf = (char *)ckalloc(200); + + strcpy(buf, "free result"); + Tcl_SetResult(interp, buf, TCL_DYNAMIC); + break; + } + case RESULT_DYNAMIC: + Tcl_SetResult(interp, (char *)"dynamic result", TestsaveresultFree); + break; + case RESULT_OBJECT: + objPtr = Tcl_NewStringObj("object result", TCL_INDEX_NONE); + Tcl_SetObjResult(interp, objPtr); + break; + } + + Tcl_SaveResult(interp, &state); + + if (((enum options) index) == RESULT_OBJECT) { + result = Tcl_EvalObjEx(interp, objv[2], 0); + } else { + result = Tcl_EvalEx(interp, Tcl_GetString(objv[2]), TCL_INDEX_NONE, 0); + } + + if (discard) { + Tcl_DiscardResult(&state); + } else { + Tcl_RestoreResult(interp, &state); + result = TCL_OK; + } + + switch ((enum options) index) { + case RESULT_DYNAMIC: { + int presentOrFreed = (iPtr->freeProc == TestsaveresultFree) ^ freeCount; + + Tcl_AppendElement(interp, presentOrFreed ? "presentOrFreed" : "missingOrLeak"); + break; + } + case RESULT_OBJECT: + Tcl_AppendElement(interp, Tcl_GetObjResult(interp) == objPtr + ? "same" : "different"); + break; + default: + break; + } + return result; +} + +/* + *---------------------------------------------------------------------- + * + * TestsaveresultFree -- + * + * Special purpose freeProc used by TestsaveresultCmd. + * + * Results: + * None. + * + * Side effects: + * Increments the freeCount. + * + *---------------------------------------------------------------------- + */ + +static void +TestsaveresultFree( +#if TCL_MAJOR_VERSION > 8 + TCL_UNUSED(void *)) +#else + TCL_UNUSED(char *)) +#endif +{ + freeCount++; +} +#endif /* TCL_NO_DEPRECATED */ + +/* + *---------------------------------------------------------------------- + * * TestmainthreadCmd -- * * Implements the "testmainthread" cmd that is used to test the @@ -6013,7 +6148,7 @@ TestChannelCmd( *nextPtrPtr = curPtr->nextPtr; curPtr->nextPtr = NULL; chan = curPtr->chan; - Tcl_Free(curPtr); + ckfree(curPtr); break; } } @@ -6082,7 +6217,7 @@ TestChannelCmd( /* Remember the channel in the pool of detached channels */ - det = (TestChannel *)Tcl_Alloc(sizeof(TestChannel)); + det = (TestChannel *)ckalloc(sizeof(TestChannel)); det->chan = chan; det->nextPtr = firstDetached; firstDetached = det; @@ -6516,7 +6651,7 @@ TestChannelEventCmd( return TCL_ERROR; } - esPtr = (EventScriptRecord *)Tcl_Alloc(sizeof(EventScriptRecord)); + esPtr = (EventScriptRecord *)ckalloc(sizeof(EventScriptRecord)); esPtr->nextPtr = statePtr->scriptRecordPtr; statePtr->scriptRecordPtr = esPtr; @@ -6573,7 +6708,7 @@ TestChannelEventCmd( Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, TclChannelEventScriptInvoker, esPtr); Tcl_DecrRefCount(esPtr->scriptPtr); - Tcl_Free(esPtr); + ckfree(esPtr); return TCL_OK; } @@ -6614,7 +6749,7 @@ TestChannelEventCmd( Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr, TclChannelEventScriptInvoker, esPtr); Tcl_DecrRefCount(esPtr->scriptPtr); - Tcl_Free(esPtr); + ckfree(esPtr); } statePtr->scriptRecordPtr = NULL; return TCL_OK; @@ -7913,8 +8048,8 @@ TestNRELevels( TCL_UNUSED(Tcl_Obj *const *) /*objv*/) { Interp *iPtr = (Interp *) interp; - static Tcl_Size *refDepth = NULL; - Tcl_Size depth; + static ptrdiff_t *refDepth = NULL; + ptrdiff_t depth; Tcl_Obj *levels[6]; Tcl_Size i = 0; NRE_callback *cbPtr = iPtr->execEnvPtr->callbackPtr; @@ -8306,7 +8441,7 @@ TestparseargsCmd( result[3] = Tcl_NewStringObj(color ? color : "NULL", -1); result[4] = Tcl_NewStringObj(media ? media : "NULL", -1); Tcl_SetObjResult(interp, Tcl_NewListObj(5, result)); - Tcl_Free(remObjv); + ckfree(remObjv); return TCL_OK; } @@ -8433,7 +8568,7 @@ HashVarFree( Tcl_Var var) { if (VarHashRefCount(var) < 2) { - Tcl_Free(var); + ckfree(var); } else { VarHashRefCount(var)--; } @@ -8449,7 +8584,7 @@ MyCompiledVarFree( if (resVarInfo->var) { HashVarFree(resVarInfo->var); } - Tcl_Free(vInfoPtr); + ckfree(vInfoPtr); } #define TclVarHashGetValue(hPtr) \ @@ -8492,7 +8627,7 @@ MyCompiledVarFetch( resVarInfo->var = var; /* - * Increment the reference counter to avoid Tcl_Free() of the variable in + * Increment the reference counter to avoid ckfree() of the variable in * Tcl's FreeVarEntry(); for cleanup, we provide our own HashVarFree(); */ @@ -8509,7 +8644,7 @@ InterpCompiledVarResolver( Tcl_ResolvedVarInfo **rPtr) { if (*name == 'T') { - MyResolvedVarInfo *resVarInfo = (MyResolvedVarInfo *)Tcl_Alloc(sizeof(MyResolvedVarInfo)); + MyResolvedVarInfo *resVarInfo = (MyResolvedVarInfo *)ckalloc(sizeof(MyResolvedVarInfo)); resVarInfo->vInfo.fetchProc = MyCompiledVarFetch; resVarInfo->vInfo.deleteProc = MyCompiledVarFree; @@ -8644,102 +8779,6 @@ int TestApplyLambdaObjCmd ( } /* - *---------------------------------------------------------------------- - * - * TestLutilCmd -- - * - * This procedure implements the "testlequal" command. It is used to - * test compare two lists for equality using the string representation - * of each element. Implemented in C because script level loops are - * too slow for comparing large (GB count) lists. - * - * Results: - * A standard Tcl result. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static int -TestLutilCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Arguments. */ -{ - Tcl_Size nL1, nL2; - Tcl_Obj *l1Obj = NULL; - Tcl_Obj *l2Obj = NULL; - Tcl_Obj **l1Elems; - Tcl_Obj **l2Elems; - static const char *const subcmds[] = { - "equal", "diffindex", NULL - }; - enum options { - LUTIL_EQUAL, LUTIL_DIFFINDEX - } idx; - - if (objc != 4) { - Tcl_WrongNumArgs(interp, 1, objv, "list1 list2"); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[1], subcmds, "option", 0, - &idx) != TCL_OK) { - return TCL_ERROR; - } - - /* Protect against shimmering, just to be safe */ - l1Obj = Tcl_DuplicateObj(objv[2]); - l2Obj = Tcl_DuplicateObj(objv[3]); - - int ret = TCL_ERROR; - if (Tcl_ListObjGetElements(interp, l1Obj, &nL1, &l1Elems) != TCL_OK) { - goto vamoose; - } - if (Tcl_ListObjGetElements(interp, l2Obj, &nL2, &l2Elems) != TCL_OK) { - goto vamoose; - } - - Tcl_Size i, nCmp; - - ret = TCL_OK; - switch (idx) { - case LUTIL_EQUAL: - /* Avoid the loop below if lengths differ */ - if (nL1 != nL2) { - Tcl_SetObjResult(interp, Tcl_NewIntObj(0)); - break; - } - /* FALLTHRU */ - case LUTIL_DIFFINDEX: - nCmp = nL1 <= nL2 ? nL1 : nL2; - for (i = 0; i < nCmp; ++i) { - if (strcmp(Tcl_GetString(l1Elems[i]), Tcl_GetString(l2Elems[i]))) { - break; - } - } - if (i == nCmp && nCmp == nL1 && nCmp == nL2) { - nCmp = idx == LUTIL_EQUAL ? 1 : -1; - } else { - nCmp = idx == LUTIL_EQUAL ? 0 : i; - } - Tcl_SetObjResult(interp, Tcl_NewWideIntObj(nCmp)); - break; - } - -vamoose: - if (l1Obj) { - Tcl_DecrRefCount(l1Obj); - } - if (l2Obj) { - Tcl_DecrRefCount(l2Obj); - } - return ret; -} - -/* * Local Variables: * mode: c * c-basic-offset: 4 diff --git a/generic/tclTestABSList.c b/generic/tclTestABSList.c deleted file mode 100644 index 5d3f814..0000000 --- a/generic/tclTestABSList.c +++ /dev/null @@ -1,1256 +0,0 @@ -// Tcl Abstract List test command: "lstring" - -#undef BUILD_tcl -#undef STATIC_BUILD -#ifndef USE_TCL_STUBS -# define USE_TCL_STUBS -#endif -#include <string.h> -#include <limits.h> -#include "tclInt.h" - -/* - * Forward references - */ - -Tcl_Obj *myNewLStringObj(Tcl_WideInt start, - Tcl_WideInt length); -static void freeRep(Tcl_Obj* alObj); -static Tcl_Obj* my_LStringObjSetElem(Tcl_Interp *interp, - Tcl_Obj *listPtr, - Tcl_Size numIndcies, - Tcl_Obj *const indicies[], - Tcl_Obj *valueObj); -static void DupLStringRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); -static Tcl_Size my_LStringObjLength(Tcl_Obj *lstringObjPtr); -static int my_LStringObjIndex(Tcl_Interp *interp, - Tcl_Obj *lstringObj, - Tcl_Size index, - Tcl_Obj **charObjPtr); -static int my_LStringObjRange(Tcl_Interp *interp, Tcl_Obj *lstringObj, - Tcl_Size fromIdx, Tcl_Size toIdx, - Tcl_Obj **newObjPtr); -static int my_LStringObjReverse(Tcl_Interp *interp, Tcl_Obj *srcObj, - Tcl_Obj **newObjPtr); -static int my_LStringReplace(Tcl_Interp *interp, - Tcl_Obj *listObj, - Tcl_Size first, - Tcl_Size numToDelete, - Tcl_Size numToInsert, - Tcl_Obj *const insertObjs[]); -static int my_LStringGetElements(Tcl_Interp *interp, - Tcl_Obj *listPtr, - Tcl_Size *objcptr, - Tcl_Obj ***objvptr); -static void lstringFreeElements(Tcl_Obj* lstringObj); -static void UpdateStringOfLString(Tcl_Obj *objPtr); - -/* - * Internal Representation of an lstring type value - */ - -typedef struct LString { - char *string; // NULL terminated utf-8 string - Tcl_Size strlen; // num bytes in string - Tcl_Size allocated; // num bytes allocated - Tcl_Obj**elements; // elements array, allocated when GetElements is - // called -} LString; - -/* - * AbstractList definition of an lstring type - */ -static const Tcl_ObjType lstringTypes[11] = { - {/*0*/ - "lstring", - freeRep, - DupLStringRep, - UpdateStringOfLString, - NULL, - TCL_OBJTYPE_V2( - my_LStringObjLength, /* Length */ - my_LStringObjIndex, /* Index */ - my_LStringObjRange, /* Slice */ - my_LStringObjReverse, /* Reverse */ - my_LStringGetElements, /* GetElements */ - my_LStringObjSetElem, /* SetElement */ - my_LStringReplace, /* Replace */ - NULL) /* "in" operator */ - }, - {/*1*/ - "lstring", - freeRep, - DupLStringRep, - UpdateStringOfLString, - NULL, - TCL_OBJTYPE_V2( - NULL, /* Length */ - my_LStringObjIndex, /* Index */ - my_LStringObjRange, /* Slice */ - my_LStringObjReverse, /* Reverse */ - my_LStringGetElements, /* GetElements */ - my_LStringObjSetElem, /* SetElement */ - my_LStringReplace, /* Replace */ - NULL) /* "in" operator */ - }, - {/*2*/ - "lstring", - freeRep, - DupLStringRep, - UpdateStringOfLString, - NULL, - TCL_OBJTYPE_V2( - my_LStringObjLength, /* Length */ - NULL, /* Index */ - my_LStringObjRange, /* Slice */ - my_LStringObjReverse, /* Reverse */ - my_LStringGetElements, /* GetElements */ - my_LStringObjSetElem, /* SetElement */ - my_LStringReplace, /* Replace */ - NULL) /* "in" operator */ - }, - {/*3*/ - "lstring", - freeRep, - DupLStringRep, - UpdateStringOfLString, - NULL, - TCL_OBJTYPE_V2( - my_LStringObjLength, /* Length */ - my_LStringObjIndex, /* Index */ - NULL, /* Slice */ - my_LStringObjReverse, /* Reverse */ - my_LStringGetElements, /* GetElements */ - my_LStringObjSetElem, /* SetElement */ - my_LStringReplace, /* Replace */ - NULL) /* "in" operator */ - }, - {/*4*/ - "lstring", - freeRep, - DupLStringRep, - UpdateStringOfLString, - NULL, - TCL_OBJTYPE_V2( - my_LStringObjLength, /* Length */ - my_LStringObjIndex, /* Index */ - my_LStringObjRange, /* Slice */ - NULL, /* Reverse */ - my_LStringGetElements, /* GetElements */ - my_LStringObjSetElem, /* SetElement */ - my_LStringReplace, /* Replace */ - NULL) /* "in" operator */ - }, - {/*5*/ - "lstring", - freeRep, - DupLStringRep, - UpdateStringOfLString, - NULL, - TCL_OBJTYPE_V2( - my_LStringObjLength, /* Length */ - my_LStringObjIndex, /* Index */ - my_LStringObjRange, /* Slice */ - my_LStringObjReverse, /* Reverse */ - NULL, /* GetElements */ - my_LStringObjSetElem, /* SetElement */ - my_LStringReplace, /* Replace */ - NULL) /* "in" operator */ - }, - {/*6*/ - "lstring", - freeRep, - DupLStringRep, - UpdateStringOfLString, - NULL, - TCL_OBJTYPE_V2( - my_LStringObjLength, /* Length */ - my_LStringObjIndex, /* Index */ - my_LStringObjRange, /* Slice */ - my_LStringObjReverse, /* Reverse */ - my_LStringGetElements, /* GetElements */ - NULL, /* SetElement */ - my_LStringReplace, /* Replace */ - NULL) /* "in" operator */ - }, - {/*7*/ - "lstring", - freeRep, - DupLStringRep, - UpdateStringOfLString, - NULL, - TCL_OBJTYPE_V2( - my_LStringObjLength, /* Length */ - my_LStringObjIndex, /* Index */ - my_LStringObjRange, /* Slice */ - my_LStringObjReverse, /* Reverse */ - my_LStringGetElements, /* GetElements */ - my_LStringObjSetElem, /* SetElement */ - NULL, /* Replace */ - NULL) /* "in" operator */ - }, - {/*8*/ - "lstring", - freeRep, - DupLStringRep, - UpdateStringOfLString, - NULL, - TCL_OBJTYPE_V2( - my_LStringObjLength, /* Length */ - my_LStringObjIndex, /* Index */ - my_LStringObjRange, /* Slice */ - my_LStringObjReverse, /* Reverse */ - my_LStringGetElements, /* GetElements */ - my_LStringObjSetElem, /* SetElement */ - my_LStringReplace, /* Replace */ - NULL) /* "in" operator */ - }, - {/*9*/ - "lstring", - freeRep, - DupLStringRep, - UpdateStringOfLString, - NULL, - TCL_OBJTYPE_V2( - my_LStringObjLength, /* Length */ - my_LStringObjIndex, /* Index */ - my_LStringObjRange, /* Slice */ - my_LStringObjReverse, /* Reverse */ - my_LStringGetElements, /* GetElements */ - my_LStringObjSetElem, /* SetElement */ - my_LStringReplace, /* Replace */ - NULL) /* "in" operator */ - }, - {/*10*/ - "lstring", - freeRep, - DupLStringRep, - UpdateStringOfLString, - NULL, - TCL_OBJTYPE_V2( - my_LStringObjLength, /* Length */ - my_LStringObjIndex, /* Index */ - my_LStringObjRange, /* Slice */ - my_LStringObjReverse, /* Reverse */ - my_LStringGetElements, /* GetElements */ - my_LStringObjSetElem, /* SetElement */ - my_LStringReplace, /* Replace */ - NULL) /* "in" operator */ - } -}; - - -/* - *---------------------------------------------------------------------- - * - * my_LStringObjIndex -- - * - * Implements the AbstractList Index function for the lstring type. The - * Index function returns the value at the index position given. Caller - * is resposible for freeing the Obj. - * - * Results: - * TCL_OK on success. Returns a new Obj, with a 0 refcount in the - * supplied charObjPtr location. Call has ownership of the Obj. - * - * Side effects: - * Obj allocated. - * - *---------------------------------------------------------------------- - */ - -static int -my_LStringObjIndex( - Tcl_Interp *interp, - Tcl_Obj *lstringObj, - Tcl_Size index, - Tcl_Obj **charObjPtr) -{ - LString *lstringRepPtr = (LString*)lstringObj->internalRep.twoPtrValue.ptr1; - - (void)interp; - - if (index < lstringRepPtr->strlen) { - char cchar[2]; - cchar[0] = lstringRepPtr->string[index]; - cchar[1] = 0; - *charObjPtr = Tcl_NewStringObj(cchar,1); - } else { - *charObjPtr = NULL; - } - - return TCL_OK; -} - - -/* - *---------------------------------------------------------------------- - * - * my_LStringObjLength -- - * - * Implements the AbstractList Length function for the lstring type. - * The Length function returns the number of elements in the list. - * - * Results: - * WideInt number of elements in the list. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -static Tcl_Size -my_LStringObjLength(Tcl_Obj *lstringObjPtr) -{ - LString *lstringRepPtr = (LString *)lstringObjPtr->internalRep.twoPtrValue.ptr1; - return lstringRepPtr->strlen; -} - - -/* - *---------------------------------------------------------------------- - * - * DupLStringRep -- - * - * Replicates the internal representation of the src value, and storing - * it in the copy - * - * Results: - * void - * - * Side effects: - * Modifies the rep of the copyObj. - * - *---------------------------------------------------------------------- - */ - -static void -DupLStringRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr) -{ - LString *srcLString = (LString*)srcPtr->internalRep.twoPtrValue.ptr1; - LString *copyLString = (LString*)Tcl_Alloc(sizeof(LString)); - - memcpy(copyLString, srcLString, sizeof(LString)); - copyLString->string = (char*)Tcl_Alloc(srcLString->allocated); - strncpy(copyLString->string, srcLString->string, srcLString->strlen); - copyLString->string[srcLString->strlen] = '\0'; - copyLString->elements = NULL; - Tcl_ObjInternalRep itr; - itr.twoPtrValue.ptr1 = copyLString; - itr.twoPtrValue.ptr2 = NULL; - Tcl_StoreInternalRep(copyPtr, srcPtr->typePtr, &itr); - - return; -} - -/* - *---------------------------------------------------------------------- - * - * my_LStringObjSetElem -- - * - * Replace the element value at the given (nested) index with the - * valueObj provided. If the lstring obj is shared, a new list is - * created conntaining the modifed element. - * - * Results: - * The modifed lstring is returned, either new or original. If the - * index is invalid, NULL is returned, and an error is added to the - * interp, if provided. - * - * Side effects: - * A new obj may be created. - * - *---------------------------------------------------------------------- - */ - -static Tcl_Obj* -my_LStringObjSetElem( - Tcl_Interp *interp, - Tcl_Obj *lstringObj, - Tcl_Size numIndicies, - Tcl_Obj *const indicies[], - Tcl_Obj *valueObj) -{ - LString *lstringRepPtr = (LString*)lstringObj->internalRep.twoPtrValue.ptr1; - Tcl_Size index; - int status; - Tcl_Obj *returnObj; - - if (numIndicies > 1) { - Tcl_SetObjResult(interp, - Tcl_ObjPrintf("Multiple indicies not supported by lstring.")); - return NULL; - } - - status = Tcl_GetIntForIndex(interp, indicies[0], lstringRepPtr->strlen, &index); - if (status != TCL_OK) { - return NULL; - } - - returnObj = Tcl_IsShared(lstringObj) ? Tcl_DuplicateObj(lstringObj) : lstringObj; - lstringRepPtr = (LString*)returnObj->internalRep.twoPtrValue.ptr1; - - if (index >= lstringRepPtr->strlen) { - index = lstringRepPtr->strlen; - lstringRepPtr->strlen++; - lstringRepPtr->string = (char*)Tcl_Realloc(lstringRepPtr->string, lstringRepPtr->strlen+1); - } - - if (valueObj) { - const char newvalue = Tcl_GetString(valueObj)[0]; - lstringRepPtr->string[index] = newvalue; - } else if (index < lstringRepPtr->strlen) { - /* Remove the char by sliding the tail of the string down */ - char *sptr = &lstringRepPtr->string[index]; - /* This is an overlapping copy, by definition */ - lstringRepPtr->strlen--; - memmove(sptr, (sptr+1), (lstringRepPtr->strlen - index)); - } - // else do nothing - - Tcl_InvalidateStringRep(returnObj); - - return returnObj; -} - -/* - *---------------------------------------------------------------------- - * - * my_LStringObjRange -- - * - * Creates a new Obj with a slice of the src listPtr. - * - * Results: - * A new Obj is assigned to newObjPtr. Returns TCL_OK - * - * Side effects: - * A new Obj is created. - * - *---------------------------------------------------------------------- - */ - -static int my_LStringObjRange( - Tcl_Interp *interp, - Tcl_Obj *lstringObj, - Tcl_Size fromIdx, - Tcl_Size toIdx, - Tcl_Obj **newObjPtr) -{ - Tcl_Obj *rangeObj; - LString *lstringRepPtr = (LString*)lstringObj->internalRep.twoPtrValue.ptr1; - LString *rangeRep; - Tcl_WideInt len = toIdx - fromIdx + 1; - - if (lstringRepPtr->strlen < fromIdx || - lstringRepPtr->strlen < toIdx) { - Tcl_SetObjResult(interp, - Tcl_ObjPrintf("Range out of bounds ")); - return TCL_ERROR; - } - - if (len <= 0) { - // Return empty value; - *newObjPtr = Tcl_NewObj(); - } else { - rangeRep = (LString*)Tcl_Alloc(sizeof(LString)); - rangeRep->allocated = len+1; - rangeRep->strlen = len; - rangeRep->string = (char*)Tcl_Alloc(rangeRep->allocated); - strncpy(rangeRep->string,&lstringRepPtr->string[fromIdx],len); - rangeRep->string[len] = 0; - rangeRep->elements = NULL; - rangeObj = Tcl_NewObj(); - Tcl_ObjInternalRep itr; - itr.twoPtrValue.ptr1 = rangeRep; - itr.twoPtrValue.ptr2 = NULL; - Tcl_StoreInternalRep(rangeObj, lstringObj->typePtr, &itr); - if (rangeRep->strlen > 0) { - Tcl_InvalidateStringRep(rangeObj); - } else { - Tcl_InitStringRep(rangeObj, NULL, 0); - } - *newObjPtr = rangeObj; - } - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * my_LStringObjReverse -- - * - * Creates a new Obj with the the order of the elements in the lstring - * value reversed, where first is last and last is first, etc. - * - * Results: - * A new Obj is assigned to newObjPtr. Returns TCL_OK - * - * Side effects: - * A new Obj is created. - * - *---------------------------------------------------------------------- - */ - -static int -my_LStringObjReverse(Tcl_Interp *interp, Tcl_Obj *srcObj, Tcl_Obj **newObjPtr) -{ - LString *srcRep = (LString*)srcObj->internalRep.twoPtrValue.ptr1; - Tcl_Obj *revObj; - LString *revRep = (LString*)Tcl_Alloc(sizeof(LString)); - Tcl_ObjInternalRep itr; - Tcl_Size len; - char *srcp, *dstp, *endp; - (void)interp; - len = srcRep->strlen; - revRep->strlen = len; - revRep->allocated = len+1; - revRep->string = (char*)Tcl_Alloc(revRep->allocated); - revRep->elements = NULL; - srcp = srcRep->string; - endp = &srcRep->string[len]; - dstp = &revRep->string[len]; - *dstp-- = 0; - while (srcp < endp) { - *dstp-- = *srcp++; - } - revObj = Tcl_NewObj(); - itr.twoPtrValue.ptr1 = revRep; - itr.twoPtrValue.ptr2 = NULL; - Tcl_StoreInternalRep(revObj, srcObj->typePtr, &itr); - if (revRep->strlen > 0) { - Tcl_InvalidateStringRep(revObj); - } else { - Tcl_InitStringRep(revObj, NULL, 0); - } - *newObjPtr = revObj; - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * my_LStringReplace -- - * - * Delete and/or Insert elements in the list, starting at index first. - * See more details in the comments below. This should not be called with - * a Shared Obj. - * - * Results: - * The value of the listObj is modified. - * - * Side effects: - * The string rep is invalidated. - * - *---------------------------------------------------------------------- - */ - -static int -my_LStringReplace( - Tcl_Interp *interp, - Tcl_Obj *listObj, - Tcl_Size first, - Tcl_Size numToDelete, - Tcl_Size numToInsert, - Tcl_Obj *const insertObjs[]) -{ - LString *lstringRep = (LString*)listObj->internalRep.twoPtrValue.ptr1; - Tcl_Size newLen; - Tcl_Size x, ix, kx; - char *newStr; - char *oldStr = lstringRep->string; - (void)interp; - - newLen = lstringRep->strlen - numToDelete + numToInsert; - - if (newLen >= lstringRep->allocated) { - lstringRep->allocated = newLen+1; - newStr = (char*)Tcl_Alloc(lstringRep->allocated); - newStr[newLen] = 0; - } else { - newStr = oldStr; - } - - /* Tcl_ListObjReplace replaces zero or more elements of the list - * referenced by listPtr with the objc values in the array referenced by - * objv. - * - * If listPtr does not point to a list value, Tcl_ListObjReplace - * will attempt to convert it to one; if the conversion fails, it returns - * TCL_ERROR and leaves an error message in the interpreter's result value - * if interp is not NULL. Otherwise, it returns TCL_OK after replacing the - * values. - * - * * If objv is NULL, no new elements are added. - * - * * 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 the one designated by first. - * Tcl_ListObjReplace invalidates listPtr's old string representation. - * - * * The reference counts of any elements inserted from objv are - * incremented since the resulting list now refers to them. Similarly, - * the reference counts for any replaced values are decremented. - */ - - // copy 0 to first-1 - if (newStr != oldStr) { - strncpy(newStr, oldStr, first); - } - - // move front elements to keep - for(x=0, kx=0; x<newLen && kx<first; kx++, x++) { - newStr[x] = oldStr[kx]; - } - // Insert new elements into new string - for(x=first, ix=0; ix<numToInsert; x++, ix++) { - char const *svalue = Tcl_GetString(insertObjs[ix]); - newStr[x] = svalue[0]; - } - // Move remaining elements - if ((first+numToDelete) < newLen) { - for(/*x,*/ kx=first+numToDelete; (kx <lstringRep->strlen && x<newLen); x++, kx++) { - newStr[x] = oldStr[kx]; - } - } - - // Terminate new string. - newStr[newLen] = 0; - - - if (oldStr != newStr) { - Tcl_Free(oldStr); - } - lstringRep->string = newStr; - lstringRep->strlen = newLen; - - /* Changes made to value, string rep and elements array no longer valid */ - Tcl_InvalidateStringRep(listObj); - lstringFreeElements(listObj); - - return TCL_OK; -} - -static const Tcl_ObjType * -my_SetAbstractProc(int ptype) -{ - const Tcl_ObjType *typePtr = &lstringTypes[0]; /* default value */ - if (4 <= ptype && ptype <= 11) { - /* Table has no entries for the slots upto setfromany */ - typePtr = &lstringTypes[(ptype-3)]; - } - return typePtr; -} - - -/* - *---------------------------------------------------------------------- - * - * my_NewLStringObj -- - * - * Creates a new lstring Obj using the string value of objv[0] - * - * Results: - * results - * - * Side effects: - * side effects - * - *---------------------------------------------------------------------- - */ - -static Tcl_Obj * -my_NewLStringObj( - Tcl_Interp *interp, - int objc, - Tcl_Obj * const objv[]) -{ - LString *lstringRepPtr; - Tcl_ObjInternalRep itr; - size_t repSize; - Tcl_Obj *lstringPtr; - const char *string; - static const char* procTypeNames[] = { - "FREEREP", "DUPREP", "UPDATESTRING", "SETFROMANY", - "LENGTH", "INDEX", "SLICE", "REVERSE", "GETELEMENTS", - "SETELEMENT", "REPLACE", NULL - }; - int i = 0; - int ptype; - const Tcl_ObjType *lstringTypePtr = &lstringTypes[10]; - - repSize = sizeof(LString); - lstringRepPtr = (LString*)Tcl_Alloc(repSize); - - while (i<objc) { - const char *s = Tcl_GetString(objv[i]); - if (strcmp(s, "-not")==0) { - i++; - if (Tcl_GetIndexFromObj(interp, objv[i], procTypeNames, "proctype", 0, &ptype)==TCL_OK) { - lstringTypePtr = my_SetAbstractProc(ptype); - } - } else if (strcmp(s, "--") == 0) { - // End of options - i++; - break; - } else { - break; - } - i++; - } - if (i != objc-1) { - Tcl_Free((char*)lstringRepPtr); - Tcl_WrongNumArgs(interp, 0, objv, "lstring string"); - return NULL; - } - string = Tcl_GetString(objv[i]); - - lstringRepPtr->strlen = strlen(string); - lstringRepPtr->allocated = lstringRepPtr->strlen + 1; - lstringRepPtr->string = (char*)Tcl_Alloc(lstringRepPtr->allocated); - strcpy(lstringRepPtr->string, string); - lstringRepPtr->elements = NULL; - lstringPtr = Tcl_NewObj(); - itr.twoPtrValue.ptr1 = lstringRepPtr; - itr.twoPtrValue.ptr2 = NULL; - Tcl_StoreInternalRep(lstringPtr, lstringTypePtr, &itr); - if (lstringRepPtr->strlen > 0) { - Tcl_InvalidateStringRep(lstringPtr); - } else { - Tcl_InitStringRep(lstringPtr, NULL, 0); - } - return lstringPtr; -} - -/* - *---------------------------------------------------------------------- - * - * freeElements -- - * - * Free the element array - * - */ - -static void -lstringFreeElements(Tcl_Obj* lstringObj) -{ - LString *lstringRepPtr = (LString*)lstringObj->internalRep.twoPtrValue.ptr1; - if (lstringRepPtr->elements) { - Tcl_Obj **objptr = lstringRepPtr->elements; - while (objptr < &lstringRepPtr->elements[lstringRepPtr->strlen]) { - Tcl_DecrRefCount(*objptr++); - } - Tcl_Free((char*)lstringRepPtr->elements); - lstringRepPtr->elements = NULL; - } -} - -/* - *---------------------------------------------------------------------- - * - * freeRep -- - * - * Free the value storage of the lstring Obj. - * - * Results: - * void - * - * Side effects: - * Memory free'd. - * - *---------------------------------------------------------------------- - */ - -static void -freeRep(Tcl_Obj* lstringObj) -{ - LString *lstringRepPtr = (LString*)lstringObj->internalRep.twoPtrValue.ptr1; - if (lstringRepPtr->string) { - Tcl_Free(lstringRepPtr->string); - } - lstringFreeElements(lstringObj); - Tcl_Free((char*)lstringRepPtr); - lstringObj->internalRep.twoPtrValue.ptr1 = NULL; -} - -/* - *---------------------------------------------------------------------- - * - * my_LStringGetElements -- - * - * Get the elements of the list in an array. - * - * Results: - * objc, objv return values - * - * Side effects: - * A Tcl_Obj is stored for every element of the abstract list - * - *---------------------------------------------------------------------- - */ - -static int my_LStringGetElements(Tcl_Interp *interp, - Tcl_Obj *lstringObj, - Tcl_Size *objcptr, - Tcl_Obj ***objvptr) -{ - LString *lstringRepPtr = (LString*)lstringObj->internalRep.twoPtrValue.ptr1; - Tcl_Obj **objPtr; - char *cptr = lstringRepPtr->string; - (void)interp; - if (lstringRepPtr->strlen == 0) { - *objcptr = 0; - *objvptr = NULL; - return TCL_OK; - } - if (lstringRepPtr->elements == NULL) { - lstringRepPtr->elements = (Tcl_Obj**)Tcl_Alloc(sizeof(Tcl_Obj*) * lstringRepPtr->strlen); - objPtr=lstringRepPtr->elements; - while (objPtr < &lstringRepPtr->elements[lstringRepPtr->strlen]) { - *objPtr = Tcl_NewStringObj(cptr++,1); - Tcl_IncrRefCount(*objPtr++); - } - } - *objvptr = lstringRepPtr->elements; - *objcptr = lstringRepPtr->strlen; - return TCL_OK; -} - -/* -** UpdateStringRep -*/ - -static void -UpdateStringOfLString(Tcl_Obj *objPtr) -{ -# define LOCAL_SIZE 64 - int localFlags[LOCAL_SIZE], *flagPtr = NULL; - Tcl_ObjType const *typePtr = objPtr->typePtr; - char *p; - int bytesNeeded = 0; - int llen, i; - - - /* - * Handle empty list case first, so rest of the routine is simpler. - */ - llen = typePtr->lengthProc(objPtr); - if (llen <= 0) { - Tcl_InitStringRep(objPtr, NULL, 0); - return; - } - - /* - * Pass 1: estimate space. - */ - if (llen <= LOCAL_SIZE) { - flagPtr = localFlags; - } else { - /* We know numElems <= LIST_MAX, so this is safe. */ - flagPtr = (int *) Tcl_Alloc(llen*sizeof(int)); - } - for (bytesNeeded = 0, i = 0; i < llen; i++) { - Tcl_Obj *elemObj; - const char *elemStr; - Tcl_Size elemLen; - flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0); - typePtr->indexProc(NULL, objPtr, i, &elemObj); - Tcl_IncrRefCount(elemObj); - elemStr = Tcl_GetStringFromObj(elemObj, &elemLen); - /* Note TclScanElement updates flagPtr[i] */ - bytesNeeded += Tcl_ScanCountedElement(elemStr, elemLen, &flagPtr[i]); - if (bytesNeeded < 0) { - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); - } - Tcl_DecrRefCount(elemObj); - } - if (bytesNeeded > INT_MAX - llen + 1) { - Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); - } - bytesNeeded += llen; /* Separating spaces and terminating nul */ - - /* - * Pass 2: generate the string repr. - */ - objPtr->bytes = (char *) Tcl_Alloc(bytesNeeded); - p = objPtr->bytes; - for (i = 0; i < llen; i++) { - Tcl_Obj *elemObj; - const char *elemStr; - Tcl_Size elemLen; - flagPtr[i] |= (i ? TCL_DONT_QUOTE_HASH : 0); - typePtr->indexProc(NULL, objPtr, i, &elemObj); - Tcl_IncrRefCount(elemObj); - elemStr = Tcl_GetStringFromObj(elemObj, &elemLen); - p += Tcl_ConvertCountedElement(elemStr, elemLen, p, flagPtr[i]); - *p++ = ' '; - Tcl_DecrRefCount(elemObj); - } - p[-1] = '\0'; /* Overwrite last space added */ - - /* Length of generated string */ - objPtr->length = p - 1 - objPtr->bytes; - - if (flagPtr != localFlags) { - Tcl_Free(flagPtr); - } -} - -/* - *---------------------------------------------------------------------- - * - * lLStringObjCmd -- - * - * Script level command that creats an lstring Obj value. - * - * Results: - * Returns and lstring Obj value in the interp results. - * - * Side effects: - * Interp results modified. - * - *---------------------------------------------------------------------- - */ - -static int -lLStringObjCmd( - void *clientData, - Tcl_Interp *interp, - int objc, - Tcl_Obj * const objv[]) -{ - Tcl_Obj *lstringObj; - - (void)clientData; - if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "string"); - return TCL_ERROR; - } - - lstringObj = my_NewLStringObj(interp, objc-1, &objv[1]); - - if (lstringObj) { - Tcl_SetObjResult(interp, lstringObj); - return TCL_OK; - } - return TCL_ERROR; -} - -/* -** lgen - Derived from TIP 192 - Lazy Lists -** Generate a list using a command provided as argument(s). -** The command computes the value for a given index. -*/ - -/* - * Internal rep for the Generate Series - */ -typedef struct LgenSeries { - Tcl_Interp *interp; // used to evaluate gen script - Tcl_Size len; // list length - Tcl_Size nargs; // Number of arguments in genFn including "index" - Tcl_Obj *genFnObj; // The preformed command as a list. Index is set in - // the last element (last argument) -} LgenSeries; - -/* - * Evaluate the generation function. - * The provided funtion computes the value for a give index - */ -static Tcl_Obj* -lgen( - Tcl_Obj* objPtr, - Tcl_Size index) -{ - LgenSeries *lgenSeriesPtr = (LgenSeries*)objPtr->internalRep.twoPtrValue.ptr1; - Tcl_Obj *elemObj = NULL; - Tcl_Interp *intrp = lgenSeriesPtr->interp; - Tcl_Obj *genCmd = lgenSeriesPtr->genFnObj; - Tcl_Size endidx = lgenSeriesPtr->nargs-1; - - if (0 <= index && index < lgenSeriesPtr->len) { - Tcl_Obj *indexObj = Tcl_NewWideIntObj(index); - Tcl_ListObjReplace(intrp, genCmd, endidx, 1, 1, &indexObj); - // EVAL DIRECT to avoid interfering with bytecode compile which may be - // active on the stack - int flags = TCL_EVAL_GLOBAL|TCL_EVAL_DIRECT; - int status = Tcl_EvalObjEx(intrp, genCmd, flags); - elemObj = Tcl_GetObjResult(intrp); - if (status != TCL_OK) { - Tcl_SetObjResult(intrp, Tcl_ObjPrintf( - "Error: %s\nwhile executing %s\n", - elemObj ? Tcl_GetString(elemObj) : "NULL", Tcl_GetString(genCmd))); - return NULL; - } - } - return elemObj; -} - -/* - * Abstract List Length function - */ -static Tcl_Size -lgenSeriesObjLength(Tcl_Obj *objPtr) -{ - LgenSeries *lgenSeriesRepPtr = (LgenSeries *)objPtr->internalRep.twoPtrValue.ptr1; - return lgenSeriesRepPtr->len; -} - -/* - * Abstract List Index function - */ -static int -lgenSeriesObjIndex( - Tcl_Interp *interp, - Tcl_Obj *lgenSeriesObjPtr, - Tcl_Size index, - Tcl_Obj **elemPtr) -{ - LgenSeries *lgenSeriesRepPtr; - Tcl_Obj *element; - - lgenSeriesRepPtr = (LgenSeries*)lgenSeriesObjPtr->internalRep.twoPtrValue.ptr1; - - if (index < 0 || index >= lgenSeriesRepPtr->len) { - *elemPtr = NULL; - return TCL_OK; - } - if (lgenSeriesRepPtr->interp == NULL && interp == NULL) { - return TCL_ERROR; - } - - lgenSeriesRepPtr->interp = interp; - - element = lgen(lgenSeriesObjPtr, index); - if (element) { - *elemPtr = element; - } else { - return TCL_ERROR; - } - - return TCL_OK; -} - -/* -** UpdateStringRep -*/ - -static void -UpdateStringOfLgen(Tcl_Obj *objPtr) -{ - LgenSeries *lgenSeriesRepPtr; - Tcl_Obj *element; - Tcl_Size i; - size_t bytlen; - Tcl_Obj *tmpstr = Tcl_NewObj(); - - lgenSeriesRepPtr = (LgenSeries*)objPtr->internalRep.twoPtrValue.ptr1; - - for (i=0, bytlen=0; i<lgenSeriesRepPtr->len; i++) { - element = lgen(objPtr, i); - if (element) { - if (i) { - Tcl_AppendToObj(tmpstr," ",1); - } - Tcl_AppendObjToObj(tmpstr,element); - } - } - - bytlen = Tcl_GetCharLength(tmpstr); - Tcl_InitStringRep(objPtr, Tcl_GetString(tmpstr), bytlen); - Tcl_DecrRefCount(tmpstr); - - return; -} - -/* - * ObjType Free Internal Rep function - */ -static void -FreeLgenInternalRep(Tcl_Obj *objPtr) -{ - LgenSeries *lgenSeries = (LgenSeries*)objPtr->internalRep.twoPtrValue.ptr1; - if (lgenSeries->genFnObj) { - Tcl_DecrRefCount(lgenSeries->genFnObj); - } - lgenSeries->interp = NULL; - Tcl_Free(lgenSeries); - objPtr->internalRep.twoPtrValue.ptr1 = 0; -} - -static void DupLgenSeriesRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); - -/* - * Abstract List ObjType definition - */ - -static const Tcl_ObjType lgenType = { - "lgenseries", - FreeLgenInternalRep, - DupLgenSeriesRep, - UpdateStringOfLgen, - NULL, /* SetFromAnyProc */ - TCL_OBJTYPE_V2( - lgenSeriesObjLength, - lgenSeriesObjIndex, - NULL, /* slice */ - NULL, /* reverse */ - NULL, /* get elements */ - NULL, /* set element */ - NULL, /* replace */ - NULL) /* "in" operator */ -}; - -/* - * ObjType Duplicate Internal Rep Function - */ -static void -DupLgenSeriesRep( - Tcl_Obj *srcPtr, - Tcl_Obj *copyPtr) -{ - LgenSeries *srcLgenSeries = (LgenSeries*)srcPtr->internalRep.twoPtrValue.ptr1; - Tcl_Size repSize = sizeof(LgenSeries); - LgenSeries *copyLgenSeries = (LgenSeries*)Tcl_Alloc(repSize); - - copyLgenSeries->interp = srcLgenSeries->interp; - copyLgenSeries->nargs = srcLgenSeries->nargs; - copyLgenSeries->len = srcLgenSeries->len; - copyLgenSeries->genFnObj = Tcl_DuplicateObj(srcLgenSeries->genFnObj); - Tcl_IncrRefCount(copyLgenSeries->genFnObj); - copyPtr->typePtr = &lgenType; - copyPtr->internalRep.twoPtrValue.ptr1 = copyLgenSeries; - copyPtr->internalRep.twoPtrValue.ptr2 = NULL; - return; -} - -/* - * Create a new lgen Tcl_Obj - */ -Tcl_Obj * -newLgenObj( - Tcl_Interp *interp, - int objc, - Tcl_Obj * const objv[]) -{ - Tcl_WideInt length; - LgenSeries *lGenSeriesRepPtr; - Tcl_Size repSize; - Tcl_Obj *lGenSeriesObj; - - if (objc < 2) { - return NULL; - } - - if (Tcl_GetWideIntFromObj(NULL, objv[0], &length) != TCL_OK - || length < 0) { - return NULL; - } - - lGenSeriesObj = Tcl_NewObj(); - repSize = sizeof(LgenSeries); - lGenSeriesRepPtr = (LgenSeries*)Tcl_Alloc(repSize); - lGenSeriesRepPtr->interp = interp; //Tcl_CreateInterp(); - lGenSeriesRepPtr->len = length; - - // Allocate array of *obj for cmd + index + args - // objv length cmd arg1 arg2 arg3 ... - // argsv 0 1 2 3 ... index - - lGenSeriesRepPtr->nargs = objc; - lGenSeriesRepPtr->genFnObj = Tcl_NewListObj(objc-1, objv+1); - // Addd 0 placeholder for index - Tcl_ListObjAppendElement(interp, lGenSeriesRepPtr->genFnObj, Tcl_NewIntObj(0)); - Tcl_IncrRefCount(lGenSeriesRepPtr->genFnObj); - lGenSeriesObj->internalRep.twoPtrValue.ptr1 = lGenSeriesRepPtr; - lGenSeriesObj->internalRep.twoPtrValue.ptr2 = NULL; - lGenSeriesObj->typePtr = &lgenType; - - if (length > 0) { - Tcl_InvalidateStringRep(lGenSeriesObj); - } else { - Tcl_InitStringRep(lGenSeriesObj, NULL, 0); - } - return lGenSeriesObj; -} - -/* - * The [lgen] command - */ -static int -lGenObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, - int objc, - Tcl_Obj * const objv[]) -{ - Tcl_Obj *genObj = newLgenObj(interp, objc-1, &objv[1]); - if (genObj) { - Tcl_SetObjResult(interp, genObj); - return TCL_OK; - } - Tcl_WrongNumArgs(interp, 1, objv, "length cmd ?args?"); - return TCL_ERROR; -} - -/* - * lgen package init - */ -int Lgen_Init(Tcl_Interp *interp) { - if (Tcl_InitStubs(interp, "8.7", 0) == NULL) { - return TCL_ERROR; - } - Tcl_CreateObjCommand(interp, "lgen", lGenObjCmd, NULL, NULL); - Tcl_PkgProvide(interp, "lgen", "1.0"); - return TCL_OK; -} - - - -/* - *---------------------------------------------------------------------- - * - * ABSListTest_Init -- - * - * Provides Abstract List implemenations via new commands - * - * lstring command - * Usage: - * lstring /string/ - * - * Description: - * Creates a list where each character in the string is treated as an - * element. The string is kept as a string, not an actual list. Indexing - * is done by char. - * - * lgen command - * Usage: - * lgen /length/ /cmd/ ?args...? - * - * The /cmd/ should take the last argument as the index value, and return - * a value for that element. - * - * Results: - * The commands listed above are added to the interp. - * - * Side effects: - * New commands defined. - * - *---------------------------------------------------------------------- - */ - -int Tcl_ABSListTest_Init(Tcl_Interp *interp) { - if (Tcl_InitStubs(interp, "8.7-", 0) == NULL) { - return TCL_ERROR; - } - Tcl_CreateObjCommand(interp, "lstring", lLStringObjCmd, NULL, NULL); - Tcl_CreateObjCommand(interp, "lgen", lGenObjCmd, NULL, NULL); - Tcl_PkgProvide(interp, "abstractlisttest", "1.0.0"); - return TCL_OK; -} diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c index e40d7af..6f996d7 100644 --- a/generic/tclTestObj.c +++ b/generic/tclTestObj.c @@ -18,6 +18,7 @@ #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif +#define TCLBOOLWARNING(boolPtr) /* needed here because we compile with -Wc++-compat */ #include "tclInt.h" #ifdef TCL_WITH_EXTERNAL_TOMMATH # include "tommath.h" @@ -25,10 +26,15 @@ # include "tclTomMath.h" #endif #include "tclStringRep.h" -#undef TCLBOOLWARNING -#define TCLBOOLWARNING(boolPtr) /* needed here because we compile with -Wc++-compat */ -#include <assert.h> +#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 /* * Forward declarations for functions defined later in this file: @@ -46,7 +52,6 @@ static Tcl_ObjCmdProc TestintobjCmd; static Tcl_ObjCmdProc TestlistobjCmd; static Tcl_ObjCmdProc TestobjCmd; static Tcl_ObjCmdProc TeststringobjCmd; -static Tcl_ObjCmdProc TestbigdataCmd; #define VARPTR_KEY "TCLOBJTEST_VARPTR" #define NUMBER_OF_OBJECT_VARS 20 @@ -63,7 +68,7 @@ VarPtrDeleteProc( Tcl_DecrRefCount(varPtr[i]); } } - Tcl_Free(varPtr); + ckfree(varPtr); } static Tcl_Obj ** @@ -106,11 +111,11 @@ TclObjTest_Init( Tcl_Obj **varPtr; #ifndef TCL_WITH_EXTERNAL_TOMMATH - if (Tcl_TomMath_InitStubs(interp, "8.7-") == NULL) { + if (Tcl_TomMath_InitStubs(interp, "8.5-") == NULL) { return TCL_ERROR; } #endif - varPtr = (Tcl_Obj **)Tcl_Alloc(NUMBER_OF_OBJECT_VARS * sizeof(varPtr[0])); + varPtr = (Tcl_Obj **)ckalloc(NUMBER_OF_OBJECT_VARS *sizeof(varPtr[0])); if (!varPtr) { return TCL_ERROR; } @@ -134,10 +139,6 @@ TclObjTest_Init( Tcl_CreateObjCommand(interp, "testobj", TestobjCmd, NULL, NULL); Tcl_CreateObjCommand(interp, "teststringobj", TeststringobjCmd, NULL, NULL); - if (sizeof(Tcl_Size) == sizeof(Tcl_WideInt)) { - Tcl_CreateObjCommand(interp, "testbigdata", TestbigdataCmd, - NULL, NULL); - } return TCL_OK; } @@ -172,7 +173,7 @@ TestbignumobjCmd( enum options { BIGNUM_SET, BIGNUM_GET, BIGNUM_MULT10, BIGNUM_DIV10, BIGNUM_ISEVEN, BIGNUM_RADIXSIZE - } idx; + }; int index; Tcl_Size varIndex; const char *string; @@ -184,7 +185,7 @@ TestbignumobjCmd( return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[1], subcmds, "option", 0, - &idx) != TCL_OK) { + &index) != TCL_OK) { return TCL_ERROR; } if (GetVariableIndex(interp, objv[2], &varIndex) != TCL_OK) { @@ -192,7 +193,7 @@ TestbignumobjCmd( } varPtr = GetVarPtr(interp); - switch (idx) { + switch ((enum options)index) { case BIGNUM_SET: if (objc != 4) { Tcl_WrongNumArgs(interp, 2, objv, "var value"); @@ -630,7 +631,7 @@ TestindexobjCmd( return TCL_ERROR; } - argv = (const char **)Tcl_Alloc((objc-3) * sizeof(char *)); + argv = (const char **)ckalloc((objc-3) * sizeof(char *)); for (i = 4; i < objc; i++) { argv[i-4] = Tcl_GetString(objv[i]); } @@ -639,7 +640,7 @@ TestindexobjCmd( result = Tcl_GetIndexFromObj((setError? interp : NULL), objv[3], argv, "token", TCL_INDEX_TEMP_TABLE|(allowAbbrev? 0 : TCL_EXACT), &index); - Tcl_Free((void *)argv); + ckfree(argv); if (result == TCL_OK) { Tcl_SetWideIntObj(Tcl_GetObjResult(interp), index); } @@ -991,13 +992,12 @@ TestlistobjCmd( != TCL_OK) { return TCL_ERROR; } - if (objP->refCount < 0) { + if (objP->refCount <= 0) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "Tcl_ListObjIndex returned object with ref count < 0", + "Tcl_ListObjIndex returned object with ref count <= 0", TCL_INDEX_NONE)); /* Keep looping since we are also looping for leaks */ } - Tcl_BounceRefCount(objP); } break; @@ -1064,33 +1064,6 @@ TestlistobjCmd( *---------------------------------------------------------------------- */ -static Tcl_Size V1TestListObjLength(TCL_UNUSED(Tcl_Obj *)) { - return 100; -} - -static int V1TestListObjIndex( - TCL_UNUSED(Tcl_Interp *), - TCL_UNUSED(Tcl_Obj *), - TCL_UNUSED(Tcl_Size), - Tcl_Obj **objPtr) -{ - *objPtr = Tcl_NewStringObj("This indexProc should never be accessed (bug: e58d7e19e9)", -1); - return TCL_OK; -} - -static const Tcl_ObjType v1TestListType = { - "testlist", /* name */ - NULL, /* freeIntRepProc */ - NULL, /* dupIntRepProc */ - NULL, /* updateStringProc */ - NULL, /* setFromAnyProc */ - offsetof(Tcl_ObjType, indexProc), /* This is a V1 objType, which doesn't have an indexProc */ - V1TestListObjLength, /* always return 100, doesn't really matter */ - V1TestListObjIndex, /* should never be accessed, because this objType = V1*/ - NULL, NULL, NULL, NULL, NULL, NULL -}; - - static int TestobjCmd( TCL_UNUSED(void *), @@ -1103,14 +1076,14 @@ TestobjCmd( const Tcl_ObjType *targetType; Tcl_Obj **varPtr; static const char *const subcommands[] = { - "freeallvars", "bug3598580", "buge58d7e19e9", + "freeallvars", "bug3598580", "types", "objtype", "newobj", "set", "assign", "convert", "duplicate", "invalidateStringRep", "refcount", "type", NULL }; enum testobjCmdIndex { - TESTOBJ_FREEALLVARS, TESTOBJ_BUG3598580, TESTOBJ_BUGE58D7E19E9, + TESTOBJ_FREEALLVARS, TESTOBJ_BUG3598580, TESTOBJ_TYPES, TESTOBJ_OBJTYPE, TESTOBJ_NEWOBJ, TESTOBJ_SET, TESTOBJ_ASSIGN, TESTOBJ_CONVERT, TESTOBJ_DUPLICATE, TESTOBJ_INVALIDATESTRINGREP, TESTOBJ_REFCOUNT, TESTOBJ_TYPE, @@ -1153,15 +1126,6 @@ TestobjCmd( Tcl_SetObjResult(interp, listObjPtr); } return TCL_OK; - case TESTOBJ_BUGE58D7E19E9: - if (objc != 3) { - goto wrongNumArgs; - } else { - Tcl_Obj *listObjPtr = Tcl_NewStringObj(Tcl_GetString(objv[2]), -1); - listObjPtr->typePtr = &v1TestListType; - Tcl_SetObjResult(interp, listObjPtr); - } - return TCL_OK; case TESTOBJ_TYPES: if (objc != 2) { goto wrongNumArgs; @@ -1328,7 +1292,7 @@ TeststringobjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - Tcl_UniChar *unicode; + unsigned short *unicode; Tcl_Size size, varIndex; int option, i; Tcl_Size length; @@ -1431,21 +1395,25 @@ TeststringobjCmd( goto wrongNumArgs; } Tcl_SetWideIntObj(Tcl_GetObjResult(interp), (varPtr[varIndex] != NULL) - ? (Tcl_WideInt)varPtr[varIndex]->length : (Tcl_WideInt)-1); + ? varPtr[varIndex]->length : -1); break; case 5: /* length2 */ if (objc != 3) { goto wrongNumArgs; } if (varPtr[varIndex] != NULL) { - Tcl_ConvertToType(NULL, varPtr[varIndex], - Tcl_GetObjType("string")); - strPtr = (String *)varPtr[varIndex]->internalRep.twoPtrValue.ptr1; - length = strPtr->allocated; + const Tcl_ObjType *objType = Tcl_GetObjType("string"); + if (objType != NULL) { + Tcl_ConvertToType(NULL, varPtr[varIndex], objType); + strPtr = (String *)varPtr[varIndex]->internalRep.twoPtrValue.ptr1; + length = (int) strPtr->allocated; + } else { + length = TCL_INDEX_NONE; + } } else { length = TCL_INDEX_NONE; } - Tcl_SetWideIntObj(Tcl_GetObjResult(interp), (Tcl_WideInt)((Tcl_WideUInt)(length + 1U)) - 1); + Tcl_SetWideIntObj(Tcl_GetObjResult(interp), length); break; case 6: /* set */ if (objc != 4) { @@ -1492,10 +1460,14 @@ TeststringobjCmd( goto wrongNumArgs; } if (varPtr[varIndex] != NULL) { - Tcl_ConvertToType(NULL, varPtr[varIndex], - Tcl_GetObjType("string")); - strPtr = (String *)varPtr[varIndex]->internalRep.twoPtrValue.ptr1; - length = strPtr->maxChars; + const Tcl_ObjType *objType = Tcl_GetObjType("string"); + if (objType != NULL) { + Tcl_ConvertToType(NULL, varPtr[varIndex],objType); + strPtr = (String *)varPtr[varIndex]->internalRep.twoPtrValue.ptr1; + length = strPtr->maxChars; + } else { + length = TCL_INDEX_NONE; + } } else { length = TCL_INDEX_NONE; } @@ -1576,21 +1548,21 @@ TeststringobjCmd( Tcl_SetObjResult(interp, varPtr[varIndex]); break; case 13: /* newunicode*/ - unicode = (Tcl_UniChar *)Tcl_Alloc((objc - 3) * sizeof(Tcl_UniChar)); + unicode = (unsigned short *)ckalloc(((unsigned)objc - 3) * sizeof(unsigned short)); for (i = 0; i < (objc - 3); ++i) { int val; if (Tcl_GetIntFromObj(interp, objv[i + 3], &val) != TCL_OK) { break; } - unicode[i] = (Tcl_UniChar)val; + unicode[i] = (unsigned short)val; } if (i < (objc-3)) { - Tcl_Free(unicode); + ckfree(unicode); return TCL_ERROR; } SetVarToObj(varPtr, varIndex, Tcl_NewUnicodeObj(unicode, objc - 3)); Tcl_SetObjResult(interp, varPtr[varIndex]); - Tcl_Free(unicode); + ckfree(unicode); break; } @@ -1598,140 +1570,6 @@ TeststringobjCmd( } /* - *------------------------------------------------------------------------ - * - * TestbigdataCmd -- - * - * Implements the Tcl command testbigdata - * testbigdata string ?LEN? ?SPLIT? - returns 01234567890123... - * testbigdata bytearray ?LEN? ?SPLIT? - returns {0 1 2 3 4 5 6 7 8 9 0 1 ...} - * testbigdata dict ?SIZE? - returns dict mapping integers to themselves - * If no arguments given, returns the pattern used to generate strings. - * If SPLIT is specified, the character at that position is set to "X". - * - * Results: - * TCL_OK - Success. - * TCL_ERROR - Error. - * - * Side effects: - * Interpreter result holds result or error message. - * - *------------------------------------------------------------------------ - */ -static int -TestbigdataCmd ( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - static const char *const subcmds[] = { - "string", "bytearray", "list", "dict", NULL - }; - enum options { - BIGDATA_STRING, BIGDATA_BYTEARRAY, BIGDATA_LIST, BIGDATA_DICT - } idx; - char *s; - unsigned char *p; - Tcl_Size i, len, split; - Tcl_DString ds; - Tcl_Obj *objPtr; -#define PATTERN_LEN 10 - Tcl_Obj *patternObjs[PATTERN_LEN]; - - if (objc < 2 || objc > 4) { - Tcl_WrongNumArgs(interp, 1, objv, "command ?len? ?split?"); - return TCL_ERROR; - } - if (Tcl_GetIndexFromObj(interp, objv[1], subcmds, "option", 0, - &idx) != TCL_OK) { - return TCL_ERROR; - } - split = -1; - if (objc == 2) { - len = PATTERN_LEN; - } else { - if (Tcl_GetSizeIntFromObj(interp, objv[2], &len) != TCL_OK) { - return TCL_ERROR; - } - if (objc == 4) { - if (Tcl_GetSizeIntFromObj(interp, objv[3], &split) != TCL_OK) { - return TCL_ERROR; - } - if (split >= len) { - split = len - 1; /* Last position */ - } - } - } - /* Need one byte for nul terminator */ - Tcl_Size limit = TCL_SIZE_MAX-1; - if (len < 0 || len > limit) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "%s is greater than max permitted length %" TCL_SIZE_MODIFIER "d", - Tcl_GetString(objv[2]), limit)); - return TCL_ERROR; - } - - switch (idx) { - case BIGDATA_STRING: - Tcl_DStringInit(&ds); - Tcl_DStringSetLength(&ds, len);/* Also stores \0 at index len+1 */ - s = Tcl_DStringValue(&ds); - for (i = 0; i < len; ++i) { - s[i] = '0' + (i % PATTERN_LEN); - } - if (split >= 0) { - assert(split < len); - s[split] = 'X'; - } - Tcl_DStringResult(interp, &ds); - break; - case BIGDATA_BYTEARRAY: - objPtr = Tcl_NewByteArrayObj(NULL, len); - p = Tcl_GetByteArrayFromObj(objPtr, &len); - for (i = 0; i < len; ++i) { - p[i] = '0' + (i % PATTERN_LEN); - } - if (split >= 0) { - assert(split < len); - p[split] = 'X'; - } - Tcl_SetObjResult(interp, objPtr); - break; - case BIGDATA_LIST: - for (i = 0; i < PATTERN_LEN; ++i) { - patternObjs[i] = Tcl_NewIntObj(i); - Tcl_IncrRefCount(patternObjs[i]); - } - objPtr = Tcl_NewListObj(len, NULL); - for (i = 0; i < len; ++i) { - Tcl_ListObjAppendElement( - interp, objPtr, patternObjs[i % PATTERN_LEN]); - } - if (split >= 0) { - assert(split < len); - Tcl_Obj *splitMarker = Tcl_NewStringObj("X", 1); - Tcl_ListObjReplace(interp, objPtr, split, 1, 1, &splitMarker); - } - for (i = 0; i < PATTERN_LEN; ++i) { - patternObjs[i] = Tcl_NewIntObj(i); - Tcl_DecrRefCount(patternObjs[i]); - } - Tcl_SetObjResult(interp, objPtr); - break; - case BIGDATA_DICT: - objPtr = Tcl_NewDictObj(); - for (i = 0; i < len; ++i) { - Tcl_Obj *objPtr2 = Tcl_NewWideIntObj(i); - Tcl_DictObjPut(interp, objPtr, objPtr2, objPtr2); - } - Tcl_SetObjResult(interp, objPtr); - break; - } - return TCL_OK; -} - -/* *---------------------------------------------------------------------- * * SetVarToObj -- diff --git a/generic/tclTestProcBodyObj.c b/generic/tclTestProcBodyObj.c index 7342af7..a86499e 100644 --- a/generic/tclTestProcBodyObj.c +++ b/generic/tclTestProcBodyObj.c @@ -11,8 +11,6 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#undef BUILD_tcl -#undef STATIC_BUILD #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif diff --git a/generic/tclThread.c b/generic/tclThread.c index 698c642..391711e 100644 --- a/generic/tclThread.c +++ b/generic/tclThread.c @@ -61,7 +61,7 @@ static void RememberSyncObject(void *objPtr, void * Tcl_GetThreadData( Tcl_ThreadDataKey *keyPtr, /* Identifier for the data chunk */ - Tcl_Size size) /* Size of storage block */ + int size) /* Size of storage block */ { void *result; #if TCL_THREADS @@ -72,13 +72,13 @@ Tcl_GetThreadData( result = TclThreadStorageKeyGet(keyPtr); if (result == NULL) { - result = Tcl_Alloc(size); + result = ckalloc(size); memset(result, 0, size); TclThreadStorageKeySet(keyPtr, result); } #else /* TCL_THREADS */ if (*keyPtr == NULL) { - result = Tcl_Alloc(size); + result = ckalloc(size); memset(result, 0, size); *keyPtr = (Tcl_ThreadDataKey)result; RememberSyncObject(keyPtr, &keyRecord); @@ -164,14 +164,14 @@ RememberSyncObject( if (recPtr->num >= recPtr->max) { recPtr->max += 8; - newList = (void **)Tcl_Alloc(recPtr->max * sizeof(void *)); + newList = (void **)ckalloc(recPtr->max * sizeof(void *)); for (i=0,j=0 ; i<recPtr->num ; i++) { if (recPtr->list[i] != NULL) { newList[j++] = recPtr->list[i]; } } if (recPtr->list != NULL) { - Tcl_Free(recPtr->list); + ckfree(recPtr->list); } recPtr->list = newList; recPtr->num = j; @@ -394,9 +394,9 @@ TclFinalizeSynchronization(void) for (i=0 ; i<keyRecord.num ; i++) { keyPtr = (Tcl_ThreadDataKey *) keyRecord.list[i]; blockPtr = *keyPtr; - Tcl_Free(blockPtr); + ckfree(blockPtr); } - Tcl_Free(keyRecord.list); + ckfree(keyRecord.list); keyRecord.list = NULL; } keyRecord.max = 0; @@ -416,7 +416,7 @@ TclFinalizeSynchronization(void) } } if (mutexRecord.list != NULL) { - Tcl_Free(mutexRecord.list); + ckfree(mutexRecord.list); mutexRecord.list = NULL; } mutexRecord.max = 0; @@ -429,7 +429,7 @@ TclFinalizeSynchronization(void) } } if (condRecord.list != NULL) { - Tcl_Free(condRecord.list); + ckfree(condRecord.list); condRecord.list = NULL; } condRecord.max = 0; @@ -462,7 +462,11 @@ Tcl_ExitThread( int status) { Tcl_FinalizeThread(); +#if TCL_THREADS TclpThreadExit(status); +#else + exit(status); +#endif } #if !TCL_THREADS diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c index 011d61b..df4d2e3 100644 --- a/generic/tclThreadAlloc.c +++ b/generic/tclThreadAlloc.c @@ -210,7 +210,7 @@ GetCache(void) cachePtr = (Cache*)TclpGetAllocCache(); if (cachePtr == NULL) { - cachePtr = (Cache*)TclpSysAlloc(sizeof(Cache)); + cachePtr = (Cache*)TclpSysAlloc(sizeof(Cache), 0); if (cachePtr == NULL) { Tcl_Panic("alloc: could not allocate new cache"); } @@ -300,13 +300,26 @@ TclFreeAllocCache( void * TclpAlloc( - size_t reqSize) + unsigned int reqSize) { Cache *cachePtr; Block *blockPtr; int bucket; size_t size; +#ifndef __LP64__ + if (sizeof(int) >= sizeof(size_t)) { + /* An unsigned int overflow can also be a size_t overflow */ + const size_t zero = 0; + const size_t max = ~zero; + + if (((size_t) reqSize) > max - sizeof(Block) - RCHECK) { + /* Requested allocation exceeds memory */ + return NULL; + } + } +#endif + GETCACHE(cachePtr); /* @@ -323,7 +336,7 @@ TclpAlloc( #endif if (size > MAXALLOC) { bucket = NBUCKETS; - blockPtr = (Block *)TclpSysAlloc(size); + blockPtr = (Block *)TclpSysAlloc(size, 0); if (blockPtr != NULL) { cachePtr->totalAssigned += reqSize; } @@ -424,7 +437,7 @@ TclpFree( void * TclpRealloc( void *ptr, - size_t reqSize) + unsigned int reqSize) { Cache *cachePtr; Block *blockPtr; @@ -436,6 +449,19 @@ TclpRealloc( return TclpAlloc(reqSize); } +#ifndef __LP64__ + if (sizeof(int) >= sizeof(size_t)) { + /* An unsigned int overflow can also be a size_t overflow */ + const size_t zero = 0; + const size_t max = ~zero; + + if (((size_t) reqSize) > max - sizeof(Block) - RCHECK) { + /* Requested allocation exceeds memory */ + return NULL; + } + } +#endif + GETCACHE(cachePtr); /* @@ -536,7 +562,7 @@ TclThreadAllocObj(void) Tcl_Obj *newObjsPtr; cachePtr->numObjects = numMove = NOBJALLOC; - newObjsPtr = (Tcl_Obj *)TclpSysAlloc(sizeof(Tcl_Obj) * numMove); + newObjsPtr = (Tcl_Obj *)TclpSysAlloc(sizeof(Tcl_Obj) * numMove, 0); if (newObjsPtr == NULL) { Tcl_Panic("alloc: could not allocate %" TCL_Z_MODIFIER "u new objects", numMove); } @@ -1005,7 +1031,7 @@ GetBlocks( if (blockPtr == NULL) { size = MAXALLOC; - blockPtr = (Block*)TclpSysAlloc(size); + blockPtr = (Block*)TclpSysAlloc(size, 0); if (blockPtr == NULL) { return 0; } diff --git a/generic/tclThreadJoin.c b/generic/tclThreadJoin.c index 2af66e3..af4bc13 100644 --- a/generic/tclThreadJoin.c +++ b/generic/tclThreadJoin.c @@ -201,7 +201,7 @@ TclJoinThread( Tcl_ConditionFinalize(&threadPtr->cond); Tcl_MutexFinalize(&threadPtr->threadMutex); - Tcl_Free(threadPtr); + ckfree(threadPtr); return TCL_OK; } @@ -230,7 +230,7 @@ TclRememberJoinableThread( { JoinableThread *threadPtr; - threadPtr = (JoinableThread *)Tcl_Alloc(sizeof(JoinableThread)); + threadPtr = (JoinableThread *)ckalloc(sizeof(JoinableThread)); threadPtr->id = id; threadPtr->done = 0; threadPtr->waitedUpon = 0; diff --git a/generic/tclThreadStorage.c b/generic/tclThreadStorage.c index 22dd0c3..b2de9b4 100644 --- a/generic/tclThreadStorage.c +++ b/generic/tclThreadStorage.c @@ -48,7 +48,7 @@ static struct { */ typedef struct { - void **tablePtr; /* The table of Tcl TSDs. */ + ClientData *tablePtr; /* The table of Tcl TSDs. */ sig_atomic_t allocated; /* The size of the table in the current * thread. */ } TSDTable; @@ -85,14 +85,14 @@ TSDTableCreate(void) TSDTable *tsdTablePtr; sig_atomic_t i; - tsdTablePtr = (TSDTable *)TclpSysAlloc(sizeof(TSDTable)); + tsdTablePtr = (TSDTable *)TclpSysAlloc(sizeof(TSDTable), 0); if (tsdTablePtr == NULL) { Tcl_Panic("unable to allocate TSDTable"); } tsdTablePtr->allocated = 8; tsdTablePtr->tablePtr = - (void **)TclpSysAlloc(sizeof(void *) * tsdTablePtr->allocated); + (void **)TclpSysAlloc(sizeof(void *) * tsdTablePtr->allocated, 0); if (tsdTablePtr->tablePtr == NULL) { Tcl_Panic("unable to allocate TSDTable"); } @@ -117,7 +117,7 @@ TSDTableDelete( * and must now be deallocated or they will leak. */ - Tcl_Free(tsdTablePtr->tablePtr[i]); + ckfree(tsdTablePtr->tablePtr[i]); } } @@ -190,7 +190,7 @@ TclThreadStorageKeyGet( Tcl_ThreadDataKey *dataKeyPtr) { TSDTable *tsdTablePtr = (TSDTable *)TclpThreadGetGlobalTSD(tsdGlobal.key); - void *resultPtr = NULL; + ClientData resultPtr = NULL; TSDUnion *keyPtr = (TSDUnion *) dataKeyPtr; sig_atomic_t offset = keyPtr->offset; diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c index b10465d..cd74071 100644 --- a/generic/tclThreadTest.c +++ b/generic/tclThreadTest.c @@ -13,8 +13,6 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#undef BUILD_tcl -#undef STATIC_BUILD #ifndef USE_TCL_STUBS # define USE_TCL_STUBS #endif @@ -211,6 +209,7 @@ ThreadObjCmd( Tcl_Obj *const objv[]) /* Argument objects. */ { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); + int option; static const char *const threadOptions[] = { "cancel", "create", "event", "exit", "id", "join", "names", "send", "wait", "errorproc", @@ -220,7 +219,7 @@ ThreadObjCmd( THREAD_CANCEL, THREAD_CREATE, THREAD_EVENT, THREAD_EXIT, THREAD_ID, THREAD_JOIN, THREAD_NAMES, THREAD_SEND, THREAD_WAIT, THREAD_ERRORPROC - } option; + }; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); @@ -243,7 +242,7 @@ ThreadObjCmd( Tcl_MutexUnlock(&threadMutex); } - switch (option) { + switch ((enum options)option) { case THREAD_CANCEL: { Tcl_WideInt id; const char *result; @@ -431,10 +430,10 @@ ThreadObjCmd( Tcl_MutexLock(&threadMutex); errorThreadId = Tcl_GetCurrentThread(); if (errorProcString) { - Tcl_Free(errorProcString); + ckfree(errorProcString); } proc = Tcl_GetString(objv[2]); - errorProcString = (char *)Tcl_Alloc(strlen(proc) + 1); + errorProcString = (char *)ckalloc(strlen(proc) + 1); strcpy(errorProcString, proc); Tcl_MutexUnlock(&threadMutex); return TCL_OK; @@ -593,7 +592,7 @@ NewTestThread( * eval'ing, for the case that we exit during evaluation */ - threadEvalScript = (char *)Tcl_Alloc(strlen(ctrlPtr->script) + 1); + threadEvalScript = (char *)ckalloc(strlen(ctrlPtr->script) + 1); strcpy(threadEvalScript, ctrlPtr->script); Tcl_CreateThreadExitHandler(ThreadExitProc, threadEvalScript); @@ -668,7 +667,7 @@ ThreadErrorProc( argv[2] = errorInfo; script = Tcl_Merge(3, argv); ThreadSend(interp, errorThreadId, script, 0); - Tcl_Free(script); + ckfree(script); } } @@ -838,13 +837,13 @@ ThreadSend( * Create the event for its event queue. */ - threadEventPtr = (ThreadEvent*)Tcl_Alloc(sizeof(ThreadEvent)); - threadEventPtr->script = (char *)Tcl_Alloc(strlen(script) + 1); + threadEventPtr = (ThreadEvent*)ckalloc(sizeof(ThreadEvent)); + threadEventPtr->script = (char *)ckalloc(strlen(script) + 1); strcpy(threadEventPtr->script, script); if (!wait) { resultPtr = threadEventPtr->resultPtr = NULL; } else { - resultPtr = (ThreadEventResult *)Tcl_Alloc(sizeof(ThreadEventResult)); + resultPtr = (ThreadEventResult *)ckalloc(sizeof(ThreadEventResult)); threadEventPtr->resultPtr = resultPtr; /* @@ -915,19 +914,19 @@ ThreadSend( if (resultPtr->code != TCL_OK) { if (resultPtr->errorCode) { Tcl_SetErrorCode(interp, resultPtr->errorCode, (void *)NULL); - Tcl_Free(resultPtr->errorCode); + ckfree(resultPtr->errorCode); } if (resultPtr->errorInfo) { Tcl_AddErrorInfo(interp, resultPtr->errorInfo); - Tcl_Free(resultPtr->errorInfo); + ckfree(resultPtr->errorInfo); } } Tcl_AppendResult(interp, resultPtr->result, (void *)NULL); Tcl_ConditionFinalize(&resultPtr->done); code = resultPtr->code; - Tcl_Free(resultPtr->result); - Tcl_Free(resultPtr); + ckfree(resultPtr->result); + ckfree(resultPtr); return code; } @@ -1035,18 +1034,18 @@ ThreadEventProc( } result = Tcl_GetStringResult(interp); } - Tcl_Free(threadEventPtr->script); + ckfree(threadEventPtr->script); if (resultPtr) { Tcl_MutexLock(&threadMutex); resultPtr->code = code; - resultPtr->result = (char *)Tcl_Alloc(strlen(result) + 1); + resultPtr->result = (char *)ckalloc(strlen(result) + 1); strcpy(resultPtr->result, result); if (errorCode != NULL) { - resultPtr->errorCode = (char *)Tcl_Alloc(strlen(errorCode) + 1); + resultPtr->errorCode = (char *)ckalloc(strlen(errorCode) + 1); strcpy(resultPtr->errorCode, errorCode); } if (errorInfo != NULL) { - resultPtr->errorInfo = (char *)Tcl_Alloc(strlen(errorInfo) + 1); + resultPtr->errorInfo = (char *)ckalloc(strlen(errorInfo) + 1); strcpy(resultPtr->errorInfo, errorInfo); } Tcl_ConditionNotify(&resultPtr->done); @@ -1080,7 +1079,7 @@ ThreadFreeProc( void *clientData) { if (clientData) { - Tcl_Free(clientData); + ckfree(clientData); } } @@ -1107,7 +1106,7 @@ ThreadDeleteEvent( TCL_UNUSED(void *)) { if (eventPtr->proc == ThreadEventProc) { - Tcl_Free(((ThreadEvent *) eventPtr)->script); + ckfree(((ThreadEvent *) eventPtr)->script); return 1; } @@ -1153,14 +1152,14 @@ ThreadExitProc( if (self == errorThreadId) { if (errorProcString) { /* Extra safety */ - Tcl_Free(errorProcString); + ckfree(errorProcString); errorProcString = NULL; } errorThreadId = 0; } if (threadEvalScript) { - Tcl_Free(threadEvalScript); + ckfree(threadEvalScript); threadEvalScript = NULL; } Tcl_DeleteEvents((Tcl_EventDeleteProc *) ThreadDeleteEvent, NULL); @@ -1183,7 +1182,7 @@ ThreadExitProc( } resultPtr->nextPtr = resultPtr->prevPtr = 0; resultPtr->eventPtr->resultPtr = NULL; - Tcl_Free(resultPtr); + ckfree(resultPtr); } else if (resultPtr->dstThreadId == self) { /* * Dang. The target is going away. Unblock the caller. The result @@ -1193,7 +1192,7 @@ ThreadExitProc( const char *msg = "target thread died"; - resultPtr->result = (char *)Tcl_Alloc(strlen(msg) + 1); + resultPtr->result = (char *)ckalloc(strlen(msg) + 1); strcpy(resultPtr->result, msg); resultPtr->code = TCL_ERROR; Tcl_ConditionNotify(&resultPtr->done); diff --git a/generic/tclTimer.c b/generic/tclTimer.c index c5477bf..d921854 100644 --- a/generic/tclTimer.c +++ b/generic/tclTimer.c @@ -21,7 +21,7 @@ typedef struct TimerHandler { Tcl_Time time; /* When timer is to fire. */ Tcl_TimerProc *proc; /* Function to call. */ - void *clientData; /* Argument to pass to proc. */ + ClientData clientData; /* Argument to pass to proc. */ Tcl_TimerToken token; /* Identifies handler so it can be deleted. */ struct TimerHandler *nextPtr; /* Next event in queue, or NULL for end of @@ -73,7 +73,7 @@ typedef struct AfterAssocData { typedef struct IdleHandler { Tcl_IdleProc *proc; /* Function to call. */ - void *clientData; /* Value to pass to proc. */ + ClientData clientData; /* Value to pass to proc. */ int generation; /* Used to distinguish older handlers from * recently-created ones. */ struct IdleHandler *nextPtr;/* Next in list of active handlers. */ @@ -117,7 +117,7 @@ static Tcl_ThreadDataKey dataKey; * side-effect free. The "prototypes" for these macros are: * * static int TCL_TIME_BEFORE(Tcl_Time t1, Tcl_Time t2); - * static Tcl_WideInt TCL_TIME_DIFF_MS(Tcl_Time t1, Tcl_Time t2); + * static long TCL_TIME_DIFF_MS(Tcl_Time t1, Tcl_Time t2); */ #define TCL_TIME_BEFORE(t1, t2) \ @@ -125,11 +125,11 @@ static Tcl_ThreadDataKey dataKey; #define TCL_TIME_DIFF_MS(t1, t2) \ (1000*((Tcl_WideInt)(t1).sec - (Tcl_WideInt)(t2).sec) + \ - ((t1).usec - (t2).usec)/1000) + ((long)(t1).usec - (long)(t2).usec)/1000) #define TCL_TIME_DIFF_MS_CEILING(t1, t2) \ (1000*((Tcl_WideInt)(t1).sec - (Tcl_WideInt)(t2).sec) + \ - ((t1).usec - (t2).usec + 999)/1000) + ((long)(t1).usec - (long)(t2).usec + 999)/1000) /* * Sleeps under that number of milliseconds don't get double-checked @@ -150,18 +150,18 @@ static Tcl_ThreadDataKey dataKey; * Prototypes for functions referenced only in this file: */ -static void AfterCleanupProc(void *clientData, +static void AfterCleanupProc(ClientData clientData, Tcl_Interp *interp); static int AfterDelay(Tcl_Interp *interp, Tcl_WideInt ms); -static void AfterProc(void *clientData); +static void AfterProc(ClientData clientData); static void FreeAfterPtr(AfterInfo *afterPtr); static AfterInfo * GetAfterEvent(AfterAssocData *assocPtr, Tcl_Obj *commandPtr); static ThreadSpecificData *InitTimer(void); -static void TimerExitProc(void *clientData); +static void TimerExitProc(ClientData clientData); static int TimerHandlerEventProc(Tcl_Event *evPtr, int flags); -static void TimerCheckProc(void *clientData, int flags); -static void TimerSetupProc(void *clientData, int flags); +static void TimerCheckProc(ClientData clientData, int flags); +static void TimerSetupProc(ClientData clientData, int flags); /* *---------------------------------------------------------------------- @@ -211,7 +211,7 @@ InitTimer(void) static void TimerExitProc( - TCL_UNUSED(void *)) + TCL_UNUSED(ClientData)) { ThreadSpecificData *tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey); @@ -222,7 +222,7 @@ TimerExitProc( timerHandlerPtr = tsdPtr->firstTimerHandlerPtr; while (timerHandlerPtr != NULL) { tsdPtr->firstTimerHandlerPtr = timerHandlerPtr->nextPtr; - Tcl_Free(timerHandlerPtr); + ckfree(timerHandlerPtr); timerHandlerPtr = tsdPtr->firstTimerHandlerPtr; } } @@ -251,7 +251,7 @@ Tcl_CreateTimerHandler( int milliseconds, /* How many milliseconds to wait before * invoking proc. */ Tcl_TimerProc *proc, /* Function to invoke. */ - void *clientData) /* Arbitrary data to pass to proc. */ + ClientData clientData) /* Arbitrary data to pass to proc. */ { Tcl_Time time; @@ -292,12 +292,12 @@ Tcl_TimerToken TclCreateAbsoluteTimerHandler( Tcl_Time *timePtr, Tcl_TimerProc *proc, - void *clientData) + ClientData clientData) { TimerHandler *timerHandlerPtr, *tPtr2, *prevPtr; ThreadSpecificData *tsdPtr = InitTimer(); - timerHandlerPtr = (TimerHandler *)Tcl_Alloc(sizeof(TimerHandler)); + timerHandlerPtr = (TimerHandler *)ckalloc(sizeof(TimerHandler)); /* * Fill in fields for the event. @@ -373,7 +373,7 @@ Tcl_DeleteTimerHandler( } else { prevPtr->nextPtr = timerHandlerPtr->nextPtr; } - Tcl_Free(timerHandlerPtr); + ckfree(timerHandlerPtr); return; } } @@ -398,7 +398,7 @@ Tcl_DeleteTimerHandler( static void TimerSetupProc( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), int flags) /* Event flags as passed to Tcl_DoOneEvent. */ { Tcl_Time blockTime; @@ -456,7 +456,7 @@ TimerSetupProc( static void TimerCheckProc( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), int flags) /* Event flags as passed to Tcl_DoOneEvent. */ { Tcl_Event *timerEvPtr; @@ -488,7 +488,7 @@ TimerCheckProc( if (blockTime.sec == 0 && blockTime.usec == 0 && !tsdPtr->timerPending) { tsdPtr->timerPending = 1; - timerEvPtr = (Tcl_Event *)Tcl_Alloc(sizeof(Tcl_Event)); + timerEvPtr = (Tcl_Event *)ckalloc(sizeof(Tcl_Event)); timerEvPtr->proc = TimerHandlerEventProc; Tcl_QueueEvent(timerEvPtr, TCL_QUEUE_TAIL); } @@ -591,7 +591,7 @@ TimerHandlerEventProc( *nextPtrPtr = timerHandlerPtr->nextPtr; timerHandlerPtr->proc(timerHandlerPtr->clientData); - Tcl_Free(timerHandlerPtr); + ckfree(timerHandlerPtr); } TimerSetupProc(NULL, TCL_TIMER_EVENTS); return 1; @@ -619,13 +619,13 @@ TimerHandlerEventProc( void Tcl_DoWhenIdle( Tcl_IdleProc *proc, /* Function to invoke. */ - void *clientData) /* Arbitrary value to pass to proc. */ + ClientData clientData) /* Arbitrary value to pass to proc. */ { IdleHandler *idlePtr; Tcl_Time blockTime; ThreadSpecificData *tsdPtr = InitTimer(); - idlePtr = (IdleHandler *)Tcl_Alloc(sizeof(IdleHandler)); + idlePtr = (IdleHandler *)ckalloc(sizeof(IdleHandler)); idlePtr->proc = proc; idlePtr->clientData = clientData; idlePtr->generation = tsdPtr->idleGeneration; @@ -663,7 +663,7 @@ Tcl_DoWhenIdle( void Tcl_CancelIdleCall( Tcl_IdleProc *proc, /* Function that was previously registered. */ - void *clientData) /* Arbitrary value to pass to proc. */ + ClientData clientData) /* Arbitrary value to pass to proc. */ { IdleHandler *idlePtr, *prevPtr; IdleHandler *nextPtr; @@ -674,7 +674,7 @@ Tcl_CancelIdleCall( while ((idlePtr->proc == proc) && (idlePtr->clientData == clientData)) { nextPtr = idlePtr->nextPtr; - Tcl_Free(idlePtr); + ckfree(idlePtr); idlePtr = nextPtr; if (prevPtr == NULL) { tsdPtr->idleList = idlePtr; @@ -749,7 +749,7 @@ TclServiceIdle(void) tsdPtr->lastIdlePtr = NULL; } idlePtr->proc(idlePtr->clientData); - Tcl_Free(idlePtr); + ckfree(idlePtr); } if (tsdPtr->idleList) { blockTime.sec = 0; @@ -778,7 +778,7 @@ TclServiceIdle(void) int Tcl_AfterObjCmd( - TCL_UNUSED(void *), + TCL_UNUSED(ClientData), Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ @@ -787,7 +787,7 @@ Tcl_AfterObjCmd( Tcl_Time wakeup; AfterInfo *afterPtr; AfterAssocData *assocPtr; - Tcl_Size length; + int length; int index = -1; static const char *const afterSubCmds[] = { "cancel", "idle", "info", NULL @@ -807,7 +807,7 @@ Tcl_AfterObjCmd( assocPtr = (AfterAssocData *)Tcl_GetAssocData(interp, "tclAfter", NULL); if (assocPtr == NULL) { - assocPtr = (AfterAssocData *)Tcl_Alloc(sizeof(AfterAssocData)); + assocPtr = (AfterAssocData *)ckalloc(sizeof(AfterAssocData)); assocPtr->interp = interp; assocPtr->firstAfterPtr = NULL; Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc, assocPtr); @@ -817,16 +817,16 @@ Tcl_AfterObjCmd( * First lets see if the command was passed a number as the first argument. */ - if (TclGetWideIntFromObj(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 = TclGetString(objv[1]); + const char *arg = TclGetString(objv[1]); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "bad argument \"%s\": must be" " cancel, idle, info, or an integer", arg)); Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "argument", - arg, (void *)NULL); + arg, (char *)NULL); return TCL_ERROR; } } @@ -844,7 +844,7 @@ Tcl_AfterObjCmd( if (objc == 2) { return AfterDelay(interp, ms); } - afterPtr = (AfterInfo *)Tcl_Alloc(sizeof(AfterInfo)); + afterPtr = (AfterInfo *)ckalloc(sizeof(AfterInfo)); afterPtr->assocPtr = assocPtr; if (objc == 3) { afterPtr->commandPtr = objv[2]; @@ -866,8 +866,8 @@ Tcl_AfterObjCmd( afterPtr->id = tsdPtr->afterId; tsdPtr->afterId += 1; Tcl_GetTime(&wakeup); - wakeup.sec += ms / 1000; - wakeup.usec += ms % 1000 * 1000; + wakeup.sec += (long)(ms / 1000); + wakeup.usec += ((long)(ms % 1000)) * 1000; if (wakeup.usec > 1000000) { wakeup.sec++; wakeup.usec -= 1000000; @@ -882,7 +882,7 @@ Tcl_AfterObjCmd( case AFTER_CANCEL: { Tcl_Obj *commandPtr; const char *command, *tempCommand; - Tcl_Size tempLength; + int tempLength; if (objc < 3) { Tcl_WrongNumArgs(interp, 2, objv, "id|command"); @@ -924,7 +924,7 @@ Tcl_AfterObjCmd( Tcl_WrongNumArgs(interp, 2, objv, "script ?script ...?"); return TCL_ERROR; } - afterPtr = (AfterInfo *)Tcl_Alloc(sizeof(AfterInfo)); + afterPtr = (AfterInfo *)ckalloc(sizeof(AfterInfo)); afterPtr->assocPtr = assocPtr; if (objc == 3) { afterPtr->commandPtr = objv[2]; @@ -965,7 +965,7 @@ Tcl_AfterObjCmd( Tcl_SetObjResult(interp, Tcl_ObjPrintf( "event \"%s\" doesn't exist", eventStr)); - Tcl_SetErrorCode(interp, "TCL","LOOKUP","EVENT", eventStr, (void *)NULL); + Tcl_SetErrorCode(interp, "TCL","LOOKUP","EVENT", eventStr, (char *)NULL); return TCL_ERROR; } else { Tcl_Obj *resultListPtr; @@ -1014,8 +1014,8 @@ AfterDelay( Tcl_GetTime(&now); endTime = now; - endTime.sec += (ms / 1000); - endTime.usec += (ms % 1000) * 1000; + endTime.sec += (long)(ms / 1000); + endTime.usec += ((int)(ms % 1000)) * 1000; if (endTime.usec >= 1000000) { endTime.sec++; endTime.usec -= 1000000; @@ -1047,7 +1047,7 @@ AfterDelay( diff = 1; } if (diff > 0) { - Tcl_Sleep((int) diff); + Tcl_Sleep((long) diff); if (diff < SLEEP_OFFLOAD_GETTIMEOFDAY) { break; } @@ -1149,7 +1149,7 @@ GetAfterEvent( static void AfterProc( - void *clientData) /* Describes command to execute. */ + ClientData clientData) /* Describes command to execute. */ { AfterInfo *afterPtr = (AfterInfo *)clientData; AfterAssocData *assocPtr = afterPtr->assocPtr; @@ -1191,7 +1191,7 @@ AfterProc( */ Tcl_DecrRefCount(afterPtr->commandPtr); - Tcl_Free(afterPtr); + ckfree(afterPtr); } /* @@ -1229,7 +1229,7 @@ FreeAfterPtr( prevPtr->nextPtr = afterPtr->nextPtr; } Tcl_DecrRefCount(afterPtr->commandPtr); - Tcl_Free(afterPtr); + ckfree(afterPtr); } /* @@ -1251,7 +1251,7 @@ FreeAfterPtr( static void AfterCleanupProc( - void *clientData, /* Points to AfterAssocData for the + ClientData clientData, /* Points to AfterAssocData for the * interpreter. */ TCL_UNUSED(Tcl_Interp *)) { @@ -1267,9 +1267,9 @@ AfterCleanupProc( Tcl_CancelIdleCall(AfterProc, afterPtr); } Tcl_DecrRefCount(afterPtr->commandPtr); - Tcl_Free(afterPtr); + ckfree(afterPtr); } - Tcl_Free(assocPtr); + ckfree(assocPtr); } /* diff --git a/generic/tclTomMath.decls b/generic/tclTomMath.decls index a6e48e9..f4aa332 100644 --- a/generic/tclTomMath.decls +++ b/generic/tclTomMath.decls @@ -32,7 +32,7 @@ declare 2 { mp_err MP_WUR TclBN_mp_add(const mp_int *a, const mp_int *b, mp_int *c) } declare 3 { - mp_err MP_WUR TclBN_mp_add_d(const mp_int *a, mp_digit b, mp_int *c) + mp_err MP_WUR TclBN_mp_add_d(const mp_int *a, unsigned int b, mp_int *c) } declare 4 { mp_err MP_WUR TclBN_mp_and(const mp_int *a, const mp_int *b, mp_int *c) @@ -50,7 +50,7 @@ declare 8 { mp_ord MP_WUR TclBN_mp_cmp(const mp_int *a, const mp_int *b) } declare 9 { - mp_ord MP_WUR TclBN_mp_cmp_d(const mp_int *a, mp_digit b) + mp_ord MP_WUR TclBN_mp_cmp_d(const mp_int *a, unsigned int b) } declare 10 { mp_ord MP_WUR TclBN_mp_cmp_mag(const mp_int *a, const mp_int *b) @@ -65,7 +65,7 @@ declare 13 { mp_err MP_WUR TclBN_mp_div(const mp_int *a, const mp_int *b, mp_int *q, mp_int *r) } declare 14 { - mp_err MP_WUR TclBN_mp_div_d(const mp_int *a, mp_digit b, mp_int *q, mp_digit *r) + mp_err MP_WUR TclBN_mp_div_d(const mp_int *a, unsigned int b, mp_int *q, unsigned int *r) } declare 15 { mp_err MP_WUR TclBN_mp_div_2(const mp_int *a, mp_int *q) @@ -73,11 +73,14 @@ declare 15 { declare 16 { mp_err MP_WUR TclBN_mp_div_2d(const mp_int *a, int b, mp_int *q, mp_int *r) } +declare 17 {deprecated {is private function in libtommath}} { + mp_err TclBN_mp_div_3(const mp_int *a, mp_int *q, unsigned int *r) +} declare 18 { void TclBN_mp_exch(mp_int *a, mp_int *b) } declare 19 { - mp_err MP_WUR TclBN_mp_expt_n(const mp_int *a, int b, mp_int *c) + mp_err MP_WUR TclBN_mp_expt_d(const mp_int *a, int b, mp_int *c) } declare 20 { mp_err MP_WUR TclBN_mp_grow(mp_int *a, int size) @@ -92,7 +95,7 @@ declare 23 { mp_err MP_WUR TclBN_mp_init_multi(mp_int *a, ...) } declare 24 { - mp_err MP_WUR TclBN_mp_init_set(mp_int *a, mp_digit b) + mp_err MP_WUR TclBN_mp_init_set(mp_int *a, unsigned int b) } declare 25 { mp_err MP_WUR TclBN_mp_init_size(mp_int *a, int size) @@ -110,7 +113,7 @@ declare 29 { mp_err MP_WUR TclBN_mp_mul(const mp_int *a, const mp_int *b, mp_int *p) } declare 30 { - mp_err MP_WUR TclBN_mp_mul_d(const mp_int *a, mp_digit b, mp_int *p) + mp_err MP_WUR TclBN_mp_mul_d(const mp_int *a, unsigned int b, mp_int *p) } declare 31 { mp_err MP_WUR TclBN_mp_mul_2(const mp_int *a, mp_int *p) @@ -136,6 +139,12 @@ declare 37 { declare 38 { mp_err MP_WUR TclBN_mp_shrink(mp_int *a) } +declare 39 {deprecated {macro calling mp_set_u64}} { + void TclBN_mp_set(mp_int *a, unsigned int b) +} +declare 40 {nostub {is private function in libtommath}} { + mp_err TclBN_mp_sqr(const mp_int *a, mp_int *b) +} declare 41 { mp_err MP_WUR TclBN_mp_sqrt(const mp_int *a, mp_int *b) } @@ -143,10 +152,20 @@ declare 42 { mp_err MP_WUR TclBN_mp_sub(const mp_int *a, const mp_int *b, mp_int *c) } declare 43 { - mp_err MP_WUR TclBN_mp_sub_d(const mp_int *a, mp_digit b, mp_int *c) + mp_err MP_WUR TclBN_mp_sub_d(const mp_int *a, unsigned int b, mp_int *c) +} +declare 44 {deprecated {Use mp_to_ubin}} { + mp_err TclBN_mp_to_unsigned_bin(const mp_int *a, unsigned char *b) +} +declare 45 {deprecated {Use mp_to_ubin}} { + mp_err TclBN_mp_to_unsigned_bin_n(const mp_int *a, unsigned char *b, + unsigned long *outlen) +} +declare 46 {deprecated {Use mp_to_radix}} { + mp_err TclBN_mp_toradix_n(const mp_int *a, char *str, int radix, int maxlen) } declare 47 { - size_t MP_WUR TclBN_mp_ubin_size(const mp_int *a) + size_t TclBN_mp_unsigned_bin_size(const mp_int *a) } declare 48 { mp_err MP_WUR TclBN_mp_xor(const mp_int *a, const mp_int *b, mp_int *c) @@ -154,9 +173,55 @@ declare 48 { declare 49 { void TclBN_mp_zero(mp_int *a) } + +# internal routines to libtommath - should not be called but must be +# exported to accommodate the "tommath" extension + +declare 50 {deprecated {is private function in libtommath}} { + void TclBN_reverse(unsigned char *s, int len) +} +declare 51 {deprecated {is private function in libtommath}} { + mp_err TclBN_fast_s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs) +} +declare 52 {deprecated {is private function in libtommath}} { + mp_err TclBN_fast_s_mp_sqr(const mp_int *a, mp_int *b) +} +declare 53 {deprecated {is private function in libtommath}} { + mp_err TclBN_mp_karatsuba_mul(const mp_int *a, const mp_int *b, mp_int *c) +} +declare 54 {deprecated {is private function in libtommath}} { + mp_err TclBN_mp_karatsuba_sqr(const mp_int *a, mp_int *b) +} +declare 55 {deprecated {is private function in libtommath}} { + mp_err TclBN_mp_toom_mul(const mp_int *a, const mp_int *b, mp_int *c) +} +declare 56 {deprecated {is private function in libtommath}} { + mp_err TclBN_mp_toom_sqr(const mp_int *a, mp_int *b) +} +declare 57 {deprecated {is private function in libtommath}} { + mp_err TclBN_s_mp_add(const mp_int *a, const mp_int *b, mp_int *c) +} +declare 58 {deprecated {is private function in libtommath}} { + mp_err TclBN_s_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs) +} +declare 59 {deprecated {is private function in libtommath}} { + mp_err TclBN_s_mp_sqr(const mp_int *a, mp_int *b) +} +declare 60 {deprecated {is private function in libtommath}} { + mp_err TclBN_s_mp_sub(const mp_int *a, const mp_int *b, mp_int *c) +} +declare 61 {deprecated {macro calling mp_init_u64}} { + mp_err TclBN_mp_init_set_int(mp_int *a, unsigned long i) +} +declare 62 {deprecated {macro calling mp_set_u64}} { + void TclBN_mp_set_ul(mp_int *a, unsigned long i) +} declare 63 { int MP_WUR TclBN_mp_cnt_lsb(const mp_int *a) } +declare 64 {deprecated {macro calling mp_init_i64}} { + int TclBN_mp_init_l(mp_int *bignum, long initVal) +} declare 65 { int MP_WUR TclBN_mp_init_i64(mp_int *bignum, int64_t initVal) } @@ -164,14 +229,19 @@ declare 66 { int MP_WUR TclBN_mp_init_u64(mp_int *bignum, uint64_t initVal) } +# Added in libtommath 1.0 +declare 67 {deprecated {Use mp_expt_n}} { + mp_err TclBN_mp_expt_d_ex(const mp_int *a, unsigned int b, mp_int *c, int fast) +} +# Added in libtommath 1.0.1 declare 68 { - void TclBN_mp_set_u64(mp_int *a, uint64_t i) + void TclBN_mp_set_ull(mp_int *a, uint64_t i) } declare 69 { - uint64_t MP_WUR TclBN_mp_get_mag_u64(const mp_int *a) + uint64_t MP_WUR TclBN_mp_get_mag_ull(const mp_int *a) } declare 70 { - void TclBN_mp_set_i64(mp_int *a, int64_t i) + void TclBN_mp_set_ll(mp_int *a, int64_t i) } declare 71 { mp_err MP_WUR TclBN_mp_unpack(mp_int *rop, size_t count, mp_order order, size_t size, @@ -182,6 +252,16 @@ declare 72 { size_t size, mp_endian endian, size_t nails, const mp_int *op) } +# Added in libtommath 1.1.0 +declare 73 {deprecated {merged with mp_and}} { + mp_err TclBN_mp_tc_and(const mp_int *a, const mp_int *b, mp_int *c) +} +declare 74 {deprecated {merged with mp_or}} { + mp_err TclBN_mp_tc_or(const mp_int *a, const mp_int *b, mp_int *c) +} +declare 75 {deprecated {merged with mp_xor}} { + mp_err TclBN_mp_tc_xor(const mp_int *a, const mp_int *b, mp_int *c) +} declare 76 { mp_err MP_WUR TclBN_mp_signed_rsh(const mp_int *a, int b, mp_int *c) } @@ -193,6 +273,9 @@ declare 77 { declare 78 { int MP_WUR TclBN_mp_to_ubin(const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written) } +declare 79 { + mp_err MP_WUR TclBN_mp_div_ld(const mp_int *a, uint64_t b, mp_int *q, uint64_t *r) +} declare 80 { int MP_WUR TclBN_mp_to_radix(const mp_int *a, char *str, size_t maxlen, size_t *written, int radix) } diff --git a/generic/tclTomMathDecls.h b/generic/tclTomMathDecls.h index 15952ae..a36c97a 100644 --- a/generic/tclTomMathDecls.h +++ b/generic/tclTomMathDecls.h @@ -35,13 +35,13 @@ /* Define custom memory allocation for libtommath */ /* MODULE_SCOPE void* TclBNAlloc( size_t ); */ -#define TclBNAlloc(s) Tcl_AttemptAlloc((size_t)(s)) +#define TclBNAlloc(s) ((void*)attemptckalloc((size_t)(s))) /* MODULE_SCOPE void* TclBNCalloc( size_t, size_t ); */ -#define TclBNCalloc(m,s) memset(Tcl_AttemptAlloc((size_t)(m)*(size_t)(s)),0,(size_t)(m)*(size_t)(s)) +#define TclBNCalloc(m,s) memset(attemptckalloc((size_t)(m)*(size_t)(s)),0,(size_t)(m)*(size_t)(s)) /* MODULE_SCOPE void* TclBNRealloc( void*, size_t ); */ -#define TclBNRealloc(x,s) Tcl_AttemptRealloc((x),(size_t)(s)) +#define TclBNRealloc(x,s) ((void*)attemptckrealloc((char*)(x),(size_t)(s))) /* MODULE_SCOPE void TclBNFree( void* ); */ -#define TclBNFree(x) Tcl_Free(x) +#define TclBNFree(x) (ckfree((char*)(x))) #undef MP_MALLOC #undef MP_CALLOC @@ -63,20 +63,17 @@ #ifdef __cplusplus extern "C" { #endif -MODULE_SCOPE mp_err TclBN_mp_sqr(const mp_int *a, mp_int *b); -MODULE_SCOPE mp_err TclBN_mp_balance_mul(const mp_int *a, const mp_int *b, mp_int *c); -MODULE_SCOPE mp_err TclBN_mp_div_3(const mp_int *a, mp_int *c, mp_digit *d); -MODULE_SCOPE mp_err TclBN_mp_karatsuba_mul(const mp_int *a, const mp_int *b, mp_int *c); -MODULE_SCOPE mp_err TclBN_mp_karatsuba_sqr(const mp_int *a, mp_int *b); -MODULE_SCOPE mp_err TclBN_mp_toom_mul(const mp_int *a, const mp_int *b, mp_int *c); -MODULE_SCOPE mp_err TclBN_mp_toom_sqr(const mp_int *a, mp_int *b); -MODULE_SCOPE mp_err TclBN_s_mp_add(const mp_int *a, const mp_int *b, mp_int *c); -MODULE_SCOPE mp_err TclBN_mp_mul_digs(const mp_int *a, const mp_int *b, mp_int *c, int digs); -MODULE_SCOPE mp_err TclBN_mp_mul_digs_fast(const mp_int *a, const mp_int *b, mp_int *c, int digs); -MODULE_SCOPE void TclBN_mp_reverse(unsigned char *s, size_t len); -MODULE_SCOPE mp_err TclBN_s_mp_sqr(const mp_int *a, mp_int *b); -MODULE_SCOPE mp_err TclBN_mp_sqr_fast(const mp_int *a, mp_int *b); -MODULE_SCOPE mp_err TclBN_s_mp_sub(const mp_int *a, const mp_int *b, mp_int *c); +MODULE_SCOPE mp_err TclBN_s_mp_balance_mul(const mp_int *a, const mp_int *b, mp_int *c); +MODULE_SCOPE mp_err TclBN_s_mp_div_3(const mp_int *a, mp_int *c, mp_digit *d); +MODULE_SCOPE mp_err TclBN_s_mp_add_d(const mp_int *a, mp_digit b, mp_int *c); +MODULE_SCOPE mp_ord TclBN_s_mp_cmp_d(const mp_int *a, mp_digit b); +MODULE_SCOPE mp_err TclBN_s_mp_div_d(const mp_int *a, mp_digit b, mp_int *c, mp_digit *d); +MODULE_SCOPE mp_err TclBN_s_mp_expt_u32(const mp_int *a, uint32_t b, mp_int *c); +MODULE_SCOPE mp_err TclBN_s_mp_init_set(mp_int *a, mp_digit b); +MODULE_SCOPE mp_err TclBN_s_mp_mul_d(const mp_int *a, mp_digit b, mp_int *c); +MODULE_SCOPE void TclBN_s_mp_reverse(unsigned char *s, size_t len); +MODULE_SCOPE void TclBN_s_mp_set(mp_int *a, mp_digit b); +MODULE_SCOPE mp_err TclBN_s_mp_sub_d(const mp_int *a, mp_digit b, mp_int *c); MODULE_SCOPE const char *const TclBN_mp_s_rmap; MODULE_SCOPE const uint8_t TclBN_mp_s_rmap_reverse[]; MODULE_SCOPE const size_t TclBN_mp_s_rmap_reverse_sz; @@ -90,38 +87,40 @@ MODULE_SCOPE mp_err TclBN_mp_set_int(mp_int *a, unsigned long b); #ifndef TCL_WITH_EXTERNAL_TOMMATH #define bn_reverse TclBN_reverse #define mp_add TclBN_mp_add -#define mp_add_d TclBN_mp_add_d +#define mp_add_d TclBN_s_mp_add_d #define mp_and TclBN_mp_and #define mp_clamp TclBN_mp_clamp #define mp_clear TclBN_mp_clear #define mp_clear_multi TclBN_mp_clear_multi #define mp_cmp TclBN_mp_cmp -#define mp_cmp_d TclBN_mp_cmp_d +#define mp_cmp_d TclBN_s_mp_cmp_d #define mp_cmp_mag TclBN_mp_cmp_mag #define mp_cnt_lsb TclBN_mp_cnt_lsb #define mp_copy TclBN_mp_copy #define mp_count_bits TclBN_mp_count_bits #define mp_div TclBN_mp_div -#define mp_div_d TclBN_mp_div_d +#define mp_div_d TclBN_s_mp_div_d #define mp_div_2 TclBN_mp_div_2 #define mp_div_2d TclBN_mp_div_2d #define mp_exch TclBN_mp_exch -#define mp_expt_d TclBN_mp_expt_n -#define mp_expt_n TclBN_mp_expt_n -#define mp_get_mag_u64 TclBN_mp_get_mag_u64 +#define mp_expt_d TclBN_mp_expt_d +#define mp_expt_d_ex TclBN_mp_expt_d_ex +#define mp_expt_u32 TclBN_s_mp_expt_u32 +#define mp_expt_n TclBN_mp_expt_d +#define mp_get_mag_u64 TclBN_mp_get_mag_ull #define mp_grow TclBN_mp_grow #define mp_init TclBN_mp_init #define mp_init_copy TclBN_mp_init_copy #define mp_init_i64 TclBN_mp_init_i64 #define mp_init_multi TclBN_mp_init_multi -#define mp_init_set TclBN_mp_init_set +#define mp_init_set TclBN_s_mp_init_set #define mp_init_size TclBN_mp_init_size #define mp_init_u64 TclBN_mp_init_u64 #define mp_lshd TclBN_mp_lshd #define mp_mod TclBN_mp_mod #define mp_mod_2d TclBN_mp_mod_2d #define mp_mul TclBN_mp_mul -#define mp_mul_d TclBN_mp_mul_d +#define mp_mul_d TclBN_s_mp_mul_d #define mp_mul_2 TclBN_mp_mul_2 #define mp_mul_2d TclBN_mp_mul_2d #define mp_neg TclBN_mp_neg @@ -134,14 +133,14 @@ MODULE_SCOPE mp_err TclBN_mp_set_int(mp_int *a, unsigned long b); #define mp_s_rmap TclBN_mp_s_rmap #define mp_s_rmap_reverse TclBN_mp_s_rmap_reverse #define mp_s_rmap_reverse_sz TclBN_mp_s_rmap_reverse_sz -#define mp_set TclBN_mp_set -#define mp_set_i64 TclBN_mp_set_i64 -#define mp_set_u64 TclBN_mp_set_u64 +#define mp_set TclBN_s_mp_set +#define mp_set_i64 TclBN_mp_set_ll +#define mp_set_u64 TclBN_mp_set_ull #define mp_shrink TclBN_mp_shrink #define mp_sqr TclBN_mp_sqr #define mp_sqrt TclBN_mp_sqrt #define mp_sub TclBN_mp_sub -#define mp_sub_d TclBN_mp_sub_d +#define mp_sub_d TclBN_s_mp_sub_d #define mp_signed_rsh TclBN_mp_signed_rsh #define mp_tc_and TclBN_mp_and #define mp_tc_div_2d TclBN_mp_signed_rsh @@ -152,25 +151,31 @@ MODULE_SCOPE mp_err TclBN_mp_set_int(mp_int *a, unsigned long b); #define mp_toradix_n TclBN_mp_toradix_n #define mp_to_radix TclBN_mp_to_radix #define mp_to_ubin TclBN_mp_to_ubin -#define mp_ubin_size TclBN_mp_ubin_size +#define mp_ubin_size TclBN_mp_unsigned_bin_size #define mp_unpack TclBN_mp_unpack #define mp_xor TclBN_mp_xor #define mp_zero TclBN_mp_zero #define s_mp_add TclBN_s_mp_add -#define s_mp_balance_mul TclBN_mp_balance_mul -#define s_mp_div_3 TclBN_mp_div_3 +#define s_mp_balance_mul TclBN_s_mp_balance_mul +#define s_mp_div_3 TclBN_s_mp_div_3 #define s_mp_karatsuba_mul TclBN_mp_karatsuba_mul #define s_mp_karatsuba_sqr TclBN_mp_karatsuba_sqr -#define s_mp_mul_digs TclBN_mp_mul_digs -#define s_mp_mul_digs_fast TclBN_mp_mul_digs_fast -#define s_mp_reverse TclBN_mp_reverse +#define s_mp_mul_digs TclBN_s_mp_mul_digs +#define s_mp_mul_digs_fast TclBN_fast_s_mp_mul_digs +#define s_mp_reverse TclBN_s_mp_reverse #define s_mp_sqr TclBN_s_mp_sqr -#define s_mp_sqr_fast TclBN_mp_sqr_fast +#define s_mp_sqr_fast TclBN_fast_s_mp_sqr #define s_mp_sub TclBN_s_mp_sub #define s_mp_toom_mul TclBN_mp_toom_mul #define s_mp_toom_sqr TclBN_mp_toom_sqr #endif /* !TCL_WITH_EXTERNAL_TOMMATH */ +#define mp_init_set_int(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_init_ul") mp_init_u64(a,(unsigned int)(b))) +#define mp_set_int(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_set_ul") (mp_set_u64((a),((unsigned int)(b))),MP_OKAY)) +#define mp_set_long(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_set_ul") (mp_set_u64((a),(long)(b)),MP_OKAY)) +#define mp_set_long_long(a,b) (MP_DEPRECATED_PRAGMA("replaced by mp_set_u64") (mp_set_u64((a),(b)),MP_OKAY)) +#define mp_unsigned_bin_size(mp) (MP_DEPRECATED_PRAGMA("replaced by mp_ubin_size") (int)mp_ubin_size(mp)) + #undef TCL_STORAGE_CLASS #ifdef BUILD_tcl # define TCL_STORAGE_CLASS DLLEXPORT @@ -206,7 +211,7 @@ EXTERN int TclBN_revision(void) MP_WUR; EXTERN mp_err TclBN_mp_add(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* 3 */ -EXTERN mp_err TclBN_mp_add_d(const mp_int *a, mp_digit b, +EXTERN mp_err TclBN_mp_add_d(const mp_int *a, unsigned int b, mp_int *c) MP_WUR; /* 4 */ EXTERN mp_err TclBN_mp_and(const mp_int *a, const mp_int *b, @@ -220,7 +225,7 @@ EXTERN void TclBN_mp_clear_multi(mp_int *a, ...); /* 8 */ EXTERN mp_ord TclBN_mp_cmp(const mp_int *a, const mp_int *b) MP_WUR; /* 9 */ -EXTERN mp_ord TclBN_mp_cmp_d(const mp_int *a, mp_digit b) MP_WUR; +EXTERN mp_ord TclBN_mp_cmp_d(const mp_int *a, unsigned int b) MP_WUR; /* 10 */ EXTERN mp_ord TclBN_mp_cmp_mag(const mp_int *a, const mp_int *b) MP_WUR; /* 11 */ @@ -231,18 +236,21 @@ EXTERN int TclBN_mp_count_bits(const mp_int *a) MP_WUR; EXTERN mp_err TclBN_mp_div(const mp_int *a, const mp_int *b, mp_int *q, mp_int *r) MP_WUR; /* 14 */ -EXTERN mp_err TclBN_mp_div_d(const mp_int *a, mp_digit b, - mp_int *q, mp_digit *r) MP_WUR; +EXTERN mp_err TclBN_mp_div_d(const mp_int *a, unsigned int b, + mp_int *q, unsigned int *r) MP_WUR; /* 15 */ EXTERN mp_err TclBN_mp_div_2(const mp_int *a, mp_int *q) MP_WUR; /* 16 */ EXTERN mp_err TclBN_mp_div_2d(const mp_int *a, int b, mp_int *q, mp_int *r) MP_WUR; -/* Slot 17 is reserved */ +/* 17 */ +TCL_DEPRECATED("is private function in libtommath") +mp_err TclBN_mp_div_3(const mp_int *a, mp_int *q, + unsigned int *r); /* 18 */ EXTERN void TclBN_mp_exch(mp_int *a, mp_int *b); /* 19 */ -EXTERN mp_err TclBN_mp_expt_n(const mp_int *a, int b, mp_int *c) MP_WUR; +EXTERN mp_err TclBN_mp_expt_d(const mp_int *a, int b, mp_int *c) MP_WUR; /* 20 */ EXTERN mp_err TclBN_mp_grow(mp_int *a, int size) MP_WUR; /* 21 */ @@ -252,7 +260,7 @@ EXTERN mp_err TclBN_mp_init_copy(mp_int *a, const mp_int *b) MP_WUR; /* 23 */ EXTERN mp_err TclBN_mp_init_multi(mp_int *a, ...) MP_WUR; /* 24 */ -EXTERN mp_err TclBN_mp_init_set(mp_int *a, mp_digit b) MP_WUR; +EXTERN mp_err TclBN_mp_init_set(mp_int *a, unsigned int b) MP_WUR; /* 25 */ EXTERN mp_err TclBN_mp_init_size(mp_int *a, int size) MP_WUR; /* 26 */ @@ -266,7 +274,7 @@ EXTERN mp_err TclBN_mp_mod_2d(const mp_int *a, int b, mp_int *r) MP_WUR; EXTERN mp_err TclBN_mp_mul(const mp_int *a, const mp_int *b, mp_int *p) MP_WUR; /* 30 */ -EXTERN mp_err TclBN_mp_mul_d(const mp_int *a, mp_digit b, +EXTERN mp_err TclBN_mp_mul_d(const mp_int *a, unsigned int b, mp_int *p) MP_WUR; /* 31 */ EXTERN mp_err TclBN_mp_mul_2(const mp_int *a, mp_int *p) MP_WUR; @@ -287,53 +295,102 @@ EXTERN mp_err TclBN_mp_read_radix(mp_int *a, const char *str, EXTERN void TclBN_mp_rshd(mp_int *a, int shift); /* 38 */ EXTERN mp_err TclBN_mp_shrink(mp_int *a) MP_WUR; -/* Slot 39 is reserved */ -/* Slot 40 is reserved */ +/* 39 */ +TCL_DEPRECATED("macro calling mp_set_u64") +void TclBN_mp_set(mp_int *a, unsigned int b); +/* 40 */ +EXTERN mp_err TclBN_mp_sqr(const mp_int *a, mp_int *b); /* 41 */ EXTERN mp_err TclBN_mp_sqrt(const mp_int *a, mp_int *b) MP_WUR; /* 42 */ EXTERN mp_err TclBN_mp_sub(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* 43 */ -EXTERN mp_err TclBN_mp_sub_d(const mp_int *a, mp_digit b, +EXTERN mp_err TclBN_mp_sub_d(const mp_int *a, unsigned int b, mp_int *c) MP_WUR; -/* Slot 44 is reserved */ -/* Slot 45 is reserved */ -/* Slot 46 is reserved */ +/* 44 */ +TCL_DEPRECATED("Use mp_to_ubin") +mp_err TclBN_mp_to_unsigned_bin(const mp_int *a, + unsigned char *b); +/* 45 */ +TCL_DEPRECATED("Use mp_to_ubin") +mp_err TclBN_mp_to_unsigned_bin_n(const mp_int *a, + unsigned char *b, unsigned long *outlen); +/* 46 */ +TCL_DEPRECATED("Use mp_to_radix") +mp_err TclBN_mp_toradix_n(const mp_int *a, char *str, + int radix, int maxlen); /* 47 */ -EXTERN size_t TclBN_mp_ubin_size(const mp_int *a) MP_WUR; +EXTERN size_t TclBN_mp_unsigned_bin_size(const mp_int *a); /* 48 */ EXTERN mp_err TclBN_mp_xor(const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* 49 */ EXTERN void TclBN_mp_zero(mp_int *a); -/* Slot 50 is reserved */ -/* Slot 51 is reserved */ -/* Slot 52 is reserved */ -/* Slot 53 is reserved */ -/* Slot 54 is reserved */ -/* Slot 55 is reserved */ -/* Slot 56 is reserved */ -/* Slot 57 is reserved */ -/* Slot 58 is reserved */ -/* Slot 59 is reserved */ -/* Slot 60 is reserved */ -/* Slot 61 is reserved */ -/* Slot 62 is reserved */ +/* 50 */ +TCL_DEPRECATED("is private function in libtommath") +void TclBN_reverse(unsigned char *s, int len); +/* 51 */ +TCL_DEPRECATED("is private function in libtommath") +mp_err TclBN_fast_s_mp_mul_digs(const mp_int *a, + const mp_int *b, mp_int *c, int digs); +/* 52 */ +TCL_DEPRECATED("is private function in libtommath") +mp_err TclBN_fast_s_mp_sqr(const mp_int *a, mp_int *b); +/* 53 */ +TCL_DEPRECATED("is private function in libtommath") +mp_err TclBN_mp_karatsuba_mul(const mp_int *a, + const mp_int *b, mp_int *c); +/* 54 */ +TCL_DEPRECATED("is private function in libtommath") +mp_err TclBN_mp_karatsuba_sqr(const mp_int *a, mp_int *b); +/* 55 */ +TCL_DEPRECATED("is private function in libtommath") +mp_err TclBN_mp_toom_mul(const mp_int *a, const mp_int *b, + mp_int *c); +/* 56 */ +TCL_DEPRECATED("is private function in libtommath") +mp_err TclBN_mp_toom_sqr(const mp_int *a, mp_int *b); +/* 57 */ +TCL_DEPRECATED("is private function in libtommath") +mp_err TclBN_s_mp_add(const mp_int *a, const mp_int *b, + mp_int *c); +/* 58 */ +TCL_DEPRECATED("is private function in libtommath") +mp_err TclBN_s_mp_mul_digs(const mp_int *a, const mp_int *b, + mp_int *c, int digs); +/* 59 */ +TCL_DEPRECATED("is private function in libtommath") +mp_err TclBN_s_mp_sqr(const mp_int *a, mp_int *b); +/* 60 */ +TCL_DEPRECATED("is private function in libtommath") +mp_err TclBN_s_mp_sub(const mp_int *a, const mp_int *b, + mp_int *c); +/* 61 */ +TCL_DEPRECATED("macro calling mp_init_u64") +mp_err TclBN_mp_init_set_int(mp_int *a, unsigned long i); +/* 62 */ +TCL_DEPRECATED("macro calling mp_set_u64") +void TclBN_mp_set_ul(mp_int *a, unsigned long i); /* 63 */ EXTERN int TclBN_mp_cnt_lsb(const mp_int *a) MP_WUR; -/* Slot 64 is reserved */ +/* 64 */ +TCL_DEPRECATED("macro calling mp_init_i64") +int TclBN_mp_init_l(mp_int *bignum, long initVal); /* 65 */ EXTERN int TclBN_mp_init_i64(mp_int *bignum, int64_t initVal) MP_WUR; /* 66 */ EXTERN int TclBN_mp_init_u64(mp_int *bignum, uint64_t initVal) MP_WUR; -/* Slot 67 is reserved */ +/* 67 */ +TCL_DEPRECATED("Use mp_expt_n") +mp_err TclBN_mp_expt_d_ex(const mp_int *a, unsigned int b, + mp_int *c, int fast); /* 68 */ -EXTERN void TclBN_mp_set_u64(mp_int *a, uint64_t i); +EXTERN void TclBN_mp_set_ull(mp_int *a, uint64_t i); /* 69 */ -EXTERN uint64_t TclBN_mp_get_mag_u64(const mp_int *a) MP_WUR; +EXTERN uint64_t TclBN_mp_get_mag_ull(const mp_int *a) MP_WUR; /* 70 */ -EXTERN void TclBN_mp_set_i64(mp_int *a, int64_t i); +EXTERN void TclBN_mp_set_ll(mp_int *a, int64_t i); /* 71 */ EXTERN mp_err TclBN_mp_unpack(mp_int *rop, size_t count, mp_order order, size_t size, @@ -344,9 +401,18 @@ EXTERN mp_err TclBN_mp_pack(void *rop, size_t maxcount, size_t *written, mp_order order, size_t size, mp_endian endian, size_t nails, const mp_int *op) MP_WUR; -/* Slot 73 is reserved */ -/* Slot 74 is reserved */ -/* Slot 75 is reserved */ +/* 73 */ +TCL_DEPRECATED("merged with mp_and") +mp_err TclBN_mp_tc_and(const mp_int *a, const mp_int *b, + mp_int *c); +/* 74 */ +TCL_DEPRECATED("merged with mp_or") +mp_err TclBN_mp_tc_or(const mp_int *a, const mp_int *b, + mp_int *c); +/* 75 */ +TCL_DEPRECATED("merged with mp_xor") +mp_err TclBN_mp_tc_xor(const mp_int *a, const mp_int *b, + mp_int *c); /* 76 */ EXTERN mp_err TclBN_mp_signed_rsh(const mp_int *a, int b, mp_int *c) MP_WUR; @@ -356,7 +422,9 @@ EXTERN size_t TclBN_mp_pack_count(const mp_int *a, size_t nails, /* 78 */ EXTERN int TclBN_mp_to_ubin(const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written) MP_WUR; -/* Slot 79 is reserved */ +/* 79 */ +EXTERN mp_err TclBN_mp_div_ld(const mp_int *a, uint64_t b, + mp_int *q, uint64_t *r) MP_WUR; /* 80 */ EXTERN int TclBN_mp_to_radix(const mp_int *a, char *str, size_t maxlen, size_t *written, int radix) MP_WUR; @@ -368,34 +436,34 @@ typedef struct TclTomMathStubs { int (*tclBN_epoch) (void) MP_WUR; /* 0 */ int (*tclBN_revision) (void) MP_WUR; /* 1 */ mp_err (*tclBN_mp_add) (const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* 2 */ - mp_err (*tclBN_mp_add_d) (const mp_int *a, mp_digit b, mp_int *c) MP_WUR; /* 3 */ + mp_err (*tclBN_mp_add_d) (const mp_int *a, unsigned int b, mp_int *c) MP_WUR; /* 3 */ mp_err (*tclBN_mp_and) (const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* 4 */ void (*tclBN_mp_clamp) (mp_int *a); /* 5 */ void (*tclBN_mp_clear) (mp_int *a); /* 6 */ void (*tclBN_mp_clear_multi) (mp_int *a, ...); /* 7 */ mp_ord (*tclBN_mp_cmp) (const mp_int *a, const mp_int *b) MP_WUR; /* 8 */ - mp_ord (*tclBN_mp_cmp_d) (const mp_int *a, mp_digit b) MP_WUR; /* 9 */ + mp_ord (*tclBN_mp_cmp_d) (const mp_int *a, unsigned int b) MP_WUR; /* 9 */ mp_ord (*tclBN_mp_cmp_mag) (const mp_int *a, const mp_int *b) MP_WUR; /* 10 */ mp_err (*tclBN_mp_copy) (const mp_int *a, mp_int *b) MP_WUR; /* 11 */ int (*tclBN_mp_count_bits) (const mp_int *a) MP_WUR; /* 12 */ mp_err (*tclBN_mp_div) (const mp_int *a, const mp_int *b, mp_int *q, mp_int *r) MP_WUR; /* 13 */ - mp_err (*tclBN_mp_div_d) (const mp_int *a, mp_digit b, mp_int *q, mp_digit *r) MP_WUR; /* 14 */ + mp_err (*tclBN_mp_div_d) (const mp_int *a, unsigned int b, mp_int *q, unsigned int *r) MP_WUR; /* 14 */ mp_err (*tclBN_mp_div_2) (const mp_int *a, mp_int *q) MP_WUR; /* 15 */ mp_err (*tclBN_mp_div_2d) (const mp_int *a, int b, mp_int *q, mp_int *r) MP_WUR; /* 16 */ - void (*reserved17)(void); + TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_mp_div_3) (const mp_int *a, mp_int *q, unsigned int *r); /* 17 */ void (*tclBN_mp_exch) (mp_int *a, mp_int *b); /* 18 */ - mp_err (*tclBN_mp_expt_n) (const mp_int *a, int b, mp_int *c) MP_WUR; /* 19 */ + mp_err (*tclBN_mp_expt_d) (const mp_int *a, int b, mp_int *c) MP_WUR; /* 19 */ mp_err (*tclBN_mp_grow) (mp_int *a, int size) MP_WUR; /* 20 */ mp_err (*tclBN_mp_init) (mp_int *a) MP_WUR; /* 21 */ mp_err (*tclBN_mp_init_copy) (mp_int *a, const mp_int *b) MP_WUR; /* 22 */ mp_err (*tclBN_mp_init_multi) (mp_int *a, ...) MP_WUR; /* 23 */ - mp_err (*tclBN_mp_init_set) (mp_int *a, mp_digit b) MP_WUR; /* 24 */ + mp_err (*tclBN_mp_init_set) (mp_int *a, unsigned int b) MP_WUR; /* 24 */ mp_err (*tclBN_mp_init_size) (mp_int *a, int size) MP_WUR; /* 25 */ mp_err (*tclBN_mp_lshd) (mp_int *a, int shift) MP_WUR; /* 26 */ mp_err (*tclBN_mp_mod) (const mp_int *a, const mp_int *b, mp_int *r) MP_WUR; /* 27 */ mp_err (*tclBN_mp_mod_2d) (const mp_int *a, int b, mp_int *r) MP_WUR; /* 28 */ mp_err (*tclBN_mp_mul) (const mp_int *a, const mp_int *b, mp_int *p) MP_WUR; /* 29 */ - mp_err (*tclBN_mp_mul_d) (const mp_int *a, mp_digit b, mp_int *p) MP_WUR; /* 30 */ + mp_err (*tclBN_mp_mul_d) (const mp_int *a, unsigned int b, mp_int *p) MP_WUR; /* 30 */ mp_err (*tclBN_mp_mul_2) (const mp_int *a, mp_int *p) MP_WUR; /* 31 */ mp_err (*tclBN_mp_mul_2d) (const mp_int *a, int d, mp_int *p) MP_WUR; /* 32 */ mp_err (*tclBN_mp_neg) (const mp_int *a, mp_int *b) MP_WUR; /* 33 */ @@ -404,47 +472,47 @@ typedef struct TclTomMathStubs { mp_err (*tclBN_mp_read_radix) (mp_int *a, const char *str, int radix) MP_WUR; /* 36 */ void (*tclBN_mp_rshd) (mp_int *a, int shift); /* 37 */ mp_err (*tclBN_mp_shrink) (mp_int *a) MP_WUR; /* 38 */ - void (*reserved39)(void); - void (*reserved40)(void); + TCL_DEPRECATED_API("macro calling mp_set_u64") void (*tclBN_mp_set) (mp_int *a, unsigned int b); /* 39 */ + TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_mp_sqr) (const mp_int *a, mp_int *b); /* 40 */ mp_err (*tclBN_mp_sqrt) (const mp_int *a, mp_int *b) MP_WUR; /* 41 */ mp_err (*tclBN_mp_sub) (const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* 42 */ - mp_err (*tclBN_mp_sub_d) (const mp_int *a, mp_digit b, mp_int *c) MP_WUR; /* 43 */ - void (*reserved44)(void); - void (*reserved45)(void); - void (*reserved46)(void); - size_t (*tclBN_mp_ubin_size) (const mp_int *a) MP_WUR; /* 47 */ + mp_err (*tclBN_mp_sub_d) (const mp_int *a, unsigned int b, mp_int *c) MP_WUR; /* 43 */ + TCL_DEPRECATED_API("Use mp_to_ubin") mp_err (*tclBN_mp_to_unsigned_bin) (const mp_int *a, unsigned char *b); /* 44 */ + TCL_DEPRECATED_API("Use mp_to_ubin") mp_err (*tclBN_mp_to_unsigned_bin_n) (const mp_int *a, unsigned char *b, unsigned long *outlen); /* 45 */ + TCL_DEPRECATED_API("Use mp_to_radix") mp_err (*tclBN_mp_toradix_n) (const mp_int *a, char *str, int radix, int maxlen); /* 46 */ + size_t (*tclBN_mp_unsigned_bin_size) (const mp_int *a); /* 47 */ mp_err (*tclBN_mp_xor) (const mp_int *a, const mp_int *b, mp_int *c) MP_WUR; /* 48 */ void (*tclBN_mp_zero) (mp_int *a); /* 49 */ - void (*reserved50)(void); - void (*reserved51)(void); - void (*reserved52)(void); - void (*reserved53)(void); - void (*reserved54)(void); - void (*reserved55)(void); - void (*reserved56)(void); - void (*reserved57)(void); - void (*reserved58)(void); - void (*reserved59)(void); - void (*reserved60)(void); - void (*reserved61)(void); - void (*reserved62)(void); + 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") mp_err (*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") mp_err (*tclBN_fast_s_mp_sqr) (const mp_int *a, mp_int *b); /* 52 */ + TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_mp_karatsuba_mul) (const mp_int *a, const mp_int *b, mp_int *c); /* 53 */ + TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_mp_karatsuba_sqr) (const mp_int *a, mp_int *b); /* 54 */ + TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_mp_toom_mul) (const mp_int *a, const mp_int *b, mp_int *c); /* 55 */ + TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_mp_toom_sqr) (const mp_int *a, mp_int *b); /* 56 */ + TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_s_mp_add) (const mp_int *a, const mp_int *b, mp_int *c); /* 57 */ + TCL_DEPRECATED_API("is private function in libtommath") mp_err (*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") mp_err (*tclBN_s_mp_sqr) (const mp_int *a, mp_int *b); /* 59 */ + TCL_DEPRECATED_API("is private function in libtommath") mp_err (*tclBN_s_mp_sub) (const mp_int *a, const mp_int *b, mp_int *c); /* 60 */ + TCL_DEPRECATED_API("macro calling mp_init_u64") mp_err (*tclBN_mp_init_set_int) (mp_int *a, unsigned long i); /* 61 */ + TCL_DEPRECATED_API("macro calling mp_set_u64") void (*tclBN_mp_set_ul) (mp_int *a, unsigned long i); /* 62 */ int (*tclBN_mp_cnt_lsb) (const mp_int *a) MP_WUR; /* 63 */ - void (*reserved64)(void); + TCL_DEPRECATED_API("macro calling mp_init_i64") int (*tclBN_mp_init_l) (mp_int *bignum, long initVal); /* 64 */ int (*tclBN_mp_init_i64) (mp_int *bignum, int64_t initVal) MP_WUR; /* 65 */ int (*tclBN_mp_init_u64) (mp_int *bignum, uint64_t initVal) MP_WUR; /* 66 */ - void (*reserved67)(void); - void (*tclBN_mp_set_u64) (mp_int *a, uint64_t i); /* 68 */ - uint64_t (*tclBN_mp_get_mag_u64) (const mp_int *a) MP_WUR; /* 69 */ - void (*tclBN_mp_set_i64) (mp_int *a, int64_t i); /* 70 */ + TCL_DEPRECATED_API("Use mp_expt_n") mp_err (*tclBN_mp_expt_d_ex) (const mp_int *a, unsigned int b, mp_int *c, int fast); /* 67 */ + void (*tclBN_mp_set_ull) (mp_int *a, uint64_t i); /* 68 */ + uint64_t (*tclBN_mp_get_mag_ull) (const mp_int *a) MP_WUR; /* 69 */ + void (*tclBN_mp_set_ll) (mp_int *a, int64_t i); /* 70 */ mp_err (*tclBN_mp_unpack) (mp_int *rop, size_t count, mp_order order, size_t size, mp_endian endian, size_t nails, const void *op) MP_WUR; /* 71 */ mp_err (*tclBN_mp_pack) (void *rop, size_t maxcount, size_t *written, mp_order order, size_t size, mp_endian endian, size_t nails, const mp_int *op) MP_WUR; /* 72 */ - void (*reserved73)(void); - void (*reserved74)(void); - void (*reserved75)(void); + TCL_DEPRECATED_API("merged with mp_and") mp_err (*tclBN_mp_tc_and) (const mp_int *a, const mp_int *b, mp_int *c); /* 73 */ + TCL_DEPRECATED_API("merged with mp_or") mp_err (*tclBN_mp_tc_or) (const mp_int *a, const mp_int *b, mp_int *c); /* 74 */ + TCL_DEPRECATED_API("merged with mp_xor") mp_err (*tclBN_mp_tc_xor) (const mp_int *a, const mp_int *b, mp_int *c); /* 75 */ mp_err (*tclBN_mp_signed_rsh) (const mp_int *a, int b, mp_int *c) MP_WUR; /* 76 */ size_t (*tclBN_mp_pack_count) (const mp_int *a, size_t nails, size_t size) MP_WUR; /* 77 */ int (*tclBN_mp_to_ubin) (const mp_int *a, unsigned char *buf, size_t maxlen, size_t *written) MP_WUR; /* 78 */ - void (*reserved79)(void); + mp_err (*tclBN_mp_div_ld) (const mp_int *a, uint64_t b, mp_int *q, uint64_t *r) MP_WUR; /* 79 */ int (*tclBN_mp_to_radix) (const mp_int *a, char *str, size_t maxlen, size_t *written, int radix) MP_WUR; /* 80 */ } TclTomMathStubs; @@ -494,11 +562,12 @@ extern const TclTomMathStubs *tclTomMathStubsPtr; (tclTomMathStubsPtr->tclBN_mp_div_2) /* 15 */ #define TclBN_mp_div_2d \ (tclTomMathStubsPtr->tclBN_mp_div_2d) /* 16 */ -/* Slot 17 is reserved */ +#define TclBN_mp_div_3 \ + (tclTomMathStubsPtr->tclBN_mp_div_3) /* 17 */ #define TclBN_mp_exch \ (tclTomMathStubsPtr->tclBN_mp_exch) /* 18 */ -#define TclBN_mp_expt_n \ - (tclTomMathStubsPtr->tclBN_mp_expt_n) /* 19 */ +#define TclBN_mp_expt_d \ + (tclTomMathStubsPtr->tclBN_mp_expt_d) /* 19 */ #define TclBN_mp_grow \ (tclTomMathStubsPtr->tclBN_mp_grow) /* 20 */ #define TclBN_mp_init \ @@ -537,64 +606,88 @@ extern const TclTomMathStubs *tclTomMathStubsPtr; (tclTomMathStubsPtr->tclBN_mp_rshd) /* 37 */ #define TclBN_mp_shrink \ (tclTomMathStubsPtr->tclBN_mp_shrink) /* 38 */ -/* Slot 39 is reserved */ -/* Slot 40 is reserved */ +#define TclBN_mp_set \ + (tclTomMathStubsPtr->tclBN_mp_set) /* 39 */ +#define TclBN_mp_sqr \ + (tclTomMathStubsPtr->tclBN_mp_sqr) /* 40 */ #define TclBN_mp_sqrt \ (tclTomMathStubsPtr->tclBN_mp_sqrt) /* 41 */ #define TclBN_mp_sub \ (tclTomMathStubsPtr->tclBN_mp_sub) /* 42 */ #define TclBN_mp_sub_d \ (tclTomMathStubsPtr->tclBN_mp_sub_d) /* 43 */ -/* Slot 44 is reserved */ -/* Slot 45 is reserved */ -/* Slot 46 is reserved */ -#define TclBN_mp_ubin_size \ - (tclTomMathStubsPtr->tclBN_mp_ubin_size) /* 47 */ +#define TclBN_mp_to_unsigned_bin \ + (tclTomMathStubsPtr->tclBN_mp_to_unsigned_bin) /* 44 */ +#define TclBN_mp_to_unsigned_bin_n \ + (tclTomMathStubsPtr->tclBN_mp_to_unsigned_bin_n) /* 45 */ +#define TclBN_mp_toradix_n \ + (tclTomMathStubsPtr->tclBN_mp_toradix_n) /* 46 */ +#define TclBN_mp_unsigned_bin_size \ + (tclTomMathStubsPtr->tclBN_mp_unsigned_bin_size) /* 47 */ #define TclBN_mp_xor \ (tclTomMathStubsPtr->tclBN_mp_xor) /* 48 */ #define TclBN_mp_zero \ (tclTomMathStubsPtr->tclBN_mp_zero) /* 49 */ -/* Slot 50 is reserved */ -/* Slot 51 is reserved */ -/* Slot 52 is reserved */ -/* Slot 53 is reserved */ -/* Slot 54 is reserved */ -/* Slot 55 is reserved */ -/* Slot 56 is reserved */ -/* Slot 57 is reserved */ -/* Slot 58 is reserved */ -/* Slot 59 is reserved */ -/* Slot 60 is reserved */ -/* Slot 61 is reserved */ -/* Slot 62 is reserved */ +#define TclBN_reverse \ + (tclTomMathStubsPtr->tclBN_reverse) /* 50 */ +#define TclBN_fast_s_mp_mul_digs \ + (tclTomMathStubsPtr->tclBN_fast_s_mp_mul_digs) /* 51 */ +#define TclBN_fast_s_mp_sqr \ + (tclTomMathStubsPtr->tclBN_fast_s_mp_sqr) /* 52 */ +#define TclBN_mp_karatsuba_mul \ + (tclTomMathStubsPtr->tclBN_mp_karatsuba_mul) /* 53 */ +#define TclBN_mp_karatsuba_sqr \ + (tclTomMathStubsPtr->tclBN_mp_karatsuba_sqr) /* 54 */ +#define TclBN_mp_toom_mul \ + (tclTomMathStubsPtr->tclBN_mp_toom_mul) /* 55 */ +#define TclBN_mp_toom_sqr \ + (tclTomMathStubsPtr->tclBN_mp_toom_sqr) /* 56 */ +#define TclBN_s_mp_add \ + (tclTomMathStubsPtr->tclBN_s_mp_add) /* 57 */ +#define TclBN_s_mp_mul_digs \ + (tclTomMathStubsPtr->tclBN_s_mp_mul_digs) /* 58 */ +#define TclBN_s_mp_sqr \ + (tclTomMathStubsPtr->tclBN_s_mp_sqr) /* 59 */ +#define TclBN_s_mp_sub \ + (tclTomMathStubsPtr->tclBN_s_mp_sub) /* 60 */ +#define TclBN_mp_init_set_int \ + (tclTomMathStubsPtr->tclBN_mp_init_set_int) /* 61 */ +#define TclBN_mp_set_ul \ + (tclTomMathStubsPtr->tclBN_mp_set_ul) /* 62 */ #define TclBN_mp_cnt_lsb \ (tclTomMathStubsPtr->tclBN_mp_cnt_lsb) /* 63 */ -/* Slot 64 is reserved */ +#define TclBN_mp_init_l \ + (tclTomMathStubsPtr->tclBN_mp_init_l) /* 64 */ #define TclBN_mp_init_i64 \ (tclTomMathStubsPtr->tclBN_mp_init_i64) /* 65 */ #define TclBN_mp_init_u64 \ (tclTomMathStubsPtr->tclBN_mp_init_u64) /* 66 */ -/* Slot 67 is reserved */ -#define TclBN_mp_set_u64 \ - (tclTomMathStubsPtr->tclBN_mp_set_u64) /* 68 */ -#define TclBN_mp_get_mag_u64 \ - (tclTomMathStubsPtr->tclBN_mp_get_mag_u64) /* 69 */ -#define TclBN_mp_set_i64 \ - (tclTomMathStubsPtr->tclBN_mp_set_i64) /* 70 */ +#define TclBN_mp_expt_d_ex \ + (tclTomMathStubsPtr->tclBN_mp_expt_d_ex) /* 67 */ +#define TclBN_mp_set_ull \ + (tclTomMathStubsPtr->tclBN_mp_set_ull) /* 68 */ +#define TclBN_mp_get_mag_ull \ + (tclTomMathStubsPtr->tclBN_mp_get_mag_ull) /* 69 */ +#define TclBN_mp_set_ll \ + (tclTomMathStubsPtr->tclBN_mp_set_ll) /* 70 */ #define TclBN_mp_unpack \ (tclTomMathStubsPtr->tclBN_mp_unpack) /* 71 */ #define TclBN_mp_pack \ (tclTomMathStubsPtr->tclBN_mp_pack) /* 72 */ -/* Slot 73 is reserved */ -/* Slot 74 is reserved */ -/* Slot 75 is reserved */ +#define TclBN_mp_tc_and \ + (tclTomMathStubsPtr->tclBN_mp_tc_and) /* 73 */ +#define TclBN_mp_tc_or \ + (tclTomMathStubsPtr->tclBN_mp_tc_or) /* 74 */ +#define TclBN_mp_tc_xor \ + (tclTomMathStubsPtr->tclBN_mp_tc_xor) /* 75 */ #define TclBN_mp_signed_rsh \ (tclTomMathStubsPtr->tclBN_mp_signed_rsh) /* 76 */ #define TclBN_mp_pack_count \ (tclTomMathStubsPtr->tclBN_mp_pack_count) /* 77 */ #define TclBN_mp_to_ubin \ (tclTomMathStubsPtr->tclBN_mp_to_ubin) /* 78 */ -/* Slot 79 is reserved */ +#define TclBN_mp_div_ld \ + (tclTomMathStubsPtr->tclBN_mp_div_ld) /* 79 */ #define TclBN_mp_to_radix \ (tclTomMathStubsPtr->tclBN_mp_to_radix) /* 80 */ @@ -602,6 +695,55 @@ extern const TclTomMathStubs *tclTomMathStubsPtr; /* !END!: Do not edit above this line. */ +#if defined(USE_TCL_STUBS) +#undef mp_add_d +#define mp_add_d TclBN_mp_add_d +#undef mp_cmp_d +#define mp_cmp_d TclBN_mp_cmp_d +#undef mp_div_d +#ifdef MP_64BIT +#define mp_div_d TclBN_mp_div_ld +#else +#define mp_div_d TclBN_mp_div_d +#endif +#undef mp_sub_d +#define mp_sub_d TclBN_mp_sub_d +#undef mp_init_set +#define mp_init_set TclBN_mp_init_set +#undef mp_mul_d +#define mp_mul_d TclBN_mp_mul_d +#undef mp_set +#define mp_set TclBN_mp_set +#undef mp_expt_u32 +#define mp_expt_u32 TclBN_mp_expt_u32 +#endif /* USE_TCL_STUBS */ + +#define TclBNInitBignumFromLong(a,b) \ + do { \ + (a)->dp = NULL; \ + (void)mp_init_i64((a),(b)); \ + if ((a)->dp == NULL) { \ + Tcl_Panic("initialization failure in TclBNInitBignumFromLong"); \ + } \ + } while (0) +#undef TclBNInitBignumFromWideInt +#define TclBNInitBignumFromWideInt(a,b) \ + do { \ + (a)->dp = NULL; \ + (void)mp_init_i64((a),(b)); \ + if ((a)->dp == NULL) { \ + Tcl_Panic("initialization failure in TclBNInitBignumFromWideInt"); \ + } \ + } while (0) +#undef TclBNInitBignumFromWideUInt +#define TclBNInitBignumFromWideUInt(a,b) \ + do { \ + (a)->dp = NULL; \ + (void)mp_init_u64((a),(b)); \ + if ((a)->dp == NULL) { \ + Tcl_Panic("initialization failure in TclBNInitBignumFromWideUInt"); \ + } \ + } while (0) #undef mp_get_ll #define mp_get_ll(a) ((long long)mp_get_i64(a)) #undef mp_set_ll diff --git a/generic/tclTrace.c b/generic/tclTrace.c index 33085f3..733685a 100644 --- a/generic/tclTrace.c +++ b/generic/tclTrace.c @@ -92,8 +92,12 @@ typedef struct { * Forward declarations for functions defined in this file: */ +/* 'OLD' options are pre-Tcl-8.4 style */ enum traceOptionsEnum { TRACE_ADD, TRACE_INFO, TRACE_REMOVE +#ifndef TCL_NO_DEPRECATED + ,TRACE_OLD_VARIABLE, TRACE_OLD_VDELETE, TRACE_OLD_VINFO +#endif }; typedef int (Tcl_TraceTypeObjCmd)(Tcl_Interp *interp, enum traceOptionsEnum optionIndex, Tcl_Size objc, Tcl_Obj *const objv[]); @@ -130,7 +134,7 @@ static char * TraceVarProc(void *clientData, Tcl_Interp *interp, static void TraceCommandProc(void *clientData, Tcl_Interp *interp, const char *oldName, const char *newName, int flags); -static Tcl_CmdObjTraceProc2 TraceExecutionProc; +static Tcl_CmdObjTraceProc TraceExecutionProc; static int StringTraceProc(void *clientData, Tcl_Interp *interp, Tcl_Size level, const char *command, Tcl_Command commandInfo, @@ -188,26 +192,47 @@ int Tcl_TraceObjCmd( TCL_UNUSED(void *), Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ + Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { +#ifndef TCL_NO_DEPRECATED + const char *name; + const char *flagOps, *p; +#endif /* Main sub commands to 'trace' */ static const char *const traceOptions[] = { "add", "info", "remove", +#ifndef TCL_NO_DEPRECATED + "variable", "vdelete", "vinfo", +#endif NULL }; - enum traceOptionsEnum optionIndex; + int optionIndex; +#ifndef TCL_NO_DEPRECATED + static const char *const traceShortOptions[] = { + "add", "info", "remove", NULL + }; +#endif if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); return TCL_ERROR; } +#ifdef TCL_NO_DEPRECATED if (Tcl_GetIndexFromObj(interp, objv[1], traceOptions, "option", 0, &optionIndex) != TCL_OK) { return TCL_ERROR; } - switch (optionIndex) { +#else + if (Tcl_GetIndexFromObj(NULL, objv[1], traceOptions, "option", 0, + &optionIndex) != TCL_OK) { + Tcl_GetIndexFromObj(interp, objv[1], traceShortOptions, "option", 0, + &optionIndex); + return TCL_ERROR; + } +#endif + switch ((enum traceOptionsEnum) optionIndex) { case TRACE_ADD: case TRACE_REMOVE: { /* @@ -226,7 +251,7 @@ Tcl_TraceObjCmd( 0, &typeIndex) != TCL_OK) { return TCL_ERROR; } - return traceSubCmds[typeIndex](interp, optionIndex, objc, objv); + return traceSubCmds[typeIndex](interp, (enum traceOptionsEnum)optionIndex, objc, objv); } case TRACE_INFO: { /* @@ -249,12 +274,119 @@ Tcl_TraceObjCmd( 0, &typeIndex) != TCL_OK) { return TCL_ERROR; } - return traceSubCmds[typeIndex](interp, optionIndex, objc, objv); + return traceSubCmds[typeIndex](interp, (enum traceOptionsEnum)optionIndex, objc, objv); break; } +#ifndef TCL_NO_DEPRECATED + case TRACE_OLD_VARIABLE: + case TRACE_OLD_VDELETE: { + Tcl_Obj *copyObjv[6]; + Tcl_Obj *opsList; + int code, numFlags; + + if (objc != 5) { + Tcl_WrongNumArgs(interp, 2, objv, "name ops command"); + return TCL_ERROR; + } + + TclNewObj(opsList); + Tcl_IncrRefCount(opsList); + flagOps = TclGetStringFromObj(objv[3], &numFlags); + if (numFlags == 0) { + Tcl_DecrRefCount(opsList); + goto badVarOps; + } + for (p = flagOps; *p != 0; p++) { + Tcl_Obj *opObj; + + if (*p == 'r') { + TclNewLiteralStringObj(opObj, "read"); + } else if (*p == 'w') { + TclNewLiteralStringObj(opObj, "write"); + } else if (*p == 'u') { + TclNewLiteralStringObj(opObj, "unset"); + } else if (*p == 'a') { + TclNewLiteralStringObj(opObj, "array"); + } else { + Tcl_DecrRefCount(opsList); + goto badVarOps; + } + Tcl_ListObjAppendElement(NULL, opsList, opObj); + } + copyObjv[0] = NULL; + memcpy(copyObjv+1, objv, objc*sizeof(Tcl_Obj *)); + copyObjv[4] = opsList; + if (optionIndex == TRACE_OLD_VARIABLE) { + code = traceSubCmds[2](interp, TRACE_ADD, objc+1, copyObjv); + } else { + code = traceSubCmds[2](interp, TRACE_REMOVE, objc+1, copyObjv); + } + Tcl_DecrRefCount(opsList); + return code; + } + case TRACE_OLD_VINFO: { + void *clientData; + char ops[5]; + Tcl_Obj *resultListPtr, *pairObjPtr, *elemObjPtr; + + if (objc != 3) { + Tcl_WrongNumArgs(interp, 2, objv, "name"); + return TCL_ERROR; + } + TclNewObj(resultListPtr); + name = TclGetString(objv[2]); + FOREACH_VAR_TRACE(interp, name, clientData) { + TraceVarInfo *tvarPtr = (TraceVarInfo *)clientData; + char *q = ops; + + pairObjPtr = Tcl_NewListObj(0, NULL); + if (tvarPtr->flags & TCL_TRACE_READS) { + *q = 'r'; + q++; + } + if (tvarPtr->flags & TCL_TRACE_WRITES) { + *q = 'w'; + q++; + } + if (tvarPtr->flags & TCL_TRACE_UNSETS) { + *q = 'u'; + q++; + } + if (tvarPtr->flags & TCL_TRACE_ARRAY) { + *q = 'a'; + q++; + } + *q = '\0'; + + /* + * Build a pair (2-item list) with the ops string as the first obj + * element and the tvarPtr->command string as the second obj + * element. Append the pair (as an element) to the end of the + * result object list. + */ + + elemObjPtr = Tcl_NewStringObj(ops, -1); + Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr); + elemObjPtr = Tcl_NewStringObj(tvarPtr->command, -1); + Tcl_ListObjAppendElement(NULL, pairObjPtr, elemObjPtr); + Tcl_ListObjAppendElement(interp, resultListPtr, pairObjPtr); + } + Tcl_SetObjResult(interp, resultListPtr); + break; + } +#endif /* TCL_NO_DEPRECATED */ } return TCL_OK; + +#ifndef TCL_NO_DEPRECATED + badVarOps: + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad operations \"%s\": should be one or more of rwua", + flagOps)); + Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "BADOPS", (char *)NULL); + return TCL_ERROR; +#endif } /* @@ -279,7 +411,7 @@ Tcl_TraceObjCmd( static int TraceExecutionObjCmd( Tcl_Interp *interp, /* Current interpreter. */ - enum traceOptionsEnum optionIndex, /* Add, info or remove */ + enum traceOptionsEnum optionIndex, /* Add, info or remove */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { @@ -291,7 +423,8 @@ TraceExecutionObjCmd( enum operations { TRACE_EXEC_ENTER, TRACE_EXEC_LEAVE, TRACE_EXEC_ENTER_STEP, TRACE_EXEC_LEAVE_STEP - } index; + }; + int index; switch (optionIndex) { case TRACE_ADD: @@ -319,7 +452,7 @@ TraceExecutionObjCmd( "bad operation list \"\": must be one or more of" " enter, leave, enterstep, or leavestep", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS", - (void *)NULL); + (char *)NULL); return TCL_ERROR; } result = TclListObjGetElements(interp, objv[4], &listLen, &elemPtrs); @@ -331,7 +464,7 @@ TraceExecutionObjCmd( "operation", TCL_EXACT, &index) != TCL_OK) { return TCL_ERROR; } - switch (index) { + switch ((enum operations) index) { case TRACE_EXEC_ENTER: flags |= TCL_TRACE_ENTER_EXEC; break; @@ -347,8 +480,8 @@ TraceExecutionObjCmd( } } command = TclGetStringFromObj(objv[5], &length); - if (optionIndex == TRACE_ADD) { - TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)Tcl_Alloc( + if ((enum traceOptionsEnum) optionIndex == TRACE_ADD) { + TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)ckalloc( offsetof(TraceCommandInfo, command) + 1 + length); tcmdPtr->flags = flags; @@ -366,7 +499,7 @@ TraceExecutionObjCmd( name = TclGetString(objv[3]); if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc, tcmdPtr) != TCL_OK) { - Tcl_Free(tcmdPtr); + ckfree(tcmdPtr); return TCL_ERROR; } } else { @@ -416,7 +549,7 @@ TraceExecutionObjCmd( Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); tcmdPtr->stepTrace = NULL; - Tcl_Free(tcmdPtr->startCmd); + ckfree(tcmdPtr->startCmd); } if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { /* @@ -426,7 +559,7 @@ TraceExecutionObjCmd( tcmdPtr->flags = 0; } if (tcmdPtr->refCount-- <= 1) { - Tcl_Free(tcmdPtr); + ckfree(tcmdPtr); } break; } @@ -500,6 +633,10 @@ TraceExecutionObjCmd( Tcl_SetObjResult(interp, resultListPtr); break; } +#ifndef TCL_NO_DEPRECATED + default: + break; +#endif } return TCL_OK; } @@ -533,7 +670,8 @@ TraceCommandObjCmd( const char *name, *command; Tcl_Size length; static const char *const opStrings[] = { "delete", "rename", NULL }; - enum operations { TRACE_CMD_DELETE, TRACE_CMD_RENAME } index; + enum operations { TRACE_CMD_DELETE, TRACE_CMD_RENAME }; + int index; switch (optionIndex) { case TRACE_ADD: @@ -561,7 +699,7 @@ TraceCommandObjCmd( "bad operation list \"\": must be one or more of" " delete or rename", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS", - (void *)NULL); + (char *)NULL); return TCL_ERROR; } result = TclListObjGetElements(interp, objv[4], &listLen, &elemPtrs); @@ -573,7 +711,7 @@ TraceCommandObjCmd( "operation", TCL_EXACT, &index) != TCL_OK) { return TCL_ERROR; } - switch (index) { + switch ((enum operations) index) { case TRACE_CMD_RENAME: flags |= TCL_TRACE_RENAME; break; @@ -584,8 +722,8 @@ TraceCommandObjCmd( } command = TclGetStringFromObj(objv[5], &length); - if (optionIndex == TRACE_ADD) { - TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)Tcl_Alloc( + if ((enum traceOptionsEnum) optionIndex == TRACE_ADD) { + TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)ckalloc( offsetof(TraceCommandInfo, command) + 1 + length); tcmdPtr->flags = flags; @@ -599,7 +737,7 @@ TraceCommandObjCmd( name = TclGetString(objv[3]); if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc, tcmdPtr) != TCL_OK) { - Tcl_Free(tcmdPtr); + ckfree(tcmdPtr); return TCL_ERROR; } } else { @@ -630,7 +768,7 @@ TraceCommandObjCmd( TraceCommandProc, clientData); tcmdPtr->flags |= TCL_TRACE_DESTROYED; if (tcmdPtr->refCount-- <= 1) { - Tcl_Free(tcmdPtr); + ckfree(tcmdPtr); } break; } @@ -694,6 +832,10 @@ TraceCommandObjCmd( Tcl_SetObjResult(interp, resultListPtr); break; } +#ifndef TCL_NO_DEPRECATED + default: + break; +#endif } return TCL_OK; } @@ -720,7 +862,7 @@ TraceCommandObjCmd( static int TraceVariableObjCmd( Tcl_Interp *interp, /* Current interpreter. */ - enum traceOptionsEnum optionIndex, /* Add, info or remove */ + enum traceOptionsEnum optionIndex, /* Add, info or remove */ Tcl_Size objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { @@ -732,9 +874,10 @@ TraceVariableObjCmd( }; enum operations { TRACE_VAR_ARRAY, TRACE_VAR_READ, TRACE_VAR_UNSET, TRACE_VAR_WRITE - } index; + }; + int index; - switch (optionIndex) { + switch ((enum traceOptionsEnum) optionIndex) { case TRACE_ADD: case TRACE_REMOVE: { int flags = 0, result; @@ -760,7 +903,7 @@ TraceVariableObjCmd( "bad operation list \"\": must be one or more of" " array, read, unset, or write", -1)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS", - (void *)NULL); + (char *)NULL); return TCL_ERROR; } result = TclListObjGetElements(interp, objv[4], &listLen, &elemPtrs); @@ -772,7 +915,7 @@ TraceVariableObjCmd( "operation", TCL_EXACT, &index) != TCL_OK) { return TCL_ERROR; } - switch (index) { + switch ((enum operations) index) { case TRACE_VAR_ARRAY: flags |= TCL_TRACE_ARRAY; break; @@ -788,12 +931,17 @@ TraceVariableObjCmd( } } command = TclGetStringFromObj(objv[5], &length); - if (optionIndex == TRACE_ADD) { - CombinedTraceVarInfo *ctvarPtr = (CombinedTraceVarInfo *)Tcl_Alloc( + if ((enum traceOptionsEnum) optionIndex == TRACE_ADD) { + CombinedTraceVarInfo *ctvarPtr = (CombinedTraceVarInfo *)ckalloc( offsetof(CombinedTraceVarInfo, traceCmdInfo.command) + 1 + length); ctvarPtr->traceCmdInfo.flags = flags; +#ifndef TCL_NO_DEPRECATED + if (objv[0] == NULL) { + ctvarPtr->traceCmdInfo.flags |= TCL_TRACE_OLD_STYLE; + } +#endif ctvarPtr->traceCmdInfo.length = length; flags |= TCL_TRACE_UNSETS | TCL_TRACE_RESULT_OBJECT; memcpy(ctvarPtr->traceCmdInfo.command, command, length+1); @@ -803,7 +951,7 @@ TraceVariableObjCmd( name = TclGetString(objv[3]); if (TraceVarEx(interp, name, NULL, (VarTrace *) ctvarPtr) != TCL_OK) { - Tcl_Free(ctvarPtr); + ckfree(ctvarPtr); return TCL_ERROR; } } else { @@ -818,7 +966,11 @@ TraceVariableObjCmd( TraceVarInfo *tvarPtr = (TraceVarInfo *)clientData; if ((tvarPtr->length == length) - && ((tvarPtr->flags)==flags) + && ((tvarPtr->flags +#ifndef TCL_NO_DEPRECATED +& ~TCL_TRACE_OLD_STYLE +#endif + )==flags) && (strncmp(command, tvarPtr->command, length) == 0)) { Tcl_UntraceVar2(interp, name, NULL, @@ -878,6 +1030,10 @@ TraceVariableObjCmd( Tcl_SetObjResult(interp, resultListPtr); break; } +#ifndef TCL_NO_DEPRECATED + default: + break; +#endif } return TCL_OK; } @@ -996,7 +1152,7 @@ Tcl_TraceCommand( * Set up trace information. */ - tracePtr = (CommandTrace *)Tcl_Alloc(sizeof(CommandTrace)); + tracePtr = (CommandTrace *)ckalloc(sizeof(CommandTrace)); tracePtr->traceProc = proc; tracePtr->clientData = clientData; tracePtr->flags = flags & @@ -1102,7 +1258,7 @@ Tcl_UntraceCommand( tracePtr->flags = 0; if (tracePtr->refCount-- <= 1) { - Tcl_Free(tracePtr); + ckfree(tracePtr); } if (hasExecTraces) { @@ -1215,7 +1371,7 @@ TraceCommandProc( if (tcmdPtr->stepTrace != NULL) { Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); tcmdPtr->stepTrace = NULL; - Tcl_Free(tcmdPtr->startCmd); + ckfree(tcmdPtr->startCmd); } if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) { /* @@ -1257,7 +1413,7 @@ TraceCommandProc( tcmdPtr->refCount--; } if (tcmdPtr->refCount-- <= 1) { - Tcl_Free(tcmdPtr); + ckfree(tcmdPtr); } } @@ -1348,7 +1504,7 @@ TclCheckExecutionTraces( traceCode = TraceExecutionProc(tcmdPtr, interp, curLevel, command, (Tcl_Command) cmdPtr, objc, objv); if (tcmdPtr->refCount-- <= 1) { - Tcl_Free(tcmdPtr); + ckfree(tcmdPtr); } } } @@ -1595,7 +1751,7 @@ CommandObjTraceDeleted( TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)clientData; if (tcmdPtr->refCount-- <= 1) { - Tcl_Free(tcmdPtr); + ckfree(tcmdPtr); } } @@ -1677,7 +1833,7 @@ TraceExecutionProc( && (strcmp(command, tcmdPtr->startCmd) == 0)) { Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); tcmdPtr->stepTrace = NULL; - Tcl_Free(tcmdPtr->startCmd); + ckfree(tcmdPtr->startCmd); } /* @@ -1791,10 +1947,10 @@ TraceExecutionProc( unsigned len = strlen(command) + 1; tcmdPtr->startLevel = level; - tcmdPtr->startCmd = (char *)Tcl_Alloc(len); + tcmdPtr->startCmd = (char *)ckalloc(len); memcpy(tcmdPtr->startCmd, command, len); tcmdPtr->refCount++; - tcmdPtr->stepTrace = Tcl_CreateObjTrace2(interp, 0, + tcmdPtr->stepTrace = Tcl_CreateObjTrace(interp, 0, (tcmdPtr->flags & TCL_TRACE_ANY_EXEC) >> 2, TraceExecutionProc, tcmdPtr, CommandObjTraceDeleted); } @@ -1803,12 +1959,12 @@ TraceExecutionProc( if (tcmdPtr->stepTrace != NULL) { Tcl_DeleteTrace(interp, tcmdPtr->stepTrace); tcmdPtr->stepTrace = NULL; - Tcl_Free(tcmdPtr->startCmd); + ckfree(tcmdPtr->startCmd); } } if (call) { if (tcmdPtr->refCount-- <= 1) { - Tcl_Free(tcmdPtr); + ckfree(tcmdPtr); } } return traceCode; @@ -1868,6 +2024,19 @@ TraceVarProc( Tcl_DStringAppend(&cmd, tvarPtr->command, tvarPtr->length); Tcl_DStringAppendElement(&cmd, name1); Tcl_DStringAppendElement(&cmd, (name2 ? name2 : "")); +#ifndef TCL_NO_DEPRECATED + if (tvarPtr->flags & TCL_TRACE_OLD_STYLE) { + if (flags & TCL_TRACE_ARRAY) { + TclDStringAppendLiteral(&cmd, " a"); + } else if (flags & TCL_TRACE_READS) { + TclDStringAppendLiteral(&cmd, " r"); + } else if (flags & TCL_TRACE_WRITES) { + TclDStringAppendLiteral(&cmd, " w"); + } else if (flags & TCL_TRACE_UNSETS) { + TclDStringAppendLiteral(&cmd, " u"); + } + } else { +#endif if (flags & TCL_TRACE_ARRAY) { TclDStringAppendLiteral(&cmd, " array"); } else if (flags & TCL_TRACE_READS) { @@ -1877,6 +2046,9 @@ TraceVarProc( } else if (flags & TCL_TRACE_UNSETS) { TclDStringAppendLiteral(&cmd, " unset"); } +#ifndef TCL_NO_DEPRECATED + } +#endif /* * Execute the command. We discard any object result the command @@ -1979,41 +2151,6 @@ TraceVarProc( *---------------------------------------------------------------------- */ -typedef struct { - Tcl_CmdObjTraceProc *proc; - Tcl_CmdObjTraceDeleteProc *delProc; - void *clientData; -} TraceWrapperInfo; - -static int -traceWrapperProc( - void *clientData, - Tcl_Interp *interp, - Tcl_Size level, - const char *command, - Tcl_Command commandInfo, - Tcl_Size objc, - Tcl_Obj *const objv[]) -{ - TraceWrapperInfo *info = (TraceWrapperInfo *)clientData; - if (objc > INT_MAX) { - objc = -1; /* Signal Tcl_CmdObjTraceProc that objc is out of range */ - } - return info->proc(info->clientData, interp, (int)level, command, commandInfo, objc, objv); -} - -static void -traceWrapperDelProc( - void *clientData) -{ - TraceWrapperInfo *info = (TraceWrapperInfo *)clientData; - clientData = info->clientData; - if (info->delProc) { - info->delProc(clientData); - } - Tcl_Free(info); -} - Tcl_Trace Tcl_CreateObjTrace( Tcl_Interp *interp, /* Tcl interpreter */ @@ -2024,25 +2161,6 @@ Tcl_CreateObjTrace( Tcl_CmdObjTraceDeleteProc *delProc) /* Function to call when trace is deleted */ { - TraceWrapperInfo *info = (TraceWrapperInfo *)Tcl_Alloc(sizeof(TraceWrapperInfo)); - info->proc = proc; - info->delProc = delProc; - info->clientData = clientData; - return Tcl_CreateObjTrace2(interp, level, flags, - (proc ? traceWrapperProc : NULL), - info, traceWrapperDelProc); -} - -Tcl_Trace -Tcl_CreateObjTrace2( - Tcl_Interp *interp, /* Tcl interpreter */ - Tcl_Size level, /* Maximum nesting level */ - int flags, /* Flags, see above */ - Tcl_CmdObjTraceProc2 *proc, /* Trace callback */ - void *clientData, /* Client data for the callback */ - Tcl_CmdObjTraceDeleteProc *delProc) - /* Function to call when trace is deleted */ -{ Trace *tracePtr; Interp *iPtr = (Interp *) interp; @@ -2068,7 +2186,7 @@ Tcl_CreateObjTrace2( iPtr->tracesForbiddingInline++; } - tracePtr = (Trace *)Tcl_Alloc(sizeof(Trace)); + tracePtr = (Trace *)ckalloc(sizeof(Trace)); tracePtr->level = level; tracePtr->proc = proc; tracePtr->clientData = clientData; @@ -2131,11 +2249,11 @@ Tcl_CreateTrace( * command. */ void *clientData) /* Arbitrary value word to pass to proc. */ { - StringTraceData *data = (StringTraceData *)Tcl_Alloc(sizeof(StringTraceData)); + StringTraceData *data = (StringTraceData *)ckalloc(sizeof(StringTraceData)); data->clientData = clientData; data->proc = proc; - return Tcl_CreateObjTrace2(interp, level, 0, StringTraceProc, + return Tcl_CreateObjTrace(interp, level, 0, StringTraceProc, data, StringTraceDeleteProc); } @@ -2215,7 +2333,7 @@ static void StringTraceDeleteProc( void *clientData) { - Tcl_Free(clientData); + ckfree(clientData); } /* @@ -2399,7 +2517,7 @@ TclCheckArrayTraces( int code = TCL_OK; if (varPtr && (varPtr->flags & VAR_TRACED_ARRAY) - && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { + && (TclIsVarArray(varPtr) || TclIsVarUndefined(varPtr))) { Interp *iPtr = (Interp *)interp; code = TclObjCallVarTraces(iPtr, arrayPtr, varPtr, name, NULL, @@ -2466,6 +2584,9 @@ TclObjCallVarTraces( leaveErrMsg); } +#undef TCL_INTERP_DESTROYED +#define TCL_INTERP_DESTROYED 0x100 + int TclCallVarTraces( Interp *iPtr, /* Interpreter containing variable. */ @@ -2493,7 +2614,6 @@ TclCallVarTraces( Tcl_InterpState state = NULL; Tcl_HashEntry *hPtr; int traceflags = flags & VAR_ALL_TRACES; - const char *element; /* * If there are already similar trace functions active for the variable, @@ -2545,19 +2665,12 @@ TclCallVarTraces( } } - /* Keep the original pointer for possible use in an error message */ - element = part2; - if (part2 == NULL) { - if (TclIsVarArrayElement(varPtr)) { - Tcl_Obj *keyObj = VarHashGetKey(varPtr); - part2 = Tcl_GetString(keyObj); - } - } else if ((flags & VAR_TRACED_UNSET) && !(flags & VAR_ARRAY_ELEMENT)) { - /* On unset traces, part2 has already been set by the caller, and - * the VAR_ARRAY_ELEMENT flag indicates whether the accessed - * variable actually has a second part, or is a scalar */ - element = NULL; - } + /* + * Ignore any caller-provided TCL_INTERP_DESTROYED flag. Only we can + * set it correctly. + */ + + flags &= ~TCL_INTERP_DESTROYED; /* * Invoke traces on the array containing the variable, if relevant. @@ -2581,6 +2694,9 @@ TclCallVarTraces( if (state == NULL) { state = Tcl_SaveInterpState((Tcl_Interp *) iPtr, code); } + if (Tcl_InterpDeleted((Tcl_Interp *) iPtr)) { + flags |= TCL_INTERP_DESTROYED; + } result = tracePtr->traceProc(tracePtr->clientData, (Tcl_Interp *) iPtr, part1, part2, flags); if (result != NULL) { @@ -2622,6 +2738,9 @@ TclCallVarTraces( if (state == NULL) { state = Tcl_SaveInterpState((Tcl_Interp *) iPtr, code); } + if (Tcl_InterpDeleted((Tcl_Interp *) iPtr)) { + flags |= TCL_INTERP_DESTROYED; + } result = tracePtr->traceProc(tracePtr->clientData, (Tcl_Interp *) iPtr, part1, part2, flags); if (result != NULL) { @@ -2679,13 +2798,13 @@ TclCallVarTraces( Tcl_AppendObjToErrorInfo((Tcl_Interp *)iPtr, Tcl_ObjPrintf( "\n (%s trace on \"%s%s%s%s\")", type, part1, - (element ? "(" : ""), (element ? element : ""), - (element ? ")" : "") )); + (part2 ? "(" : ""), (part2 ? part2 : ""), + (part2 ? ")" : "") )); if (disposeFlags & TCL_TRACE_RESULT_OBJECT) { - TclVarErrMsg((Tcl_Interp *) iPtr, part1, element, verb, + TclVarErrMsg((Tcl_Interp *) iPtr, part1, part2, verb, TclGetString((Tcl_Obj *) result)); } else { - TclVarErrMsg((Tcl_Interp *) iPtr, part1, element, verb, result); + TclVarErrMsg((Tcl_Interp *) iPtr, part1, part2, verb, result); } iPtr->flags &= ~(ERR_ALREADY_LOGGED); Tcl_DiscardInterpState(state); @@ -2742,7 +2861,7 @@ DisposeTraceResult( * to be disposed. */ { if (flags & TCL_TRACE_RESULT_DYNAMIC) { - Tcl_Free(result); + ckfree(result); } else if (flags & TCL_TRACE_RESULT_OBJECT) { Tcl_DecrRefCount((Tcl_Obj *) result); } @@ -2751,6 +2870,41 @@ DisposeTraceResult( /* *---------------------------------------------------------------------- * + * Tcl_UntraceVar -- + * + * Remove a previously-created trace for a variable. + * + * Results: + * None. + * + * Side effects: + * If there exists a trace for the variable given by varName with the + * given flags, proc, and clientData, then that trace is removed. + * + *---------------------------------------------------------------------- + */ + +#ifndef TCL_NO_DEPRECATED +#undef Tcl_UntraceVar +void +Tcl_UntraceVar( + Tcl_Interp *interp, /* Interpreter containing variable. */ + const char *varName, /* Name of variable; may end with "(index)" to + * signify an array reference. */ + int flags, /* OR-ed collection of bits describing current + * trace, including any of TCL_TRACE_READS, + * TCL_TRACE_WRITES, TCL_TRACE_UNSETS, + * TCL_GLOBAL_ONLY and TCL_NAMESPACE_ONLY. */ + Tcl_VarTraceProc *proc, /* Function assocated with trace. */ + ClientData clientData) /* Arbitrary argument to pass to proc. */ +{ + Tcl_UntraceVar2(interp, varName, NULL, flags, proc, clientData); +} +#endif /* TCL_NO_DEPRECATED */ + +/* + *---------------------------------------------------------------------- + * * Tcl_UntraceVar2 -- * * Remove a previously-created trace for a variable. @@ -2777,7 +2931,7 @@ Tcl_UntraceVar2( * TCL_TRACE_WRITES, TCL_TRACE_UNSETS, * TCL_GLOBAL_ONLY, and TCL_NAMESPACE_ONLY. */ Tcl_VarTraceProc *proc, /* Function associated with trace. */ - void *clientData) /* Arbitrary argument to pass to proc. */ + ClientData clientData) /* Arbitrary argument to pass to proc. */ { VarTrace *tracePtr; VarTrace *prevPtr, *nextPtr; @@ -2806,6 +2960,9 @@ Tcl_UntraceVar2( flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT; +#ifndef TCL_NO_DEPRECATED + flagMask |= TCL_TRACE_OLD_STYLE; +#endif flags &= flagMask; hPtr = Tcl_FindHashEntry(&iPtr->varTraces, (char *) varPtr); @@ -2878,6 +3035,49 @@ Tcl_UntraceVar2( /* *---------------------------------------------------------------------- * + * Tcl_VarTraceInfo -- + * + * Return the clientData value associated with a trace on a variable. + * This function can also be used to step through all of the traces on a + * particular variable that have the same trace function. + * + * Results: + * The return value is the clientData value associated with a trace on + * the given variable. Information will only be returned for a trace with + * proc as trace function. If the clientData argument is NULL then the + * first such trace is returned; otherwise, the next relevant one after + * the one given by clientData will be returned. If the variable doesn't + * exist, or if there are no (more) traces for it, then NULL is returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#ifndef TCL_NO_DEPRECATED +#undef Tcl_VarTraceInfo +ClientData +Tcl_VarTraceInfo( + Tcl_Interp *interp, /* Interpreter containing variable. */ + const char *varName, /* Name of variable; may end with "(index)" to + * signify an array reference. */ + int flags, /* OR-ed combo or TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY (can be 0). */ + Tcl_VarTraceProc *proc, /* Function associated with trace. */ + ClientData prevClientData) /* If non-NULL, gives last value returned by + * this function, so this call will return the + * next trace after that one. If NULL, this + * call will return the first trace. */ +{ + return Tcl_VarTraceInfo2(interp, varName, NULL, flags, proc, + prevClientData); +} +#endif /* TCL_NO_DEPRECATED */ + +/* + *---------------------------------------------------------------------- + * * Tcl_VarTraceInfo2 -- * * Same as Tcl_VarTraceInfo, except takes name in two pieces instead of @@ -2892,7 +3092,7 @@ Tcl_UntraceVar2( *---------------------------------------------------------------------- */ -void * +ClientData Tcl_VarTraceInfo2( Tcl_Interp *interp, /* Interpreter containing variable. */ const char *part1, /* Name of variable or array. */ @@ -2902,7 +3102,7 @@ Tcl_VarTraceInfo2( int flags, /* OR-ed combination of TCL_GLOBAL_ONLY, * TCL_NAMESPACE_ONLY. */ Tcl_VarTraceProc *proc, /* Function associated with trace. */ - void *prevClientData) /* If non-NULL, gives last value returned by + ClientData prevClientData) /* If non-NULL, gives last value returned by * this function, so this call will return the * next trace after that one. If NULL, this * call will return the first trace. */ @@ -2948,6 +3148,47 @@ Tcl_VarTraceInfo2( /* *---------------------------------------------------------------------- * + * Tcl_TraceVar -- + * + * Arrange for reads and/or writes to a variable to cause a function to + * be invoked, which can monitor the operations and/or change their + * actions. + * + * Results: + * A standard Tcl return value. + * + * Side effects: + * A trace is set up on the variable given by varName, such that future + * references to the variable will be mediated by proc. See the + * manual entry for complete details on the calling sequence for proc. + * The variable's flags are updated. + * + *---------------------------------------------------------------------- + */ + +#ifndef TCL_NO_DEPRECATED +#undef Tcl_TraceVar +int +Tcl_TraceVar( + Tcl_Interp *interp, /* Interpreter in which variable is to be + * traced. */ + const char *varName, /* Name of variable; may end with "(index)" to + * signify an array reference. */ + int flags, /* OR-ed collection of bits, including any of + * TCL_TRACE_READS, TCL_TRACE_WRITES, + * TCL_TRACE_UNSETS, TCL_GLOBAL_ONLY, and + * TCL_NAMESPACE_ONLY. */ + Tcl_VarTraceProc *proc, /* Function to call when specified ops are + * invoked upon varName. */ + ClientData clientData) /* Arbitrary argument to pass to proc. */ +{ + return Tcl_TraceVar2(interp, varName, NULL, flags, proc, clientData); +} +#endif /* TCL_NO_DEPRECATED */ + +/* + *---------------------------------------------------------------------- + * * Tcl_TraceVar2 -- * * Arrange for reads and/or writes to a variable to cause a function to @@ -2985,7 +3226,7 @@ Tcl_TraceVar2( VarTrace *tracePtr; int result; - tracePtr = (VarTrace *)Tcl_Alloc(sizeof(VarTrace)); + tracePtr = (VarTrace *)ckalloc(sizeof(VarTrace)); tracePtr->traceProc = proc; tracePtr->clientData = clientData; tracePtr->flags = flags; @@ -2993,7 +3234,7 @@ Tcl_TraceVar2( result = TraceVarEx(interp, part1, part2, tracePtr); if (result != TCL_OK) { - Tcl_Free(tracePtr); + ckfree(tracePtr); } return result; } @@ -3029,7 +3270,7 @@ TraceVarEx( * as-a-whole. */ VarTrace *tracePtr)/* Structure containing flags, traceProc and * clientData fields. Others should be left - * blank. Will be Tcl_Free()d (eventually) if + * blank. Will be ckfree()d (eventually) if * this function returns TCL_OK, and up to * caller to free if this function returns * TCL_ERROR. */ @@ -3070,6 +3311,9 @@ TraceVarEx( flagMask = TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS | TCL_TRACE_ARRAY | TCL_TRACE_RESULT_DYNAMIC | TCL_TRACE_RESULT_OBJECT; +#ifndef TCL_NO_DEPRECATED + flagMask |= TCL_TRACE_OLD_STYLE; +#endif tracePtr->flags = tracePtr->flags & flagMask; hPtr = Tcl_CreateHashEntry(&iPtr->varTraces, varPtr, &isNew); diff --git a/generic/tclUtf.c b/generic/tclUtf.c index e107081..2fa0e80 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -207,18 +207,13 @@ Invalid( Tcl_Size Tcl_UniCharToUtf( int ch, /* The Tcl_UniChar to be stored in the - * buffer. Can be or'ed with flag TCL_COMBINE. + * buffer. */ char *buf) /* Buffer in which the UTF-8 representation of * ch is stored. Must be large enough to hold the UTF-8 * character (at most 4 bytes). */ { - int flags = ch; - - if (ch >= TCL_COMBINE) { - ch &= (TCL_COMBINE - 1); - } if ((unsigned)(ch - 1) < (UNICODE_SELF - 1)) { buf[0] = (char) ch; return 1; @@ -230,12 +225,11 @@ Tcl_UniCharToUtf( return 2; } if (ch <= 0xFFFF) { - if ((flags & TCL_COMBINE) && - ((ch & 0xF800) == 0xD800)) { + if ((ch & 0xF800) == 0xD800) { if (ch & 0x0400) { /* Low surrogate */ - if ( (0x80 == (0xC0 & buf[0])) - && (0 == (0xCF & buf[1]))) { + if ( (0x80 == (0xC0 & buf[0])) + && (0 == (0xCF & buf[1]))) { /* Previous Tcl_UniChar was a high surrogate, so combine */ buf[2] = (char) (0x80 | (0x3F & ch)); buf[1] |= (char) (0x80 | (0x0F & (ch >> 6))); @@ -246,11 +240,12 @@ Tcl_UniCharToUtf( /* High surrogate */ /* Add 0x10000 to the raw number encoded in the surrogate - * pair in order to get the code point. */ + * pair in order to get the code point. + */ ch += 0x40; /* Fill buffer with specific 3-byte (invalid) byte combination, - * so following low surrogate can recognize it and combine */ + so following low surrogate can recognize it and combine */ buf[2] = (char) ((ch << 4) & 0x30); buf[1] = (char) (0x80 | (0x3F & (ch >> 2))); buf[0] = (char) (0xF0 | (0x07 & (ch >> 8))); @@ -267,9 +262,9 @@ Tcl_UniCharToUtf( return 4; } } else if (ch == -1) { - if ( (0x80 == (0xC0 & buf[0])) - && (0 == (0xCF & buf[1])) - && (0xF0 == (0xF8 & buf[-1]))) { + if ( (0x80 == (0xC0 & buf[0])) + && (0 == (0xCF & buf[1])) + && (0xF0 == (0xF8 & buf[-1]))) { ch = 0xD7C0 + ((0x07 & buf[-1]) << 8) + ((0x3F & buf[0]) << 2) @@ -307,6 +302,7 @@ three: *--------------------------------------------------------------------------- */ +#undef Tcl_UniCharToUtfDString char * Tcl_UniCharToUtfDString( const int *uniStr, /* Unicode string to convert to UTF-8. */ @@ -390,7 +386,7 @@ Tcl_Char16ToUtfDString( /* Special case for handling high surrogates. */ p += Tcl_UniCharToUtf(-1, p); } - len = Tcl_UniCharToUtf(*w | TCL_COMBINE, p); + len = Tcl_UniCharToUtf(*w, p); p += len; if ((*w >= 0xD800) && (len < 3)) { len = 0; /* Indication that high surrogate was found */ @@ -421,6 +417,15 @@ Tcl_Char16ToUtfDString( * Tcl_UtfCharComplete() before calling this routine to ensure that * enough bytes remain in the string. * + * Special handling of Surrogate pairs is done: + * 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 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. + * * Results: * *chPtr is filled with the Tcl_UniChar, and the return value is the * number of bytes from the UTF-8 string that were consumed. @@ -638,6 +643,7 @@ Tcl_UtfToChar16( *--------------------------------------------------------------------------- */ +#undef Tcl_UtfToUniCharDString int * Tcl_UtfToUniCharDString( const char *src, /* UTF-8 string to convert to Unicode. */ @@ -800,7 +806,7 @@ Tcl_UtfCharComplete( */ Tcl_Size -Tcl_NumUtfChars( +TclNumUtfChars( const char *src, /* The UTF-8 string to measure. */ Tcl_Size length) /* The length of the string in bytes, or * negative value for strlen(src). */ @@ -810,7 +816,7 @@ Tcl_NumUtfChars( if (length < 0) { /* string is NUL-terminated, so TclUtfToUniChar calls are safe. */ - while (*src != '\0') { + while ((*src != '\0') && (i < INT_MAX)) { src += TclUtfToUniChar(src, &ch); i++; } @@ -851,8 +857,9 @@ Tcl_NumUtfChars( return i; } +#if !defined(TCL_NO_DEPRECATED) Tcl_Size -TclNumUtfChars( +Tcl_NumUtfChars( const char *src, /* The UTF-8 string to measure. */ Tcl_Size length) /* The length of the string in bytes, or * negative for strlen(src). */ @@ -862,7 +869,7 @@ TclNumUtfChars( if (length < 0) { /* string is NUL-terminated, so TclUtfToUniChar calls are safe. */ - while (*src != '\0') { + while ((*src != '\0') && (i < INT_MAX)) { src += Tcl_UtfToChar16(src, &ch); i++; } @@ -902,6 +909,7 @@ TclNumUtfChars( } return i; } +#endif /* *--------------------------------------------------------------------------- @@ -1180,16 +1188,20 @@ Tcl_UniCharAtIndex( const char *src, /* The UTF-8 string to dereference. */ Tcl_Size index) /* The position of the desired character. */ { - Tcl_UniChar ch = 0; + unsigned short ch = 0; int i = 0; if (index < 0) { return -1; } - while (index--) { - i = TclUtfToUniChar(src, &ch); + while (index-- > 0) { + i = Tcl_UtfToChar16(src, &ch); src += i; } + if ((ch >= 0xD800) && (i < 3)) { + /* Index points at character following high Surrogate */ + return -1; + } TclUtfToUniChar(src, &i); return i; } @@ -1212,7 +1224,7 @@ Tcl_UniCharAtIndex( */ const char * -Tcl_UtfAtIndex( +TclUtfAtIndex( const char *src, /* The UTF-8 string. */ Tcl_Size index) /* The position of the desired character. */ { @@ -1224,8 +1236,9 @@ Tcl_UtfAtIndex( return src; } +#if !defined(TCL_NO_DEPRECATED) const char * -TclUtfAtIndex( +Tcl_UtfAtIndex( const char *src, /* The UTF-8 string. */ Tcl_Size index) /* The position of the desired character. */ { @@ -1243,6 +1256,7 @@ TclUtfAtIndex( } return src; } +#endif /* *--------------------------------------------------------------------------- @@ -1338,7 +1352,7 @@ Tcl_UtfToUpper( * char to dst if its size is <= the original char. */ - if (len < TclUtfCount(upChar)) { + if ((len < TclUtfCount(upChar)) || ((upChar & ~0x7FF) == 0xD800)) { memmove(dst, src, len); dst += len; } else { @@ -1391,7 +1405,7 @@ Tcl_UtfToLower( * char to dst if its size is <= the original char. */ - if (len < TclUtfCount(lowChar)) { + if ((len < TclUtfCount(lowChar)) || ((lowChar & ~0x7FF) == 0xD800)) { memmove(dst, src, len); dst += len; } else { @@ -1441,7 +1455,7 @@ Tcl_UtfToTitle( len = TclUtfToUniChar(src, &ch); titleChar = Tcl_UniCharToTitle(ch); - if (len < TclUtfCount(titleChar)) { + if ((len < TclUtfCount(titleChar)) || ((titleChar & ~0x7FF) == 0xD800)) { memmove(dst, src, len); dst += len; } else { @@ -1457,7 +1471,7 @@ Tcl_UtfToTitle( lowChar = Tcl_UniCharToLower(lowChar); } - if (len < TclUtfCount(lowChar)) { + if ((len < TclUtfCount(lowChar)) || ((lowChar & ~0x7FF) == 0xD800)) { memmove(dst, src, len); dst += len; } else { @@ -1488,12 +1502,10 @@ Tcl_UtfToTitle( int TclpUtfNcmp2( - const void *csPtr, /* UTF string to compare to ct. */ - const void *ctPtr, /* UTF string cs is compared to. */ - size_t numBytes) /* Number of *bytes* to compare. */ + const char *cs, /* UTF string to compare to ct. */ + const char *ct, /* UTF string cs is compared to. */ + unsigned long numBytes) /* Number of *bytes* to compare. */ { - const char *cs = (const char *)csPtr; - const char *ct = (const char *)ctPtr; /* * We can't simply call 'memcmp(cs, ct, numBytes);' because we need to * check for Tcl's \xC0\x80 non-utf-8 null encoding. Otherwise utf-8 lexes @@ -1523,8 +1535,8 @@ TclpUtfNcmp2( * * Tcl_UtfNcmp -- * - * Compare at most numChars chars (not bytes) of string cs to string ct. Both cs - * and ct are assumed to be at least numChars chars long. + * Compare at most numChars UTF-16 chars of string cs to string ct. Both cs + * and ct are assumed to be at least numChars UTF-16 chars long. * * Results: * Return <0 if cs < ct, 0 if cs == ct, or >0 if cs > ct. @@ -1535,11 +1547,12 @@ TclpUtfNcmp2( *---------------------------------------------------------------------- */ +#if !defined(TCL_NO_DEPRECATED) int -TclUtfNcmp( +Tcl_UtfNcmp( const char *cs, /* UTF string to compare to ct. */ const char *ct, /* UTF string cs is compared to. */ - size_t numChars) /* Number of UTF-16 chars to compare. */ + unsigned long numChars) /* Number of UTF-16 chars to compare. */ { unsigned short ch1 = 0, ch2 = 0; @@ -1551,7 +1564,7 @@ TclUtfNcmp( while (numChars-- > 0) { /* - * n must be interpreted as chars, not bytes. This should be called + * n must be interpreted as UTF-16 chars, not bytes. This should be called * only when both strings are of at least n UTF-16 chars long (no need for \0 * check) */ @@ -1572,9 +1585,10 @@ TclUtfNcmp( } return 0; } +#endif /* TCL_NO_DEPRECATED */ int -Tcl_UtfNcmp( +TclUtfNcmp( const char *cs, /* UTF string to compare to ct. */ const char *ct, /* UTF string cs is compared to. */ size_t numChars) /* Number of chars to compare. */ @@ -1602,14 +1616,46 @@ Tcl_UtfNcmp( } return 0; } + +int +TclUtfNmemcmp( + const void *csPtr, /* UTF string to compare to ct. */ + const void *ctPtr, /* UTF string cs is compared to. */ + size_t numChars) /* Number of chars to compare. */ +{ + Tcl_UniChar ch1 = 0, ch2 = 0; + const char *cs = (const char *)csPtr; + const char *ct = (const char *)ctPtr; + + /* + * Cannot use 'memcmp(cs, ct, n);' as byte representation of \u0000 (the + * pair of bytes 0xC0,0x80) is larger than byte representation of \u0001 + * (the byte 0x01.) + */ + + while (numChars-- > 0) { + /* + * n must be interpreted as chars, not bytes. This should be called + * only when both strings are of at least n chars long (no need for \0 + * check) + */ + + cs += TclUtfToUniChar(cs, &ch1); + ct += TclUtfToUniChar(ct, &ch2); + if (ch1 != ch2) { + return (ch1 - ch2); + } + } + return 0; +} /* *---------------------------------------------------------------------- * * Tcl_UtfNcasecmp -- * - * Compare at most numChars chars (not bytes) of string cs to string ct case - * insensitive. Both cs and ct are assumed to be at least numChars UTF + * Compare at most numChars UTF-16 chars of string cs to string ct case + * insensitive. Both cs and ct are assumed to be at least numChars UTF-16 * chars long. * * Results: @@ -1621,11 +1667,12 @@ Tcl_UtfNcmp( *---------------------------------------------------------------------- */ +#if !defined(TCL_NO_DEPRECATED) int -TclUtfNcasecmp( +Tcl_UtfNcasecmp( const char *cs, /* UTF string to compare to ct. */ const char *ct, /* UTF string cs is compared to. */ - size_t numChars) /* Number of UTF-16 chars to compare. */ + unsigned long numChars) /* Number of UTF-16 chars to compare. */ { unsigned short ch1 = 0, ch2 = 0; @@ -1655,9 +1702,11 @@ TclUtfNcasecmp( } return 0; } +#endif /* TCL_NO_DEPRECATED */ + int -Tcl_UtfNcasecmp( +TclUtfNcasecmp( const char *cs, /* UTF string to compare to ct. */ const char *ct, /* UTF string cs is compared to. */ size_t numChars) /* Number of chars to compare. */ @@ -1683,6 +1732,35 @@ Tcl_UtfNcasecmp( return 0; } +int +TclUtfNcasememcmp( + const void *csPtr, /* UTF string to compare to ct. */ + const void *ctPtr, /* UTF string cs is compared to. */ + size_t numChars) /* Number of chars to compare. */ +{ + const char *cs = (const char *)csPtr; + const char *ct = (const char *)ctPtr; + Tcl_UniChar ch1 = 0, ch2 = 0; + + while (numChars-- > 0) { + /* + * n must be interpreted as chars, not bytes. + * This should be called only when both strings are of + * at least n chars long (no need for \0 check) + */ + cs += TclUtfToUniChar(cs, &ch1); + ct += TclUtfToUniChar(ct, &ch2); + if (ch1 != ch2) { + ch1 = Tcl_UniCharToLower(ch1); + ch2 = Tcl_UniCharToLower(ch2); + if (ch1 != ch2) { + return (ch1 - ch2); + } + } + } + return 0; +} + /* *---------------------------------------------------------------------- * @@ -1909,6 +1987,7 @@ Tcl_Char16Len( *---------------------------------------------------------------------- */ +#undef Tcl_UniCharLen Tcl_Size Tcl_UniCharLen( const int *uniStr) /* Unicode string to find length of. */ @@ -1925,7 +2004,7 @@ Tcl_UniCharLen( /* *---------------------------------------------------------------------- * - * TclUniCharNcmp -- + * Tcl_UniCharNcmp -- * * Compare at most numChars chars (not bytes) of string ucs to string uct. * Both ucs and uct are assumed to be at least numChars chars long. @@ -1966,10 +2045,73 @@ TclUniCharNcmp( #endif /* WORDS_BIGENDIAN */ } +int +TclUniCharNmemcmp( + const void *ucsPtr, /* Unicode string to compare to uct. */ + const void *uctPtr, /* Unicode string ucs is compared to. */ + size_t numChars) /* Number of chars (not bytes) to compare. */ +{ + const Tcl_UniChar *ucs = (const Tcl_UniChar *)ucsPtr; + const Tcl_UniChar *uct = (const Tcl_UniChar *)uctPtr; +#if defined(WORDS_BIGENDIAN) + /* + * We are definitely on a big-endian machine; memcmp() is safe + */ + + return memcmp(ucs, uct, numChars*sizeof(Tcl_UniChar)); + +#else /* !WORDS_BIGENDIAN */ + /* + * We can't simply call memcmp() because that is not lexically correct. + */ + + for ( ; numChars != 0; ucs++, uct++, numChars--) { + if (*ucs != *uct) { + return (*ucs - *uct); + } + } + return 0; +#endif /* WORDS_BIGENDIAN */ +} + +#if !defined(TCL_NO_DEPRECATED) +int +Tcl_UniCharNcmp( + const unsigned short *ucs, /* Unicode string to compare to uct. */ + const unsigned short *uct, /* Unicode string ucs is compared to. */ + unsigned long numChars) /* Number of chars (not bytes) to compare. */ +{ +#if defined(WORDS_BIGENDIAN) + /* + * We are definitely on a big-endian machine; memcmp() is safe + */ + + return memcmp(ucs, uct, numChars*sizeof(Tcl_UniChar)); + +#else /* !WORDS_BIGENDIAN */ + /* + * We can't simply call memcmp() because that is not lexically correct. + */ + + for ( ; numChars != 0; ucs++, uct++, numChars--) { + if (*ucs != *uct) { + /* special case for handling upper surrogates */ + if (((*ucs & 0xFC00) == 0xD800) && ((*uct & 0xFC00) != 0xD800)) { + return 1; + } else if (((*uct & 0xFC00) == 0xD800)) { + return -1; + } + return (*ucs - *uct); + } + } + return 0; +#endif /* WORDS_BIGENDIAN */ +} +#endif /* *---------------------------------------------------------------------- * - * TclUniCharNcasecmp -- + * Tcl_UniCharNcasecmp -- * * Compare at most numChars chars (not bytes) of string ucs to string uct case * insensitive. Both ucs and uct are assumed to be at least numChars @@ -2002,6 +2144,54 @@ TclUniCharNcasecmp( } return 0; } + +int +TclUniCharNcasememcmp( + const void *ucsPtr, /* Unicode string to compare to uct. */ + const void *uctPtr, /* Unicode string ucs is compared to. */ + size_t numChars) /* Number of chars (not bytes) to compare. */ +{ + const Tcl_UniChar *ucs = (const Tcl_UniChar *)ucsPtr; + const Tcl_UniChar *uct = (const Tcl_UniChar *)uctPtr; + for ( ; numChars != 0; numChars--, ucs++, uct++) { + if (*ucs != *uct) { + Tcl_UniChar lcs = Tcl_UniCharToLower(*ucs); + Tcl_UniChar lct = Tcl_UniCharToLower(*uct); + + if (lcs != lct) { + return (lcs - lct); + } + } + } + return 0; +} + +#if !defined(TCL_NO_DEPRECATED) +int +Tcl_UniCharNcasecmp( + const unsigned short *ucs, /* Unicode string to compare to uct. */ + const unsigned short *uct, /* Unicode string ucs is compared to. */ + unsigned long numChars) /* Number of chars (not bytes) to compare. */ +{ + for ( ; numChars != 0; numChars--, ucs++, uct++) { + if (*ucs != *uct) { + unsigned short lcs = Tcl_UniCharToLower(*ucs); + unsigned short lct = Tcl_UniCharToLower(*uct); + + if (lcs != lct) { + /* special case for handling upper surrogates */ + if (((lcs & 0xFC00) == 0xD800) && ((lct & 0xFC00) != 0xD800)) { + return 1; + } else if (((lct & 0xFC00) == 0xD800)) { + return -1; + } + return (lcs - lct); + } + } + } + return 0; +} +#endif /* *---------------------------------------------------------------------- @@ -2308,7 +2498,7 @@ Tcl_UniCharIsWordChar( /* *---------------------------------------------------------------------- * - * TclUniCharCaseMatch -- + * Tcl_UniCharCaseMatch -- * * See if a particular Unicode string matches a particular pattern. * Allows case insensitivity. This is the Unicode equivalent of the char* @@ -2494,6 +2684,175 @@ TclUniCharCaseMatch( uniPattern++; } } + +#if !defined(TCL_NO_DEPRECATED) +int +Tcl_UniCharCaseMatch( + const unsigned short *uniStr, /* Unicode String. */ + const unsigned short *uniPattern, + /* Pattern, which may contain special + * characters. */ + int nocase) /* 0 for case sensitive, 1 for insensitive */ +{ + unsigned short ch1 = 0, p; + + while (1) { + p = *uniPattern; + + /* + * See if we're at the end of both the pattern and the string. If so, + * we succeeded. If we're at the end of the pattern but not at the end + * of the string, we failed. + */ + + if (p == 0) { + return (*uniStr == 0); + } + if ((*uniStr == 0) && (p != '*')) { + return 0; + } + + /* + * Check for a "*" as the next pattern character. It matches any + * substring. We handle this by skipping all the characters up to the + * next matching one in the pattern, and then calling ourselves + * recursively for each postfix of string, until either we match or we + * reach the end of the string. + */ + + if (p == '*') { + /* + * Skip all successive *'s in the pattern + */ + + while (*(++uniPattern) == '*') { + /* empty body */ + } + p = *uniPattern; + if (p == 0) { + return 1; + } + if (nocase) { + p = Tcl_UniCharToLower(p); + } + while (1) { + /* + * Optimization for matching - cruise through the string + * quickly if the next char in the pattern isn't a special + * character + */ + + if ((p != '[') && (p != '?') && (p != '\\')) { + if (nocase) { + while (*uniStr && (p != *uniStr) + && (p != Tcl_UniCharToLower(*uniStr))) { + uniStr++; + } + } else { + while (*uniStr && (p != *uniStr)) { + uniStr++; + } + } + } + if (Tcl_UniCharCaseMatch(uniStr, uniPattern, nocase)) { + return 1; + } + if (*uniStr == 0) { + return 0; + } + uniStr++; + } + } + + /* + * Check for a "?" as the next pattern character. It matches any + * single character. + */ + + if (p == '?') { + uniPattern++; + uniStr++; + continue; + } + + /* + * Check for a "[" as the next pattern character. It is followed by a + * list of characters that are acceptable, or by a range (two + * characters separated by "-"). + */ + + if (p == '[') { + unsigned short startChar, endChar; + + uniPattern++; + ch1 = (nocase ? Tcl_UniCharToLower(*uniStr) : *uniStr); + uniStr++; + while (1) { + if ((*uniPattern == ']') || (*uniPattern == 0)) { + return 0; + } + startChar = (nocase ? Tcl_UniCharToLower(*uniPattern) + : *uniPattern); + uniPattern++; + if (*uniPattern == '-') { + uniPattern++; + if (*uniPattern == 0) { + return 0; + } + endChar = (nocase ? Tcl_UniCharToLower(*uniPattern) + : *uniPattern); + uniPattern++; + if (((startChar <= ch1) && (ch1 <= endChar)) + || ((endChar <= ch1) && (ch1 <= startChar))) { + /* + * Matches ranges of form [a-z] or [z-a]. + */ + break; + } + } else if (startChar == ch1) { + break; + } + } + while (*uniPattern != ']') { + if (*uniPattern == 0) { + uniPattern--; + break; + } + uniPattern++; + } + uniPattern++; + continue; + } + + /* + * If the next pattern character is '\', just strip off the '\' so we + * do exact matching on the character that follows. + */ + + if (p == '\\') { + if (*(++uniPattern) == '\0') { + return 0; + } + } + + /* + * There's no special character. Just make sure that the next bytes of + * each string match. + */ + + if (nocase) { + if (Tcl_UniCharToLower(*uniStr) != + Tcl_UniCharToLower(*uniPattern)) { + return 0; + } + } else if (*uniStr != *uniPattern) { + return 0; + } + uniStr++; + uniPattern++; + } +} +#endif /* *---------------------------------------------------------------------- @@ -2502,7 +2861,7 @@ TclUniCharCaseMatch( * * See if a particular Unicode string matches a particular pattern. * Allows case insensitivity. This is the Unicode equivalent of the char* - * Tcl_StringCaseMatch. This variant of TclUniCharCaseMatch uses counted + * Tcl_StringCaseMatch. This variant of Tcl_UniCharCaseMatch uses counted * Strings, so embedded NULLs are allowed. * * Results: diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 0c9a3b2..c73841f 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -12,7 +12,6 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#include <assert.h> #include "tclInt.h" #include "tclParse.h" #include "tclStringTrim.h" @@ -96,6 +95,13 @@ static ProcessGlobalValue executableName = { #define CONVERT_ANY 16 /* + * The following key is used by Tcl_PrintDouble and TclPrecTraceProc to + * access the precision to be used for double formatting. + */ + +static Tcl_ThreadDataKey precisionKey; + +/* * Prototypes for functions defined later in this file. */ @@ -128,17 +134,9 @@ static const Tcl_ObjType endOffsetType = { NULL, /* freeIntRepProc */ NULL, /* dupIntRepProc */ NULL, /* updateStringProc */ - NULL, /* setFromAnyProc */ - TCL_OBJTYPE_V1(TclLengthOne) + NULL /* setFromAnyProc */ }; -Tcl_Size -TclLengthOne( - TCL_UNUSED(Tcl_Obj *)) -{ - return 1; -} - /* * * STRING REPRESENTATION OF LISTS * * * * @@ -879,7 +877,7 @@ Tcl_SplitList( size = TclMaxListLength(list, TCL_INDEX_NONE, &end) + 1; length = end - list; - argv = (const char **)Tcl_Alloc((size * sizeof(char *)) + length + 1); + argv = (const char **)ckalloc((size * sizeof(char *)) + length + 1); for (i = 0, p = ((char *) argv) + size*sizeof(char *); *list != 0; i++) { @@ -890,14 +888,14 @@ Tcl_SplitList( &elSize, &literal); length -= (list - prevList); if (result != TCL_OK) { - Tcl_Free((void *)argv); + ckfree(argv); return result; } if (*element == 0) { break; } if (i >= size) { - Tcl_Free((void *)argv); + ckfree(argv); if (interp != NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "internal error in Tcl_SplitList", -1)); @@ -1020,7 +1018,7 @@ Tcl_ScanCountedElement( *---------------------------------------------------------------------- */ -Tcl_Size +TCL_HASH_TYPE TclScanElement( const char *src, /* String to convert to Tcl list element. */ Tcl_Size length, /* Number of bytes in src, or TCL_INDEX_NONE. */ @@ -1036,7 +1034,7 @@ TclScanElement( Tcl_Size extra = 0; /* Count of number of extra bytes needed for * formatted element, assuming we use escape * sequences in formatting. */ - Tcl_Size bytesNeeded; /* Buffer length computed to complete the + TCL_HASH_TYPE bytesNeeded; /* Buffer length computed to complete the * element formatting in the selected mode. */ #if COMPAT int preferEscape = 0; /* Use preferences to track whether to use */ @@ -1178,7 +1176,7 @@ TclScanElement( } endOfString: - if (nestingLevel > 0) { + if (nestingLevel != 0) { /* * Unbalanced braces! Cannot format with brace quoting. */ @@ -1208,7 +1206,7 @@ TclScanElement( bytesNeeded++; } *flagPtr = CONVERT_ESCAPE; - return bytesNeeded; + goto overflowCheck; } if (*flagPtr & CONVERT_ANY) { /* @@ -1256,7 +1254,7 @@ TclScanElement( bytesNeeded += braceCount; } *flagPtr = CONVERT_MASK; - return bytesNeeded; + goto overflowCheck; } #endif /* COMPAT */ if (*flagPtr & TCL_DONT_USE_BRACES) { @@ -1282,7 +1280,7 @@ TclScanElement( bytesNeeded += 2; } *flagPtr = CONVERT_BRACE; - return bytesNeeded; + goto overflowCheck; } /* @@ -1297,6 +1295,11 @@ TclScanElement( bytesNeeded += 2; } *flagPtr = CONVERT_NONE; + + overflowCheck: + if (bytesNeeded > INT_MAX) { + Tcl_Panic("TclScanElement: string length overflow"); + } return bytesNeeded; } @@ -1573,7 +1576,7 @@ Tcl_Merge( #define LOCAL_SIZE 64 char localFlags[LOCAL_SIZE], *flagPtr = NULL; Tcl_Size i; - size_t bytesNeeded = 0; + unsigned int bytesNeeded = 0; char *result, *dst; /* @@ -1583,9 +1586,9 @@ Tcl_Merge( if (argc <= 0) { if (argc < 0) { - Tcl_Panic("Tcl_Merge called with negative argc (%" TCL_SIZE_MODIFIER "d)", argc); + Tcl_Panic("Tcl_Merge called with negative argc (%d)", argc); } - result = (char *)Tcl_Alloc(1); + result = (char *)ckalloc(1); result[0] = '\0'; return result; } @@ -1597,11 +1600,17 @@ Tcl_Merge( if (argc <= LOCAL_SIZE) { flagPtr = localFlags; } else { - flagPtr = (char *)Tcl_Alloc(argc); + flagPtr = (char *)ckalloc(argc); } for (i = 0; i < argc; i++) { flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 ); bytesNeeded += TclScanElement(argv[i], TCL_INDEX_NONE, &flagPtr[i]); + if (bytesNeeded > INT_MAX) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); + } + } + if (bytesNeeded + argc > INT_MAX + 1U) { + Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX); } bytesNeeded += argc; @@ -1609,7 +1618,7 @@ Tcl_Merge( * Pass two: copy into the result area. */ - result = (char *)Tcl_Alloc(bytesNeeded); + result = (char *)ckalloc(bytesNeeded); dst = result; for (i = 0; i < argc; i++) { flagPtr[i] |= ( i ? TCL_DONT_QUOTE_HASH : 0 ); @@ -1620,11 +1629,47 @@ Tcl_Merge( dst[-1] = 0; if (flagPtr != localFlags) { - Tcl_Free(flagPtr); + ckfree(flagPtr); } return result; } +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 +/* + *---------------------------------------------------------------------- + * + * Tcl_Backslash -- + * + * Figure out how to handle a backslash sequence. + * + * Results: + * The return value is the character that should be substituted in place + * of the backslash sequence that starts at src. If readPtr isn't NULL + * then it is filled in with a count of the number of characters in the + * backslash sequence. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +char +Tcl_Backslash( + const char *src, /* Points to the backslash character of a + * backslash sequence. */ + int *readPtr) /* Fill in with number of characters read from + * src, unless NULL. */ +{ + char buf[4] = ""; + Tcl_UniChar ch = 0; + + Tcl_UtfBackslash(src, readPtr, buf); + TclUtfToUniChar(buf, &ch); + return (char) ch; +} +#endif /* !TCL_NO_DEPRECATED */ + /* *---------------------------------------------------------------------- * @@ -1855,7 +1900,7 @@ TclTrim( */ /* The whitespace characters trimmed during [concat] operations */ -#define CONCAT_WS_SIZE (sizeof(CONCAT_TRIM_SET "") - 1) +#define CONCAT_WS_SIZE (int) (sizeof(CONCAT_TRIM_SET "") - 1) char * Tcl_Concat( @@ -1870,7 +1915,7 @@ Tcl_Concat( */ if (argc == 0) { - result = (char *) Tcl_Alloc(1); + result = (char *) ckalloc(1); result[0] = '\0'; return result; } @@ -1881,7 +1926,7 @@ Tcl_Concat( for (i = 0; i < argc; i++) { bytesNeeded += strlen(argv[i]); - if (bytesNeeded < 0) { + if (bytesNeeded < 0) { Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded"); } } @@ -1898,7 +1943,7 @@ Tcl_Concat( Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded"); } - result = (char *)Tcl_Alloc(bytesNeeded + argc); + result = (char *)ckalloc(bytesNeeded + argc); for (p = result, i = 0; i < argc; i++) { Tcl_Size triml, trimr, elemLength; @@ -1977,11 +2022,10 @@ Tcl_ConcatObj( Tcl_Size length; objPtr = objv[i]; - if (TclListObjIsCanonical(objPtr) || - TclObjTypeHasProc(objPtr, indexProc)) { + if (TclListObjIsCanonical(objPtr)) { continue; } - (void)TclGetStringFromObj(objPtr, &length); + TclGetStringFromObj(objPtr, &length); if (length > 0) { break; } @@ -1990,8 +2034,7 @@ Tcl_ConcatObj( resPtr = NULL; for (i = 0; i < objc; i++) { objPtr = objv[i]; - if (!TclListObjIsCanonical(objPtr) && - !TclObjTypeHasProc(objPtr, indexProc)) { + if (!TclListObjIsCanonical(objPtr)) { continue; } if (resPtr) { @@ -2005,10 +2048,8 @@ Tcl_ConcatObj( != Tcl_ListObjAppendList(NULL, resPtr, objPtr)) { /* Abandon ship! */ Tcl_DecrRefCount(resPtr); - Tcl_BounceRefCount(elemPtr); // could be an abstract list element goto slow; } - Tcl_BounceRefCount(elemPtr); // could be an an abstract list element } else { resPtr = TclListObjCopy(NULL, objPtr); } @@ -2029,10 +2070,10 @@ Tcl_ConcatObj( for (i = 0; i < objc; i++) { element = TclGetStringFromObj(objv[i], &elemLength); - if (bytesNeeded > (TCL_SIZE_MAX - elemLength)) { - break; /* Overflow. Do not preallocate. See comment below. */ - } bytesNeeded += elemLength; + if (bytesNeeded < 0) { + break; + } } /* @@ -2080,6 +2121,35 @@ Tcl_ConcatObj( return resPtr; } +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 +/* + *---------------------------------------------------------------------- + * + * Tcl_StringMatch -- + * + * See if a particular string matches a particular pattern. + * + * Results: + * The return value is 1 if string matches pattern, and 0 otherwise. The + * matching operation permits the following special characters in the + * pattern: *?\[] (see the manual entry for details on what these mean). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#undef Tcl_StringMatch +int +Tcl_StringMatch( + const char *str, /* String. */ + const char *pattern) /* Pattern, which may contain special + * characters. */ +{ + return Tcl_StringCaseMatch(str, pattern, 0); +} +#endif /* TCL_NO_DEPRECATED */ /* *---------------------------------------------------------------------- * @@ -2137,7 +2207,7 @@ Tcl_StringCaseMatch( * Skip all successive *'s in the pattern */ - while (*(++pattern) == '*'); + while (*(++pattern) == '*') {} p = *pattern; if (p == '\0') { return 1; @@ -2398,7 +2468,7 @@ TclByteArrayMatch( } } if (TclByteArrayMatch(string, stringEnd - string, - pattern, patternEnd - pattern, 0)) { + pattern, patternEnd - pattern, 0)) { return 1; } if (string == stringEnd) { @@ -2519,7 +2589,7 @@ TclStringMatchObj( * 0. */ { int match; - Tcl_Size length = 0, plen = 0; + Tcl_Size length, plen; /* * Promote based on the type of incoming object. @@ -2528,18 +2598,18 @@ TclStringMatchObj( trivial = nocase ? 0 : TclMatchIsTrivial(TclGetString(ptnObj)); */ - if (TclHasInternalRep(strObj, &tclStringType) || (strObj->typePtr == NULL)) { + if (TclHasInternalRep(strObj, &tclUniCharStringType) || (strObj->typePtr == NULL)) { Tcl_UniChar *udata, *uptn; - udata = Tcl_GetUnicodeFromObj(strObj, &length); - uptn = Tcl_GetUnicodeFromObj(ptnObj, &plen); + udata = TclGetUnicodeFromObj(strObj, &length); + uptn = TclGetUnicodeFromObj(ptnObj, &plen); match = TclUniCharMatch(udata, length, uptn, plen, flags); } else if (TclIsPureByteArray(strObj) && TclIsPureByteArray(ptnObj) && !flags) { unsigned char *data, *ptn; - data = Tcl_GetBytesFromObj(NULL, strObj, &length); - ptn = Tcl_GetBytesFromObj(NULL, ptnObj, &plen); + data = Tcl_GetByteArrayFromObj(strObj, &length); + ptn = Tcl_GetByteArrayFromObj(ptnObj, &plen); match = TclByteArrayMatch(data, length, ptn, plen, 0); } else { match = Tcl_StringCaseMatch(TclGetString(strObj), @@ -2598,9 +2668,9 @@ char * Tcl_DStringAppend( Tcl_DString *dsPtr, /* Structure describing dynamic string. */ const char *bytes, /* String to append. If length is - * TCL_INDEX_NONE then this must be null-terminated. */ + * < 0 then this must be null-terminated. */ Tcl_Size length) /* Number of bytes from "bytes" to append. If - * TCL_INDEX_NONE, then append all of bytes, up to null + * < 0, then append all of bytes, up to null * at end. */ { Tcl_Size newSize; @@ -2608,20 +2678,19 @@ Tcl_DStringAppend( if (length < 0) { length = strlen(bytes); } + newSize = length + dsPtr->length; - if (length > (TCL_SIZE_MAX - dsPtr->length - 1)) { - Tcl_Panic("max size for a Tcl value (%" TCL_SIZE_MODIFIER - "d bytes) exceeded", - TCL_SIZE_MAX); - return NULL; /* NOTREACHED */ - } - newSize = length + dsPtr->length + 1; - + /* + * Allocate a larger buffer for the string if the current one isn't large + * enough. Allocate extra space in the new buffer so that there will be + * room to grow before we have to allocate again. + */ - if (newSize > dsPtr->spaceAvl) { + if (newSize >= dsPtr->spaceAvl) { + dsPtr->spaceAvl = newSize * 2; if (dsPtr->string == dsPtr->staticSpace) { - char *newString; - newString = (char *) TclAllocEx(newSize, &dsPtr->spaceAvl); + char *newString = (char *)ckalloc(dsPtr->spaceAvl); + memcpy(newString, dsPtr->string, dsPtr->length); dsPtr->string = newString; } else { @@ -2634,7 +2703,7 @@ Tcl_DStringAppend( offset = bytes - dsPtr->string; } dsPtr->string = - (char *)TclReallocEx(dsPtr->string, newSize, &dsPtr->spaceAvl); + (char *)ckrealloc(dsPtr->string, dsPtr->spaceAvl); if (offset >= 0) { bytes = dsPtr->string + offset; } @@ -2748,10 +2817,12 @@ Tcl_DStringAppendElement( * memcpy, not strcpy, to copy the string to a larger buffer, since there * may be embedded NULLs in the string in some cases. */ - newSize += 1; /* For terminating nul */ - if (newSize > dsPtr->spaceAvl) { + + if (newSize >= dsPtr->spaceAvl) { + dsPtr->spaceAvl = newSize * 2; if (dsPtr->string == dsPtr->staticSpace) { - char *newString = (char *) TclAllocEx(newSize, &dsPtr->spaceAvl); + char *newString = (char *)ckalloc(dsPtr->spaceAvl); + memcpy(newString, dsPtr->string, dsPtr->length); dsPtr->string = newString; } else { @@ -2764,7 +2835,7 @@ Tcl_DStringAppendElement( offset = element - dsPtr->string; } dsPtr->string = - (char *)TclReallocEx(dsPtr->string, newSize, &dsPtr->spaceAvl); + (char *)ckrealloc(dsPtr->string, dsPtr->spaceAvl); if (offset >= 0) { element = dsPtr->string + offset; } @@ -2801,7 +2872,8 @@ Tcl_DStringAppendElement( * * Side effects: * The length of dsPtr is changed to length and a null byte is stored at - * that position in the string. + * that position in the string. If length is larger than the space + * allocated for dsPtr, then a panic occurs. * *---------------------------------------------------------------------- */ @@ -2823,28 +2895,25 @@ Tcl_DStringSetLength( * would be wasteful to overallocate that buffer, so we just allocate * enough for the requested size plus the trailing null byte. In the * second case, we are growing the buffer incrementally, so we need - * behavior similar to Tcl_DStringAppend. - * TODO - the above makes no sense to me. How does the code below - * translate into distinguishing the two cases above? IMO, if caller - * specifically sets the length, there is no cause for overallocation. + * behavior similar to Tcl_DStringAppend. The requested length will + * usually be a small delta above the current spaceAvl, so we'll end + * up doubling the old size. This won't grow the buffer quite as + * quickly, but it should be close enough. */ - if (length >= TCL_SIZE_MAX) { - Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded"); - } - newsize = TclUpsizeAlloc(dsPtr->spaceAvl, length + 1, TCL_SIZE_MAX); + newsize = dsPtr->spaceAvl * 2; if (length < newsize) { dsPtr->spaceAvl = newsize; } else { dsPtr->spaceAvl = length + 1; } if (dsPtr->string == dsPtr->staticSpace) { - char *newString = (char *)Tcl_Alloc(dsPtr->spaceAvl); + char *newString = (char *)ckalloc(dsPtr->spaceAvl); memcpy(newString, dsPtr->string, dsPtr->length); dsPtr->string = newString; } else { - dsPtr->string = (char *)Tcl_Realloc(dsPtr->string, dsPtr->spaceAvl); + dsPtr->string = (char *)ckrealloc(dsPtr->string, dsPtr->spaceAvl); } } dsPtr->length = length; @@ -2874,7 +2943,7 @@ Tcl_DStringFree( Tcl_DString *dsPtr) /* Structure describing dynamic string. */ { if (dsPtr->string != dsPtr->staticSpace) { - Tcl_Free(dsPtr->string); + ckfree(dsPtr->string); } dsPtr->string = dsPtr->staticSpace; dsPtr->length = 0; @@ -2936,12 +3005,86 @@ Tcl_DStringGetResult( Tcl_DString *dsPtr) /* Dynamic string that is to become the result * of interp. */ { +#if defined(TCL_NO_DEPRECATED) || TCL_MAJOR_VERSION > 8 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) { + ckfree(dsPtr->string); + } + + /* + * Do more efficient transfer when we know the result is a Tcl_Obj. When + * there's no string result, we only have to deal with two cases: + * + * 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. + + * 2. When the string rep is not there or there's a real string rep, when + * we use Tcl_GetString to fetch (or generate) the string rep - which + * we know to have been allocated with ckalloc() - and use it to + * populate the DString space. Then, we free the internal rep. and set + * the object's string representation back to the canonical empty + * string. + */ + + if (!iPtr->result[0] && iPtr->objResultPtr + && !Tcl_IsShared(iPtr->objResultPtr)) { + 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 = TclGetString(iPtr->objResultPtr); + dsPtr->length = iPtr->objResultPtr->length; + dsPtr->spaceAvl = dsPtr->length + 1; + TclFreeInternalRep(iPtr->objResultPtr); + iPtr->objResultPtr->bytes = &tclEmptyString; + iPtr->objResultPtr->length = 0; + } + return; + } + + /* + * If the string result is empty, move the object result to the string + * result, then reset the object result. + */ + + (void) Tcl_GetStringResult(interp); + + dsPtr->length = strlen(iPtr->result); + if (iPtr->freeProc != NULL) { + if (iPtr->freeProc == TCL_DYNAMIC) { + dsPtr->string = iPtr->result; + dsPtr->spaceAvl = dsPtr->length+1; + } else { + dsPtr->string = (char *)ckalloc(dsPtr->length+1); + memcpy(dsPtr->string, iPtr->result, dsPtr->length+1); + iPtr->freeProc(iPtr->result); + } + dsPtr->spaceAvl = dsPtr->length+1; + iPtr->freeProc = NULL; + } else { + if (dsPtr->length < TCL_DSTRING_STATIC_SIZE) { + dsPtr->string = dsPtr->staticSpace; + dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE; + } else { + dsPtr->string = (char *)ckalloc(dsPtr->length+1); + dsPtr->spaceAvl = dsPtr->length + 1; + } + memcpy(dsPtr->string, iPtr->result, dsPtr->length+1); + } + + iPtr->result = iPtr->resultSpace; + iPtr->resultSpace[0] = 0; +#endif /* !TCL_NO_DEPRECATED */ } /* @@ -3067,9 +3210,10 @@ Tcl_DStringEndSublist( * string using. * * Results: - * The ASCII equivalent of "value" is written at "dst". It is guaranteed - * to contain a decimal point or exponent, so that it looks like a - * floating-point value and not an integer. + * The ASCII equivalent of "value" is written at "dst". It is written + * using the current precision, and it is guaranteed to contain a decimal + * point or exponent, so that it looks like a floating-point value and + * not an integer. * * Side effects: * None. @@ -3089,6 +3233,7 @@ Tcl_PrintDouble( int signum; char *digits; char *end; + int *precisionPtr = (int *)Tcl_GetThreadData(&precisionKey, sizeof(int)); /* * Handle NaN. @@ -3120,8 +3265,53 @@ Tcl_PrintDouble( * Ordinary (normal and denormal) values. */ - digits = TclDoubleDigits(value, -1, TCL_DD_SHORTEST, - &exponent, &signum, &end); + if (*precisionPtr == 0) { + digits = TclDoubleDigits(value, TCL_INDEX_NONE, TCL_DD_SHORTEST, + &exponent, &signum, &end); + } else { + /* + * There are at least two possible interpretations for tcl_precision. + * + * The first is, "choose the decimal representation having + * $tcl_precision digits of significance that is nearest to the given + * number, breaking ties by rounding to even, and then trimming + * trailing zeros." This gives the greatest possible precision in the + * decimal string, but offers the anomaly that [expr 0.1] will be + * "0.10000000000000001". + * + * The second is "choose the decimal representation having at most + * $tcl_precision digits of significance that is nearest to the given + * number. If no such representation converts exactly to the given + * number, choose the one that is closest, breaking ties by rounding + * to even. If more than one such representation converts exactly to + * the given number, choose the shortest, breaking ties in favour of + * the nearest, breaking remaining ties in favour of the one ending in + * an even digit." + * + * Tcl 8.4 implements the first of these, which gives rise to + * anomalies in formatting: + * + * % expr 0.1 + * 0.10000000000000001 + * % expr 0.01 + * 0.01 + * % expr 1e-7 + * 9.9999999999999995e-08 + * + * For human readability, it appears better to choose the second rule, + * and let [expr 0.1] return 0.1. But for 8.4 compatibility, we prefer + * the first (the recommended zero value for tcl_precision avoids the + * problem entirely). + * + * Uncomment TCL_DD_SHORTEST in the next call to prefer the method + * that allows floating point values to be shortened if it can be done + * without loss of precision. + */ + + digits = TclDoubleDigits(value, *precisionPtr, + TCL_DD_E_FORMAT /* | TCL_DD_SHORTEST */, + &exponent, &signum, &end); + } if (signum) { *dst++ = '-'; } @@ -3141,7 +3331,16 @@ Tcl_PrintDouble( } } - snprintf(dst, TCL_DOUBLE_SPACE, "e%+d", exponent); + /* + * Tcl 8.4 appears to format with at least a two-digit exponent; + * preserve that behaviour when tcl_precision != 0 + */ + + if (*precisionPtr == 0) { + snprintf(dst, TCL_DOUBLE_SPACE, "e%+d", exponent); + } else { + snprintf(dst, TCL_DOUBLE_SPACE, "e%+03d", exponent); + } } else { /* * F format for others. @@ -3173,12 +3372,91 @@ Tcl_PrintDouble( } *dst++ = '\0'; } - Tcl_Free(digits); + ckfree(digits); } /* *---------------------------------------------------------------------- * + * TclPrecTraceProc -- + * + * This function is invoked whenever the variable "tcl_precision" is + * written. + * + * Results: + * Returns NULL if all went well, or an error message if the new value + * for the variable doesn't make sense. + * + * Side effects: + * If the new value doesn't make sense then this function undoes the + * effect of the variable modification. Otherwise it modifies the format + * string that's used by Tcl_PrintDouble. + * + *---------------------------------------------------------------------- + */ + +#if !defined(TCL_NO_DEPRECATED) && TCL_MAJOR_VERSION < 9 +char * +TclPrecTraceProc( + void *clientData, + Tcl_Interp *interp, /* Interpreter containing variable. */ + const char *name1, /* Name of variable. */ + const char *name2, /* Second part of variable name. */ + int flags) /* Information about what happened. */ +{ + Tcl_Obj *value; + Tcl_WideInt prec; + int *precisionPtr = (int *)Tcl_GetThreadData(&precisionKey, sizeof(int)); + + /* + * If the variable is unset, then recreate the trace. + */ + + if (flags & TCL_TRACE_UNSETS) { + if ((flags & TCL_TRACE_DESTROYED) && !Tcl_InterpDeleted(interp)) { + Tcl_TraceVar2(interp, name1, name2, + TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES + |TCL_TRACE_UNSETS, TclPrecTraceProc, clientData); + } + return NULL; + } + + /* + * When the variable is read, reset its value from our shared value. This + * is needed in case the variable was modified in some other interpreter + * so that this interpreter's value is out of date. + */ + + + if (flags & TCL_TRACE_READS) { + Tcl_SetVar2Ex(interp, name1, name2, Tcl_NewWideIntObj(*precisionPtr), + flags & TCL_GLOBAL_ONLY); + return NULL; + } + + /* + * The variable is being written. Check the new value and disallow it if + * it isn't reasonable or if this is a safe interpreter (we don't want + * safe interpreters messing up the precision of other interpreters). + */ + + if (Tcl_IsSafe(interp)) { + return (char *) "can't modify precision from a safe interpreter"; + } + value = Tcl_GetVar2Ex(interp, name1, name2, flags & TCL_GLOBAL_ONLY); + if (value == NULL + || Tcl_GetWideIntFromObj(NULL, value, &prec) != TCL_OK + || prec < 0 || prec > TCL_MAX_PREC) { + return (char *) "improper value for precision"; + } + *precisionPtr = (int)prec; + return NULL; +} +#endif /* !TCL_NO_DEPRECATED)*/ + +/* + *---------------------------------------------------------------------- + * * TclNeedSpace -- * * This function checks to see whether it is appropriate to add a space @@ -3378,7 +3656,7 @@ GetWideForIndex( if (numType == TCL_NUMBER_INT) { /* objPtr holds an integer in the signed wide range */ *widePtr = *(Tcl_WideInt *)cd; - if ((*widePtr < 0)) { + if ((*widePtr < 0)) { *widePtr = (endValue == -1) ? WIDE_MIN : -1; } return TCL_OK; @@ -3386,7 +3664,7 @@ GetWideForIndex( if (numType == TCL_NUMBER_BIG) { /* objPtr holds an integer outside the signed wide range */ /* Truncate to the signed wide range. */ - *widePtr = ((mp_isneg((mp_int *)cd)) ? WIDE_MIN : WIDE_MAX); + *widePtr = ((mp_isneg((mp_int *)cd)) ? ((endValue == -1) ? WIDE_MIN : -1) : WIDE_MAX); return TCL_OK; } } @@ -3408,14 +3686,12 @@ GetWideForIndex( * (0..TCL_SIZE_MAX) it is returned. Higher values are returned as * TCL_SIZE_MAX. Negative values are returned as TCL_INDEX_NONE (-1). * - * Callers should pass reasonable values for endValue - one in the - * valid index range or TCL_INDEX_NONE (-1), for example for an empty - * list. * * Results: * TCL_OK * - * The index is stored at the address given by by 'indexPtr'. + * The index is stored at the address given by by 'indexPtr'. If + * 'objPtr' has the value "end", the value stored is 'endValue'. * * TCL_ERROR * @@ -3423,9 +3699,10 @@ GetWideForIndex( * 'interp' is non-NULL, an error message is left in the interpreter's * result object. * - * Side effects: + * Effect * - * The internal representation contained within objPtr may shimmer. + * The object referenced by 'objPtr' is converted, as needed, to an + * integer, wide integer, or end-based-index object. * *---------------------------------------------------------------------- */ @@ -3447,17 +3724,14 @@ Tcl_GetIntForIndex( return TCL_ERROR; } if (indexPtr != NULL) { - /* Note: check against TCL_SIZE_MAX needed for 32-bit builds */ - if (wide >= 0 && wide <= TCL_SIZE_MAX) { - *indexPtr = (Tcl_Size)wide; /* A valid index */ - } else if (wide > TCL_SIZE_MAX) { - *indexPtr = TCL_SIZE_MAX; /* Beyond max possible index */ - } else if (wide < -1-TCL_SIZE_MAX) { - *indexPtr = -1-TCL_SIZE_MAX; /* Below most negative index */ - } else if ((wide < 0) && (endValue >= 0)) { - *indexPtr = TCL_INDEX_NONE; /* No clue why this special case */ - } else { - *indexPtr = (Tcl_Size) wide; + if ((wide < 0) && (endValue >= 0)) { + *indexPtr = TCL_INDEX_NONE; + } else if (wide > INT_MAX) { + *indexPtr = INT_MAX; + } else if (wide < INT_MIN) { + *indexPtr = INT_MIN; + } else { + *indexPtr = (int) wide; } } return TCL_OK; @@ -3531,6 +3805,7 @@ GetEndOffsetFromObj( * This relies on TclGetString() returning a NUL-terminated string. */ if ((TclMaxListLength(bytes, TCL_INDEX_NONE, NULL) > 1) + /* If it's possible, do the full list parse. */ && (TCL_OK == TclListObjLength(NULL, objPtr, &length)) && (length > 1)) { @@ -3656,7 +3931,7 @@ GetEndOffsetFromObj( /* Parse the integer offset */ if (TCL_OK != TclParseNumber(NULL, objPtr, NULL, - bytes + 4, length - 4, NULL, TCL_PARSE_INTEGER_ONLY)) { + bytes+4, length-4, NULL, TCL_PARSE_INTEGER_ONLY)) { /* Not a recognized integer format */ goto parseError; } @@ -3696,27 +3971,17 @@ GetEndOffsetFromObj( offset = irPtr->wideValue; if (offset == WIDE_MAX) { - /* - * Encodes end+1. This is distinguished from end+n as noted - * in function header. - * NOTE: this may wrap around if the caller passes (as lset does) - * listLen-1 as endValue and and listLen is 0. The -1 will be - * interpreted as FF...FF and adding 1 will result in 0 which - * is what we want. Callers like lset which pass in listLen-1 == -1 - * as endValue will have to adjust accordingly. - */ *widePtr = (endValue == -1) ? WIDE_MAX : endValue + 1; } else if (offset == WIDE_MIN) { - /* -1 - position before first */ *widePtr = -1; + } else if (endValue == -1) { + *widePtr = offset; } else if (offset < 0) { - /* end-(n-1) - Different signs, sum cannot overflow */ + /* Different signs, sum cannot overflow */ *widePtr = endValue + offset + 1; } else if (offset < WIDE_MAX) { - /* 0:WIDE_MAX-1 - plain old index. */ *widePtr = offset; } else { - /* Huh, what case remains here? */ *widePtr = WIDE_MAX; } return TCL_OK; @@ -3731,6 +3996,7 @@ GetEndOffsetFromObj( if (!strncmp(bytes, "end-", 4)) { bytes += 4; } + TclCheckBadOctal(interp, bytes); Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", (char *)NULL); } @@ -3741,26 +4007,19 @@ GetEndOffsetFromObj( *---------------------------------------------------------------------- * * TclIndexEncode -- - * IMPORTANT: function only encodes indices in the range that fits within - * an "int" type. Do NOT change this as the byte code compiler and engine - * which call this function cannot handle wider index types. Indices - * outside the range will result in the function returning an error. * * Parse objPtr to determine if it is an index value. Two cases * are possible. The value objPtr might be parsed as an absolute - * index value in the Tcl_Size range. Note that this includes + * index value in the C signed int range. Note that this includes * index values that are integers as presented and it includes index - * arithmetic expressions. - * - * The largest string supported in Tcl 8 has byte length TCL_SIZE_MAX. - * This means the largest supported character length is also TCL_SIZE_MAX, - * and the index of the last character in a string of length TCL_SIZE_MAX - * is TCL_SIZE_MAX-1. Thus the absolute index values that can be + * arithmetic expressions. The absolute index values that can be * directly meaningful as an index into either a list or a string are - * integer values in the range 0 to TCL_SIZE_MAX - 1. - * - * This function however can only handle integer indices in the range - * 0 : INT_MAX-1. + * those integer values >= TCL_INDEX_START (0) + * 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 + * is INT_MAX-1. * * Any absolute index value parsed outside that range is encoded * using the before and after values passed in by the @@ -3786,8 +4045,7 @@ GetEndOffsetFromObj( * they can be encoded with the before value. * * Returns: - * TCL_OK if parsing succeeded, and TCL_ERROR if it failed or the - * index does not fit in an int type. + * TCL_OK if parsing succeeded, and TCL_ERROR if it failed. * * Side effects: * When TCL_OK is returned, the encoded index value is written @@ -3800,133 +4058,41 @@ int TclIndexEncode( Tcl_Interp *interp, /* For error reporting, may be NULL */ Tcl_Obj *objPtr, /* Index value to parse */ - int before, /* Value to return for index before beginning */ - int after, /* Value to return for index after end */ + Tcl_Size before, /* Value to return for index before beginning */ + Tcl_Size after, /* Value to return for index after end */ int *indexPtr) /* Where to write the encoded answer, not NULL */ { Tcl_WideInt wide; int idx; - const Tcl_WideInt ENDVALUE = 2 * (Tcl_WideInt) INT_MAX; - - assert(ENDVALUE < WIDE_MAX); - if (TCL_OK != GetWideForIndex(interp, objPtr, ENDVALUE, &wide)) { - return TCL_ERROR; - } - /* - * We passed 2*INT_MAX as the "end value" to GetWideForIndex. The computed - * index will be in one of the following ranges that need to be - * distinguished for encoding purposes in the following code. - * (1) 0:INT_MAX when - * (a) objPtr was a pure non-negative numeric value in that range - * (b) objPtr was a numeric computation M+/-N with a result in that range - * (c) objPtr was of the form end-N where N was in range INT_MAX:2*INT_MAX - * (2) INT_MAX+1:2*INT_MAX when - * (a,b) as above - * (c) objPtr was of the form end-N where N was in range 0:INT_MAX-1 - * (3) 2*INT_MAX:WIDE_MAX when - * (a,b) as above - * (c) objPtr was of the form end+N - * (4) (2*INT_MAX)-TCL_SIZE_MAX : -1 when - * (a,b) as above - * (c) objPtr was of the form end-N where N was in the range 0:TCL_SIZE_MAX - * (5) WIDE_MIN:(2*INT_MAX)-TCL_SIZE_MAX - * (a,b) as above - * (c) objPtr was of the form end-N where N was > TCL_SIZE_MAX - * - * For all cases (b) and (c), the internal representation of objPtr - * will be shimmered to endOffsetType. That allows us to distinguish between - * (for example) 1a (encodable) and 1c (not encodable) though the computed - * index value is the same. - * - * Further note, the values TCL_SIZE_MAX < N < WIDE_MAX come into play - * only in the 32-bit builds as TCL_SIZE_MAX == WIDE_MAX for 64-bits. - */ - - const Tcl_ObjInternalRep *irPtr = - TclFetchInternalRep(objPtr, &endOffsetType); - - if (irPtr && irPtr->wideValue >= 0) { - /* - * "int[+-]int" syntax, works the same here as "int". - * Note same does not hold for negative integers. - * Distinguishes 1b and 1c where wide will be in 0:INT_MAX for - * both but irPtr->wideValue will be negative for 1c. - */ - irPtr = NULL; - } - - if (irPtr == NULL) { - /* objPtr can be treated as a purely numeric value. */ - /* - * On 64-bit systems, indices in the range INT_MAX:TCL_SIZE_MAX are - * valid indices but are not in the encodable range. Thus an - * error is raised. On 32-bit systems, indices in that range indicate - * the position after the end and so do not raise an error. - */ - if ((sizeof(int) != sizeof(Tcl_Size)) && - (wide > INT_MAX) && (wide < WIDE_MAX-1)) { - /* 2(a,b) on 64-bit systems*/ - goto rangeerror; + if (TCL_OK == GetWideForIndex(interp, objPtr, (unsigned)TCL_INDEX_END , &wide)) { + const Tcl_ObjInternalRep *irPtr = TclFetchInternalRep(objPtr, &endOffsetType); + if (irPtr && irPtr->wideValue >= 0) { + /* "int[+-]int" syntax, works the same here as "int" */ + irPtr = NULL; } - if (wide > INT_MAX) { - /* - * 3(a,b) on 64-bit systems and 2(a,b), 3(a,b) on 32-bit systems - * Because of the check above, this case holds for indices - * greater than INT_MAX on 32-bit systems and > TCL_SIZE_MAX - * on 64-bit systems. Always maps to the element after the end. - */ - idx = after; - } else if (wide < 0) { - /* 4(a,b) (32-bit systems), 5(a,b) - before the beginning */ - idx = before; - } else { - /* 1(a,b) Encodable range */ - idx = (int)wide; - } - } else { - /* objPtr is not purely numeric (end etc.) */ - /* - * On 64-bit systems, indices in the range end-LIST_MAX:end-INT_MAX - * are valid indices (with max size strings/lists) but are not in - * the encodable range. Thus an error is raised. On 32-bit systems, - * indices in that range indicate the position before the beginning - * and so do not raise an error. + * We parsed an end+offset index value. + * wide holds the offset value in the range WIDE_MIN...WIDE_MAX. */ - if ((sizeof(int) != sizeof(Tcl_Size)) && - (wide > (ENDVALUE - LIST_MAX)) && (wide <= INT_MAX)) { - /* 1(c), 4(a,b) on 64-bit systems */ - goto rangeerror; - } - if (wide > ENDVALUE) { + if (wide > (unsigned)(irPtr ? TCL_INDEX_END : INT_MAX)) { /* - * 2(c) (32-bit systems), 3(c) - * All end+positive or end-negative expressions + * All end+postive or end-negative expressions * always indicate "after the end". - * Note we will not reach here for a pure numeric value in this - * range because irPtr will be NULL in that case. */ idx = after; - } else if (wide <= INT_MAX) { - /* 1(c) (32-bit systems), 4(c) (32-bit systems), 5(c) */ + } else if (wide <= (irPtr ? INT_MAX : TCL_INDEX_NONE)) { + /* These indices always indicate "before the beginning" */ idx = before; } else { - /* 2(c) Encodable end-positive (or end+negative) */ + /* Encoded end-positive (or end+negative) are offset */ idx = (int)wide; } + } else { + return TCL_ERROR; } *indexPtr = idx; return TCL_OK; - -rangeerror: - if (interp) { - Tcl_SetObjResult( - interp, - Tcl_ObjPrintf("index \"%s\" out of range", TclGetString(objPtr))); - Tcl_SetErrorCode(interp, "TCL", "VALUE", "INDEX", "OUTOFRANGE", (void *)NULL); - } - return TCL_ERROR; } /* @@ -3960,39 +4126,70 @@ TclIndexDecode( } /* - *------------------------------------------------------------------------ + *---------------------------------------------------------------------- * - * TclCommandWordLimitErrpr -- + * TclCheckBadOctal -- * - * Generates an error message limit on number of command words exceeded. + * This function checks for a bad octal value and appends a meaningful + * error to the interp's result. * * Results: - * Always return TCL_ERROR. + * 1 if the argument was a bad octal, else 0. * * Side effects: - * If interp is not-NULL, an error message is stored in it. + * The interpreter's result is modified. * - *------------------------------------------------------------------------ + *---------------------------------------------------------------------- */ + int -TclCommandWordLimitError( - Tcl_Interp *interp, /* May be NULL */ - Tcl_Size count) /* If <= 0, "unknown" */ +TclCheckBadOctal( + Tcl_Interp *interp, /* Interpreter to use for error reporting. If + * NULL, then no error message is left after + * errors. */ + const char *value) /* String to check. */ { - if (interp) { - if (count > 0) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "Number of words (%" TCL_SIZE_MODIFIER - "d) in command exceeds limit %" TCL_SIZE_MODIFIER "d.", - count, (Tcl_Size)INT_MAX)); - } else { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "Number of words in command exceeds limit %" - TCL_SIZE_MODIFIER "d.", - (Tcl_Size)INT_MAX)); + const char *p = value; + + /* + * A frequent mistake is invalid octal values due to an unwanted leading + * zero. Try to generate a meaningful error message. + */ + + while (TclIsSpaceProcM(*p)) { + p++; + } + if (*p == '+' || *p == '-') { + p++; + } + if (*p == '0') { + if ((p[1] == 'o') || p[1] == 'O') { + p += 2; + } + while (isdigit(UCHAR(*p))) { /* INTL: digit. */ + p++; + } + while (TclIsSpaceProcM(*p)) { + p++; + } + if (*p == '\0') { + /* + * Reached end of string. + */ + + if (interp != NULL) { + /* + * Don't reset the result here because we want this result to + * be added to an existing error message as extra info. + */ + + Tcl_AppendToObj(Tcl_GetObjResult(interp), + " (looks like invalid octal number)", TCL_INDEX_NONE); + } + return 1; } } - return TCL_ERROR; /* Always */ + return 0; } /* @@ -4047,7 +4244,7 @@ GetThreadHash( (Tcl_HashTable **)Tcl_GetThreadData(keyPtr, sizeof(Tcl_HashTable *)); if (NULL == *tablePtrPtr) { - *tablePtrPtr = (Tcl_HashTable *)Tcl_Alloc(sizeof(Tcl_HashTable)); + *tablePtrPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable)); Tcl_CreateThreadExitHandler(FreeThreadHash, *tablePtrPtr); Tcl_InitHashTable(*tablePtrPtr, TCL_ONE_WORD_KEYS); } @@ -4076,7 +4273,7 @@ FreeThreadHash( ClearHash(tablePtr); Tcl_DeleteHashTable(tablePtr); - Tcl_Free(tablePtr); + ckfree(tablePtr); } /* @@ -4098,7 +4295,7 @@ FreeProcessGlobalValue( pgvPtr->epoch++; pgvPtr->numBytes = 0; - Tcl_Free(pgvPtr->value); + ckfree(pgvPtr->value); pgvPtr->value = NULL; if (pgvPtr->encoding) { Tcl_FreeEncoding(pgvPtr->encoding); @@ -4137,13 +4334,13 @@ TclSetProcessGlobalValue( pgvPtr->epoch++; if (NULL != pgvPtr->value) { - Tcl_Free(pgvPtr->value); + ckfree(pgvPtr->value); } else { Tcl_CreateExitHandler(FreeProcessGlobalValue, pgvPtr); } bytes = TclGetString(newValue); pgvPtr->numBytes = newValue->length; - pgvPtr->value = (char *)Tcl_Alloc(pgvPtr->numBytes + 1); + pgvPtr->value = (char *)ckalloc(pgvPtr->numBytes + 1); memcpy(pgvPtr->value, bytes, pgvPtr->numBytes + 1); if (pgvPtr->encoding) { Tcl_FreeEncoding(pgvPtr->encoding); @@ -4201,14 +4398,13 @@ TclGetProcessGlobalValue( Tcl_MutexLock(&pgvPtr->mutex); epoch = ++pgvPtr->epoch; - Tcl_UtfToExternalDStringEx(NULL, pgvPtr->encoding, pgvPtr->value, - pgvPtr->numBytes, TCL_ENCODING_PROFILE_TCL8, &native, NULL); - Tcl_ExternalToUtfDStringEx(NULL, current, Tcl_DStringValue(&native), - Tcl_DStringLength(&native), TCL_ENCODING_PROFILE_TCL8, - &newValue, NULL); + Tcl_UtfToExternalDString(pgvPtr->encoding, pgvPtr->value, + pgvPtr->numBytes, &native); + Tcl_ExternalToUtfDString(current, Tcl_DStringValue(&native), + Tcl_DStringLength(&native), &newValue); Tcl_DStringFree(&native); - Tcl_Free(pgvPtr->value); - pgvPtr->value = (char *)Tcl_Alloc(Tcl_DStringLength(&newValue) + 1); + ckfree(pgvPtr->value); + pgvPtr->value = (char *)ckalloc(Tcl_DStringLength(&newValue) + 1); memcpy(pgvPtr->value, Tcl_DStringValue(&newValue), Tcl_DStringLength(&newValue) + 1); Tcl_DStringFree(&newValue); @@ -4348,6 +4544,31 @@ Tcl_GetNameOfExecutable(void) /* *---------------------------------------------------------------------- * + * TclpGetTime -- + * + * Deprecated synonym for Tcl_GetTime. This function is provided for the + * benefit of extensions written before Tcl_GetTime was exported from the + * library. + * + * Results: + * None. + * + * Side effects: + * Stores current time in the buffer designated by "timePtr" + * + *---------------------------------------------------------------------- + */ + +void +TclpGetTime( + Tcl_Time *timePtr) +{ + Tcl_GetTime(timePtr); +} + +/* + *---------------------------------------------------------------------- + * * TclGetPlatform -- * * This is a kludge that allows the test library to get access the diff --git a/generic/tclVar.c b/generic/tclVar.c index 41bfa39..8deb2b7 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -128,8 +128,6 @@ static const char BADNAMESPACE[] = "parent namespace doesn't exist"; static const char MISSINGNAME[] = "missing variable name"; static const char ISARRAYELEMENT[] = "name refers to an element in an array"; -static const char ISCONST[] = "variable is a constant"; -static const char EXISTS[] = "variable already exists"; /* * A test to see if we are in a call frame that has local variables. This is @@ -180,8 +178,7 @@ typedef struct ArrayVarHashTable { */ static void AppendLocals(Tcl_Interp *interp, Tcl_Obj *listPtr, - Tcl_Obj *patternPtr, int includeLinks, - int justConstants); + Tcl_Obj *patternPtr, int includeLinks); static void ArrayPopulateSearch(Tcl_Interp *interp, Tcl_Obj *arrayNameObj, Var *varPtr, ArraySearch *searchPtr); @@ -248,8 +245,7 @@ static Tcl_DupInternalRepProc DupParsedVarName; static const Tcl_ObjType localVarNameType = { "localVarName", - FreeLocalVarName, DupLocalVarName, NULL, NULL, - TCL_OBJTYPE_V0 + FreeLocalVarName, DupLocalVarName, NULL, NULL }; #define LocalSetInternalRep(objPtr, index, namePtr) \ @@ -272,8 +268,7 @@ static const Tcl_ObjType localVarNameType = { static const Tcl_ObjType parsedVarNameType = { "parsedVarName", - FreeParsedVarName, DupParsedVarName, NULL, NULL, - TCL_OBJTYPE_V0 + FreeParsedVarName, DupParsedVarName, NULL, NULL }; #define ParsedSetInternalRep(objPtr, arrayPtr, elem) \ @@ -384,7 +379,7 @@ CleanupVar( && (VarHashRefCount(varPtr) == (Tcl_Size) !TclIsVarDeadHash(varPtr))) { if (VarHashRefCount(varPtr) == 0) { - Tcl_Free(varPtr); + ckfree(varPtr); } else { VarHashDeleteEntry(varPtr); } @@ -394,7 +389,7 @@ CleanupVar( (VarHashRefCount(arrayPtr) == (Tcl_Size) !TclIsVarDeadHash(arrayPtr))) { if (VarHashRefCount(arrayPtr) == 0) { - Tcl_Free(arrayPtr); + ckfree(arrayPtr); } else { VarHashDeleteEntry(arrayPtr); } @@ -914,14 +909,18 @@ TclLookupSimpleVar( const char *tail; int lookGlobal = (flags & TCL_GLOBAL_ONLY) || (cxtNsPtr == iPtr->globalNsPtr) - || ((varName[0] == ':') && (varName[1] == ':')); + || ((*varName == ':') && (*(varName+1) == ':')); if (lookGlobal) { *indexPtr = -1; flags = (flags | TCL_GLOBAL_ONLY) & ~TCL_NAMESPACE_ONLY; } else { - flags = (flags | TCL_NAMESPACE_ONLY); - *indexPtr = -2; + if (flags & TCL_AVOID_RESOLVERS) { + flags = (flags | TCL_NAMESPACE_ONLY); + } + if (flags & TCL_NAMESPACE_ONLY) { + *indexPtr = -2; + } } /* @@ -986,7 +985,7 @@ TclLookupSimpleVar( localNameStr = TclGetStringFromObj(objPtr, &localLen); if ((varLen == localLen) && (varName[0] == localNameStr[0]) - && !memcmp(varName, localNameStr, varLen)) { + && !memcmp(varName, localNameStr, varLen)) { *indexPtr = i; return (Var *) &varFramePtr->compiledLocals[i]; } @@ -996,9 +995,8 @@ TclLookupSimpleVar( tablePtr = varFramePtr->varTablePtr; if (create) { if (tablePtr == NULL) { - tablePtr = (TclVarHashTable *)Tcl_Alloc(sizeof(TclVarHashTable)); + tablePtr = (TclVarHashTable *)ckalloc(sizeof(TclVarHashTable)); TclInitVarHashTable(tablePtr, NULL); - tablePtr->arrayPtr = varPtr; varFramePtr->varTablePtr = tablePtr; } varPtr = VarHashCreateVar(tablePtr, varNamePtr, &isNew); @@ -1145,6 +1143,51 @@ TclLookupArrayElement( /* *---------------------------------------------------------------------- * + * Tcl_GetVar -- + * + * Return the value of a Tcl variable as a string. + * + * Results: + * The return value points to the current value of varName as a string. + * If the variable is not defined or can't be read because of a clash in + * array usage then a NULL pointer is returned and an error message is + * left in the interp's result if the TCL_LEAVE_ERR_MSG flag is set. + * Note: the return value is only valid up until the next change to the + * variable; if you depend on the value lasting longer than that, then + * make yourself a private copy. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +#ifndef TCL_NO_DEPRECATED +#undef Tcl_GetVar +const char * +Tcl_GetVar( + Tcl_Interp *interp, /* Command interpreter in which varName is to + * be looked up. */ + const char *varName, /* Name of a variable in interp. */ + int flags) /* OR-ed combination of TCL_GLOBAL_ONLY, + * TCL_NAMESPACE_ONLY or TCL_LEAVE_ERR_MSG + * bits. */ +{ + Tcl_Obj *varNamePtr = Tcl_NewStringObj(varName, -1); + Tcl_Obj *resultPtr = Tcl_ObjGetVar2(interp, varNamePtr, NULL, flags); + + TclDecrRefCount(varNamePtr); + + if (resultPtr == NULL) { + return NULL; + } + return TclGetString(resultPtr); +} +#endif /* TCL_NO_DEPRECATED */ + +/* + *---------------------------------------------------------------------- + * * Tcl_GetVar2 -- * * Return the value of a Tcl variable as a string, given a two-part name @@ -1390,9 +1433,6 @@ TclPtrGetVarIdx( { Interp *iPtr = (Interp *) interp; const char *msg; - Var *initialArrayPtr = arrayPtr; - - TclVarFindHiddenArray(varPtr, arrayPtr); /* * Invoke any read traces that have been set for the variable. @@ -1439,8 +1479,8 @@ TclPtrGetVarIdx( } if (flags & TCL_LEAVE_ERR_MSG) { - if (TclIsVarUndefined(varPtr) && initialArrayPtr - && !TclIsVarUndefined(initialArrayPtr)) { + if (TclIsVarUndefined(varPtr) && arrayPtr + && !TclIsVarUndefined(arrayPtr)) { msg = NOSUCHELEMENT; } else if (TclIsVarArray(varPtr)) { msg = ISARRAY; @@ -1513,6 +1553,53 @@ Tcl_SetObjCmd( /* *---------------------------------------------------------------------- * + * Tcl_SetVar -- + * + * Change the value of a variable. + * + * Results: + * Returns a pointer to the malloc'ed string which is the character + * representation of the variable's new value. The caller must not modify + * this string. If the write operation was disallowed then NULL is + * returned; if the TCL_LEAVE_ERR_MSG flag is set, then an explanatory + * message will be left in the interp's result. Note that the returned + * string may not be the same as newValue; this is because variable + * traces may modify the variable's value. + * + * Side effects: + * If varName is defined as a local or global variable in interp, its + * value is changed to newValue. If varName isn't currently defined, then + * a new global variable by that name is created. + * + *---------------------------------------------------------------------- + */ + +#ifndef TCL_NO_DEPRECATED +#undef Tcl_SetVar +const char * +Tcl_SetVar( + Tcl_Interp *interp, /* Command interpreter in which varName is to + * be looked up. */ + const char *varName, /* Name of a variable in interp. */ + const char *newValue, /* New value for varName. */ + int flags) /* Various flags that tell how to set value: + * any of TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, + * TCL_APPEND_VALUE, TCL_LIST_ELEMENT, + * TCL_LEAVE_ERR_MSG. */ +{ + Tcl_Obj *varValuePtr = Tcl_SetVar2Ex(interp, varName, NULL, + Tcl_NewStringObj(newValue, -1), flags); + + if (varValuePtr == NULL) { + return NULL; + } + return TclGetString(varValuePtr); +} +#endif /* TCL_NO_DEPRECATED */ + +/* + *---------------------------------------------------------------------- + * * Tcl_SetVar2 -- * * Given a two-part variable name, which may refer either to a scalar @@ -1945,17 +2032,6 @@ TclPtrSetVarIdx( } /* - * It's an error to try to set a constant. - */ - if (TclIsVarConstant(varPtr)) { - if (flags & TCL_LEAVE_ERR_MSG) { - TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "set", ISCONST,index); - Tcl_SetErrorCode(interp, "TCL", "WRITE", "CONST", (void *)NULL); - } - goto earlyError; - } - - /* * It's an error to try to set an array variable itself. */ @@ -1967,8 +2043,6 @@ TclPtrSetVarIdx( goto earlyError; } - TclVarFindHiddenArray(varPtr, arrayPtr); - /* * Invoke any read traces that have been set for the variable if it is * requested. This was done for INST_LAPPEND_* but that was inconsistent @@ -2235,17 +2309,6 @@ TclPtrIncrObjVarIdx( { Tcl_Obj *varValuePtr; - /* - * It's an error to try to increment a constant. - */ - if (TclIsVarConstant(varPtr)) { - if (flags & TCL_LEAVE_ERR_MSG) { - TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "incr", ISCONST,index); - Tcl_SetErrorCode(interp, "TCL", "WRITE", "CONST", (void *)NULL); - } - return NULL; - } - if (TclIsVarInHash(varPtr)) { VarHashRefCount(varPtr)++; } @@ -2289,6 +2352,57 @@ TclPtrIncrObjVarIdx( /* *---------------------------------------------------------------------- * + * Tcl_UnsetVar -- + * + * Delete a variable, so that it may not be accessed anymore. + * + * Results: + * Returns TCL_OK if the variable was successfully deleted, TCL_ERROR if + * the variable can't be unset. In the event of an error, if the + * TCL_LEAVE_ERR_MSG flag is set then an error message is left in the + * interp's result. + * + * Side effects: + * If varName is defined as a local or global variable in interp, it is + * deleted. + * + *---------------------------------------------------------------------- + */ + +#ifndef TCL_NO_DEPRECATED +#undef Tcl_UnsetVar +int +Tcl_UnsetVar( + Tcl_Interp *interp, /* Command interpreter in which varName is to + * be looked up. */ + const char *varName, /* Name of a variable in interp. May be either + * a scalar name or an array name or an + * element in an array. */ + int flags) /* OR-ed combination of any of + * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY or + * TCL_LEAVE_ERR_MSG. */ +{ + int result; + Tcl_Obj *varNamePtr; + + varNamePtr = Tcl_NewStringObj(varName, -1); + Tcl_IncrRefCount(varNamePtr); + + /* + * Filter to pass through only the flags this interface supports. + */ + + flags &= (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|TCL_LEAVE_ERR_MSG); + result = TclObjUnsetVar2(interp, varNamePtr, NULL, flags); + + Tcl_DecrRefCount(varNamePtr); + return result; +} +#endif /* TCL_NO_DEPRECATED */ + +/* + *---------------------------------------------------------------------- + * * Tcl_UnsetVar2 -- * * Delete a variable, given a 2-part name. @@ -2454,14 +2568,14 @@ int TclPtrUnsetVarIdx( Tcl_Interp *interp, /* Command interpreter in which varName is to * be looked up. */ - Var *varPtr, /* The variable to be unset. */ + Var *varPtr, /* The variable to be unset. */ Var *arrayPtr, /* NULL for scalar variables, pointer to the * containing array otherwise. */ Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or * the name of a variable. */ Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element * in the array part1. */ - int flags, /* OR-ed combination of any of + int flags, /* OR-ed combination of any of * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * TCL_LEAVE_ERR_MSG. */ int index) /* Index into the local variable table of the @@ -2470,18 +2584,6 @@ TclPtrUnsetVarIdx( { Interp *iPtr = (Interp *) interp; int result = (TclIsVarUndefined(varPtr)? TCL_ERROR : TCL_OK); - Var *initialArrayPtr = arrayPtr; - - /* - * It's an error to try to unset a constant. - */ - if (TclIsVarConstant(varPtr)) { - if (flags & TCL_LEAVE_ERR_MSG) { - TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "unset", ISCONST,index); - Tcl_SetErrorCode(interp, "TCL", "UNSET", "CONST", (void *)NULL); - } - return TCL_ERROR; - } /* * Keep the variable alive until we're done with it. We used to @@ -2494,8 +2596,6 @@ TclPtrUnsetVarIdx( VarHashRefCount(varPtr)++; } - TclVarFindHiddenArray(varPtr, arrayPtr); - UnsetVarStruct(varPtr, arrayPtr, iPtr, part1Ptr, part2Ptr, flags, index); /* @@ -2505,7 +2605,7 @@ TclPtrUnsetVarIdx( if (result != TCL_OK) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "unset", - ((initialArrayPtr == NULL) ? NOSUCHVAR : NOSUCHELEMENT), index); + ((arrayPtr == NULL) ? NOSUCHVAR : NOSUCHELEMENT), index); Tcl_SetErrorCode(interp, "TCL", "UNSET", "VARNAME", (char *)NULL); } } @@ -2613,23 +2713,9 @@ UnsetVarStruct( if ((dummyVar.flags & VAR_TRACED_UNSET) || (arrayPtr && (arrayPtr->flags & VAR_TRACED_UNSET))) { - - /* - * Pass the array element name to TclObjCallVarTraces(), because - * it cannot be determined from dummyVar. Alternatively, indicate - * via flags whether the variable involved in the code that caused - * the trace to be triggered was an array element, for the correct - * formatting of error messages. - */ - if (part2Ptr) { - flags |= VAR_ARRAY_ELEMENT; - } else if (TclIsVarArrayElement(varPtr)) { - part2Ptr = VarHashGetKey(varPtr); - } - dummyVar.flags &= ~VAR_TRACE_ACTIVE; TclObjCallVarTraces(iPtr, arrayPtr, &dummyVar, part1Ptr, part2Ptr, - (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY|VAR_ARRAY_ELEMENT)) + (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_UNSETS, /* leaveErrMsg */ 0, index); @@ -3127,7 +3213,7 @@ ArrayForNRCmd( * Make a new array search, put it on the stack. */ - searchPtr = (ArraySearch *)Tcl_Alloc(sizeof(ArraySearch)); + searchPtr = (ArraySearch *)ckalloc(sizeof(ArraySearch)); ArrayPopulateSearch(interp, arrayNameObj, varPtr, searchPtr); /* @@ -3135,7 +3221,8 @@ ArrayForNRCmd( * loop) don't vanish. */ - varListObj = TclListObjCopy(NULL, objv[1]); + /* Do not use TclListObjCopy here - shimmers arithseries to list */ + varListObj = Tcl_DuplicateObj(objv[1]); if (!varListObj) { return TCL_ERROR; } @@ -3255,7 +3342,7 @@ ArrayForLoopCallback( ArrayDoneSearch(iPtr, varPtr, searchPtr); Tcl_DecrRefCount(searchPtr->name); - Tcl_Free(searchPtr); + ckfree(searchPtr); } TclDecrRefCount(varListObj); @@ -3341,7 +3428,7 @@ ArrayStartSearchCmd( * Make a new array search with a free name. */ - searchPtr = (ArraySearch *)Tcl_Alloc(sizeof(ArraySearch)); + searchPtr = (ArraySearch *)ckalloc(sizeof(ArraySearch)); ArrayPopulateSearch(interp, objv[1], varPtr, searchPtr); Tcl_SetObjResult(interp, searchPtr->name); return TCL_OK; @@ -3605,7 +3692,7 @@ ArrayDoneSearchCmd( ArrayDoneSearch(iPtr, varPtr, searchPtr); Tcl_DecrRefCount(searchPtr->name); - Tcl_Free(searchPtr); + ckfree(searchPtr); return TCL_OK; } @@ -3836,12 +3923,12 @@ ArrayNamesCmd( static const char *const options[] = { "-exact", "-glob", "-regexp", NULL }; - enum arrayNamesOptionsEnum {OPT_EXACT, OPT_GLOB, OPT_REGEXP} mode = OPT_GLOB; + enum arrayNamesOptionsEnum { OPT_EXACT, OPT_GLOB, OPT_REGEXP }; Var *varPtr, *varPtr2; Tcl_Obj *nameObj, *resultObj, *patternObj; Tcl_HashSearch search; const char *pattern = NULL; - int isArray; + int isArray, mode = OPT_GLOB; if ((objc < 2) || (objc > 4)) { Tcl_WrongNumArgs(interp, 1, objv, "arrayName ?mode? ?pattern?"); @@ -3904,7 +3991,7 @@ ArrayNamesCmd( const char *name = TclGetString(nameObj); int matched = 0; - switch (mode) { + switch ((enum arrayNamesOptionsEnum) mode) { case OPT_EXACT: Tcl_Panic("exact matching shouldn't get here"); case OPT_GLOB: @@ -3971,7 +4058,7 @@ TclFindArrayPtrElements( continue; } nameObj = VarHashGetKey(varPtr); - hPtr = Tcl_CreateHashEntry(tablePtr, nameObj, &dummy); + hPtr = Tcl_CreateHashEntry(tablePtr, (char *) nameObj, &dummy); Tcl_SetHashValue(hPtr, nameObj); } } @@ -4038,12 +4125,11 @@ ArraySetCmd( Tcl_Obj *keyPtr, *valuePtr; Tcl_DictSearch search; int done; - Tcl_Size size; - if (Tcl_DictObjSize(interp, arrayElemObj, &size) != TCL_OK) { + if (Tcl_DictObjSize(interp, arrayElemObj, &done) != TCL_OK) { return TCL_ERROR; } - if (size == 0) { + if (done == 0) { /* * Empty, so we'll just force the array to be properly existing * instead. @@ -4269,7 +4355,7 @@ ArrayStatsCmd( return TCL_ERROR; } Tcl_SetObjResult(interp, Tcl_NewStringObj(stats, -1)); - Tcl_Free(stats); + ckfree(stats); return TCL_OK; } @@ -4727,6 +4813,63 @@ TclPtrObjMakeUpvarIdx( /* *---------------------------------------------------------------------- * + * Tcl_UpVar -- + * + * This function links one variable to another, just like the "upvar" + * command. + * + * Results: + * A standard Tcl completion code. If an error occurs then an error + * message is left in the interp's result. + * + * Side effects: + * The variable in frameName whose name is given by varName becomes + * accessible under the name localNameStr, so that references to + * localNameStr are redirected to the other variable like a symbolic + * link. + * + *---------------------------------------------------------------------- + */ + +#ifndef TCL_NO_DEPRECATED +#undef Tcl_UpVar +int +Tcl_UpVar( + Tcl_Interp *interp, /* Command interpreter in which varName is to + * be looked up. */ + const char *frameName, /* Name of the frame containing the source + * variable, such as "1" or "#0". */ + const char *varName, /* Name of a variable in interp to link to. + * May be either a scalar name or an element + * in an array. */ + const char *localNameStr, /* Name of link variable. */ + int flags) /* 0, TCL_GLOBAL_ONLY or TCL_NAMESPACE_ONLY: + * indicates scope of localNameStr. */ +{ + int result; + CallFrame *framePtr; + Tcl_Obj *varNamePtr, *localNamePtr; + + if (TclGetFrame(interp, frameName, &framePtr) == -1) { + return TCL_ERROR; + } + + varNamePtr = Tcl_NewStringObj(varName, -1); + Tcl_IncrRefCount(varNamePtr); + localNamePtr = Tcl_NewStringObj(localNameStr, -1); + Tcl_IncrRefCount(localNamePtr); + + result = ObjMakeUpvar(interp, framePtr, varNamePtr, NULL, 0, + localNamePtr, flags, -1); + Tcl_DecrRefCount(varNamePtr); + Tcl_DecrRefCount(localNamePtr); + return result; +} +#endif /* TCL_NO_DEPRECATED */ + +/* + *---------------------------------------------------------------------- + * * Tcl_UpVar2 -- * * This function links one variable to another, just like the "upvar" @@ -4834,7 +4977,7 @@ Tcl_GetVariableFullName( } else if (iPtr->varFramePtr->procPtr) { Tcl_Size index = varPtr - iPtr->varFramePtr->compiledLocals; - if (index < iPtr->varFramePtr->numCompiledLocals) { + if (index >= 0 && index < iPtr->varFramePtr->numCompiledLocals) { namePtr = localName(iPtr->varFramePtr, index); Tcl_AppendObjToObj(objPtr, namePtr); } @@ -4844,81 +4987,6 @@ Tcl_GetVariableFullName( /* *---------------------------------------------------------------------- * - * Tcl_ConstObjCmd -- - * - * This function is invoked to process the "const" Tcl command. - * See the user documentation for details on what it does. - * - * Results: - * A standard Tcl object result value. - * - * Side effects: - * See the user documentation. - * - *---------------------------------------------------------------------- - */ - -int -Tcl_ConstObjCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Var *varPtr, *arrayPtr; - Tcl_Obj *part1Ptr; - - if (objc != 3) { - Tcl_WrongNumArgs(interp, 1, objv, "varName value"); - return TCL_ERROR; - } - - part1Ptr = objv[1]; - varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, TCL_LEAVE_ERR_MSG, - "const", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr); - if (TclIsVarArray(varPtr)) { - TclObjVarErrMsg(interp, part1Ptr, NULL, "make constant", ISARRAY, -1); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONST", (void *)NULL); - return TCL_ERROR; - } - if (TclIsVarArrayElement(varPtr)) { - if (TclIsVarUndefined(varPtr)) { - CleanupVar(varPtr, arrayPtr); - } - TclObjVarErrMsg(interp, part1Ptr, NULL, "make constant", ISARRAYELEMENT, -1); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONST", (void *)NULL); - return TCL_ERROR; - } - - /* - * If already exists, either a constant (no problem) or an error. - */ - if (!TclIsVarUndefined(varPtr)) { - if (TclIsVarConstant(varPtr)) { - return TCL_OK; - } - TclObjVarErrMsg(interp, part1Ptr, NULL, "make constant", EXISTS, -1); - Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONST", (void *)NULL); - return TCL_ERROR; - } - - /* - * Make the variable and flag it as a constant. - */ - if (TclPtrSetVar(interp, (Tcl_Var) varPtr, NULL, objv[1], NULL, - objv[2], TCL_LEAVE_ERR_MSG) == NULL) { - if (TclIsVarUndefined(varPtr)) { - CleanupVar(varPtr, arrayPtr); - } - return TCL_ERROR; - }; - TclSetVarConstant(varPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * * Tcl_GlobalObjCmd -- * * This object-based function is invoked to process the "global" Tcl @@ -4971,7 +5039,7 @@ Tcl_GlobalObjCmd( for (tail=varName ; *tail!='\0' ; tail++) { /* empty body */ } - while ((tail > varName) && ((tail[0] != ':') || (tail[-1] != ':'))) { + while ((tail > varName) && ((*tail != ':') || (*(tail-1) != ':'))) { tail--; } if ((*tail == ':') && (tail > varName)) { @@ -5349,7 +5417,7 @@ DeleteSearches( searchPtr = nextPtr) { nextPtr = searchPtr->nextPtr; Tcl_DecrRefCount(searchPtr->name); - Tcl_Free(searchPtr); + ckfree(searchPtr); } arrayVarPtr->flags &= ~VAR_SEARCH_ACTIVE; Tcl_DeleteHashEntry(sPtr); @@ -5496,7 +5564,7 @@ TclDeleteVars( } for (varPtr = VarHashFirstVar(tablePtr, &search); varPtr != NULL; - varPtr = VarHashFirstVar(tablePtr, &search)) { + varPtr = VarHashFirstVar(tablePtr, &search)) { UnsetVarStruct(varPtr, NULL, iPtr, VarHashGetKey(varPtr), NULL, flags, -1); VarHashDeleteEntry(varPtr); @@ -5926,10 +5994,6 @@ ObjFindNamespaceVar( * Find the namespace(s) that contain the variable. */ - if (!(flags & TCL_GLOBAL_ONLY)) { - flags |= TCL_NAMESPACE_ONLY; - } - TclGetNamespaceForQualName(interp, name, (Namespace *) contextNsPtr, flags, &nsPtr[0], &nsPtr[1], &cxtNsPtr, &simpleName); @@ -6146,7 +6210,7 @@ TclInfoVarsCmd( } } } else if (iPtr->varFramePtr->procPtr != NULL) { - AppendLocals(interp, listPtr, simplePatternPtr, 1, 0); + AppendLocals(interp, listPtr, simplePatternPtr, 1); } if (simplePatternPtr) { @@ -6300,201 +6364,7 @@ TclInfoLocalsCmd( */ listPtr = Tcl_NewListObj(0, NULL); - AppendLocals(interp, listPtr, patternPtr, 0, 0); - Tcl_SetObjResult(interp, listPtr); - return TCL_OK; -} - -/* - *---------------------------------------------------------------------- - * - * TclInfoConstsCmd -- - * - * Called to implement the "info consts" command that returns the list of - * constants in the interpreter that match an optional pattern. The - * pattern, if any, consists of an optional sequence of namespace names - * separated by "::" qualifiers, which is followed by a glob-style - * pattern that restricts which variables are returned. Handles the - * following syntax: - * - * info consts ?pattern? - * - * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. - * - * Side effects: - * Returns a result in the interpreter's result object. If there is an - * error, the result is an error message. - * - *---------------------------------------------------------------------- - */ - -int -TclInfoConstsCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Interp *iPtr = (Interp *) interp; - const char *varName, *pattern, *simplePattern; - Tcl_HashSearch search; - Var *varPtr; - Namespace *nsPtr; - Namespace *globalNsPtr = (Namespace *) Tcl_GetGlobalNamespace(interp); - Namespace *currNsPtr = (Namespace *) Tcl_GetCurrentNamespace(interp); - Tcl_Obj *listPtr, *elemObjPtr, *varNamePtr; - int specificNsInPattern = 0;/* Init. to avoid compiler warning. */ - Tcl_Obj *simplePatternPtr = NULL; - - /* - * Get the pattern and find the "effective namespace" in which to list - * variables. We only use this effective namespace if there's no active - * Tcl procedure frame. - */ - - if (objc == 1) { - simplePattern = NULL; - nsPtr = currNsPtr; - specificNsInPattern = 0; - } else if (objc == 2) { - /* - * From the pattern, get the effective namespace and the simple - * pattern (no namespace qualifiers or ::'s) at the end. If an error - * was found while parsing the pattern, return it. Otherwise, if the - * namespace wasn't found, just leave nsPtr NULL: we will return an - * empty list since no variables there can be found. - */ - - Namespace *dummy1NsPtr, *dummy2NsPtr; - - pattern = TclGetString(objv[1]); - TclGetNamespaceForQualName(interp, pattern, NULL, /*flags*/ 0, - &nsPtr, &dummy1NsPtr, &dummy2NsPtr, &simplePattern); - - if (nsPtr != NULL) { /* We successfully found the pattern's ns. */ - specificNsInPattern = (strcmp(simplePattern, pattern) != 0); - if (simplePattern == pattern) { - simplePatternPtr = objv[1]; - } else { - simplePatternPtr = Tcl_NewStringObj(simplePattern, -1); - } - Tcl_IncrRefCount(simplePatternPtr); - } - } else { - Tcl_WrongNumArgs(interp, 1, objv, "?pattern?"); - return TCL_ERROR; - } - - /* - * If the namespace specified in the pattern wasn't found, just return. - */ - - if (nsPtr == NULL) { - return TCL_OK; - } - - listPtr = Tcl_NewListObj(0, NULL); - - if (!HasLocalVars(iPtr->varFramePtr) || specificNsInPattern) { - /* - * There is no frame pointer, the frame pointer was pushed only to - * activate a namespace, or we are in a procedure call frame but a - * specific namespace was specified. Create a list containing only the - * variables in the effective namespace's variable table. - */ - - if (simplePattern && TclMatchIsTrivial(simplePattern)) { - /* - * If we can just do hash lookups, that simplifies things a lot. - */ - - varPtr = VarHashFindVar(&nsPtr->varTable, simplePatternPtr); - if (varPtr && TclIsVarConstant(varPtr)) { - if (!TclIsVarUndefined(varPtr) - || TclIsVarNamespaceVar(varPtr)) { - if (specificNsInPattern) { - TclNewObj(elemObjPtr); - Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, - elemObjPtr); - } else { - elemObjPtr = VarHashGetKey(varPtr); - } - Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); - } - } else if ((nsPtr != globalNsPtr) && !specificNsInPattern) { - varPtr = VarHashFindVar(&globalNsPtr->varTable, - simplePatternPtr); - if (varPtr && TclIsVarConstant(varPtr)) { - if (!TclIsVarUndefined(varPtr) - || TclIsVarNamespaceVar(varPtr)) { - Tcl_ListObjAppendElement(interp, listPtr, - VarHashGetKey(varPtr)); - } - } - } - } else { - /* - * Have to scan the tables of variables. - */ - - varPtr = VarHashFirstVar(&nsPtr->varTable, &search); - while (varPtr) { - if (TclIsVarConstant(varPtr) && (!TclIsVarUndefined(varPtr) - || TclIsVarNamespaceVar(varPtr))) { - varNamePtr = VarHashGetKey(varPtr); - varName = TclGetString(varNamePtr); - if ((simplePattern == NULL) - || Tcl_StringMatch(varName, simplePattern)) { - if (specificNsInPattern) { - TclNewObj(elemObjPtr); - Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, - elemObjPtr); - } else { - elemObjPtr = varNamePtr; - } - Tcl_ListObjAppendElement(interp, listPtr, elemObjPtr); - } - } - varPtr = VarHashNextVar(&search); - } - - /* - * If the effective namespace isn't the global :: namespace, and a - * specific namespace wasn't requested in the pattern (i.e., the - * pattern only specifies variable names), then add in all global - * :: variables that match the simple pattern. Of course, add in - * only those variables that aren't hidden by a variable in the - * effective namespace. - */ - - if ((nsPtr != globalNsPtr) && !specificNsInPattern) { - varPtr = VarHashFirstVar(&globalNsPtr->varTable, &search); - while (varPtr) { - if (TclIsVarConstant(varPtr) && (!TclIsVarUndefined(varPtr) - || TclIsVarNamespaceVar(varPtr))) { - varNamePtr = VarHashGetKey(varPtr); - varName = TclGetString(varNamePtr); - if ((simplePattern == NULL) - || Tcl_StringMatch(varName, simplePattern)) { - if (VarHashFindVar(&nsPtr->varTable, - varNamePtr) == NULL) { - Tcl_ListObjAppendElement(interp, listPtr, - varNamePtr); - } - } - } - varPtr = VarHashNextVar(&search); - } - } - } - } else if (iPtr->varFramePtr->procPtr != NULL) { - AppendLocals(interp, listPtr, simplePatternPtr, 1, 1); - } - - if (simplePatternPtr) { - Tcl_DecrRefCount(simplePatternPtr); - } + AppendLocals(interp, listPtr, patternPtr, 0); Tcl_SetObjResult(interp, listPtr); return TCL_OK; } @@ -6516,31 +6386,12 @@ TclInfoConstsCmd( *---------------------------------------------------------------------- */ -static int -ContextObjectContainsConstant( - Tcl_ObjectContext context, - Tcl_Obj *varNamePtr) -{ - /* - * Helper for AppendLocals to check if an object contains a variable - * that is a constant. It's too complicated without factoring this - * check out! - */ - - Object *oPtr = (Object *) Tcl_ObjectContextObject(context); - Namespace *nsPtr = (Namespace *) oPtr->namespacePtr; - Var *varPtr = VarHashFindVar(&nsPtr->varTable, varNamePtr); - - return !TclIsVarUndefined(varPtr) && TclIsVarConstant(varPtr); -} - static void AppendLocals( Tcl_Interp *interp, /* Current interpreter. */ Tcl_Obj *listPtr, /* List object to append names to. */ Tcl_Obj *patternPtr, /* Pattern to match against. */ - int includeLinks, /* 1 if upvars should be included, else 0. */ - int justConstants) /* 1 if just constants should be included. */ + int includeLinks) /* 1 if upvars should be included, else 0. */ { Interp *iPtr = (Interp *) interp; Var *varPtr; @@ -6569,12 +6420,10 @@ AppendLocals( */ if (*varNamePtr && !TclIsVarUndefined(varPtr) - && (includeLinks || !TclIsVarLink(varPtr))) { + && (includeLinks || !TclIsVarLink(varPtr))) { varName = TclGetString(*varNamePtr); if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { - if (!justConstants || TclIsVarConstant(varPtr)) { - Tcl_ListObjAppendElement(interp, listPtr, *varNamePtr); - } + Tcl_ListObjAppendElement(interp, listPtr, *varNamePtr); if (includeLinks) { Tcl_CreateHashEntry(&addedTable, *varNamePtr, &added); } @@ -6601,10 +6450,8 @@ AppendLocals( if (varPtr != NULL) { if (!TclIsVarUndefined(varPtr) && (includeLinks || !TclIsVarLink(varPtr))) { - if ((!justConstants || TclIsVarConstant(varPtr))) { - Tcl_ListObjAppendElement(interp, listPtr, - VarHashGetKey(varPtr)); - } + Tcl_ListObjAppendElement(interp, listPtr, + VarHashGetKey(varPtr)); if (includeLinks) { Tcl_CreateHashEntry(&addedTable, VarHashGetKey(varPtr), &added); @@ -6626,9 +6473,7 @@ AppendLocals( objNamePtr = VarHashGetKey(varPtr); varName = TclGetString(objNamePtr); if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) { - if (!justConstants || TclIsVarConstant(varPtr)) { - Tcl_ListObjAppendElement(interp, listPtr, objNamePtr); - } + Tcl_ListObjAppendElement(interp, listPtr, objNamePtr); if (includeLinks) { Tcl_CreateHashEntry(&addedTable, objNamePtr, &added); } @@ -6642,9 +6487,8 @@ AppendLocals( } if (iPtr->varFramePtr->isProcCallFrame & FRAME_IS_METHOD) { - Tcl_ObjectContext context = (Tcl_ObjectContext) - iPtr->varFramePtr->clientData; - Method *mPtr = (Method *) Tcl_ObjectContextMethod(context); + Method *mPtr = (Method *) + Tcl_ObjectContextMethod((Tcl_ObjectContext)iPtr->varFramePtr->clientData); PrivateVariableMapping *privatePtr; if (mPtr->declaringObjectPtr) { @@ -6652,10 +6496,6 @@ AppendLocals( FOREACH(objNamePtr, oPtr->variables) { Tcl_CreateHashEntry(&addedTable, objNamePtr, &added); - if (justConstants && !ContextObjectContainsConstant(context, - objNamePtr)) { - continue; - } if (added && (!pattern || Tcl_StringMatch(TclGetString(objNamePtr), pattern))) { Tcl_ListObjAppendElement(interp, listPtr, objNamePtr); @@ -6664,10 +6504,6 @@ AppendLocals( FOREACH_STRUCT(privatePtr, oPtr->privateVariables) { Tcl_CreateHashEntry(&addedTable, privatePtr->variableObj, &added); - if (justConstants && !ContextObjectContainsConstant(context, - privatePtr->fullNameObj)) { - continue; - } if (added && (!pattern || Tcl_StringMatch(TclGetString(privatePtr->variableObj), pattern))) { @@ -6680,10 +6516,6 @@ AppendLocals( FOREACH(objNamePtr, clsPtr->variables) { Tcl_CreateHashEntry(&addedTable, objNamePtr, &added); - if (justConstants && !ContextObjectContainsConstant(context, - objNamePtr)) { - continue; - } if (added && (!pattern || Tcl_StringMatch(TclGetString(objNamePtr), pattern))) { Tcl_ListObjAppendElement(interp, listPtr, objNamePtr); @@ -6692,10 +6524,6 @@ AppendLocals( FOREACH_STRUCT(privatePtr, clsPtr->privateVariables) { Tcl_CreateHashEntry(&addedTable, privatePtr->variableObj, &added); - if (justConstants && !ContextObjectContainsConstant(context, - privatePtr->fullNameObj)) { - continue; - } if (added && (!pattern || Tcl_StringMatch(TclGetString(privatePtr->variableObj), pattern))) { @@ -6709,47 +6537,6 @@ AppendLocals( } /* - *---------------------------------------------------------------------- - * - * TclInfoConstantCmd -- - * - * Called to implement the "info constant" command that tests whether a - * specific variable is a constant. Handles the following syntax: - * - * info constant varName - * - * Results: - * Returns TCL_OK if successful and TCL_ERROR if there is an error. - * - * Side effects: - * Returns a result in the interpreter's result object. If there is an - * error, the result is an error message. - * - *---------------------------------------------------------------------- - */ - -int -TclInfoConstantCmd( - TCL_UNUSED(void *), - Tcl_Interp *interp, /* Current interpreter. */ - int objc, /* Number of arguments. */ - Tcl_Obj *const objv[]) /* Argument objects. */ -{ - Var *varPtr, *arrayPtr; - int result; - - if (objc != 2) { - Tcl_WrongNumArgs(interp, 1, objv, "varName"); - return TCL_ERROR; - } - varPtr = TclObjLookupVar(interp, objv[1], NULL, 0, "lookup", 0, 0, - &arrayPtr); - result = (varPtr && TclIsVarConstant(varPtr)); - Tcl_SetObjResult(interp, Tcl_NewBooleanObj(result)); - return TCL_OK; -} - -/* * Hash table implementation - first, just copy and adapt the obj key stuff */ @@ -6761,7 +6548,6 @@ TclInitVarHashTable( Tcl_InitCustomHashTable(&tablePtr->table, TCL_CUSTOM_TYPE_KEYS, &tclVarHashKeyType); tablePtr->nsPtr = nsPtr; - tablePtr->arrayPtr = NULL; } static Tcl_HashEntry * @@ -6773,7 +6559,7 @@ AllocVarEntry( Tcl_HashEntry *hPtr; Var *varPtr; - varPtr = (Var *)Tcl_Alloc(sizeof(VarInHash)); + varPtr = (Var *)ckalloc(sizeof(VarInHash)); varPtr->flags = VAR_IN_HASHTABLE; varPtr->value.objPtr = NULL; VarHashRefCount(varPtr) = 1; @@ -6795,7 +6581,7 @@ FreeVarEntry( if (TclIsVarUndefined(varPtr) && !TclIsVarTraced(varPtr) && (VarHashRefCount(varPtr) == 1)) { - Tcl_Free(varPtr); + ckfree(varPtr); } else { VarHashInvalidateEntry(varPtr); TclSetVarUndefined(varPtr); @@ -6812,7 +6598,7 @@ CompareVarKeys( Tcl_Obj *objPtr1 = (Tcl_Obj *)keyPtr; Tcl_Obj *objPtr2 = hPtr->key.objPtr; const char *p1, *p2; - size_t l1, l2; + Tcl_Size l1, l2; /* * If the object pointers are the same then they match. @@ -6826,10 +6612,8 @@ CompareVarKeys( * register. */ - p1 = TclGetString(objPtr1); - l1 = objPtr1->length; - p2 = TclGetString(objPtr2); - l2 = objPtr2->length; + p1 = TclGetStringFromObj(objPtr1, &l1); + p2 = TclGetStringFromObj(objPtr2, &l2); /* * Only compare string representations of the same length. @@ -6864,10 +6648,10 @@ ArrayDefaultCmd( static const char *const options[] = { "get", "set", "exists", "unset", NULL }; - enum arrayDefaultOptionsEnum { OPT_GET, OPT_SET, OPT_EXISTS, OPT_UNSET } option; + enum arrayDefaultOptionsEnum { OPT_GET, OPT_SET, OPT_EXISTS, OPT_UNSET }; Tcl_Obj *arrayNameObj, *defaultValueObj; Var *varPtr, *arrayPtr; - int isArray; + int isArray, option; /* * Parse arguments. @@ -6888,7 +6672,7 @@ ArrayDefaultCmd( return TCL_ERROR; } - switch (option) { + switch ((enum arrayDefaultOptionsEnum)option) { case OPT_GET: if (objc != 3) { Tcl_WrongNumArgs(interp, 2, objv, "arrayName"); @@ -7002,7 +6786,7 @@ void TclInitArrayVar( Var *arrayPtr) { - ArrayVarHashTable *tablePtr = (ArrayVarHashTable *)Tcl_Alloc(sizeof(ArrayVarHashTable)); + ArrayVarHashTable *tablePtr = (ArrayVarHashTable *)ckalloc(sizeof(ArrayVarHashTable)); /* * Mark the variable as an array. @@ -7016,7 +6800,6 @@ TclInitArrayVar( arrayPtr->value.tablePtr = (TclVarHashTable *) tablePtr; TclInitVarHashTable(arrayPtr->value.tablePtr, TclGetVarNsPtr(arrayPtr)); - arrayPtr->value.tablePtr->arrayPtr = arrayPtr; /* * Default value initialization. @@ -7047,7 +6830,7 @@ DeleteArrayVar( */ VarHashDeleteTable(arrayPtr->value.tablePtr); - Tcl_Free(tablePtr); + ckfree(tablePtr); } /* diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index 12f0ea0..3b26f78 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -267,11 +267,7 @@ typedef struct ZipChannel { int mode; /* O_WRITE, O_APPEND, O_TRUNC etc.*/ unsigned long keys[3]; /* Key for decryption */ } ZipChannel; - -static inline int -ZipChannelWritable( - ZipChannel *info) -{ +static inline int ZipChannelWritable(ZipChannel *info) { return (info->mode & (O_WRONLY | O_RDWR)) != 0; } @@ -385,6 +381,10 @@ static int ZipChannelClose(void *instanceData, static Tcl_DriverGetHandleProc ZipChannelGetFile; static int ZipChannelRead(void *instanceData, char *buf, int toRead, int *errloc); +#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9) +static int ZipChannelSeek(void *instanceData, long offset, + int mode, int *errloc); +#endif static long long ZipChannelWideSeek(void *instanceData, long long offset, int mode, int *errloc); static void ZipChannelWatchChannel(void *instanceData, @@ -437,10 +437,14 @@ static const Tcl_Filesystem zipfsFilesystem = { static Tcl_ChannelType ZipChannelType = { "zip", /* Type name. */ TCL_CHANNEL_VERSION_5, - NULL, /* Close channel, clean instance data */ + TCL_CLOSE2PROC, /* Close channel, clean instance data */ ZipChannelRead, /* Handle read request */ ZipChannelWrite, /* Handle write request */ +#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9) + ZipChannelSeek, /* Move location of access point, NULL'able */ +#else NULL, /* Move location of access point, NULL'able */ +#endif NULL, /* Set options, NULL'able */ NULL, /* Get options, NULL'able */ ZipChannelWatchChannel, /* Initialize notifier */ @@ -456,6 +460,12 @@ static Tcl_ChannelType ZipChannelType = { }; /* + * Miscellaneous constants. + */ + +#define ERROR_LENGTH ((size_t) -1) + +/* *------------------------------------------------------------------------ * * TclIsZipfsPath -- @@ -471,9 +481,7 @@ static Tcl_ChannelType ZipChannelType = { * *------------------------------------------------------------------------ */ -int -TclIsZipfsPath( - const char *path) +int TclIsZipfsPath (const char *path) { #ifdef _WIN32 return strncmp(path, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN) ? 0 : ZIPFS_VOLUME_LEN; @@ -481,7 +489,7 @@ TclIsZipfsPath( int i; for (i = 0; i < ZIPFS_VOLUME_LEN; ++i) { if (path[i] != ZIPFS_VOLUME[i] && - (path[i] != '\\' || ZIPFS_VOLUME[i] != '/')) { + (path[i] != '\\' || ZIPFS_VOLUME[i] != '/')) { return 0; } } @@ -761,10 +769,10 @@ CountSlashes( * *------------------------------------------------------------------------ */ -static int -IsCryptHeaderValid( - ZipEntry *z, - unsigned char cryptHeader[ZIP_CRYPT_HDR_LEN]) +static int IsCryptHeaderValid( + ZipEntry *z, + unsigned char cryptHeader[ZIP_CRYPT_HDR_LEN] + ) { /* * There are multiple possibilities. The last one or two bytes of the @@ -897,7 +905,8 @@ DecodeZipEntryText( src = (const char *) inputBytes; dst = Tcl_DStringValue(dstPtr); dstLen = dstPtr->spaceAvl - 1; - flags = TCL_ENCODING_START | TCL_ENCODING_END; /* Special flag! */ + flags = TCL_ENCODING_START | TCL_ENCODING_END | + TCL_ENCODING_PROFILE_STRICT; /* Special flag! */ while (1) { int srcRead, dstWrote; @@ -1035,8 +1044,8 @@ NormalizeMountPoint(Tcl_Interp *interp, invalidMountPath: if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "Invalid mount path \"%s\"", mountPath)); + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("Invalid mount path \"%s\"", mountPath)); ZIPFS_ERROR_CODE(interp, "MOUNT_PATH"); } @@ -1100,7 +1109,7 @@ MapPathToZipfs(Tcl_Interp *interp, Tcl_DStringFree(&dsJoin); partsPtr[0] = mountPath; (void)Tcl_JoinPath(numParts, partsPtr, &dsJoin); - Tcl_Free(partsPtr); + ckfree(partsPtr); } unnormalizedObj = Tcl_DStringToObj(&dsJoin); /* Also resets dsJoin */ Tcl_IncrRefCount(unnormalizedObj); @@ -1205,9 +1214,7 @@ ZipFSLookupZip( *------------------------------------------------------------------------ */ static int -ContainsMountPoint( - const char *path, - int pathLen) +ContainsMountPoint (const char *path, int pathLen) { Tcl_HashEntry *hPtr; Tcl_HashSearch search; @@ -1215,16 +1222,15 @@ ContainsMountPoint( if (ZipFS.zipHash.numEntries == 0) { return 0; } - if (pathLen < 0) { + if (pathLen < 0) pathLen = strlen(path); - } /* * We are looking for the case where the path is //zipfs:/a/b * and there is a mount point //zipfs:/a/b/c/.. below it */ for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr; - hPtr = Tcl_NextHashEntry(&search)) { + hPtr = Tcl_NextHashEntry(&search)) { ZipFile *zf = (ZipFile *) Tcl_GetHashValue(hPtr); if (zf->mountPointLen == 0) { @@ -1238,8 +1244,8 @@ ContainsMountPoint( for (z = zf->topEnts; z; z = z->tnext) { int lenz = (int) strlen(z->name); if ((lenz >= pathLen) && - (z->name[pathLen] == '/' || z->name[pathLen] == '\0') && - (strncmp(z->name, path, pathLen) == 0)) { + (z->name[pathLen] == '/' || z->name[pathLen] == '\0') && + (strncmp(z->name, path, pathLen) == 0)) { return 1; } } @@ -1280,7 +1286,7 @@ AllocateZipFile( size_t mountPointNameLength) { size_t size = sizeof(ZipFile) + mountPointNameLength + 1; - ZipFile *zf = (ZipFile *) Tcl_AttemptAlloc(size); + ZipFile *zf = (ZipFile *) attemptckalloc(size); if (!zf) { ZIPFS_MEM_ERROR(interp); @@ -1293,7 +1299,7 @@ AllocateZipFile( static inline ZipEntry * AllocateZipEntry(void) { - ZipEntry *z = (ZipEntry *) Tcl_Alloc(sizeof(ZipEntry)); + ZipEntry *z = (ZipEntry *) ckalloc(sizeof(ZipEntry)); memset(z, 0, sizeof(ZipEntry)); return z; } @@ -1302,7 +1308,7 @@ static inline ZipChannel * AllocateZipChannel( Tcl_Interp *interp) { - ZipChannel *zc = (ZipChannel *) Tcl_AttemptAlloc(sizeof(ZipChannel)); + ZipChannel *zc = (ZipChannel *) attemptckalloc(sizeof(ZipChannel)); if (!zc) { ZIPFS_MEM_ERROR(interp); @@ -1335,12 +1341,12 @@ ZipFSCloseArchive( ZipFile *zf) { if (zf->nameLength) { - Tcl_Free(zf->name); + ckfree(zf->name); } if (zf->isMemBuffer) { /* Pointer to memory */ if (zf->ptrToFree) { - Tcl_Free(zf->ptrToFree); + ckfree(zf->ptrToFree); zf->ptrToFree = NULL; } zf->data = NULL; @@ -1367,7 +1373,7 @@ ZipFSCloseArchive( #endif /* _WIN32 */ if (zf->ptrToFree) { - Tcl_Free(zf->ptrToFree); + ckfree(zf->ptrToFree); zf->ptrToFree = NULL; } if (zf->chan) { @@ -1486,7 +1492,7 @@ ZipFSFindTOC( * the EOCD. Note this automatically means cdirZipOffset+cdirSize < zf->length. */ if (!(cdirZipOffset <= (size_t)eocdDataOffset && - cdirSize <= eocdDataOffset - cdirZipOffset)) { + cdirSize <= eocdDataOffset - cdirZipOffset)) { if (!needZip) { /* Simply point to end od data */ zf->directoryOffset = zf->baseOffset = zf->passOffset = zf->length; @@ -1534,7 +1540,7 @@ ZipFSFindTOC( size_t localhdr_off = ZipReadInt(start, end, dirEntry + ZIP_CENTRAL_LOCALHDR_OFFS); const unsigned char *localP = zf->data + zf->baseOffset + localhdr_off; if (localP > (cdirStart - ZIP_LOCAL_HEADER_LEN) || - ZipReadInt(start, end, localP) != ZIP_LOCAL_HEADER_SIG) { + ZipReadInt(start, end, localP) != ZIP_LOCAL_HEADER_SIG) { ZIPFS_ERROR(interp, "Failed to find local header"); ZIPFS_ERROR_CODE(interp, "LCL_HDR"); goto error; @@ -1653,14 +1659,14 @@ ZipFSOpenArchive( */ zf->length = Tcl_Seek(zf->chan, 0, SEEK_END); - if (zf->length == (size_t) TCL_INDEX_NONE) { + if (zf->length == ERROR_LENGTH) { ZIPFS_POSIX_ERROR(interp, "seek error"); goto error; } /* What's the magic about 64 * 1024 * 1024 ? */ if ((zf->length <= ZIP_CENTRAL_END_LEN) || - (zf->length - ZIP_CENTRAL_END_LEN) > - (64 * 1024 * 1024 - ZIP_CENTRAL_END_LEN)) { + (zf->length - ZIP_CENTRAL_END_LEN) > + (64 * 1024 * 1024 - ZIP_CENTRAL_END_LEN)) { ZIPFS_ERROR(interp, "illegal file size"); ZIPFS_ERROR_CODE(interp, "FILE_SIZE"); goto error; @@ -1669,7 +1675,7 @@ ZipFSOpenArchive( ZIPFS_POSIX_ERROR(interp, "seek error"); goto error; } - zf->ptrToFree = zf->data = (unsigned char *) Tcl_AttemptAlloc(zf->length); + zf->ptrToFree = zf->data = (unsigned char *) attemptckalloc(zf->length); if (!zf->ptrToFree) { ZIPFS_MEM_ERROR(interp); goto error; @@ -1768,7 +1774,7 @@ ZipMapArchive( */ zf->length = lseek(fd, 0, SEEK_END); - if (zf->length == (size_t)-1) { + if (zf->length == ERROR_LENGTH) { ZIPFS_POSIX_ERROR(interp, "failed to retrieve file size"); return TCL_ERROR; } @@ -1865,7 +1871,7 @@ ZipFSCatalogFilesystem( pwlen = strlen(passwd); if (IsPasswordValid(interp, passwd, pwlen) != TCL_OK) { ZipFSCloseArchive(interp, zf); - Tcl_Free(zf); + ckfree(zf); return TCL_ERROR; } } @@ -1879,7 +1885,7 @@ ZipFSCatalogFilesystem( ZIPFS_ERROR(interp, "bad zip data"); ZIPFS_ERROR_CODE(interp, "BAD_ZIP"); ZipFSCloseArchive(interp, zf); - Tcl_Free(zf); + ckfree(zf); return TCL_ERROR; } @@ -1896,7 +1902,7 @@ ZipFSCatalogFilesystem( Unlock(); ZipFSCloseArchive(interp, zf); Tcl_DStringFree(&ds); - Tcl_Free(zf); + ckfree(zf); return TCL_ERROR; } @@ -1908,7 +1914,7 @@ ZipFSCatalogFilesystem( zf->mountPointLen = strlen(zf->mountPoint); zf->nameLength = strlen(zipname); - zf->name = (char *) Tcl_Alloc(zf->nameLength + 1); + zf->name = (char *) ckalloc(zf->nameLength + 1); memcpy(zf->name, zipname, zf->nameLength + 1); Tcl_SetHashValue(hPtr, zf); @@ -2056,7 +2062,7 @@ ZipFSCatalogFilesystem( hPtr = Tcl_CreateHashEntry(&ZipFS.fileHash, fullpath, &isNew); if (!isNew) { /* should not happen but skip it anyway */ - Tcl_Free(z); + ckfree(z); goto nextent; } @@ -2154,7 +2160,7 @@ ZipfsSetup(void) ZipFS.idCount = 1; ZipFS.wrmax = DEFAULT_WRITE_MAX_SIZE; ZipFS.fallbackEntryEncoding = (char *) - Tcl_Alloc(strlen(ZIPFS_FALLBACK_ENCODING) + 1); + ckalloc(strlen(ZIPFS_FALLBACK_ENCODING) + 1); strcpy(ZipFS.fallbackEntryEncoding, ZIPFS_FALLBACK_ENCODING); ZipFS.initialized = 1; } @@ -2238,9 +2244,9 @@ CleanupMount(ZipFile *zf) /* Mount point */ Tcl_DeleteHashEntry(hPtr); } if (z->data) { - Tcl_Free(z->data); + ckfree(z->data); } - Tcl_Free(z); + ckfree(z); } zf->entries = NULL; } @@ -2353,24 +2359,27 @@ TclZipfs_Mount( Tcl_IncrRefCount(zipPathObj); normZipPathObj = Tcl_FSGetNormalizedPath(interp, zipPathObj); if (normZipPathObj == NULL) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "could not normalize zip filename \"%s\"", zipname)); + Tcl_SetObjResult( + interp, + Tcl_ObjPrintf("could not normalize zip filename \"%s\"", zipname)); Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NORMALIZE", (char *)NULL); ret = TCL_ERROR; } else { Tcl_IncrRefCount(normZipPathObj); - const char *normPath = Tcl_GetString(normZipPathObj); + const char *normPath = TclGetString(normZipPathObj); if (passwd == NULL || - (ret = IsPasswordValid(interp, passwd, - strlen(passwd))) == TCL_OK) { + (ret = IsPasswordValid(interp, passwd, strlen(passwd))) == + TCL_OK) { zf = AllocateZipFile(interp, strlen(mountPoint)); if (zf == NULL) { ret = TCL_ERROR; - } else { + } + else { ret = ZipFSOpenArchive(interp, normPath, 1, zf); if (ret != TCL_OK) { - Tcl_Free(zf); - } else { + ckfree(zf); + } + else { ret = ZipFSCatalogFilesystem( interp, zf, mountPoint, passwd, normPath); /* Note zf is already freed on error! */ @@ -2446,8 +2455,8 @@ TclZipfs_MountBuffer( */ ret = TCL_ERROR; if ((datalen <= ZIP_CENTRAL_END_LEN) || - (datalen - ZIP_CENTRAL_END_LEN) > - (64 * 1024 * 1024 - ZIP_CENTRAL_END_LEN)) { + (datalen - ZIP_CENTRAL_END_LEN) > + (64 * 1024 * 1024 - ZIP_CENTRAL_END_LEN)) { ZIPFS_ERROR(interp, "illegal file size"); ZIPFS_ERROR_CODE(interp, "FILE_SIZE"); goto done; @@ -2460,23 +2469,25 @@ TclZipfs_MountBuffer( zf->length = datalen; if (copy) { - zf->data = (unsigned char *)Tcl_AttemptAlloc(datalen); + zf->data = (unsigned char *)attemptckalloc(datalen); if (zf->data == NULL) { ZipFSCloseArchive(interp, zf); - Tcl_Free(zf); + ckfree(zf); ZIPFS_MEM_ERROR(interp); goto done; } memcpy(zf->data, data, datalen); zf->ptrToFree = zf->data; - } else { + } + else { zf->data = (unsigned char *)data; zf->ptrToFree = NULL; } ret = ZipFSFindTOC(interp, 1, zf); if (ret != TCL_OK) { - Tcl_Free(zf); - } else { + ckfree(zf); + } + else { /* Note ZipFSCatalogFilesystem will free zf on error */ ret = ZipFSCatalogFilesystem( interp, zf, mountPoint, NULL, "Memory Buffer"); @@ -2556,7 +2567,7 @@ TclZipfs_Unmount( CleanupMount(zf); ZipFSCloseArchive(interp, zf); - Tcl_Free(zf); + ckfree(zf); unmounted = 1; done: @@ -2605,13 +2616,13 @@ ZipFSMountObjCmd( */ if (objc > 1) { if (objc == 2) { - mountPoint = Tcl_GetString(objv[1]); + mountPoint = TclGetString(objv[1]); } else { /* 2 < objc < 4 */ - zipFile = Tcl_GetString(objv[1]); - mountPoint = Tcl_GetString(objv[2]); + zipFile = TclGetString(objv[1]); + mountPoint = TclGetString(objv[2]); if (objc > 3) { - password = Tcl_GetString(objv[3]); + password = TclGetString(objv[3]); } } } @@ -2652,7 +2663,7 @@ ZipFSMountBufferObjCmd( return TCL_ERROR; } data = Tcl_GetBytesFromObj(interp, objv[1], &length); - mountPoint = Tcl_GetString(objv[2]); + mountPoint = TclGetString(objv[2]); if (data == NULL) { return TCL_ERROR; } @@ -2762,7 +2773,7 @@ ZipFSMkKeyObjCmd( } passObj = Tcl_NewByteArrayObj(NULL, 264); - passBuf = Tcl_GetBytesFromObj(NULL, passObj, (Tcl_Size *)NULL); + passBuf = Tcl_GetByteArrayFromObj(passObj, (Tcl_Size *)NULL); while (len > 0) { int ch = pw[len - 1]; @@ -2869,8 +2880,7 @@ ZipAddFile( * UTF-8). */ const char *zpathTcl; /* Filename in Tcl's internal encoding. */ int crc, flush, zpathlen; - size_t nbyte, nbytecompr; - Tcl_Size len, olen, align = 0; + size_t nbyte, nbytecompr, len, olen, align = 0; long long headerStartOffset, dataStartOffset, dataEndOffset; int mtime = 0, isNew, compMeth; unsigned long keys[3], keys0[3]; @@ -2894,11 +2904,7 @@ ZipAddFile( * crazy enough to embed NULs in filenames, they deserve what they get! */ - if (Tcl_UtfToExternalDStringEx(interp, tclUtf8Encoding, zpathTcl, TCL_INDEX_NONE, 0, &zpathDs, NULL) != TCL_OK) { - Tcl_DStringFree(&zpathDs); - return TCL_ERROR; - } - zpathExt = Tcl_DStringValue(&zpathDs); + zpathExt = Tcl_UtfToExternalDString(tclUtf8Encoding, zpathTcl, -1, &zpathDs); zpathlen = strlen(zpathExt); if (zpathlen + ZIP_CENTRAL_HEADER_LEN > bufsize) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( @@ -2936,7 +2942,7 @@ ZipAddFile( nbyte = nbytecompr = 0; while (1) { len = Tcl_Read(in, buf, bufsize); - if (len < 0) { + if (len == ERROR_LENGTH) { Tcl_DStringFree(&zpathDs); if (nbyte == 0 && errno == EISDIR) { Tcl_Close(interp, in); @@ -2977,7 +2983,7 @@ ZipAddFile( memset(buf, '\0', ZIP_LOCAL_HEADER_LEN); memcpy(buf + ZIP_LOCAL_HEADER_LEN, zpathExt, zpathlen); len = zpathlen + ZIP_LOCAL_HEADER_LEN; - if (Tcl_Write(out, buf, len) != len) { + if ((size_t) Tcl_Write(out, buf, len) != len) { writeErrorWithChannelOpen: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "write error on \"%s\": %s", @@ -3001,7 +3007,7 @@ ZipAddFile( ZipWriteShort(astart, aend, abuf, 0xffff); ZipWriteShort(astart, aend, abuf + 2, align - 4); ZipWriteInt(astart, aend, abuf + 4, 0x03020100); - if (Tcl_Write(out, (const char *) abuf, align) != align) { + if ((size_t) Tcl_Write(out, (const char *) abuf, align) != align) { goto writeErrorWithChannelOpen; } } @@ -3066,7 +3072,7 @@ ZipAddFile( do { len = Tcl_Read(in, buf, bufsize); - if (len < 0) { + if (len == ERROR_LENGTH) { deflateEnd(&stream); goto readErrorWithChannelOpen; } @@ -3077,7 +3083,7 @@ ZipAddFile( stream.avail_out = sizeof(obuf); stream.next_out = (unsigned char *) obuf; len = deflate(&stream, flush); - if (len == Z_STREAM_ERROR) { + if (len == (size_t) Z_STREAM_ERROR) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "deflate error on \"%s\"", TclGetString(pathObj))); ZIPFS_ERROR_CODE(interp, "DEFLATE"); @@ -3088,14 +3094,14 @@ ZipAddFile( } olen = sizeof(obuf) - stream.avail_out; if (passwd) { - Tcl_Size i; + size_t i; int tmp; for (i = 0; i < olen; i++) { obuf[i] = (char) zencode(keys, crc32tab, obuf[i], tmp); } } - if (olen && (Tcl_Write(out, obuf, olen) != olen)) { + if (olen && ((size_t) Tcl_Write(out, obuf, olen) != olen)) { deflateEnd(&stream); goto writeErrorWithChannelOpen; } @@ -3130,20 +3136,20 @@ ZipAddFile( nbytecompr = (passwd ? ZIP_CRYPT_HDR_LEN : 0); while (1) { len = Tcl_Read(in, buf, bufsize); - if (len < 0) { + if (len == ERROR_LENGTH) { goto readErrorWithChannelOpen; } else if (len == 0) { break; } if (passwd) { - Tcl_Size i; + size_t i; int tmp; for (i = 0; i < len; i++) { buf[i] = (char) zencode(keys0, crc32tab, buf[i], tmp); } } - if (Tcl_Write(out, buf, len) != len) { + if ((size_t) Tcl_Write(out, buf, len) != len) { goto writeErrorWithChannelOpen; } nbytecompr += len; @@ -3196,14 +3202,14 @@ ZipAddFile( zpathlen, align); if (Tcl_Seek(out, headerStartOffset, SEEK_SET) != headerStartOffset) { Tcl_DeleteHashEntry(hPtr); - Tcl_Free(z); + 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); - Tcl_Free(z); + ckfree(z); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "write error: %s", Tcl_PosixError(interp))); return TCL_ERROR; @@ -3211,7 +3217,7 @@ ZipAddFile( Tcl_Flush(out); if (Tcl_Seek(out, dataEndOffset, SEEK_SET) != dataEndOffset) { Tcl_DeleteHashEntry(hPtr); - Tcl_Free(z); + ckfree(z); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "seek error: %s", Tcl_PosixError(interp))); return TCL_ERROR; @@ -3349,8 +3355,8 @@ ZipFSMkZipOrImg( { Tcl_Channel out; int count, ret = TCL_ERROR; - Tcl_Size pwlen = 0, slen = 0, len, i = 0; - Tcl_Size lobjc; + int pwlen = 0, slen = 0, lobjc; + size_t len, i = 0; long long directoryStartOffset; /* The overall file offset of the start of the * central directory. */ @@ -3376,8 +3382,9 @@ ZipFSMkZipOrImg( if (IsPasswordValid(interp, pw, pwlen) != TCL_OK) { return TCL_ERROR; } - if (pwlen == 0) { + if (pwlen <= 0) { pw = NULL; + pwlen = 0; } } if (dirRoot != NULL) { @@ -3536,7 +3543,7 @@ ZipFSMkZipOrImg( strip = NULL; } } - for (i = 0; i < lobjc; i += (mappingList ? 2 : 1)) { + for (i = 0; i < (size_t) lobjc; i += (mappingList ? 2 : 1)) { Tcl_Obj *pathObj = lobjv[i]; const char *name = ComputeNameInArchive(pathObj, (mappingList ? lobjv[i + 1] : NULL), strip, slen); @@ -3556,7 +3563,7 @@ ZipFSMkZipOrImg( directoryStartOffset = Tcl_Tell(out); count = 0; - for (i = 0; i < lobjc; i += (mappingList ? 2 : 1)) { + for (i = 0; i < (size_t) lobjc; i += (mappingList ? 2 : 1)) { const char *name = ComputeNameInArchive(lobjv[i], (mappingList ? lobjv[i + 1] : NULL), strip, slen); Tcl_DString ds; @@ -3567,17 +3574,13 @@ ZipFSMkZipOrImg( } z = (ZipEntry *) Tcl_GetHashValue(hPtr); - if (Tcl_UtfToExternalDStringEx(interp, tclUtf8Encoding, z->name, TCL_INDEX_NONE, 0, &ds, NULL) != TCL_OK) { - ret = TCL_ERROR; - goto done; - } - name = Tcl_DStringValue(&ds); + name = Tcl_UtfToExternalDString(tclUtf8Encoding, z->name, TCL_INDEX_NONE, &ds); len = Tcl_DStringLength(&ds); SerializeCentralDirectoryEntry(start, end, (unsigned char *) buf, z, len); if ((Tcl_Write(out, buf, ZIP_CENTRAL_HEADER_LEN) != ZIP_CENTRAL_HEADER_LEN) - || (Tcl_Write(out, name, len) != len)) { + || ((size_t) Tcl_Write(out, name, len) != len)) { Tcl_SetObjResult(interp, Tcl_ObjPrintf( "write error: %s", Tcl_PosixError(interp))); Tcl_DStringFree(&ds); @@ -3613,7 +3616,7 @@ ZipFSMkZipOrImg( for (hPtr = Tcl_FirstHashEntry(&fileHash, &search); hPtr; hPtr = Tcl_NextHashEntry(&search)) { z = (ZipEntry *) Tcl_GetHashValue(hPtr); - Tcl_Free(z); + ckfree(z); Tcl_DeleteHashEntry(hPtr); } Tcl_DeleteHashTable(&fileHash); @@ -3644,7 +3647,7 @@ CopyImageFile( Tcl_Channel out) /* Where to copy to; already open for writing * binary data. */ { - Tcl_WideInt i, k; + size_t i, k; Tcl_Size m, n; Tcl_Channel in; char buf[4096]; @@ -3661,7 +3664,7 @@ CopyImageFile( */ i = Tcl_Seek(in, 0, SEEK_END); - if (i == -1) { + if (i == ERROR_LENGTH) { errMsg = "seek error"; goto copyError; } @@ -3978,14 +3981,14 @@ ZipFSCanonicalObjCmd( if (objc == 2) { mntPoint = ZIPFS_VOLUME; } else { - if (NormalizeMountPoint(interp, Tcl_GetString(objv[1]), &dsMount) != TCL_OK) { + if (NormalizeMountPoint(interp, TclGetString(objv[1]), &dsMount) != TCL_OK) { return TCL_ERROR; } mntPoint = Tcl_DStringValue(&dsMount); } (void)MapPathToZipfs(interp, mntPoint, - Tcl_GetString(objv[objc - 1]), + TclGetString(objv[objc - 1]), &dsPath); Tcl_SetObjResult(interp, Tcl_DStringToObj(&dsPath)); return TCL_OK; @@ -4090,9 +4093,10 @@ ZipFSInfoObjCmd( } else { Tcl_SetErrno(ENOENT); if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "path \"%s\" not found in any zipfs volume", - filename)); + Tcl_SetObjResult( + interp, + Tcl_ObjPrintf("path \"%s\" not found in any zipfs volume", + filename)); } ret = TCL_ERROR; } @@ -4296,7 +4300,7 @@ TclZipfs_TclLibrary(void) #elif !defined(NO_DLFCN_H) Dl_info dlinfo; if (dladdr((const void *)TclZipfs_TclLibrary, &dlinfo) && (dlinfo.dli_fname != NULL) - && (ZipfsAppHookFindTclInit(dlinfo.dli_fname) == TCL_OK)) { + && (ZipfsAppHookFindTclInit(dlinfo.dli_fname) == TCL_OK)) { return ScriptLibrarySetup(zipfs_literal_tcl_library); } #else @@ -4395,7 +4399,7 @@ ZipChannelClose( ZipEntry *z = info->zipEntryPtr; assert(info->ubufToFree && info->ubuf); unsigned char *newdata; - newdata = (unsigned char *)Tcl_AttemptRealloc( + newdata = (unsigned char *)attemptckrealloc( info->ubufToFree, info->numBytes ? info->numBytes : 1); /* Bug [23dd83ce7c] */ if (newdata == NULL) { @@ -4408,7 +4412,7 @@ ZipChannelClose( /* Replace old content */ if (z->data) { - Tcl_Free(z->data); + ckfree(z->data); } z->data = newdata; /* May be NULL when ubufToFree was NULL */ z->numBytes = z->numCompressedBytes = info->numBytes; @@ -4424,12 +4428,12 @@ ZipChannelClose( Unlock(); if (info->ubufToFree) { assert(info->ubuf); - Tcl_Free(info->ubufToFree); + ckfree(info->ubufToFree); info->ubuf = NULL; info->ubufToFree = NULL; info->ubufSize = 0; } - Tcl_Free(info); + ckfree(info); return TCL_OK; } @@ -4573,7 +4577,7 @@ ZipChannelWrite( needed = info->maxWrite; } unsigned char *newBuf = - (unsigned char *)Tcl_AttemptRealloc(info->ubufToFree, needed); + (unsigned char *)attemptckrealloc(info->ubufToFree, needed); if (newBuf == NULL) { *errloc = ENOMEM; return -1; @@ -4662,6 +4666,18 @@ ZipChannelWideSeek( info->cursor = (Tcl_Size) offset; return info->cursor; } + +#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9) +static int +ZipChannelSeek( + void *instanceData, + long offset, + int mode, + int *errloc) +{ + return ZipChannelWideSeek(instanceData, offset, mode, errloc); +} +#endif /* *------------------------------------------------------------------------- @@ -4749,9 +4765,9 @@ ZipChannelOpen( if ((ZipFS.wrmax <= 0) && wr) { Tcl_SetErrno(EACCES); if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "writes not permitted: %s", - Tcl_PosixError(interp))); + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("writes not permitted: %s", + Tcl_PosixError(interp))); } return NULL; } @@ -4759,10 +4775,11 @@ ZipChannelOpen( if ((mode & (O_APPEND|O_TRUNC)) && !wr) { Tcl_SetErrno(EINVAL); if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "Invalid flags 0x%x. O_APPEND and " - "O_TRUNC require write access: %s", - mode, Tcl_PosixError(interp))); + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("Invalid flags 0x%x. O_APPEND and " + "O_TRUNC require write access: %s", + mode, + Tcl_PosixError(interp))); } return NULL; } @@ -4776,16 +4793,17 @@ ZipChannelOpen( if (!z) { Tcl_SetErrno(wr ? ENOTSUP : ENOENT); if (interp) { - Tcl_SetObjResult(interp, Tcl_ObjPrintf( - "file \"%s\" not %s: %s", - filename, wr ? "created" : "found", - Tcl_PosixError(interp))); + Tcl_SetObjResult(interp, + Tcl_ObjPrintf("file \"%s\" not %s: %s", + filename, + wr ? "created" : "found", + Tcl_PosixError(interp))); } goto error; } if (z->numBytes < 0 || z->numCompressedBytes < 0 || - z->offset >= z->zipFilePtr->length) { + z->offset >= z->zipFilePtr->length) { /* Normally this should only happen for zip64. */ ZIPFS_ERROR(interp, "file size error (may be zip64)"); ZIPFS_ERROR_CODE(interp, "FILE_SIZE"); @@ -4816,9 +4834,8 @@ ZipChannelOpen( goto error; } flags = TCL_WRITABLE; - if (mode & O_RDWR) { + if (mode & O_RDWR) flags |= TCL_READABLE; - } } else { /* Read-only */ flags |= TCL_READABLE; @@ -4848,7 +4865,7 @@ ZipChannelOpen( /* Set up a writable channel. */ if (InitWritableChannel(interp, info, z, mode) == TCL_ERROR) { - Tcl_Free(info); + ckfree(info); goto error; } } else if (z->data) { @@ -4864,7 +4881,7 @@ ZipChannelOpen( */ if (InitReadableChannel(interp, info, z) == TCL_ERROR) { - Tcl_Free(info); + ckfree(info); goto error; } } @@ -4882,10 +4899,10 @@ ZipChannelOpen( ZIPFS_ERROR(interp, "invalid CRC"); ZIPFS_ERROR_CODE(interp, "CRC_FAILED"); if (info->ubufToFree) { - Tcl_Free(info->ubufToFree); + ckfree(info->ubufToFree); info->ubufSize = 0; } - Tcl_Free(info); + ckfree(info); goto error; } } @@ -4943,7 +4960,7 @@ InitWritableChannel( info->maxWrite = ZipFS.wrmax; info->ubufSize = z->numBytes ? z->numBytes : 1; - info->ubufToFree = (unsigned char *)Tcl_AttemptAlloc(info->ubufSize); + info->ubufToFree = (unsigned char *)attemptckalloc(info->ubufSize); info->ubuf = info->ubufToFree; if (info->ubufToFree == NULL) { goto memoryError; @@ -4951,8 +4968,9 @@ InitWritableChannel( if (z->isEncrypted) { assert(z->numCompressedBytes >= ZIP_CRYPT_HDR_LEN); /* caller should have checked*/ - if (DecodeCryptHeader(interp, z, info->keys, - z->zipFilePtr->data + z->offset) != TCL_OK) { + if (DecodeCryptHeader( + interp, z, info->keys, z->zipFilePtr->data + z->offset) != + TCL_OK) { goto error_cleanup; } } @@ -4998,7 +5016,7 @@ InitWritableChannel( assert(stream.avail_in >= ZIP_CRYPT_HDR_LEN); stream.avail_in -= ZIP_CRYPT_HDR_LEN; - cbuf = (unsigned char *) Tcl_AttemptAlloc(stream.avail_in ? stream.avail_in : 1); + cbuf = (unsigned char *) attemptckalloc(stream.avail_in ? stream.avail_in : 1); if (!cbuf) { goto memoryError; } @@ -5018,25 +5036,23 @@ InitWritableChannel( err = inflate(&stream, Z_SYNC_FLUSH); inflateEnd(&stream); if ((err != Z_STREAM_END) && - ((err != Z_OK) || (stream.avail_in != 0))) { + ((err != Z_OK) || (stream.avail_in != 0))) { goto corruptionError; } /* Even if decompression succeeded, counts should be as expected */ - if ((int) stream.total_out != z->numBytes) { + if ((int) stream.total_out != z->numBytes) goto corruptionError; - } info->numBytes = z->numBytes; if (cbuf) { - Tcl_Free(cbuf); + ckfree(cbuf); } } else if (z->isEncrypted) { /* * Need to decrypt some otherwise-simple stored data. */ if (z->numCompressedBytes <= ZIP_CRYPT_HDR_LEN || - (z->numCompressedBytes - ZIP_CRYPT_HDR_LEN) != z->numBytes) { + (z->numCompressedBytes - ZIP_CRYPT_HDR_LEN) != z->numBytes) goto corruptionError; - } int len = z->numCompressedBytes - ZIP_CRYPT_HDR_LEN; assert(len <= info->ubufSize); for (i = 0; i < len; i++) { @@ -5044,7 +5060,8 @@ InitWritableChannel( info->ubuf[i] = zdecode(info->keys, crc32tab, ch); } info->numBytes = len; - } else { + } + else { /* * Simple stored data. Copy into our working buffer. */ @@ -5067,14 +5084,14 @@ InitWritableChannel( corruptionError: if (cbuf) { memset(info->keys, 0, sizeof(info->keys)); - Tcl_Free(cbuf); + ckfree(cbuf); } ZIPFS_ERROR(interp, "decompression error"); ZIPFS_ERROR_CODE(interp, "CORRUPT"); error_cleanup: if (info->ubufToFree) { - Tcl_Free(info->ubufToFree); + ckfree(info->ubufToFree); info->ubufToFree = NULL; info->ubuf = NULL; info->ubufSize = 0; @@ -5151,7 +5168,7 @@ InitReadableChannel( if (info->isEncrypted) { assert(stream.avail_in >= ZIP_CRYPT_HDR_LEN); stream.avail_in -= ZIP_CRYPT_HDR_LEN; - ubuf = (unsigned char *) Tcl_AttemptAlloc(stream.avail_in ? stream.avail_in : 1); + ubuf = (unsigned char *) attemptckalloc(stream.avail_in ? stream.avail_in : 1); if (!ubuf) { goto memoryError; } @@ -5166,7 +5183,7 @@ InitReadableChannel( } info->ubufSize = info->numBytes ? info->numBytes : 1; - info->ubufToFree = (unsigned char *)Tcl_AttemptAlloc(info->ubufSize); + info->ubufToFree = (unsigned char *)attemptckalloc(info->ubufSize); info->ubuf = info->ubufToFree; stream.next_out = info->ubuf; if (!info->ubuf) { @@ -5189,14 +5206,13 @@ InitReadableChannel( goto corruptionError; } /* Even if decompression succeeded, counts should be as expected */ - if ((int) stream.total_out != z->numBytes) { + if ((int) stream.total_out != z->numBytes) goto corruptionError; - } if (ubuf) { info->isEncrypted = 0; memset(info->keys, 0, sizeof(info->keys)); - Tcl_Free(ubuf); + ckfree(ubuf); } } else if (info->isEncrypted) { unsigned int j, len; @@ -5206,11 +5222,10 @@ InitReadableChannel( * on it, and it can be randomly accessed later. */ if (z->numCompressedBytes <= ZIP_CRYPT_HDR_LEN || - (z->numCompressedBytes - ZIP_CRYPT_HDR_LEN) != z->numBytes) { + (z->numCompressedBytes - ZIP_CRYPT_HDR_LEN) != z->numBytes) goto corruptionError; - } len = z->numCompressedBytes - ZIP_CRYPT_HDR_LEN; - ubuf = (unsigned char *) Tcl_AttemptAlloc(len); + ubuf = (unsigned char *) attemptckalloc(len); if (ubuf == NULL) { goto memoryError; } @@ -5237,10 +5252,10 @@ InitReadableChannel( error_cleanup: if (ubuf) { memset(info->keys, 0, sizeof(info->keys)); - Tcl_Free(ubuf); + ckfree(ubuf); } if (info->ubufToFree) { - Tcl_Free(info->ubufToFree); + ckfree(info->ubufToFree); info->ubufToFree = NULL; info->ubuf = NULL; info->ubufSize = 0; @@ -5380,7 +5395,7 @@ ZipFSOpenFileChannelProc( return NULL; } - return ZipChannelOpen(interp, Tcl_GetString(pathPtr), mode); + return ZipChannelOpen(interp, TclGetString(pathPtr), mode); } /* @@ -5484,11 +5499,11 @@ AppendWithPrefix( Tcl_DString *prefix, /* The prefix to add to the element, or NULL * for don't do that. */ const char *name, /* The name to append. */ - size_t nameLen) /* The length of the name. May be TCL_INDEX_NONE for + Tcl_Size nameLen) /* The length of the name. May be < 0 for * append-up-to-NUL-byte. */ { if (prefix) { - size_t prefixLength = Tcl_DStringLength(prefix); + Tcl_Size prefixLength = Tcl_DStringLength(prefix); Tcl_DStringAppend(prefix, name, nameLen); Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj( @@ -5549,13 +5564,14 @@ ZipFSMatchInDirectoryProc( return TCL_ERROR; } if ((wanted & (TCL_GLOB_TYPE_DIR | TCL_GLOB_TYPE_FILE | - TCL_GLOB_TYPE_MOUNT)) == 0) { + TCL_GLOB_TYPE_MOUNT)) == 0) { /* Not looking for files,dirs,mounts. zipfs cannot have others */ return TCL_OK; } wanted &= (TCL_GLOB_TYPE_DIR | TCL_GLOB_TYPE_FILE | TCL_GLOB_TYPE_MOUNT); - } else { + } + else { wanted = TCL_GLOB_TYPE_DIR | TCL_GLOB_TYPE_FILE; } @@ -5612,8 +5628,8 @@ ZipFSMatchInDirectoryProc( /* TODO - can't seem to get to this code from script for tests. */ /* Follow logic of what tclUnixFile.c does */ if ((wanted == (TCL_GLOB_TYPE_DIR | TCL_GLOB_TYPE_FILE)) || - (wanted == TCL_GLOB_TYPE_DIR && z->isDirectory) || - (wanted == TCL_GLOB_TYPE_FILE && !z->isDirectory)) { + (wanted == TCL_GLOB_TYPE_DIR && z->isDirectory) || + (wanted == TCL_GLOB_TYPE_FILE && !z->isDirectory)) { Tcl_ListObjAppendElement(NULL, result, pathPtr); } goto end; @@ -5638,7 +5654,7 @@ ZipFSMatchInDirectoryProc( */ l = strlen(pattern); - pat = (char *) Tcl_Alloc(len + l + 2); + pat = (char *) ckalloc(len + l + 2); memcpy(pat, path, len); while ((len > 1) && (pat[len - 1] == '/')) { --len; @@ -5658,17 +5674,17 @@ ZipFSMatchInDirectoryProc( Tcl_HashSearch search; if (foundInHash) { for (hPtr = Tcl_FirstHashEntry(&ZipFS.fileHash, &search); hPtr; - hPtr = Tcl_NextHashEntry(&search)) { + hPtr = Tcl_NextHashEntry(&search)) { z = (ZipEntry *)Tcl_GetHashValue(hPtr); if ((wanted == (TCL_GLOB_TYPE_DIR | TCL_GLOB_TYPE_FILE)) || - (wanted == TCL_GLOB_TYPE_DIR && z->isDirectory) || - (wanted == TCL_GLOB_TYPE_FILE && !z->isDirectory)) { + (wanted == TCL_GLOB_TYPE_DIR && z->isDirectory) || + (wanted == TCL_GLOB_TYPE_FILE && !z->isDirectory)) { if ((z->depth == scnt) && - ((z->flags & ZE_F_VOLUME) == 0) /* Bug 14db54d81e */ - && Tcl_StringCaseMatch(z->name, pat, 0)) { - Tcl_CreateHashEntry(&duplicates, z->name + strip, - ¬Duplicate); + ((z->flags & ZE_F_VOLUME) == 0) /* Bug 14db54d81e */ + && Tcl_StringCaseMatch(z->name, pat, 0)) { + Tcl_CreateHashEntry( + &duplicates, z->name + strip, ¬Duplicate); assert(notDuplicate); AppendWithPrefix(result, prefixBuf, z->name + strip, -1); } @@ -5685,16 +5701,16 @@ ZipFSMatchInDirectoryProc( Tcl_DString ds; Tcl_DStringInit(&ds); for (hPtr = Tcl_FirstHashEntry(&ZipFS.zipHash, &search); hPtr; - hPtr = Tcl_NextHashEntry(&search)) { + hPtr = Tcl_NextHashEntry(&search)) { ZipFile *zf = (ZipFile *)Tcl_GetHashValue(hPtr); if (Tcl_StringCaseMatch(zf->mountPoint, pat, 0)) { const char *tail = zf->mountPoint + len; - if (*tail == '\0') { + if (*tail == '\0') continue; - } const char *end = strchr(tail, '/'); - Tcl_DStringAppend(&ds, zf->mountPoint + strip, - end ? (Tcl_Size)(end - zf->mountPoint) : -1); + Tcl_DStringAppend(&ds, + zf->mountPoint + strip, + end ? (Tcl_Size)(end - zf->mountPoint) : -1); const char *matchedPath = Tcl_DStringValue(&ds); (void)Tcl_CreateHashEntry( &duplicates, matchedPath, ¬Duplicate); @@ -5707,7 +5723,7 @@ ZipFSMatchInDirectoryProc( } } Tcl_DeleteHashTable(&duplicates); - Tcl_Free(pat); + ckfree(pat); end: Unlock(); @@ -5746,7 +5762,7 @@ ZipFSMatchMountPoints( { Tcl_HashEntry *hPtr; Tcl_HashSearch search; - int l; + size_t l; Tcl_Size normLength; const char *path = TclGetStringFromObj(normPathPtr, &normLength); Tcl_Size len = normLength; @@ -5786,7 +5802,7 @@ ZipFSMatchMountPoints( if ((lenz > len + 1) && (strncmp(z->name, path, len) == 0) && (z->name[len] == '/') - && ((int) CountSlashes(z->name) == l) + && (CountSlashes(z->name) == l) && Tcl_StringCaseMatch(z->name + len + 1, pattern, 0)) { AppendWithPrefix(result, prefix, z->name, lenz); } @@ -5794,7 +5810,7 @@ ZipFSMatchMountPoints( } else if ((zf->mountPointLen > len + 1) && (strncmp(zf->mountPoint, path, len) == 0) && (zf->mountPoint[len] == '/') - && ((int) CountSlashes(zf->mountPoint) == l) + && (CountSlashes(zf->mountPoint) == l) && Tcl_StringCaseMatch(zf->mountPoint + len + 1, pattern, 0)) { /* @@ -6331,8 +6347,7 @@ ZipfsAppHookFindTclInit( * *------------------------------------------------------------------------ */ -void -TclZipfsFinalize(void) +void TclZipfsFinalize(void) { WriteLock(); if (!ZipFS.initialized) { @@ -6348,14 +6363,14 @@ TclZipfsFinalize(void) Tcl_DeleteHashEntry(hPtr); CleanupMount(zf); /* Frees file entries belonging to the archive */ ZipFSCloseArchive(NULL, zf); - Tcl_Free(zf); + ckfree(zf); } Tcl_FSUnregister(&zipfsFilesystem); Tcl_DeleteHashTable(&ZipFS.fileHash); Tcl_DeleteHashTable(&ZipFS.zipHash); if (ZipFS.fallbackEntryEncoding) { - Tcl_Free(ZipFS.fallbackEntryEncoding); + ckfree(ZipFS.fallbackEntryEncoding); ZipFS.fallbackEntryEncoding = NULL; } @@ -6387,12 +6402,12 @@ TclZipfs_AppHook( #endif /* _WIN32 */ { const char *archive; - const char *result; + const char *version = Tcl_InitSubsystems(); #ifdef _WIN32 - result = Tcl_FindExecutable(NULL); + Tcl_FindExecutable(NULL); #else - result = Tcl_FindExecutable((*argvPtr)[0]); + Tcl_FindExecutable((*argvPtr)[0]); #endif archive = Tcl_GetNameOfExecutable(); TclZipfs_Init(NULL); @@ -6430,7 +6445,7 @@ TclZipfs_AppHook( Tcl_DecrRefCount(vfsInitScript); if (found == TCL_OK) { zipfs_literal_tcl_library = ZIPFS_APP_MOUNT "/tcl_library"; - return result; + return version; } } #ifdef SUPPORT_BUILTIN_ZIP_INSTALL @@ -6463,7 +6478,7 @@ TclZipfs_AppHook( if (Tcl_FSAccess(vfsInitScript, F_OK) == 0) { Tcl_SetStartupScript(vfsInitScript, NULL); } - return result; + return version; } else if (!TclZipfs_Mount(NULL, archive, ZIPFS_APP_MOUNT, NULL)) { int found; Tcl_Obj *vfsInitScript; @@ -6487,7 +6502,7 @@ TclZipfs_AppHook( Tcl_DecrRefCount(vfsInitScript); if (found == TCL_OK) { zipfs_literal_tcl_library = ZIPFS_APP_MOUNT "/tcl_library"; - return result; + return version; } } #ifdef _WIN32 @@ -6495,7 +6510,7 @@ TclZipfs_AppHook( #endif /* _WIN32 */ #endif /* SUPPORT_BUILTIN_ZIP_INSTALL */ } - return result; + return version; } #else /* !HAVE_ZLIB */ @@ -6564,9 +6579,7 @@ TclZipfs_TclLibrary(void) return NULL; } -int -TclIsZipfsPath( - TCL_UNUSED(const char *)) /* path */ +int TclIsZipfsPath (const char *path) { return 0; } diff --git a/generic/tclZlib.c b/generic/tclZlib.c index 4138089..7ec2ae1 100644 --- a/generic/tclZlib.c +++ b/generic/tclZlib.c @@ -181,7 +181,7 @@ static void ConvertError(Tcl_Interp *interp, int code, uLong adler); static Tcl_Obj * ConvertErrorToList(int code, uLong adler); static inline int Deflate(z_streamp strm, void *bufferPtr, - size_t bufferSize, int flush, size_t *writtenPtr); + int bufferSize, int flush, int *writtenPtr); static void ExtractHeader(gz_header *headerPtr, Tcl_Obj *dictObj); static int GenerateHeader(Tcl_Interp *interp, Tcl_Obj *dictObj, GzipHeader *headerPtr, int *extraSizePtr); @@ -206,7 +206,7 @@ static void ZlibTransformTimerRun(void *clientData); static const Tcl_ChannelType zlibChannelType = { "zlib", TCL_CHANNEL_VERSION_5, - NULL, + TCL_CLOSE2PROC, ZlibTransformInput, ZlibTransformOutput, NULL, /* seekProc */ @@ -423,7 +423,6 @@ GenerateHeader( { Tcl_Obj *value; int len, result = TCL_ERROR; - Tcl_Size length; Tcl_WideInt wideValue = 0; const char *valueStr; Tcl_Encoding latin1enc; @@ -444,8 +443,8 @@ GenerateHeader( goto error; } else if (value != NULL) { Tcl_EncodingState state; - valueStr = TclGetStringFromObj(value, &length); - result = Tcl_UtfToExternal(NULL, latin1enc, valueStr, length, + valueStr = TclGetStringFromObj(value, &len); + result = Tcl_UtfToExternal(NULL, latin1enc, valueStr, len, TCL_ENCODING_START|TCL_ENCODING_END|TCL_ENCODING_PROFILE_STRICT, &state, headerPtr->nativeCommentBuf, MAX_COMMENT_LEN-1, NULL, &len, NULL); @@ -479,8 +478,8 @@ GenerateHeader( goto error; } else if (value != NULL) { Tcl_EncodingState state; - valueStr = TclGetStringFromObj(value, &length); - result = Tcl_UtfToExternal(NULL, latin1enc, valueStr, length, + valueStr = TclGetStringFromObj(value, &len); + result = Tcl_UtfToExternal(NULL, latin1enc, valueStr, len, TCL_ENCODING_START|TCL_ENCODING_END|TCL_ENCODING_PROFILE_STRICT, &state, headerPtr->nativeFilenameBuf, MAXPATHLEN-1, NULL, &len, NULL); @@ -577,7 +576,7 @@ ExtractHeader( } } - (void)Tcl_ExternalToUtfDString(latin1enc, (char *) headerPtr->comment, TCL_INDEX_NONE, + Tcl_ExternalToUtfDString(latin1enc, (char *) headerPtr->comment, TCL_INDEX_NONE, &tmp); SetValue(dictObj, "comment", Tcl_DStringToObj(&tmp)); } @@ -594,7 +593,7 @@ ExtractHeader( } } - (void)Tcl_ExternalToUtfDString(latin1enc, (char *) headerPtr->name, TCL_INDEX_NONE, + Tcl_ExternalToUtfDString(latin1enc, (char *) headerPtr->name, TCL_INDEX_NONE, &tmp); SetValue(dictObj, "filename", Tcl_DStringToObj(&tmp)); } @@ -624,12 +623,9 @@ SetInflateDictionary( Tcl_Obj *compDictObj) { if (compDictObj != NULL) { - Tcl_Size length = 0; - unsigned char *bytes = Tcl_GetBytesFromObj(NULL, compDictObj, &length); + Tcl_Size length; + unsigned char *bytes = Tcl_GetByteArrayFromObj(compDictObj, &length); - if (bytes == NULL) { - return Z_DATA_ERROR; - } return inflateSetDictionary(strm, bytes, length); } return Z_OK; @@ -641,12 +637,9 @@ SetDeflateDictionary( Tcl_Obj *compDictObj) { if (compDictObj != NULL) { - Tcl_Size length = 0; - unsigned char *bytes = Tcl_GetBytesFromObj(NULL, compDictObj, &length); + Tcl_Size length; + unsigned char *bytes = Tcl_GetByteArrayFromObj(compDictObj, &length); - if (bytes == NULL) { - return Z_DATA_ERROR; - } return deflateSetDictionary(strm, bytes, length); } return Z_OK; @@ -656,9 +649,9 @@ static inline int Deflate( z_streamp strm, void *bufferPtr, - size_t bufferSize, + int bufferSize, int flush, - size_t *writtenPtr) + int *writtenPtr) { int e; @@ -675,7 +668,7 @@ static inline void AppendByteArray( Tcl_Obj *listObj, void *buffer, - size_t size) + int size) { if (size > 0) { Tcl_Obj *baObj = Tcl_NewByteArrayObj((unsigned char *) buffer, size); @@ -737,11 +730,11 @@ Tcl_ZlibStreamInit( case TCL_ZLIB_FORMAT_GZIP: wbits = WBITS_GZIP; if (dictObj) { - gzHeaderPtr = (GzipHeader *)Tcl_Alloc(sizeof(GzipHeader)); + gzHeaderPtr = (GzipHeader *)ckalloc(sizeof(GzipHeader)); memset(gzHeaderPtr, 0, sizeof(GzipHeader)); if (GenerateHeader(interp, dictObj, gzHeaderPtr, NULL) != TCL_OK) { - Tcl_Free(gzHeaderPtr); + ckfree(gzHeaderPtr); return TCL_ERROR; } } @@ -771,7 +764,7 @@ Tcl_ZlibStreamInit( break; case TCL_ZLIB_FORMAT_GZIP: wbits = WBITS_GZIP; - gzHeaderPtr = (GzipHeader *)Tcl_Alloc(sizeof(GzipHeader)); + gzHeaderPtr = (GzipHeader *)ckalloc(sizeof(GzipHeader)); memset(gzHeaderPtr, 0, sizeof(GzipHeader)); gzHeaderPtr->header.name = (Bytef *) gzHeaderPtr->nativeFilenameBuf; @@ -797,7 +790,7 @@ Tcl_ZlibStreamInit( " TCL_ZLIB_STREAM_INFLATE"); } - zshPtr = (ZlibStreamHandle *)Tcl_Alloc(sizeof(ZlibStreamHandle)); + zshPtr = (ZlibStreamHandle *)ckalloc(sizeof(ZlibStreamHandle)); zshPtr->interp = interp; zshPtr->mode = mode; zshPtr->format = format; @@ -897,9 +890,9 @@ Tcl_ZlibStreamInit( Tcl_DecrRefCount(zshPtr->compDictObj); } if (zshPtr->gzHeaderPtr) { - Tcl_Free(zshPtr->gzHeaderPtr); + ckfree(zshPtr->gzHeaderPtr); } - Tcl_Free(zshPtr); + ckfree(zshPtr); return TCL_ERROR; } @@ -1010,10 +1003,10 @@ ZlibStreamCleanup( Tcl_DecrRefCount(zshPtr->compDictObj); } if (zshPtr->gzHeaderPtr) { - Tcl_Free(zshPtr->gzHeaderPtr); + ckfree(zshPtr->gzHeaderPtr); } - Tcl_Free(zshPtr); + ckfree(zshPtr); } /* @@ -1191,7 +1184,7 @@ Tcl_ZlibStreamSetCompressionDictionary( ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle; if (compressionDictionaryObj && (NULL == Tcl_GetBytesFromObj(NULL, - compressionDictionaryObj, (Tcl_Size *)NULL))) { + compressionDictionaryObj, NULL))) { /* Missing or invalid compression dictionary */ compressionDictionaryObj = NULL; } @@ -1234,8 +1227,8 @@ Tcl_ZlibStreamPut( ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle; char *dataTmp = NULL; int e; - Tcl_Size size = 0; - size_t outSize, toStore; + Tcl_Size size; + int outSize, toStore; unsigned char *bytes; if (zshPtr->streamEnd) { @@ -1284,7 +1277,7 @@ Tcl_ZlibStreamPut( if (outSize > BUFFER_SIZE_LIMIT) { outSize = BUFFER_SIZE_LIMIT; } - dataTmp = (char *)Tcl_Alloc(outSize); + dataTmp = (char *)ckalloc(outSize); while (1) { e = Deflate(&zshPtr->stream, dataTmp, outSize, flush, &toStore); @@ -1318,7 +1311,7 @@ Tcl_ZlibStreamPut( if (outSize < BUFFER_SIZE_LIMIT) { outSize = BUFFER_SIZE_LIMIT; /* There may be *lots* of data left to output... */ - dataTmp = (char *)Tcl_Realloc(dataTmp, outSize); + dataTmp = (char *)ckrealloc(dataTmp, outSize); } } @@ -1327,7 +1320,7 @@ Tcl_ZlibStreamPut( */ AppendByteArray(zshPtr->outData, dataTmp, toStore); - Tcl_Free(dataTmp); + ckfree(dataTmp); } else { /* * This is easy. Just append to the inData list. @@ -1365,10 +1358,10 @@ Tcl_ZlibStreamGet( { ZlibStreamHandle *zshPtr = (ZlibStreamHandle *) zshandle; int e; - Tcl_Size listLen, i, itemLen = 0, dataPos = 0; + Tcl_Size listLen, i, itemLen, dataPos = 0; Tcl_Obj *itemObj; unsigned char *dataPtr, *itemPtr; - Tcl_Size existing = 0; + Tcl_Size existing; /* * Getting beyond the of stream, just return empty string. @@ -1383,7 +1376,7 @@ Tcl_ZlibStreamGet( } if (zshPtr->mode == TCL_ZLIB_STREAM_INFLATE) { - if (count < 0) { + if (count == -1) { /* * The only safe thing to do is restict to 65k. We might cause a * panic for out of memory if we just kept growing the buffer. @@ -1423,7 +1416,7 @@ Tcl_ZlibStreamGet( if (Tcl_IsShared(itemObj)) { itemObj = Tcl_DuplicateObj(itemObj); } - itemPtr = Tcl_GetBytesFromObj(NULL, itemObj, &itemLen); + itemPtr = Tcl_GetByteArrayFromObj(itemObj, &itemLen); Tcl_IncrRefCount(itemObj); zshPtr->currentInput = itemObj; zshPtr->stream.next_in = itemPtr; @@ -1495,7 +1488,7 @@ Tcl_ZlibStreamGet( if (Tcl_IsShared(itemObj)) { itemObj = Tcl_DuplicateObj(itemObj); } - itemPtr = Tcl_GetBytesFromObj(NULL, itemObj, &itemLen); + itemPtr = Tcl_GetByteArrayFromObj(itemObj, &itemLen); Tcl_IncrRefCount(itemObj); zshPtr->currentInput = itemObj; zshPtr->stream.next_in = itemPtr; @@ -1540,11 +1533,11 @@ Tcl_ZlibStreamGet( } } else { TclListObjLength(NULL, zshPtr->outData, &listLen); - if (count < 0) { + if (count == -1) { count = 0; for (i=0; i<listLen; i++) { Tcl_ListObjIndex(NULL, zshPtr->outData, i, &itemObj); - (void) Tcl_GetBytesFromObj(NULL, itemObj, &itemLen); + (void) Tcl_GetByteArrayFromObj(itemObj, &itemLen); if (i == 0) { count += itemLen - zshPtr->outPos; } else { @@ -1569,9 +1562,9 @@ Tcl_ZlibStreamGet( */ Tcl_ListObjIndex(NULL, zshPtr->outData, 0, &itemObj); - itemPtr = Tcl_GetBytesFromObj(NULL, itemObj, &itemLen); - if ((itemLen-zshPtr->outPos) >= count-dataPos) { - Tcl_Size len = count - dataPos; + itemPtr = Tcl_GetByteArrayFromObj(itemObj, &itemLen); + if (itemLen-zshPtr->outPos >= count-dataPos) { + size_t len = count - dataPos; memcpy(dataPtr + dataPos, itemPtr + zshPtr->outPos, len); zshPtr->outPos += len; @@ -1580,7 +1573,7 @@ Tcl_ZlibStreamGet( zshPtr->outPos = 0; } } else { - Tcl_Size len = itemLen - zshPtr->outPos; + size_t len = itemLen - zshPtr->outPos; memcpy(dataPtr + dataPos, itemPtr + zshPtr->outPos, len); dataPos += len; @@ -1817,10 +1810,10 @@ Tcl_ZlibInflate( if (gzipHeaderDictObj) { headerPtr = &header; memset(headerPtr, 0, sizeof(gz_header)); - nameBuf = (char *)Tcl_Alloc(MAXPATHLEN); + nameBuf = (char *)ckalloc(MAXPATHLEN); header.name = (Bytef *) nameBuf; header.name_max = MAXPATHLEN - 1; - commentBuf = (char *)Tcl_Alloc(MAX_COMMENT_LEN); + commentBuf = (char *)ckalloc(MAX_COMMENT_LEN); header.comment = (Bytef *) commentBuf; header.comm_max = MAX_COMMENT_LEN - 1; } @@ -1925,8 +1918,8 @@ Tcl_ZlibInflate( ExtractHeader(&header, gzipHeaderDictObj); SetValue(gzipHeaderDictObj, "size", Tcl_NewWideIntObj(stream.total_out)); - Tcl_Free(nameBuf); - Tcl_Free(commentBuf); + ckfree(nameBuf); + ckfree(commentBuf); } Tcl_SetObjResult(interp, obj); return TCL_OK; @@ -1935,10 +1928,10 @@ Tcl_ZlibInflate( TclDecrRefCount(obj); ConvertError(interp, e, stream.adler); if (nameBuf) { - Tcl_Free(nameBuf); + ckfree(nameBuf); } if (commentBuf) { - Tcl_Free(commentBuf); + ckfree(commentBuf); } return TCL_ERROR; } @@ -1989,10 +1982,10 @@ ZlibCmd( int objc, Tcl_Obj *const objv[]) { - int i, option, level = -1; - size_t buffersize = 0; - Tcl_Size dlen = 0; - unsigned int start; + int command, i, option, level = -1; + unsigned buffersize = 0; + Tcl_Size dlen; + unsigned start; Tcl_WideInt wideLen; Byte *data; Tcl_Obj *headerDictObj; @@ -2005,7 +1998,7 @@ ZlibCmd( enum zlibCommands { CMD_ADLER, CMD_COMPRESS, CMD_CRC, CMD_DECOMPRESS, CMD_DEFLATE, CMD_GUNZIP, CMD_GZIP, CMD_INFLATE, CMD_PUSH, CMD_STREAM - } command; + }; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "command arg ?...?"); @@ -2016,7 +2009,7 @@ ZlibCmd( return TCL_ERROR; } - switch (command) { + switch ((enum zlibCommands) command) { case CMD_ADLER: /* adler32 str ?startvalue? * -> checksum */ if (objc < 3 || objc > 4) { @@ -2276,7 +2269,7 @@ ZlibStreamSubcmd( enum zlibFormats { FMT_COMPRESS, FMT_DECOMPRESS, FMT_DEFLATE, FMT_GUNZIP, FMT_GZIP, FMT_INFLATE - } fmt; + }; int i, format, mode = 0, option, level; enum objIndices { OPT_COMPRESSION_DICTIONARY = 0, @@ -2317,7 +2310,7 @@ ZlibStreamSubcmd( return TCL_ERROR; } if (Tcl_GetIndexFromObj(interp, objv[2], stream_formats, "mode", 0, - &fmt) != TCL_OK) { + &format) != TCL_OK) { return TCL_ERROR; } @@ -2326,7 +2319,7 @@ ZlibStreamSubcmd( * specified. */ - switch (fmt) { + switch ((enum zlibFormats) format) { case FMT_DEFLATE: desc = compressionOpts; mode = TCL_ZLIB_STREAM_DEFLATE; @@ -2436,9 +2429,9 @@ ZlibPushSubcmd( enum zlibFormats { FMT_COMPRESS, FMT_DECOMPRESS, FMT_DEFLATE, FMT_GUNZIP, FMT_GZIP, FMT_INFLATE - } fmt; + }; Tcl_Channel chan; - int chanMode, format, mode = 0, level, i; + int chanMode, format, mode = 0, level, i, option; static const char *const pushCompressOptions[] = { "-dictionary", "-header", "-level", NULL }; @@ -2446,7 +2439,7 @@ ZlibPushSubcmd( "-dictionary", "-header", "-level", "-limit", NULL }; const char *const *pushOptions = pushDecompressOptions; - enum pushOptionsEnum {poDictionary, poHeader, poLevel, poLimit} option; + enum pushOptionsEnum {poDictionary, poHeader, poLevel, poLimit}; Tcl_Obj *headerObj = NULL, *compDictObj = NULL; int limit = DEFAULT_BUFFER_SIZE; Tcl_Size dummy; @@ -2457,10 +2450,10 @@ ZlibPushSubcmd( } if (Tcl_GetIndexFromObj(interp, objv[2], stream_formats, "mode", 0, - &fmt) != TCL_OK) { + &format) != TCL_OK) { return TCL_ERROR; } - switch (fmt) { + switch ((enum zlibFormats) format) { case FMT_DEFLATE: mode = TCL_ZLIB_STREAM_DEFLATE; format = TCL_ZLIB_FORMAT_RAW; @@ -2508,7 +2501,7 @@ ZlibPushSubcmd( } if (mode == TCL_ZLIB_STREAM_INFLATE && !(chanMode & TCL_READABLE)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( - "decompression may only be applied to readable channels",TCL_INDEX_NONE)); + "decompression may only be applied to readable channels", TCL_INDEX_NONE)); Tcl_SetErrorCode(interp, "TCL", "ZIP", "UNREADABLE", (char *)NULL); return TCL_ERROR; } @@ -2529,7 +2522,7 @@ ZlibPushSubcmd( Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", (char *)NULL); return TCL_ERROR; } - switch (option) { + switch ((enum pushOptionsEnum) option) { case poHeader: headerObj = objv[i]; if (Tcl_DictObjSize(interp, headerObj, &dummy) != TCL_OK) { @@ -2609,7 +2602,7 @@ ZlibStreamCmd( Tcl_Obj *const objv[]) { Tcl_ZlibStream zstream = (Tcl_ZlibStream)cd; - int count, code; + int command, count, code; Tcl_Obj *obj; static const char *const cmds[] = { "add", "checksum", "close", "eof", "finalize", "flush", @@ -2619,7 +2612,7 @@ ZlibStreamCmd( enum zlibStreamCommands { zs_add, zs_checksum, zs_close, zs_eof, zs_finalize, zs_flush, zs_fullflush, zs_get, zs_header, zs_put, zs_reset - } command; + }; if (objc < 2) { Tcl_WrongNumArgs(interp, 1, objv, "option data ?...?"); @@ -2631,7 +2624,7 @@ ZlibStreamCmd( return TCL_ERROR; } - switch (command) { + switch ((enum zlibStreamCommands) command) { case zs_add: /* $strm add ?$flushopt? $data */ return ZlibStreamAddCmd(zstream, interp, objc, objv); case zs_header: /* $strm header */ @@ -2735,14 +2728,14 @@ ZlibStreamAddCmd( Tcl_Obj *const objv[]) { Tcl_ZlibStream zstream = (Tcl_ZlibStream)cd; - int code, buffersize = -1, flush = -1, i; + int index, code, buffersize = -1, flush = -1, i; Tcl_Obj *obj, *compDictObj = NULL; static const char *const add_options[] = { "-buffer", "-dictionary", "-finalize", "-flush", "-fullflush", NULL }; enum addOptions { ao_buffer, ao_dictionary, ao_finalize, ao_flush, ao_fullflush - } index; + }; for (i=2; i<objc-1; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], add_options, "option", 0, @@ -2750,7 +2743,7 @@ ZlibStreamAddCmd( return TCL_ERROR; } - switch (index) { + switch ((enum addOptions) index) { case ao_flush: /* -flush */ if (flush >= 0) { flush = -2; @@ -2820,7 +2813,7 @@ ZlibStreamAddCmd( */ if (compDictObj != NULL) { - Tcl_Size len = 0; + Tcl_Size len; if (NULL == Tcl_GetBytesFromObj(interp, compDictObj, &len)) { return TCL_ERROR; @@ -2862,14 +2855,14 @@ ZlibStreamPutCmd( Tcl_Obj *const objv[]) { Tcl_ZlibStream zstream = (Tcl_ZlibStream)cd; - int flush = -1, i; + int index, flush = -1, i; Tcl_Obj *compDictObj = NULL; static const char *const put_options[] = { "-dictionary", "-finalize", "-flush", "-fullflush", NULL }; enum putOptions { po_dictionary, po_finalize, po_flush, po_fullflush - } index; + }; for (i=2; i<objc-1; i++) { if (Tcl_GetIndexFromObj(interp, objv[i], put_options, "option", 0, @@ -2877,7 +2870,7 @@ ZlibStreamPutCmd( return TCL_ERROR; } - switch (index) { + switch ((enum putOptions) index) { case po_flush: /* -flush */ if (flush >= 0) { flush = -2; @@ -2927,7 +2920,7 @@ ZlibStreamPutCmd( */ if (compDictObj != NULL) { - Tcl_Size len = 0; + Tcl_Size len; if (NULL == Tcl_GetBytesFromObj(interp, compDictObj, &len)) { return TCL_ERROR; @@ -2992,7 +2985,7 @@ ZlibTransformClose( { ZlibChannelData *cd = (ZlibChannelData *)instanceData; int e, result = TCL_OK; - size_t written; + int written; if ((flags & (TCL_CLOSE_READ | TCL_CLOSE_WRITE)) != 0) { return EINVAL; @@ -3068,14 +3061,14 @@ ZlibTransformClose( } if (cd->inBuffer) { - Tcl_Free(cd->inBuffer); + ckfree(cd->inBuffer); cd->inBuffer = NULL; } if (cd->outBuffer) { - Tcl_Free(cd->outBuffer); + ckfree(cd->outBuffer); cd->outBuffer = NULL; } - Tcl_Free(cd); + ckfree(cd); return result; } @@ -3148,13 +3141,13 @@ ZlibTransformInput( * Three cases here: * 1. Got some data from the underlying channel (readBytes > 0) so * it should be fed through the decompression engine. - * 2. Got an error (readBytes == -1) which we should report up except + * 2. Got an error (readBytes < 0) which we should report up except * for the case where we can convert it to a short read. * 3. Got an end-of-data from EOF or blocking (readBytes == 0). If * it is EOF, try flushing the data out of the decompressor. */ - if (readBytes == -1) { + if (readBytes < 0) { /* See ReflectInput() in tclIORTrans.c */ if (Tcl_InputBlocked(cd->parent) && (gotBytes > 0)) { @@ -3235,7 +3228,7 @@ ZlibTransformOutput( Tcl_DriverOutputProc *outProc = Tcl_ChannelOutputProc(Tcl_GetChannelType(cd->parent)); int e; - size_t produced; + int produced; Tcl_Obj *errObj; if (cd->mode == TCL_ZLIB_STREAM_INFLATE) { @@ -3298,7 +3291,7 @@ ZlibTransformFlush( int flushType) { int e; - size_t len; + int len; cd->outStream.avail_in = 0; do { @@ -3725,7 +3718,7 @@ ZlibStackChannelTransform( * dictionary (not dictObj!) to use if * necessary. */ { - ZlibChannelData *cd = (ZlibChannelData *)Tcl_Alloc(sizeof(ZlibChannelData)); + ZlibChannelData *cd = (ZlibChannelData *)ckalloc(sizeof(ZlibChannelData)); Tcl_Channel chan; int wbits = 0; @@ -3761,7 +3754,7 @@ ZlibStackChannelTransform( if (compDictObj != NULL) { cd->compDictObj = Tcl_DuplicateObj(compDictObj); Tcl_IncrRefCount(cd->compDictObj); - Tcl_GetBytesFromObj(NULL, cd->compDictObj, (Tcl_Size *)NULL); + Tcl_GetByteArrayFromObj(cd->compDictObj, (Tcl_Size *)NULL); } if (format == TCL_ZLIB_FORMAT_RAW) { @@ -3788,7 +3781,7 @@ ZlibStackChannelTransform( if (cd->inAllocated < cd->readAheadLimit) { cd->inAllocated = cd->readAheadLimit; } - cd->inBuffer = (char *)Tcl_Alloc(cd->inAllocated); + cd->inBuffer = (char *)ckalloc(cd->inAllocated); if (cd->flags & IN_HEADER) { if (inflateGetHeader(&cd->inStream, &cd->inHeader.header) != Z_OK) { goto error; @@ -3805,7 +3798,7 @@ ZlibStackChannelTransform( goto error; } cd->outAllocated = DEFAULT_BUFFER_SIZE; - cd->outBuffer = (char *)Tcl_Alloc(cd->outAllocated); + cd->outBuffer = (char *)ckalloc(cd->outAllocated); if (cd->flags & OUT_HEADER) { if (deflateSetHeader(&cd->outStream, &cd->outHeader.header) != Z_OK) { goto error; @@ -3830,17 +3823,17 @@ ZlibStackChannelTransform( error: if (cd->inBuffer) { - Tcl_Free(cd->inBuffer); + ckfree(cd->inBuffer); inflateEnd(&cd->inStream); } if (cd->outBuffer) { - Tcl_Free(cd->outBuffer); + ckfree(cd->outBuffer); deflateEnd(&cd->outStream); } if (cd->compDictObj) { Tcl_DecrRefCount(cd->compDictObj); } - Tcl_Free(cd); + ckfree(cd); return NULL; } @@ -4009,7 +4002,10 @@ TclZlibInit( * Formally provide the package as a Tcl built-in. */ - return Tcl_PkgProvideEx(interp, "tcl::zlib", TCL_ZLIB_VERSION, NULL); +#if !defined(TCL_NO_DEPRECATED) && (TCL_MAJOR_VERSION < 9) + Tcl_PkgProvide(interp, "zlib", TCL_ZLIB_VERSION); +#endif + return Tcl_PkgProvide(interp, "tcl::zlib", TCL_ZLIB_VERSION); } /* @@ -4084,7 +4080,7 @@ int Tcl_ZlibStreamGet( Tcl_ZlibStream zshandle, Tcl_Obj *data, - size_t count) + Tcl_Size count) { return TCL_OK; } @@ -4109,7 +4105,7 @@ Tcl_ZlibInflate( Tcl_Interp *interp, int format, Tcl_Obj *data, - size_t bufferSize, + Tcl_Size bufferSize, Tcl_Obj *gzipHeaderDictObj) { if (interp) { @@ -4123,7 +4119,7 @@ unsigned int Tcl_ZlibCRC32( TCL_UNUSED(unsigned int), TCL_UNUSED(const unsigned char *), - TCL_UNUSED(size_t)) + TCL_UNUSED(Tcl_Size)) { return 0; } @@ -4132,7 +4128,7 @@ unsigned int Tcl_ZlibAdler32( TCL_UNUSED(unsigned int), TCL_UNUSED(const unsigned char *), - TCL_UNUSED(size_t)) + TCL_UNUSED(Tcl_Size)) { return 0; } |